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/.gitignore b/.gitignore index 1a344da2a9e..b135f052d74 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,7 @@ *.exe *.lib +*.dll +*.exp *.obj *.suo *.u2d @@ -47,6 +49,7 @@ examples/python/.ipynb_checkpoints/*.ipynb doc/Notes/*.pdf doc/mf6report/*.pdf doc/GWFModelReport/*.pdf +doc/mf6bmi/*.pdf doc/mf6io/*.pdf doc/ReleaseNotes/*.pdf doc/GettingStarted/*.pdf @@ -56,8 +59,12 @@ doc/ConverterGuide/*.pdf doc/zonebudget/*.pdf bin/mf6 +bin/libmf6.* bin/mf5to6 bin/zbud6 +bin/*.txt + +UserPrefs.xml tmp_simulations/ autotest/temp/ @@ -71,6 +78,8 @@ mod_temp/ obj_temp/ src_temp/ +trash/ + .ipynb_checkpoints/ distrib_training/mf6beta* @@ -85,3 +94,8 @@ Thumbs.db *.blg *.bat + +msvs/My Advisor Results* + +build/ +CMakeFiles/ diff --git a/.travis.yml b/.travis.yml index 87bf6076cb4..a70cdf423f4 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,190 +1,73 @@ language: c os: linux -dist: trusty -sudo: required +dist: xenial compiler: gcc cache: - apt: true pip: true directories: - - $HOME/.cache/pip - - $HOME/.local - + - "$HOME/.cache/pip" + - "$HOME/.local" matrix: include: - - env: CVER=gfortran4 - language: c - addons: - apt: - sources: - - ubuntu-toolchain-r-test - packages: - - gfortran-4.9 - - texlive-base - - texlive-latex-base - - texlive-latex-extra - - texlive-latex-recommended - - texlive-science - - texlive-fonts-recommended - - texlive-fonts-extra - - dpkg - - tex-common - - latex-xcolor - - unzip - - - env: CVER=gfortran5 - language: c - addons: - apt: - sources: - - ubuntu-toolchain-r-test - packages: - - gfortran-5 - - texlive-base - - texlive-latex-base - - texlive-latex-extra - - texlive-latex-recommended - - texlive-science - - texlive-fonts-recommended - - texlive-fonts-extra - - dpkg - - tex-common - - latex-xcolor - - unzip - - - env: CVER=gfortran6 - language: c - addons: - apt: - sources: - - ubuntu-toolchain-r-test - packages: - - gfortran-6 - - texlive-base - - texlive-latex-base - - texlive-latex-extra - - texlive-latex-recommended - - texlive-science - - texlive-fonts-recommended - - texlive-fonts-extra - - dpkg - - tex-common - - latex-xcolor - - unzip - - - env: CVER=gfortran7 - language: c - addons: - apt: - sources: - - ubuntu-toolchain-r-test - packages: - - gfortran-7 - - texlive-base - - texlive-latex-base - - texlive-latex-extra - - texlive-latex-recommended - - texlive-science - - texlive-fonts-recommended - - texlive-fonts-extra - - dpkg - - tex-common - - latex-xcolor - - unzip - - - env: CVER=gfortran8 - language: c - addons: - apt: - sources: - - ubuntu-toolchain-r-test - packages: - - gfortran-8 - - texlive-base - - texlive-latex-base - - texlive-latex-extra - - texlive-latex-recommended - - texlive-science - - texlive-fonts-recommended - - texlive-fonts-extra - - dpkg - - tex-common - - latex-xcolor - - unzip - - # allowed failures - uncomment lines below to allow failure - # of specific gfortran compilers - #allow_failures: - # - env: CVER=gfortran7 - # - env: CVER=gfortran8 - - - - + - env: FC=gfortran-4.9 + - env: FC=gfortran-5 + - env: FC=gfortran-6 + - env: FC=gfortran-7 + - env: FC=gfortran-8 +before_install: +- sudo apt-add-repository -y ppa:ubuntu-toolchain-r/test +- sudo apt-get update -y +- sudo apt-get install -y $FC +- sudo apt-get install -y texlive texlive-latex-extra + texlive-latex-recommended texlive-science texlive-fonts-extra +- wget https://repo.continuum.io/miniconda/Miniconda3-latest-Linux-x86_64.sh -O $HOME/miniconda.sh +- bash $HOME/miniconda.sh -b -p $HOME/anaconda +- export PATH="$HOME/anaconda/bin:$PATH" +- hash -r +- conda config --set always_yes yes --set changeps1 no +- conda update -q conda +- conda config --add channels conda-forge +- conda install --file requirements.travis.txt +- conda info -a install: - - if [[ ! -d "$HOME/.local/bin" ]]; then - mkdir "$HOME/.local/bin"; - fi - - export PATH="$HOME/.local/bin:$PATH" - - if [[ $CVER == "gfortran4" ]]; then - ln -fs /usr/bin/gfortran-4.9 "$HOME/.local/bin/gfortran"; - gfortran --version; - ls -l /usr/bin/gfortran-4.9; - fi - - if [[ $CVER == "gfortran5" ]]; then - ln -fs /usr/bin/gfortran-5 "$HOME/.local/bin/gfortran"; - gfortran --version; - ls -l /usr/bin/gfortran-5; - fi - - if [[ $CVER == "gfortran6" ]]; then - ln -fs /usr/bin/gfortran-6 "$HOME/.local/bin/gfortran"; - gfortran --version; - ls -l /usr/bin/gfortran-6; - fi - - if [[ $CVER == "gfortran7" ]]; then - ln -fs /usr/bin/gfortran-7 "$HOME/.local/bin/gfortran"; - gfortran --version; - ls -l /usr/bin/gfortran-7; - fi - - if [[ $CVER == "gfortran8" ]]; then - ln -fs /usr/bin/gfortran-8 "$HOME/.local/bin/gfortran"; - gfortran --version; - ls -l /usr/bin/gfortran-8; - fi - # install anaconda - - if [[ "${TRAVIS_OS_NAME}" == "linux" ]]; then - wget https://repo.continuum.io/miniconda/Miniconda3-latest-Linux-x86_64.sh -O miniconda.sh; - fi - - bash miniconda.sh -b -p $HOME/miniconda - - export PATH="$HOME/miniconda/bin:$PATH" - - hash -r - - conda config --set always_yes yes --set changeps1 no - - conda update -q conda - # Useful for debugging any issues with conda - - conda info -a - - conda install nose - - python --version - - pip install numpy - - pip install https://github.com/modflowpy/flopy/zipball/develop - - pip install https://github.com/modflowpy/pymake/zipball/master - - pip install nose-timer - - +- if [[ ! -d "$HOME/.local/bin" ]]; then mkdir "$HOME/.local/bin"; fi +- ln -fs /usr/bin/$FC $HOME/.local/bin/gfortran +- gfortran --version +- python --version +- pip --version +- pip config --user set global.progress_bar off +- git clone https://github.com/modflowpy/flopy --depth 1 --branch=develop ~/flopy +- pip install --user -e ~/flopy +- git clone https://github.com/modflowpy/pymake --depth 1 --branch=master ~/pymake +- pip install --user -e ~/pymake +- git clone https://github.com/mjr-deltares/modflow6-bmipy.git --depth 1 --branch=master ~/amipy +- pip install --user -e ~/amipy script: - - export BRANCH=$(if [ "$TRAVIS_PULL_REQUEST" == "false" ]; then echo $TRAVIS_BRANCH; else echo $TRAVIS_PULL_REQUEST_BRANCH; fi) - - echo "TRAVIS_BRANCH=$TRAVIS_BRANCH, PR=$PR, BRANCH=$BRANCH" - - pwd - - git clone https://github.com/MODFLOW-USGS/modflow6-examples.git ../modflow6-examples - - ls ../ - - which python - - python --version - - python -c "import numpy as np; print('numpy version {}'.format(np.__version__))" - - python -c "import flopy; flopypth = flopy.__path__[0]; print('flopy is installed in {}'.format(flopypth))" - - python -c "import flopy; dir(flopy.mf6)" - - cd ./autotest - - python update_flopy.py - - cd .. - - python -c "import flopy; dir(flopy.mf6)" - - which nosetests - - nosetests --version - - nosetests -v --with-id --with-timer -w ./autotest +- export BRANCH=$(if [ "$TRAVIS_PULL_REQUEST" == "false" ]; then echo $TRAVIS_BRANCH; + else echo $TRAVIS_PULL_REQUEST_BRANCH; fi) +- echo "TRAVIS_BRANCH=$TRAVIS_BRANCH, PR=$PR, BRANCH=$BRANCH" +- pwd +- git clone https://github.com/MODFLOW-USGS/modflow6-examples ../modflow6-examples +- cd ../modflow6-examples +- if git show-ref -q --heads $BRANCH; then + git checkout $BRANCH; echo switched to modflow6-examples branch $BRANCH; + else echo using modflow6-examples branch master; fi +- git branch +- cd ../modflow6 +- ls ../ +- which python +- python --version +- python -c "import numpy as np; print('numpy version {}'.format(np.__version__))" +- python -c "import flopy; flopypth = flopy.__path__[0]; print('flopy is installed + in {}'.format(flopypth))" +- python -c "import flopy; dir(flopy.mf6)" +- cd ./autotest +- python update_flopy.py +- cd .. +- python -c "import flopy; dir(flopy.mf6)" +- which nosetests +- nosetests --version +- nosetests -v --with-id --with-timer -w ./autotest +notifications: + slack: + secure: u8y6K08360InJfEUS3A4B+xxazxeuAbwViRDNnzkuQohFR3rewmzlnrDUSudZQbF4uokpkmQ9/kP8hlwKjrYHHay+4mRgu7ogoWGLnj/KOJjAr04bXuFa8+WOOOSHBjhVhrv86RlApO7/p9HWl2zqINVPl2/UUtnTxYoUnf82EfvYQh9C3hfq6sDAroV1Ei3USk3mpCITuNujHCvAheaBFGX/mElG3JG5TxfZbBQE+srwZTZ5cNT9px76nLfFB2lGKYnjq6WT9miwhIqLv/SJJamGr2an7fHeTtSB4fwETKYxDPhZurWZr4tulp8zUqLN9M9rsND59IJfwo6fV98SZvWSxCMfF31l9Y+n25mZJJFOXqx88glrcNbPLcZQMRG9qFvv8V7S0hpp/1HaMGGWB5gw+h4lrF5cuboatgzMQI6bArESbTNlkUj6TStH0cDw9+jnypPEwa+Ryh6qyq747h9K5duIOZW8DKFB08TAN/PVlmCc5c0HRb6TcEwDRvpOtDnWmsUiKhAhhamN5yfa/6xaXWaJ9aenlJ1lrZVcZkLODYCd52JTHH9CQ51xyXePGBTXVnYne7+7RyG79sXTW2AYvTzAHg8ixs613nrqZV8VyG5y+vKuUrJ61IKab14t9W0lOFDSQoX+pf3YwCkT05K72CHj0chVjrTaWF2Bu4= diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index efd141459e8..9d52417fc94 100755 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -131,7 +131,7 @@ from the main (upstream) repository: ## Coding Rules To ensure consistency throughout the source code, keep these rules in mind as you are working: -* All features or bug fixes **must be tested** by one or more specs (unit-tests). +* All features or bug fixes **must be tested** by one or more specs (unit-tests and/or integration/regression-tests). ## Commit Message Guidelines @@ -175,7 +175,7 @@ If the commit reverts a previous commit, it should begin with `revert: `, follow ### Type Must be one of the following: -* **ci**: Changes to our CI configuration files and scripts (example scopes: Travis, Circle, BrowserStack, SauceLabs) +* **ci**: Changes to our CI configuration files and scripts (example scopes: Travis) * **docs**: Documentation only changes * **feat**: A new feature * **fix**: A bug fix @@ -185,13 +185,10 @@ Must be one of the following: * **test**: Adding missing tests or correcting existing tests ### Scope -The scope should be the name of the MODFLOW 6 module/class affected (as perceived by the person reading the changelog generated from commit messages. +The scope should be the name of the MODFLOW 6 module/class affected (as perceived by the person reading the changelog generated from commit messages). There are currently a few exceptions to the "use module/class name" rule: -* **packaging**: used for changes that change the npm package layout in all of our packages, e.g. - public path changes, package.json changes done to all packages, d.ts file/format changes, changes - to bundles, etc. * **releasenotes**: used for updating the release notes * **readme**: used for updating the release notes in README.md * **changelog**: used for updating the release notes in CHANGELOG.md diff --git a/DEVELOPER.md b/DEVELOPER.md index 90a07fbe9ba..202d4aec1b5 100644 --- a/DEVELOPER.md +++ b/DEVELOPER.md @@ -81,7 +81,7 @@ To run tests: ```shell # Go to the autotest directory -cd modflow6/autotests +cd modflow6/autotest # Run all modflow6 tests (including building executables and the mfio documentation - requires installation of LaTeX nosetests -v diff --git a/README.md b/README.md index 59f689b0103..985c94d347b 100644 --- a/README.md +++ b/README.md @@ -7,8 +7,8 @@ ## Automated Testing Status on Travis-CI -### Version 6.0.3 vkd — build 8 -[![Build Status](https://travis-ci.org/MODFLOW-USGS/modflow6.svg?branch=vkd)](https://travis-ci.org/MODFLOW-USGS/modflow6) +### Version 6.1.1 release candidate +[![Build Status](https://travis-ci.org/MODFLOW-USGS/modflow6.svg?branch=develop)](https://travis-ci.org/MODFLOW-USGS/modflow6) ## Introduction @@ -31,8 +31,7 @@ MODFLOW 6 is the latest core version of MODFLOW. It synthesizes many of the capa #### ***Software/Code citation for MODFLOW 6:*** -[Langevin, C.D., Hughes, J.D., Banta, E.R., Provost, A.M., Niswonger, R.G., and Panday, Sorab, 2018, MODFLOW 6 Modular Hydrologic Model version 6.0.3 — vkd: U.S. Geological Survey Software Release, 06 September 2018, https://doi.org/10.5066/F76Q1VQV](https://doi.org/10.5066/F76Q1VQV) - +[Langevin, C.D., Hughes, J.D., Banta, E.R., Provost, A.M., Niswonger, R.G., and Panday, Sorab, 2019, MODFLOW 6 Modular Hydrologic Model version 6.1.1 release candidate: U.S. Geological Survey Software Release, 12 December 2019, https://doi.org/10.5066/F76Q1VQV](https://doi.org/10.5066/F76Q1VQV) ## Instructions for building definition files for new packages diff --git a/autotest/data/ibc01_ibound.ref b/autotest/data/ibc01_ibound.ref new file mode 100644 index 00000000000..f83054758e8 --- /dev/null +++ b/autotest/data/ibc01_ibound.ref @@ -0,0 +1,20 @@ + 0 0 0 0 0 1 1 2 1 1 0 0 0 0 0 + 0 0 0 0 2 1 1 2 1 1 1 2 0 0 0 + 0 0 0 2 1 1 1 1 1 1 1 1 0 0 0 + 0 0 0 1 1 1 1 1 1 1 1 2 0 0 0 + 0 0 2 1 1 1 1 1 1 1 1 1 2 0 0 + 0 0 1 1 1 1 1 1 1 1 1 1 1 2 0 + 0 2 1 1 1 1 1 1 1 1 1 1 1 1 0 + 0 1 1 1 1 1 1 1 1 1 1 1 1 1 0 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 0 1 1 1 1 1 1 1 1 1 1 1 1 1 0 + 0 2 1 1 1 1 1 1 1 1 1 1 1 2 0 + 0 0 1 1 1 1 1 1 1 1 1 1 1 0 0 + 0 0 2 1 1 1 1 1 1 1 1 1 2 0 0 + 0 0 0 1 1 1 1 1 1 1 1 1 2 0 0 + 0 0 0 2 1 1 1 1 1 1 1 2 0 0 0 + 0 0 0 0 0 0 2 1 1 1 0 0 0 0 0 + 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 diff --git a/autotest/data/ibc03_dstart1.ref b/autotest/data/ibc03_dstart1.ref new file mode 100644 index 00000000000..2b7650ff573 --- /dev/null +++ b/autotest/data/ibc03_dstart1.ref @@ -0,0 +1,10 @@ + 22.659 22.314 21.659 21.246 21.045 21.045 21.246 21.659 22.314 22.659 + 21.622 21.127 20.711 20.419 20.270 20.270 20.419 20.711 21.127 21.622 + 20.114 19.628 19.267 19.026 18.905 18.905 19.026 19.267 19.628 20.114 + 18.047 17.619 17.327 17.142 17.051 17.051 17.142 17.327 17.619 18.047 + 15.116 15.030 14.930 14.850 14.807 14.807 14.850 14.930 15.030 15.116 + 12.470 12.443 12.404 12.368 12.346 12.346 12.368 12.404 12.443 12.470 + 9.870 9.845 9.805 9.766 9.742 9.742 9.766 9.805 9.845 9.870 + 7.297 7.235 7.133 7.029 6.970 6.970 7.029 7.133 7.235 7.297 + 4.891 4.709 4.383 4.017 3.864 3.864 4.017 4.383 4.709 4.891 + 3.135 2.680 1.696 0.000 0.000 0.000 0.000 1.696 2.680 3.135 diff --git a/autotest/data/ibc03_dstart3.ref b/autotest/data/ibc03_dstart3.ref new file mode 100644 index 00000000000..887746f5bfc --- /dev/null +++ b/autotest/data/ibc03_dstart3.ref @@ -0,0 +1,10 @@ + 13.294 13.295 13.296 13.297 13.298 13.298 13.297 13.296 13.295 13.294 + 13.270 13.275 13.278 13.279 13.280 13.280 13.279 13.278 13.275 13.270 + 13.214 13.218 13.221 13.223 13.224 13.224 13.223 13.221 13.218 13.214 + 13.129 13.132 13.134 13.136 13.136 13.136 13.136 13.134 13.132 13.129 + 13.024 13.026 13.027 13.028 13.028 13.028 13.028 13.027 13.026 13.024 + 12.911 12.911 12.911 12.910 12.910 12.910 12.910 12.911 12.911 12.911 + 12.801 12.799 12.797 12.796 12.796 12.796 12.796 12.797 12.799 12.801 + 12.707 12.703 12.700 12.698 12.697 12.697 12.698 12.700 12.703 12.707 + 12.640 12.636 12.632 12.630 12.628 12.628 12.630 12.632 12.636 12.640 + 12.611 12.610 12.608 12.606 12.605 12.605 12.606 12.608 12.610 12.611 \ No newline at end of file diff --git a/autotest/data/nwtp03_bot.ref b/autotest/data/nwtp03_bot.ref new file mode 100644 index 00000000000..404ec6116c5 --- /dev/null +++ b/autotest/data/nwtp03_bot.ref @@ -0,0 +1,80 @@ +34.92 35.48 36.05 36.62 37.19 37.76 38.33 38.90 39.48 40.06 40.64 41.22 41.80 42.38 42.96 43.54 44.13 44.71 45.30 45.89 46.47 47.06 47.65 48.24 48.82 49.41 50.00 50.59 51.18 51.76 52.35 52.94 53.53 54.11 54.70 55.29 55.87 56.46 57.04 57.62 58.20 58.78 59.36 59.94 60.52 61.10 61.67 62.24 62.81 63.38 63.95 64.52 65.08 65.65 66.21 66.77 67.32 67.88 68.43 68.98 69.53 70.08 70.62 71.16 71.70 72.23 72.77 73.30 73.82 74.35 74.87 75.39 75.90 76.41 76.92 77.42 77.93 78.42 78.92 79.41 +35.93 36.46 36.98 37.48 37.97 38.46 38.94 39.41 39.88 40.36 40.84 41.33 41.83 42.34 42.87 43.41 43.97 44.54 45.14 45.74 46.36 46.99 47.63 48.27 48.92 49.56 50.20 50.83 51.45 52.05 52.64 53.22 53.78 54.32 54.85 55.37 55.87 56.36 56.84 57.32 57.80 58.28 58.77 59.26 59.76 60.28 60.80 61.35 61.90 62.47 63.06 63.65 64.26 64.87 65.49 66.10 66.72 67.32 67.92 68.51 69.08 69.64 70.18 70.70 71.20 71.69 72.16 72.61 73.05 73.48 73.90 74.32 74.73 75.15 75.57 76.00 76.44 76.89 77.35 77.82 +36.98 37.47 37.94 38.38 38.80 39.19 39.57 39.95 40.31 40.69 41.07 41.46 41.88 42.32 42.79 43.29 43.82 44.39 44.99 45.61 46.26 46.93 47.62 48.32 49.02 49.71 50.39 51.06 51.71 52.34 52.93 53.49 54.02 54.52 54.99 55.43 55.85 56.24 56.63 57.00 57.38 57.76 58.14 58.55 58.98 59.43 59.91 60.42 60.96 61.53 62.13 62.75 63.39 64.05 64.72 65.39 66.06 66.72 67.36 67.98 68.58 69.15 69.68 70.19 70.65 71.09 71.49 71.86 72.22 72.55 72.87 73.19 73.50 73.82 74.16 74.51 74.88 75.28 75.70 76.15 +38.06 38.53 38.94 39.32 39.65 39.96 40.24 40.51 40.77 41.04 41.32 41.62 41.95 42.32 42.73 43.19 43.70 44.25 44.85 45.49 46.17 46.88 47.62 48.36 49.12 49.86 50.59 51.30 51.97 52.61 53.21 53.75 54.26 54.71 55.11 55.48 55.81 56.11 56.39 56.66 56.93 57.21 57.50 57.82 58.17 58.55 58.98 59.46 59.98 60.55 61.16 61.81 62.49 63.19 63.91 64.64 65.36 66.07 66.75 67.41 68.03 68.61 69.14 69.62 70.05 70.43 70.76 71.06 71.32 71.56 71.78 71.99 72.20 72.43 72.67 72.94 73.25 73.59 73.98 74.41 +39.19 39.61 39.97 40.28 40.54 40.75 40.94 41.10 41.26 41.42 41.59 41.80 42.05 42.34 42.69 43.11 43.58 44.12 44.73 45.39 46.09 46.84 47.62 48.42 49.22 50.01 50.79 51.53 52.23 52.88 53.48 54.01 54.48 54.88 55.23 55.52 55.76 55.97 56.14 56.31 56.47 56.64 56.83 57.06 57.33 57.65 58.03 58.48 58.98 59.54 60.16 60.84 61.55 62.30 63.07 63.84 64.62 65.37 66.10 66.79 67.43 68.01 68.54 68.99 69.38 69.71 69.98 70.19 70.37 70.51 70.62 70.73 70.84 70.97 71.12 71.31 71.55 71.84 72.20 72.61 +40.34 40.73 41.03 41.27 41.45 41.57 41.66 41.71 41.76 41.82 41.89 42.00 42.16 42.38 42.68 43.04 43.49 44.01 44.62 45.29 46.02 46.81 47.63 48.47 49.32 50.16 50.98 51.76 52.49 53.15 53.74 54.25 54.69 55.05 55.33 55.54 55.69 55.80 55.88 55.93 55.99 56.05 56.15 56.28 56.48 56.73 57.06 57.46 57.95 58.51 59.14 59.83 60.58 61.37 62.18 63.01 63.83 64.64 65.41 66.13 66.78 67.37 67.89 68.32 68.67 68.94 69.14 69.28 69.36 69.40 69.41 69.41 69.42 69.45 69.51 69.63 69.80 70.03 70.34 70.73 +41.52 41.87 42.12 42.29 42.39 42.42 42.40 42.35 42.29 42.24 42.21 42.23 42.30 42.44 42.67 42.99 43.41 43.92 44.52 45.20 45.96 46.78 47.64 48.53 49.43 50.32 51.17 51.98 52.73 53.41 53.99 54.49 54.89 55.20 55.41 55.55 55.61 55.62 55.59 55.54 55.49 55.45 55.44 55.49 55.60 55.79 56.06 56.43 56.89 57.44 58.08 58.80 59.58 60.41 61.27 62.14 63.01 63.86 64.67 65.42 66.09 66.69 67.19 67.60 67.91 68.12 68.25 68.31 68.30 68.24 68.15 68.04 67.95 67.88 67.85 67.88 67.98 68.16 68.44 68.80 +42.73 43.04 43.24 43.33 43.35 43.28 43.17 43.01 42.84 42.68 42.55 42.47 42.45 42.52 42.69 42.96 43.34 43.84 44.43 45.13 45.91 46.76 47.66 48.60 49.54 50.47 51.37 52.21 52.98 53.66 54.24 54.71 55.08 55.34 55.49 55.54 55.52 55.43 55.30 55.14 54.97 54.83 54.72 54.68 54.71 54.83 55.05 55.38 55.81 56.36 57.00 57.74 58.55 59.41 60.32 61.24 62.16 63.05 63.89 64.67 65.36 65.96 66.45 66.83 67.10 67.26 67.32 67.29 67.18 67.03 66.83 66.62 66.43 66.26 66.14 66.08 66.12 66.24 66.47 66.81 +43.97 44.23 44.37 44.40 44.33 44.17 43.95 43.69 43.42 43.15 42.91 42.73 42.63 42.62 42.72 42.95 43.29 43.77 44.36 45.07 45.87 46.75 47.69 48.66 49.65 50.62 51.55 52.42 53.21 53.90 54.48 54.93 55.26 55.46 55.55 55.53 55.41 55.22 54.98 54.72 54.44 54.19 53.99 53.85 53.80 53.85 54.02 54.30 54.72 55.25 55.90 56.65 57.49 58.39 59.34 60.31 61.27 62.20 63.08 63.88 64.59 65.19 65.66 66.02 66.24 66.34 66.33 66.22 66.03 65.77 65.47 65.16 64.85 64.59 64.37 64.24 64.20 64.27 64.46 64.77 +45.22 45.44 45.52 45.48 45.33 45.08 44.76 44.39 44.00 43.63 43.29 43.01 42.82 42.73 42.77 42.95 43.26 43.71 44.30 45.01 45.83 46.74 47.72 48.74 49.76 50.77 51.74 52.64 53.44 54.14 54.70 55.14 55.43 55.58 55.60 55.50 55.29 55.01 54.66 54.28 53.90 53.54 53.24 53.01 52.87 52.86 52.97 53.22 53.60 54.13 54.78 55.55 56.41 57.35 58.34 59.35 60.35 61.32 62.23 63.06 63.78 64.38 64.84 65.16 65.35 65.39 65.31 65.11 64.83 64.47 64.07 63.65 63.24 62.87 62.57 62.35 62.25 62.26 62.41 62.69 +46.49 46.67 46.69 46.58 46.34 46.00 45.58 45.10 44.61 44.12 43.68 43.31 43.03 42.86 42.84 42.96 43.24 43.67 44.25 44.97 45.81 46.75 47.76 48.81 49.88 50.92 51.92 52.85 53.67 54.37 54.92 55.33 55.58 55.68 55.64 55.45 55.16 54.77 54.32 53.84 53.35 52.88 52.48 52.15 51.94 51.85 51.91 52.12 52.48 52.99 53.64 54.43 55.31 56.29 57.31 58.36 59.41 60.41 61.35 62.20 62.93 63.53 63.98 64.27 64.41 64.40 64.24 63.97 63.59 63.13 62.63 62.10 61.59 61.12 60.73 60.43 60.25 60.21 60.31 60.57 +47.77 47.91 47.87 47.69 47.37 46.93 46.41 45.83 45.23 44.64 44.09 43.62 43.25 43.01 42.92 42.99 43.23 43.64 44.22 44.94 45.79 46.76 47.80 48.89 49.99 51.07 52.10 53.05 53.89 54.59 55.13 55.52 55.73 55.78 55.66 55.40 55.02 54.53 53.98 53.38 52.78 52.22 51.71 51.29 51.00 50.84 50.84 51.00 51.34 51.84 52.49 53.29 54.20 55.20 56.26 57.35 58.43 59.48 60.45 61.31 62.06 62.65 63.08 63.35 63.44 63.37 63.14 62.78 62.31 61.76 61.15 60.52 59.91 59.34 58.85 58.47 58.22 58.12 58.19 58.42 +49.07 49.16 49.07 48.81 48.41 47.88 47.26 46.57 45.86 45.16 44.51 43.94 43.49 43.17 43.02 43.04 43.24 43.63 44.19 44.92 45.79 46.77 47.84 48.97 50.11 51.22 52.28 53.25 54.10 54.80 55.33 55.69 55.87 55.86 55.67 55.34 54.86 54.28 53.62 52.92 52.21 51.54 50.93 50.42 50.05 49.82 49.76 49.88 50.19 50.68 51.33 52.14 53.07 54.10 55.20 56.32 57.44 58.52 59.51 60.40 61.15 61.74 62.16 62.39 62.44 62.31 62.01 61.57 61.01 60.35 59.64 58.91 58.20 57.53 56.95 56.49 56.17 56.01 56.03 56.23 +50.37 50.42 50.27 49.94 49.45 48.83 48.11 47.32 46.51 45.70 44.95 44.28 43.74 43.35 43.13 43.10 43.26 43.63 44.18 44.91 45.79 46.80 47.90 49.05 50.22 51.37 52.46 53.44 54.30 55.00 55.53 55.86 55.99 55.93 55.68 55.26 54.69 54.01 53.25 52.44 51.63 50.85 50.15 49.55 49.09 48.79 48.68 48.76 49.04 49.51 50.16 50.98 51.93 52.99 54.11 55.27 56.43 57.53 58.56 59.46 60.22 60.80 61.20 61.40 61.41 61.22 60.85 60.33 59.67 58.92 58.11 57.28 56.46 55.70 55.03 54.49 54.10 53.88 53.85 54.03 +51.68 51.68 51.47 51.07 50.51 49.79 48.97 48.08 47.16 46.25 45.40 44.64 44.01 43.54 43.25 43.17 43.30 43.63 44.18 44.91 45.80 46.82 47.95 49.13 50.34 51.51 52.62 53.63 54.50 55.20 55.71 56.01 56.10 55.99 55.67 55.17 54.52 53.74 52.88 51.97 51.05 50.17 49.36 48.67 48.13 47.77 47.60 47.63 47.88 48.34 48.99 49.81 50.78 51.86 53.02 54.21 55.40 56.53 57.58 58.50 59.26 59.84 60.22 60.39 60.35 60.10 59.66 59.06 58.31 57.47 56.55 55.62 54.70 53.84 53.09 52.46 52.00 51.73 51.66 51.80 +52.99 52.94 52.68 52.21 51.56 50.76 49.84 48.85 47.82 46.81 45.85 45.00 44.28 43.74 43.39 43.25 43.34 43.66 44.18 44.91 45.82 46.86 48.01 49.22 50.45 51.66 52.79 53.81 54.69 55.38 55.88 56.16 56.21 56.04 55.65 55.08 54.34 53.46 52.50 51.48 50.46 49.48 48.58 47.80 47.18 46.74 46.51 46.51 46.73 47.16 47.81 48.64 49.62 50.73 51.92 53.14 54.35 55.52 56.59 57.52 58.29 58.86 59.22 59.36 59.27 58.96 58.46 57.77 56.94 55.99 54.98 53.95 52.93 51.98 51.13 50.43 49.90 49.57 49.46 49.57 +54.30 54.21 53.89 53.35 52.61 51.72 50.71 49.61 48.49 47.37 46.32 45.37 44.57 43.95 43.54 43.35 43.40 43.69 44.20 44.93 45.84 46.90 48.07 49.31 50.57 51.80 52.95 53.99 54.87 55.56 56.04 56.29 56.30 56.07 55.62 54.97 54.14 53.18 52.11 50.99 49.87 48.78 47.79 46.92 46.22 45.72 45.43 45.38 45.57 45.99 46.63 47.47 48.47 49.59 50.81 52.06 53.30 54.49 55.58 56.52 57.29 57.86 58.20 58.30 58.17 57.81 57.23 56.46 55.54 54.51 53.40 52.26 51.15 50.10 49.17 48.39 47.79 47.41 47.25 47.33 +55.60 55.47 55.09 54.48 53.67 52.69 51.58 50.39 49.16 47.94 46.79 45.75 44.87 44.17 43.70 43.46 43.47 43.73 44.23 44.95 45.87 46.95 48.14 49.40 50.68 51.93 53.11 54.16 55.04 55.73 56.19 56.41 56.38 56.10 55.59 54.86 53.94 52.88 51.72 50.50 49.28 48.09 47.00 46.05 45.27 44.70 44.36 44.27 44.42 44.83 45.46 46.30 47.31 48.46 49.69 50.97 52.24 53.45 54.56 55.51 56.29 56.84 57.16 57.23 57.05 56.63 55.99 55.14 54.14 53.01 51.80 50.57 49.36 48.23 47.21 46.35 45.68 45.24 45.04 45.09 +56.90 56.72 56.28 55.60 54.71 53.65 52.45 51.16 49.83 48.52 47.27 46.14 45.18 44.41 43.87 43.58 43.55 43.78 44.27 44.99 45.91 47.00 48.21 49.49 50.79 52.07 53.26 54.32 55.21 55.89 56.33 56.52 56.45 56.12 55.54 54.74 53.74 52.59 51.33 50.01 48.68 47.41 46.22 45.18 44.33 43.69 43.29 43.16 43.28 43.67 44.29 45.13 46.16 47.32 48.58 49.88 51.17 52.41 53.53 54.50 55.27 55.81 56.11 56.15 55.93 55.45 54.74 53.81 52.72 51.50 50.21 48.88 47.58 46.35 45.25 44.31 43.58 43.08 42.84 42.86 +58.18 57.96 57.46 56.72 55.75 54.60 53.31 51.92 50.50 49.09 47.76 46.54 45.49 44.65 44.05 43.71 43.64 43.85 44.32 45.03 45.95 47.05 48.28 49.58 50.90 52.20 53.40 54.48 55.37 56.04 56.47 56.63 56.51 56.13 55.48 54.61 53.53 52.28 50.93 49.52 48.09 46.72 45.45 44.32 43.39 42.69 42.24 42.06 42.15 42.52 43.13 43.98 45.01 46.19 47.47 48.79 50.11 51.36 52.50 53.47 54.24 54.78 55.05 55.06 54.79 54.26 53.48 52.48 51.31 50.00 48.61 47.19 45.79 44.48 43.29 42.28 41.49 40.94 40.65 40.64 +59.45 59.18 58.63 57.82 56.78 55.55 54.17 52.69 51.17 49.67 48.24 46.94 45.81 44.90 44.24 43.85 43.74 43.92 44.37 45.08 46.00 47.11 48.35 49.67 51.01 52.32 53.54 54.62 55.52 56.18 56.59 56.72 56.56 56.13 55.42 54.47 53.31 51.98 50.53 49.03 47.51 46.04 44.68 43.48 42.47 41.70 41.20 40.98 41.04 41.38 41.99 42.83 43.87 45.07 46.36 47.71 49.04 50.31 51.46 52.44 53.21 53.74 53.99 53.96 53.65 53.06 52.21 51.14 49.89 48.49 47.01 45.50 44.02 42.62 41.35 40.27 39.41 38.81 38.48 38.43 +60.70 60.39 59.79 58.91 57.80 56.48 55.02 53.45 51.84 50.24 48.73 47.34 46.14 45.16 44.43 44.00 43.85 44.00 44.44 45.13 46.06 47.18 48.43 49.76 51.12 52.45 53.68 54.77 55.66 56.31 56.70 56.80 56.61 56.12 55.35 54.33 53.09 51.67 50.14 48.54 46.93 45.37 43.93 42.64 41.56 40.73 40.17 39.91 39.94 40.26 40.86 41.70 42.75 43.95 45.27 46.63 47.98 49.27 50.43 51.41 52.18 52.69 52.92 52.86 52.50 51.86 50.95 49.81 48.48 47.00 45.43 43.83 42.26 40.78 39.43 38.28 37.36 36.70 36.33 36.25 +61.93 61.58 60.92 59.98 58.80 57.41 55.85 54.20 52.50 50.82 49.21 47.75 46.47 45.42 44.64 44.15 43.97 44.09 44.51 45.20 46.12 47.24 48.51 49.85 51.23 52.57 53.81 54.90 55.79 56.43 56.80 56.87 56.64 56.10 55.27 54.18 52.86 51.37 49.74 48.05 46.36 44.71 43.18 41.82 40.67 39.78 39.17 38.86 38.86 39.16 39.75 40.58 41.64 42.85 44.18 45.56 46.93 48.23 49.40 50.39 51.15 51.65 51.86 51.76 51.36 50.66 49.69 48.48 47.07 45.51 43.86 42.18 40.52 38.96 37.54 36.31 35.33 34.62 34.21 34.11 +63.14 62.74 62.03 61.03 59.78 58.31 56.68 54.94 53.15 51.39 49.70 48.15 46.80 45.69 44.85 44.31 44.09 44.19 44.59 45.27 46.19 47.31 48.59 49.95 51.33 52.68 53.93 55.02 55.91 56.54 56.89 56.93 56.66 56.07 55.18 54.03 52.63 51.06 49.35 47.58 45.79 44.06 42.45 41.01 39.80 38.84 38.18 37.83 37.80 38.08 38.66 39.49 40.54 41.77 43.11 44.50 45.89 47.20 48.37 49.36 50.12 50.61 50.79 50.66 50.22 49.47 48.44 47.16 45.68 44.04 42.31 40.54 38.80 37.16 35.67 34.38 33.34 32.58 32.13 31.99 +64.32 63.88 63.12 62.06 60.74 59.20 57.49 55.66 53.80 51.95 50.18 48.56 47.13 45.96 45.07 44.48 44.23 44.29 44.67 45.34 46.26 47.39 48.67 50.04 51.43 52.79 54.05 55.14 56.02 56.65 56.97 56.99 56.67 56.03 55.09 53.87 52.41 50.75 48.97 47.11 45.24 43.43 41.74 40.23 38.94 37.93 37.22 36.83 36.77 37.03 37.59 38.42 39.47 40.71 42.06 43.46 44.86 46.18 47.36 48.35 49.10 49.57 49.74 49.58 49.09 48.29 47.21 45.86 44.30 42.59 40.78 38.93 37.12 35.40 33.83 32.48 31.38 30.57 30.08 29.92 +65.47 64.99 64.18 63.06 61.68 60.07 58.28 56.38 54.43 52.50 50.66 48.96 47.47 46.23 45.29 44.66 44.36 44.40 44.76 45.42 46.34 47.47 48.75 50.13 51.53 52.90 54.16 55.25 56.13 56.74 57.04 57.03 56.68 55.99 54.99 53.71 52.18 50.45 48.58 46.64 44.70 42.81 41.04 39.46 38.11 37.04 36.29 35.86 35.77 36.00 36.55 37.37 38.43 39.67 41.02 42.44 43.84 45.17 46.36 47.35 48.09 48.55 48.69 48.50 47.98 47.13 45.98 44.57 42.95 41.16 39.27 37.35 35.46 33.67 32.04 30.62 29.47 28.61 28.08 27.89 +66.58 66.06 65.21 64.04 62.59 60.91 59.05 57.07 55.05 53.05 51.13 49.36 47.80 46.51 45.51 44.84 44.51 44.52 44.86 45.51 46.42 47.55 48.83 50.22 51.63 53.00 54.26 55.36 56.22 56.82 57.11 57.06 56.67 55.94 54.89 53.54 51.94 50.15 48.21 46.19 44.17 42.20 40.36 38.72 37.31 36.18 35.38 34.91 34.79 35.01 35.54 36.35 37.41 38.65 40.01 41.44 42.85 44.18 45.37 46.36 47.10 47.54 47.66 47.44 46.87 45.98 44.78 43.31 41.62 39.76 37.80 35.81 33.84 31.98 30.28 28.81 27.60 26.70 26.14 25.91 +67.66 67.11 66.20 64.98 63.47 61.73 59.80 57.75 55.66 53.58 51.59 49.76 48.14 46.78 45.74 45.02 44.66 44.64 44.97 45.60 46.50 47.63 48.92 50.30 51.72 53.09 54.36 55.45 56.31 56.89 57.16 57.08 56.66 55.88 54.78 53.38 51.71 49.85 47.84 45.75 43.65 41.61 39.71 38.00 36.53 35.35 34.50 34.00 33.85 34.04 34.56 35.37 36.42 37.66 39.03 40.46 41.88 43.22 44.41 45.39 46.12 46.55 46.64 46.39 45.79 44.85 43.60 42.07 40.32 38.39 36.36 34.30 32.27 30.34 28.58 27.05 25.79 24.85 24.24 23.99 +68.71 68.11 67.17 65.89 64.33 62.52 60.53 58.41 56.25 54.10 52.04 50.15 48.47 47.06 45.97 45.21 44.81 44.77 45.07 45.69 46.59 47.71 49.00 50.39 51.81 53.18 54.45 55.53 56.39 56.95 57.20 57.10 56.63 55.82 54.67 53.21 51.49 49.55 47.48 45.32 43.15 41.05 39.08 37.30 35.78 34.55 33.66 33.12 32.94 33.11 33.61 34.41 35.46 36.70 38.08 39.51 40.93 42.27 43.47 44.45 45.16 45.57 45.64 45.36 44.73 43.74 42.44 40.86 39.04 37.06 34.96 32.83 30.74 28.75 26.93 25.34 24.04 23.05 22.41 22.14 +69.71 69.08 68.09 66.77 65.15 63.28 61.23 59.05 56.82 54.61 52.49 50.53 48.80 47.34 46.20 45.40 44.97 44.90 45.19 45.79 46.68 47.80 49.08 50.47 51.89 53.27 54.53 55.61 56.45 57.01 57.23 57.10 56.61 55.75 54.55 53.04 51.26 49.27 47.12 44.90 42.67 40.50 38.47 36.63 35.06 33.79 32.85 32.28 32.07 32.22 32.70 33.49 34.54 35.78 37.15 38.59 40.01 41.36 42.55 43.52 44.23 44.62 44.67 44.36 43.69 42.66 41.32 39.68 37.81 35.76 33.61 31.42 29.26 27.21 25.34 23.70 22.34 21.32 20.65 20.34 +70.66 70.00 68.97 67.60 65.94 64.01 61.90 59.66 57.37 55.10 52.92 50.91 49.12 47.61 46.43 45.59 45.13 45.04 45.30 45.89 46.77 47.88 49.17 50.55 51.97 53.35 54.61 55.68 56.51 57.05 57.25 57.10 56.57 55.67 54.43 52.87 51.04 48.98 46.78 44.50 42.20 39.98 37.89 36.00 34.37 33.05 32.08 31.47 31.23 31.36 31.83 32.61 33.65 34.89 36.26 37.70 39.13 40.47 41.65 42.62 43.32 43.69 43.72 43.38 42.68 41.61 40.22 38.54 36.61 34.51 32.30 30.05 27.83 25.73 23.80 22.12 20.72 19.66 18.95 18.62 +71.57 70.88 69.81 68.40 66.68 64.71 62.54 60.25 57.90 55.57 53.34 51.27 49.43 47.88 46.66 45.79 45.30 45.18 45.42 46.00 46.86 47.97 49.25 50.63 52.05 53.42 54.67 55.74 56.56 57.08 57.26 57.08 56.52 55.59 54.31 52.70 50.81 48.71 46.45 44.11 41.76 39.48 37.33 35.39 33.72 32.36 31.35 30.71 30.44 30.55 31.01 31.77 32.80 34.04 35.41 36.85 38.27 39.61 40.79 41.75 42.43 42.79 42.80 42.44 41.70 40.60 39.16 37.43 35.46 33.30 31.04 28.73 26.47 24.31 22.34 20.60 19.17 18.07 17.34 16.98 +72.44 71.71 70.61 69.16 67.40 65.38 63.16 60.81 58.41 56.03 53.74 51.63 49.74 48.15 46.88 45.98 45.46 45.32 45.54 46.10 46.96 48.06 49.33 50.71 52.12 53.49 54.73 55.79 56.60 57.11 57.27 57.06 56.47 55.51 54.18 52.53 50.60 48.44 46.13 43.74 41.34 39.00 36.81 34.82 33.10 31.70 30.65 29.98 29.69 29.78 30.22 30.98 32.00 33.23 34.60 36.03 37.45 38.78 39.96 40.91 41.58 41.93 41.91 41.52 40.75 39.62 38.14 36.37 34.35 32.15 29.83 27.48 25.16 22.96 20.94 19.16 17.69 16.56 15.80 15.42 +73.25 72.49 71.35 69.87 68.07 66.00 63.74 61.34 58.89 56.46 54.13 51.97 50.04 48.41 47.11 46.18 45.63 45.46 45.67 46.21 47.06 48.14 49.41 50.78 52.19 53.55 54.79 55.84 56.63 57.12 57.26 57.03 56.41 55.41 54.05 52.36 50.39 48.19 45.83 43.39 40.94 38.55 36.31 34.28 32.52 31.08 30.00 29.30 28.99 29.06 29.48 30.23 31.24 32.46 33.82 35.25 36.66 37.99 39.16 40.10 40.76 41.09 41.06 40.64 39.84 38.68 37.17 35.35 33.29 31.04 28.68 26.28 23.92 21.68 19.61 17.80 16.29 15.13 14.34 13.94 +74.00 73.22 72.05 70.53 68.69 66.59 64.28 61.85 59.35 56.88 54.51 52.30 50.34 48.67 47.33 46.37 45.80 45.61 45.80 46.32 47.15 48.23 49.49 50.85 52.25 53.60 54.83 55.87 56.65 57.12 57.25 56.99 56.35 55.32 53.92 52.19 50.18 47.94 45.54 43.05 40.56 38.13 35.85 33.78 31.98 30.51 29.40 28.67 28.34 28.38 28.79 29.52 30.52 31.74 33.09 34.51 35.92 37.24 38.40 39.33 39.98 40.29 40.24 39.80 38.97 37.78 36.23 34.38 32.28 30.00 27.60 25.15 22.75 20.47 18.37 16.52 14.98 13.79 12.97 12.55 +74.71 73.90 72.70 71.15 69.28 67.14 64.79 62.32 59.79 57.27 54.86 52.62 50.62 48.92 47.56 46.57 45.97 45.76 45.92 46.44 47.25 48.32 49.56 50.92 52.31 53.65 54.87 55.89 56.66 57.12 57.22 56.94 56.28 55.22 53.79 52.03 49.98 47.70 45.26 42.74 40.20 37.74 35.42 33.31 31.48 29.98 28.84 28.09 27.73 27.76 28.15 28.87 29.86 31.06 32.40 33.82 35.22 36.53 37.68 38.60 39.23 39.53 39.45 38.99 38.15 36.92 35.35 33.46 31.33 29.01 26.57 24.09 21.65 19.33 17.20 15.32 13.75 12.53 11.69 11.25 +75.35 74.52 73.30 71.72 69.82 67.64 65.27 62.76 60.19 57.64 55.20 52.93 50.89 49.16 47.77 46.76 46.13 45.90 46.05 46.55 47.35 48.40 49.64 50.98 52.36 53.69 54.90 55.91 56.66 57.10 57.19 56.89 56.20 55.12 53.66 51.87 49.79 47.48 45.00 42.44 39.87 37.37 35.02 32.88 31.02 29.49 28.33 27.55 27.17 27.18 27.56 28.26 29.24 30.43 31.76 33.17 34.56 35.86 37.00 37.91 38.52 38.80 38.71 38.23 37.36 36.11 34.51 32.60 30.43 28.08 25.61 23.10 20.63 18.28 16.12 14.21 12.61 11.37 10.51 10.05 +75.94 75.09 73.84 72.24 70.31 68.11 65.70 63.16 60.57 57.99 55.52 53.22 51.16 49.40 47.98 46.94 46.30 46.05 46.18 46.66 47.45 48.49 49.71 51.04 52.41 53.73 54.92 55.92 56.66 57.08 57.15 56.83 56.11 55.01 53.53 51.71 49.60 47.26 44.76 42.17 39.57 37.04 34.66 32.49 30.61 29.05 27.86 27.07 26.67 26.66 27.02 27.71 28.67 29.85 31.17 32.57 33.95 35.24 36.36 37.26 37.86 38.12 38.01 37.52 36.62 35.35 33.72 31.79 29.60 27.22 24.72 22.18 19.69 17.31 15.12 13.19 11.57 10.30 9.43 8.95 +76.47 75.59 74.33 72.70 70.75 68.53 66.10 63.53 60.91 58.31 55.81 53.49 51.41 49.62 48.19 47.13 46.47 46.20 46.31 46.78 47.55 48.57 49.78 51.10 52.45 53.75 54.93 55.92 56.64 57.05 57.10 56.76 56.03 54.90 53.40 51.56 49.43 47.06 44.53 41.92 39.29 36.74 34.33 32.15 30.24 28.66 27.45 26.63 26.22 26.19 26.53 27.21 28.16 29.32 30.63 32.01 33.38 34.66 35.77 36.65 37.24 37.49 37.36 36.84 35.93 34.64 32.99 31.04 28.83 26.42 23.90 21.34 18.82 16.42 14.21 12.26 10.62 9.34 8.44 7.95 +76.93 76.04 74.76 73.11 71.14 68.90 66.45 63.87 61.23 58.61 56.09 53.74 51.64 49.84 48.39 47.31 46.63 46.35 46.44 46.89 47.65 48.66 49.85 51.15 52.49 53.78 54.94 55.91 56.62 57.01 57.04 56.68 55.93 54.79 53.27 51.41 49.26 46.87 44.33 41.69 39.05 36.47 34.05 31.84 29.91 28.31 27.09 26.25 25.82 25.78 26.11 26.76 27.70 28.85 30.14 31.51 32.86 34.13 35.22 36.09 36.66 36.89 36.75 36.22 35.29 33.98 32.32 30.35 28.12 25.69 23.16 20.58 18.04 15.62 13.39 11.42 9.77 8.47 7.56 7.05 +77.33 76.43 75.13 73.47 71.49 69.23 66.77 64.17 61.51 58.88 56.34 53.98 51.87 50.05 48.58 47.49 46.79 46.49 46.57 47.01 47.75 48.74 49.91 51.20 52.52 53.79 54.94 55.89 56.58 56.95 56.97 56.60 55.83 54.67 53.14 51.26 49.10 46.70 44.14 41.48 38.83 36.24 33.80 31.57 29.63 28.02 26.78 25.93 25.48 25.42 25.73 26.37 27.29 28.43 29.71 31.06 32.40 33.64 34.73 35.58 36.13 36.35 36.20 35.65 34.71 33.38 31.70 29.72 27.47 25.04 22.49 19.90 17.34 14.91 12.67 10.69 9.02 7.71 6.79 6.26 +77.67 76.75 75.44 73.77 71.78 69.51 67.04 64.43 61.76 59.12 56.57 54.20 52.08 50.25 48.77 47.66 46.95 46.64 46.70 47.12 47.84 48.82 49.97 51.24 52.54 53.80 54.93 55.86 56.54 56.89 56.90 56.51 55.73 54.56 53.01 51.12 48.95 46.54 43.96 41.30 38.63 36.04 33.58 31.35 29.40 27.77 26.52 25.66 25.19 25.12 25.42 26.04 26.95 28.06 29.33 30.66 31.98 33.21 34.28 35.11 35.65 35.86 35.69 35.13 34.17 32.84 31.15 29.15 26.90 24.45 21.89 19.29 16.74 14.29 12.04 10.05 8.38 7.05 6.12 5.59 +77.95 77.02 75.70 74.02 72.01 69.74 67.26 64.65 61.98 59.33 56.78 54.41 52.27 50.44 48.94 47.83 47.11 46.78 46.83 47.23 47.94 48.89 50.03 51.28 52.56 53.80 54.91 55.83 56.48 56.83 56.81 56.42 55.62 54.44 52.88 50.99 48.80 46.39 43.81 41.15 38.47 35.87 33.41 31.17 29.21 27.58 26.32 25.44 24.97 24.88 25.16 25.77 26.66 27.76 29.00 30.31 31.62 32.83 33.88 34.70 35.22 35.41 35.23 34.66 33.69 32.35 30.65 28.65 26.39 23.94 21.38 18.78 16.21 13.77 11.52 9.52 7.83 6.51 5.56 5.02 +78.15 77.22 75.89 74.21 72.20 69.93 67.45 64.83 62.16 59.51 56.96 54.59 52.45 50.61 49.11 47.99 47.26 46.92 46.96 47.34 48.03 48.97 50.09 51.32 52.58 53.79 54.89 55.78 56.42 56.75 56.72 56.31 55.51 54.32 52.76 50.86 48.67 46.26 43.68 41.01 38.34 35.74 33.28 31.04 29.07 27.44 26.17 25.28 24.80 24.70 24.96 25.56 26.42 27.51 28.73 30.02 31.31 32.50 33.53 34.33 34.84 35.02 34.82 34.24 33.27 31.92 30.22 28.22 25.96 23.51 20.95 18.35 15.78 13.34 11.09 9.09 7.40 6.07 5.12 4.56 +78.30 77.35 76.02 74.34 72.33 70.06 67.59 64.98 62.31 59.67 57.12 54.75 52.62 50.78 49.28 48.15 47.41 47.06 47.08 47.45 48.12 49.04 50.14 51.35 52.59 53.78 54.85 55.73 56.35 56.67 56.62 56.21 55.40 54.20 52.64 50.74 48.55 46.14 43.57 40.91 38.24 35.64 33.19 30.95 28.98 27.35 26.07 25.18 24.69 24.58 24.83 25.40 26.25 27.31 28.52 29.79 31.05 32.22 33.24 34.02 34.51 34.68 34.47 33.88 32.91 31.55 29.85 27.85 25.60 23.15 20.60 18.00 15.45 13.01 10.76 8.76 7.07 5.74 4.78 4.22 +78.37 77.42 76.09 74.41 72.41 70.15 67.68 65.08 62.43 59.79 57.26 54.89 52.76 50.93 49.43 48.30 47.55 47.19 47.20 47.56 48.21 49.11 50.19 51.37 52.59 53.76 54.81 55.67 56.28 56.57 56.52 56.09 55.28 54.08 52.52 50.62 48.44 46.04 43.47 40.83 38.17 35.58 33.13 30.90 28.94 27.31 26.03 25.14 24.63 24.51 24.75 25.31 26.14 27.18 28.36 29.61 30.85 32.00 32.99 33.76 34.24 34.39 34.17 33.58 32.60 31.25 29.55 27.55 25.31 22.87 20.33 17.74 15.20 12.77 10.53 8.54 6.86 5.52 4.57 4.00 +78.38 77.43 76.10 74.42 72.43 70.18 67.73 65.15 62.51 59.89 57.37 55.02 52.90 51.07 49.57 48.44 47.69 47.32 47.32 47.66 48.30 49.17 50.23 51.39 52.59 53.73 54.76 55.60 56.19 56.47 56.41 55.97 55.15 53.96 52.40 50.51 48.34 45.95 43.40 40.77 38.13 35.55 33.12 30.90 28.95 27.32 26.05 25.15 24.64 24.51 24.73 25.28 26.09 27.11 28.27 29.49 30.71 31.84 32.81 33.55 34.02 34.15 33.93 33.33 32.35 31.00 29.31 27.33 25.09 22.67 20.14 17.58 15.05 12.63 10.40 8.42 6.75 5.42 4.46 3.89 +78.32 77.37 76.05 74.38 72.40 70.17 67.73 65.17 62.55 59.95 57.45 55.12 53.01 51.19 49.71 48.58 47.83 47.45 47.44 47.76 48.38 49.24 50.27 51.41 52.58 53.70 54.71 55.53 56.09 56.36 56.29 55.85 55.03 53.84 52.28 50.41 48.26 45.88 43.35 40.74 38.12 35.56 33.15 30.95 29.01 27.39 26.12 25.22 24.71 24.57 24.78 25.30 26.09 27.09 28.23 29.43 30.62 31.72 32.67 33.40 33.85 33.97 33.74 33.14 32.16 30.82 29.14 27.17 24.95 22.55 20.04 17.49 14.99 12.59 10.38 8.41 6.75 5.43 4.47 3.90 +78.19 77.24 75.93 74.28 72.32 70.10 67.69 65.15 62.56 59.99 57.51 55.20 53.11 51.31 49.83 48.71 47.96 47.58 47.56 47.87 48.46 49.30 50.31 51.42 52.56 53.66 54.64 55.44 55.99 56.25 56.16 55.72 54.90 53.71 52.17 50.31 48.18 45.83 43.32 40.74 38.14 35.61 33.22 31.03 29.11 27.50 26.24 25.35 24.83 24.68 24.88 25.39 26.16 27.14 28.25 29.42 30.59 31.67 32.59 33.30 33.74 33.85 33.61 33.01 32.04 30.70 29.04 27.08 24.89 22.51 20.03 17.50 15.02 12.65 10.46 8.51 6.86 5.55 4.60 4.02 +77.99 77.05 75.75 74.11 72.18 69.98 67.60 65.09 62.53 59.99 57.54 55.26 53.19 51.41 49.94 48.83 48.08 47.70 47.67 47.96 48.54 49.36 50.34 51.42 52.54 53.61 54.57 55.35 55.88 56.12 56.03 55.58 54.77 53.59 52.07 50.23 48.12 45.79 43.31 40.76 38.19 35.69 33.33 31.17 29.27 27.67 26.42 25.53 25.01 24.86 25.05 25.54 26.29 27.24 28.32 29.47 30.61 31.67 32.57 33.26 33.68 33.78 33.54 32.94 31.97 30.65 29.00 27.07 24.89 22.55 20.09 17.60 15.15 12.81 10.64 8.72 7.08 5.78 4.84 4.27 +77.73 76.80 75.51 73.90 71.98 69.82 67.47 65.00 62.47 59.96 57.55 55.29 53.26 51.50 50.05 48.94 48.20 47.81 47.78 48.06 48.62 49.41 50.37 51.43 52.51 53.56 54.49 55.25 55.76 55.99 55.89 55.45 54.64 53.47 51.96 50.14 48.06 45.77 43.33 40.80 38.28 35.81 33.48 31.35 29.47 27.90 26.66 25.77 25.26 25.10 25.27 25.75 26.48 27.40 28.46 29.58 30.69 31.72 32.60 33.27 33.67 33.77 33.52 32.92 31.96 30.66 29.03 27.12 24.98 22.66 20.24 17.79 15.37 13.06 10.92 9.03 7.41 6.13 5.19 4.62 +77.41 76.48 75.21 73.62 71.73 69.61 67.29 64.86 62.37 59.91 57.53 55.31 53.31 51.57 50.14 49.05 48.31 47.93 47.88 48.15 48.69 49.46 50.39 51.42 52.48 53.50 54.41 55.14 55.64 55.85 55.75 55.30 54.50 53.35 51.86 50.07 48.02 45.76 43.36 40.88 38.39 35.96 33.67 31.57 29.72 28.17 26.95 26.07 25.56 25.39 25.56 26.02 26.72 27.62 28.65 29.75 30.83 31.83 32.69 33.33 33.72 33.81 33.56 32.96 32.02 30.73 29.12 27.24 25.14 22.86 20.48 18.06 15.68 13.41 11.31 9.44 7.85 6.58 5.66 5.10 +77.01 76.10 74.85 73.28 71.43 69.34 67.07 64.68 62.24 59.82 57.49 55.31 53.34 51.63 50.22 49.15 48.42 48.04 47.98 48.24 48.76 49.51 50.41 51.41 52.44 53.43 54.31 55.02 55.50 55.71 55.60 55.15 54.36 53.23 51.76 50.00 47.99 45.77 43.41 40.98 38.53 36.15 33.90 31.84 30.02 28.49 27.29 26.43 25.92 25.75 25.90 26.34 27.03 27.90 28.91 29.97 31.02 31.99 32.83 33.45 33.83 33.90 33.65 33.06 32.13 30.86 29.29 27.44 25.37 23.13 20.80 18.42 16.09 13.86 11.80 9.96 8.40 7.15 6.24 5.68 +76.56 75.66 74.43 72.89 71.08 69.03 66.81 64.47 62.08 59.70 57.42 55.28 53.35 51.68 50.30 49.24 48.52 48.14 48.08 48.33 48.83 49.55 50.43 51.40 52.40 53.36 54.21 54.90 55.36 55.56 55.44 55.00 54.22 53.11 51.67 49.95 47.97 45.80 43.49 41.10 38.71 36.37 34.17 32.15 30.37 28.87 27.68 26.84 26.33 26.16 26.30 26.73 27.39 28.24 29.21 30.24 31.27 32.21 33.02 33.63 33.98 34.05 33.80 33.22 32.30 31.06 29.51 27.70 25.67 23.48 21.20 18.87 16.59 14.40 12.38 10.58 9.05 7.82 6.93 6.38 +76.03 75.16 73.95 72.45 70.67 68.67 66.50 64.21 61.88 59.56 57.32 55.23 53.35 51.71 50.36 49.32 48.62 48.24 48.18 48.41 48.90 49.59 50.44 51.38 52.35 53.28 54.11 54.77 55.22 55.40 55.28 54.85 54.08 52.99 51.58 49.89 47.96 45.84 43.58 41.25 38.91 36.63 34.47 32.50 30.76 29.29 28.13 27.30 26.80 26.63 26.76 27.17 27.81 28.64 29.58 30.58 31.57 32.48 33.26 33.85 34.19 34.26 34.01 33.43 32.53 31.31 29.80 28.03 26.05 23.91 21.68 19.41 17.17 15.04 13.06 11.30 9.81 8.61 7.73 7.19 +75.45 74.59 73.42 71.95 70.22 68.27 66.15 63.92 61.64 59.38 57.20 55.17 53.33 51.73 50.41 49.40 48.71 48.33 48.27 48.49 48.96 49.63 50.45 51.36 52.30 53.20 53.99 54.63 55.06 55.23 55.12 54.69 53.94 52.87 51.50 49.85 47.97 45.90 43.70 41.42 39.14 36.92 34.82 32.89 31.19 29.76 28.63 27.82 27.33 27.15 27.28 27.67 28.29 29.09 30.00 30.96 31.92 32.81 33.56 34.13 34.46 34.51 34.27 33.70 32.82 31.63 30.16 28.43 26.50 24.42 22.24 20.03 17.85 15.77 13.84 12.13 10.67 9.50 8.64 8.11 +74.81 73.97 72.83 71.40 69.71 67.81 65.75 63.59 61.37 59.18 57.06 55.08 53.29 51.74 50.45 49.47 48.79 48.42 48.36 48.57 49.02 49.66 50.45 51.33 52.24 53.11 53.88 54.49 54.90 55.06 54.95 54.52 53.79 52.75 51.42 49.81 47.98 45.97 43.83 41.62 39.41 37.25 35.20 33.33 31.67 30.28 29.18 28.39 27.91 27.73 27.85 28.23 28.82 29.59 30.47 31.40 32.33 33.18 33.91 34.46 34.77 34.82 34.58 34.03 33.17 32.01 30.58 28.90 27.02 24.99 22.87 20.73 18.61 16.59 14.72 13.05 11.63 10.49 9.65 9.13 +74.10 73.29 72.18 70.79 69.16 67.32 65.32 63.22 61.08 58.95 56.90 54.98 53.24 51.73 50.49 49.53 48.87 48.51 48.44 48.64 49.07 49.69 50.46 51.30 52.17 53.01 53.75 54.34 54.73 54.89 54.77 54.36 53.65 52.63 51.34 49.78 48.01 46.06 43.98 41.84 39.69 37.60 35.62 33.80 32.20 30.85 29.78 29.01 28.54 28.37 28.48 28.84 29.41 30.15 30.99 31.89 32.79 33.61 34.31 34.83 35.13 35.18 34.94 34.40 33.57 32.44 31.05 29.43 27.61 25.64 23.59 21.51 19.45 17.49 15.68 14.06 12.69 11.58 10.77 10.26 +73.34 72.55 71.48 70.14 68.56 66.78 64.85 62.82 60.75 58.69 56.71 54.85 53.17 51.71 50.51 49.58 48.94 48.59 48.52 48.71 49.12 49.72 50.45 51.27 52.10 52.91 53.62 54.19 54.56 54.71 54.59 54.19 53.50 52.52 51.27 49.76 48.05 46.16 44.16 42.09 40.01 37.99 36.07 34.32 32.77 31.46 30.42 29.67 29.22 29.05 29.15 29.50 30.05 30.76 31.57 32.44 33.29 34.09 34.76 35.26 35.55 35.59 35.35 34.83 34.02 32.94 31.59 30.02 28.26 26.36 24.38 22.36 20.38 18.49 16.73 15.17 13.84 12.77 11.98 11.49 +72.52 71.76 70.73 69.43 67.91 66.20 64.34 62.38 60.39 58.40 56.49 54.71 53.09 51.68 50.52 49.63 49.01 48.67 48.60 48.78 49.17 49.74 50.45 51.23 52.03 52.80 53.48 54.02 54.38 54.52 54.40 54.02 53.35 52.40 51.20 49.75 48.09 46.28 44.35 42.35 40.35 38.40 36.56 34.87 33.37 32.11 31.11 30.39 29.95 29.79 29.88 30.21 30.74 31.42 32.20 33.03 33.85 34.61 35.25 35.73 36.01 36.04 35.81 35.31 34.53 33.48 32.19 30.67 28.98 27.15 25.24 23.30 21.39 19.56 17.88 16.37 15.09 14.05 13.30 12.82 +71.65 70.92 69.92 68.68 67.22 65.57 63.79 61.91 60.00 58.09 56.26 54.54 52.99 51.64 50.52 49.66 49.07 48.74 48.68 48.84 49.22 49.77 50.44 51.18 51.95 52.69 53.34 53.86 54.20 54.33 54.21 53.84 53.20 52.29 51.13 49.74 48.15 46.41 44.55 42.64 40.72 38.85 37.08 35.45 34.02 32.81 31.85 31.15 30.73 30.57 30.66 30.97 31.48 32.12 32.87 33.67 34.45 35.18 35.79 36.25 36.51 36.54 36.32 35.84 35.09 34.08 32.84 31.38 29.76 28.00 26.17 24.31 22.47 20.72 19.10 17.65 16.42 15.43 14.70 14.25 +70.73 70.03 69.07 67.89 66.49 64.91 63.21 61.41 59.58 57.76 56.01 54.36 52.88 51.59 50.52 49.70 49.13 48.81 48.75 48.91 49.26 49.78 50.42 51.13 51.87 52.57 53.19 53.68 54.01 54.13 54.02 53.66 53.05 52.18 51.07 49.74 48.22 46.55 44.78 42.95 41.11 39.32 37.63 36.07 34.70 33.54 32.62 31.96 31.55 31.40 31.48 31.78 32.26 32.88 33.59 34.35 35.10 35.79 36.38 36.81 37.06 37.09 36.88 36.42 35.70 34.73 33.54 32.15 30.59 28.92 27.16 25.38 23.63 21.96 20.41 19.02 17.84 16.89 16.20 15.76 +69.75 69.09 68.18 67.05 65.71 64.21 62.59 60.88 59.13 57.40 55.73 54.17 52.75 51.52 50.51 49.72 49.18 48.88 48.81 48.96 49.30 49.80 50.41 51.08 51.78 52.44 53.04 53.51 53.81 53.93 53.82 53.48 52.90 52.07 51.01 49.74 48.30 46.71 45.02 43.27 41.53 39.82 38.21 36.73 35.42 34.32 33.44 32.81 32.42 32.27 32.35 32.64 33.09 33.68 34.36 35.08 35.79 36.45 37.00 37.42 37.65 37.68 37.48 37.04 36.35 35.43 34.30 32.97 31.49 29.89 28.22 26.53 24.86 23.26 21.79 20.47 19.35 18.44 17.78 17.36 +68.73 68.10 67.24 66.16 64.90 63.48 61.94 60.32 58.66 57.02 55.44 53.96 52.61 51.45 50.48 49.74 49.22 48.94 48.88 49.02 49.34 49.81 50.39 51.03 51.69 52.32 52.88 53.32 53.61 53.72 53.62 53.30 52.74 51.96 50.95 49.75 48.38 46.87 45.27 43.62 41.96 40.35 38.82 37.42 36.18 35.13 34.30 33.70 33.33 33.19 33.27 33.53 33.96 34.52 35.16 35.84 36.52 37.14 37.67 38.06 38.29 38.31 38.12 37.70 37.05 36.18 35.11 33.85 32.44 30.93 29.34 27.74 26.16 24.64 23.24 21.99 20.93 20.07 19.44 19.05 +67.66 67.07 66.26 65.24 64.05 62.71 61.26 59.73 58.17 56.62 55.13 53.73 52.46 51.36 50.45 49.75 49.27 49.00 48.94 49.08 49.38 49.82 50.36 50.97 51.59 52.19 52.71 53.13 53.41 53.51 53.42 53.11 52.59 51.85 50.90 49.77 48.48 47.05 45.54 43.99 42.42 40.90 39.45 38.13 36.96 35.98 35.19 34.63 34.28 34.15 34.22 34.47 34.88 35.40 36.01 36.65 37.29 37.88 38.38 38.75 38.96 38.98 38.80 38.41 37.79 36.97 35.96 34.77 33.45 32.02 30.52 29.01 27.52 26.09 24.77 23.59 22.59 21.78 21.18 20.81 +66.56 66.00 65.24 64.29 63.17 61.91 60.55 59.11 57.65 56.20 54.80 53.49 52.30 51.27 50.42 49.76 49.30 49.05 49.00 49.13 49.41 49.83 50.34 50.91 51.49 52.05 52.55 52.94 53.20 53.30 53.21 52.92 52.43 51.74 50.85 49.79 48.58 47.24 45.83 44.37 42.90 41.47 40.12 38.88 37.78 36.86 36.12 35.59 35.27 35.14 35.21 35.45 35.83 36.32 36.89 37.50 38.10 38.65 39.12 39.47 39.66 39.69 39.52 39.15 38.58 37.81 36.85 35.74 34.50 33.16 31.76 30.34 28.94 27.60 26.36 25.26 24.31 23.56 23.00 22.65 +65.41 64.89 64.18 63.29 62.25 61.08 59.81 58.48 57.11 55.76 54.45 53.23 52.13 51.17 50.37 49.76 49.34 49.10 49.06 49.18 49.44 49.83 50.31 50.84 51.39 51.91 52.38 52.75 52.99 53.08 53.00 52.74 52.28 51.63 50.81 49.82 48.69 47.44 46.12 44.76 43.40 42.06 40.80 39.65 38.63 37.77 37.08 36.59 36.29 36.17 36.24 36.46 36.82 37.28 37.81 38.38 38.94 39.46 39.89 40.22 40.41 40.43 40.27 39.93 39.39 38.68 37.79 36.76 35.60 34.35 33.04 31.72 30.41 29.17 28.01 26.98 26.11 25.40 24.88 24.56 +64.22 63.74 63.09 62.27 61.31 60.22 59.05 57.81 56.55 55.30 54.09 52.96 51.94 51.05 50.32 49.76 49.37 49.15 49.11 49.22 49.47 49.83 50.28 50.77 51.28 51.77 52.20 52.55 52.77 52.86 52.79 52.54 52.12 51.53 50.76 49.85 48.80 47.65 46.43 45.17 43.91 42.68 41.51 40.44 39.50 38.70 38.07 37.62 37.34 37.24 37.30 37.51 37.84 38.27 38.77 39.29 39.81 40.29 40.70 41.00 41.18 41.20 41.06 40.74 40.25 39.59 38.77 37.81 36.74 35.58 34.38 33.15 31.94 30.79 29.72 28.77 27.96 27.31 26.83 26.53 +63.00 62.56 61.96 61.21 60.33 59.34 58.26 57.13 55.97 54.83 53.72 52.68 51.75 50.94 50.26 49.75 49.39 49.20 49.16 49.27 49.50 49.84 50.25 50.70 51.17 51.62 52.02 52.34 52.55 52.64 52.57 52.35 51.96 51.42 50.72 49.88 48.93 47.87 46.75 45.60 44.44 43.31 42.24 41.26 40.40 39.67 39.09 38.68 38.42 38.33 38.39 38.59 38.89 39.29 39.75 40.23 40.71 41.16 41.53 41.82 41.98 42.00 41.87 41.58 41.13 40.53 39.78 38.90 37.92 36.86 35.75 34.63 33.52 32.47 31.49 30.62 29.87 29.28 28.84 28.57 +61.75 61.35 60.81 60.13 59.33 58.43 57.46 56.43 55.38 54.34 53.33 52.40 51.55 50.81 50.20 49.73 49.41 49.24 49.21 49.31 49.53 49.83 50.21 50.63 51.06 51.47 51.84 52.13 52.33 52.41 52.35 52.15 51.81 51.31 50.68 49.92 49.05 48.10 47.08 46.04 44.99 43.96 42.99 42.10 41.32 40.66 40.14 39.76 39.53 39.45 39.51 39.69 39.97 40.34 40.76 41.20 41.64 42.05 42.40 42.66 42.81 42.83 42.72 42.46 42.05 41.50 40.82 40.03 39.13 38.17 37.17 36.15 35.15 34.19 33.30 32.51 31.83 31.29 30.90 30.65 +60.47 60.12 59.63 59.03 58.31 57.51 56.63 55.71 54.77 53.84 52.94 52.10 51.34 50.68 50.14 49.72 49.43 49.28 49.26 49.35 49.55 49.83 50.17 50.55 50.95 51.32 51.66 51.92 52.10 52.18 52.13 51.96 51.65 51.21 50.64 49.96 49.19 48.33 47.42 46.48 45.54 44.63 43.76 42.96 42.26 41.67 41.20 40.87 40.67 40.60 40.66 40.82 41.08 41.41 41.79 42.20 42.60 42.97 43.28 43.52 43.66 43.68 43.58 43.35 42.99 42.50 41.89 41.18 40.38 39.52 38.62 37.71 36.81 35.95 35.15 34.45 33.84 33.36 33.01 32.79 +59.17 58.86 58.43 57.90 57.27 56.56 55.79 54.98 54.15 53.32 52.53 51.79 51.12 50.54 50.06 49.70 49.45 49.32 49.31 49.39 49.57 49.83 50.14 50.48 50.83 51.17 51.47 51.71 51.87 51.94 51.91 51.76 51.49 51.10 50.61 50.01 49.33 48.57 47.77 46.94 46.11 45.30 44.54 43.84 43.22 42.70 42.29 42.00 41.83 41.77 41.82 41.98 42.21 42.51 42.85 43.21 43.57 43.90 44.19 44.40 44.53 44.56 44.47 44.27 43.96 43.53 42.99 42.36 41.66 40.90 40.11 39.30 38.51 37.75 37.05 36.42 35.89 35.47 35.16 34.97 +57.84 57.58 57.21 56.75 56.21 55.60 54.93 54.23 53.51 52.80 52.12 51.48 50.90 50.40 49.99 49.68 49.47 49.36 49.35 49.43 49.60 49.82 50.10 50.40 50.71 51.01 51.28 51.49 51.64 51.71 51.68 51.56 51.33 51.00 50.57 50.06 49.47 48.82 48.12 47.41 46.69 45.99 45.33 44.73 44.20 43.75 43.40 43.15 43.00 42.96 43.01 43.15 43.36 43.62 43.93 44.25 44.56 44.86 45.11 45.30 45.42 45.45 45.38 45.21 44.94 44.57 44.11 43.57 42.96 42.30 41.62 40.92 40.23 39.58 38.97 38.44 37.98 37.61 37.35 37.19 +56.49 56.28 55.97 55.59 55.13 54.62 54.06 53.47 52.87 52.27 51.69 51.16 50.67 50.26 49.91 49.65 49.48 49.40 49.40 49.47 49.62 49.82 50.06 50.32 50.59 50.85 51.09 51.28 51.41 51.47 51.46 51.36 51.17 50.90 50.54 50.11 49.61 49.07 48.48 47.88 47.28 46.69 46.14 45.63 45.18 44.81 44.52 44.31 44.20 44.17 44.22 44.34 44.52 44.76 45.02 45.30 45.57 45.83 46.05 46.22 46.33 46.36 46.30 46.17 45.94 45.63 45.25 44.79 44.28 43.73 43.15 42.57 41.99 41.44 40.93 40.48 40.09 39.79 39.57 39.44 +55.13 54.96 54.72 54.41 54.05 53.63 53.18 52.70 52.22 51.73 51.27 50.83 50.44 50.11 49.83 49.63 49.50 49.43 49.44 49.51 49.64 49.81 50.01 50.24 50.47 50.69 50.89 51.06 51.17 51.23 51.23 51.15 51.01 50.79 50.51 50.16 49.76 49.32 48.85 48.36 47.88 47.40 46.95 46.54 46.18 45.89 45.65 45.49 45.40 45.39 45.44 45.54 45.70 45.90 46.13 46.36 46.60 46.81 47.00 47.15 47.24 47.28 47.24 47.13 46.96 46.71 46.40 46.04 45.62 45.18 44.71 44.23 43.77 43.32 42.91 42.54 42.24 41.99 41.82 41.72 +53.76 53.64 53.46 53.23 52.95 52.63 52.29 51.93 51.56 51.19 50.83 50.50 50.21 49.96 49.75 49.60 49.51 49.47 49.49 49.55 49.66 49.80 49.97 50.16 50.35 50.53 50.70 50.84 50.94 50.99 51.00 50.95 50.85 50.69 50.47 50.21 49.91 49.58 49.22 48.85 48.48 48.11 47.77 47.46 47.19 46.97 46.80 46.68 46.62 46.62 46.67 46.76 46.89 47.06 47.24 47.44 47.63 47.81 47.96 48.09 48.17 48.20 48.19 48.11 47.98 47.80 47.57 47.29 46.98 46.64 46.28 45.92 45.56 45.22 44.91 44.63 44.40 44.22 44.09 44.02 +52.38 52.30 52.18 52.03 51.84 51.63 51.40 51.15 50.89 50.64 50.40 50.17 49.97 49.81 49.67 49.58 49.52 49.51 49.53 49.59 49.68 49.79 49.93 50.08 50.22 50.37 50.50 50.61 50.70 50.75 50.77 50.75 50.68 50.58 50.44 50.27 50.06 49.83 49.59 49.34 49.08 48.83 48.60 48.39 48.21 48.06 47.95 47.88 47.85 47.86 47.90 47.98 48.09 48.22 48.37 48.52 48.67 48.81 48.93 49.03 49.10 49.14 49.14 49.10 49.02 48.90 48.74 48.55 48.34 48.10 47.86 47.61 47.36 47.13 46.92 46.73 46.57 46.45 46.37 46.33 +50.99 50.96 50.91 50.83 50.74 50.62 50.50 50.36 50.23 50.09 49.96 49.84 49.74 49.65 49.59 49.55 49.53 49.54 49.57 49.63 49.70 49.79 49.89 49.99 50.10 50.21 50.30 50.39 50.46 50.51 50.54 50.54 50.52 50.48 50.41 50.32 50.21 50.09 49.96 49.82 49.69 49.56 49.43 49.32 49.23 49.16 49.10 49.08 49.08 49.10 49.15 49.21 49.29 49.39 49.49 49.60 49.71 49.81 49.90 49.98 50.04 50.08 50.10 50.09 50.05 50.00 49.92 49.82 49.70 49.58 49.45 49.31 49.18 49.05 48.94 48.84 48.76 48.70 48.66 48.65 +49.60 49.62 49.63 49.63 49.63 49.61 49.60 49.58 49.56 49.54 49.52 49.51 49.50 49.50 49.51 49.52 49.55 49.58 49.62 49.67 49.72 49.78 49.84 49.91 49.98 50.04 50.11 50.17 50.22 50.27 50.30 50.34 50.36 50.37 50.38 50.37 50.36 50.35 50.33 50.32 50.30 50.28 50.26 50.25 50.25 50.25 50.26 50.28 50.31 50.35 50.39 50.44 50.50 50.56 50.62 50.69 50.75 50.82 50.88 50.93 50.98 51.02 51.05 51.08 51.09 51.10 51.10 51.09 51.07 51.05 51.03 51.01 50.99 50.97 50.96 50.95 50.94 50.95 50.96 50.98 +48.22 48.28 48.35 48.43 48.52 48.61 48.70 48.80 48.89 48.99 49.09 49.18 49.27 49.35 49.43 49.50 49.56 49.62 49.66 49.71 49.74 49.77 49.80 49.83 49.85 49.88 49.91 49.94 49.98 50.02 50.07 50.13 50.19 50.26 50.34 50.43 50.52 50.61 50.71 50.80 50.90 51.00 51.09 51.18 51.27 51.35 51.42 51.48 51.54 51.59 51.63 51.67 51.70 51.73 51.75 51.77 51.80 51.82 51.85 51.88 51.91 51.96 52.01 52.06 52.12 52.19 52.27 52.35 52.44 52.53 52.62 52.71 52.80 52.89 52.97 53.05 53.13 53.19 53.25 53.30 \ No newline at end of file diff --git a/autotest/data/nwtp03_rch.ref b/autotest/data/nwtp03_rch.ref new file mode 100644 index 00000000000..d579b0decc7 --- /dev/null +++ b/autotest/data/nwtp03_rch.ref @@ -0,0 +1,80 @@ + 3.49E-09 3.55E-09 3.60E-09 3.66E-09 3.72E-09 3.78E-09 3.83E-09 3.89E-09 3.95E-09 4.01E-09 4.06E-09 4.12E-09 4.18E-09 4.24E-09 4.30E-09 4.35E-09 4.41E-09 4.47E-09 4.53E-09 4.59E-09 4.65E-09 4.71E-09 4.76E-09 4.82E-09 4.88E-09 4.94E-09 5.00E-09 5.06E-09 5.12E-09 5.18E-09 5.24E-09 5.29E-09 5.35E-09 5.41E-09 5.47E-09 5.53E-09 5.59E-09 5.65E-09 5.70E-09 5.76E-09 5.82E-09 5.88E-09 5.94E-09 5.99E-09 6.05E-09 6.11E-09 6.17E-09 6.22E-09 6.28E-09 6.34E-09 6.40E-09 6.45E-09 6.51E-09 6.56E-09 6.62E-09 6.68E-09 6.73E-09 6.79E-09 6.84E-09 6.90E-09 6.95E-09 7.01E-09 7.06E-09 7.12E-09 7.17E-09 7.22E-09 7.28E-09 7.33E-09 7.38E-09 7.43E-09 7.49E-09 7.54E-09 7.59E-09 7.64E-09 7.69E-09 7.74E-09 7.79E-09 7.84E-09 7.89E-09 7.94E-09 + 3.59E-09 3.65E-09 3.70E-09 3.75E-09 3.80E-09 3.85E-09 3.89E-09 3.94E-09 3.99E-09 4.04E-09 4.08E-09 4.13E-09 4.18E-09 4.23E-09 4.29E-09 4.34E-09 4.40E-09 4.45E-09 4.51E-09 4.57E-09 4.64E-09 4.70E-09 4.76E-09 4.83E-09 4.89E-09 4.96E-09 5.02E-09 5.08E-09 5.14E-09 5.21E-09 5.26E-09 5.32E-09 5.38E-09 5.43E-09 5.49E-09 5.54E-09 5.59E-09 5.64E-09 5.68E-09 5.73E-09 5.78E-09 5.83E-09 5.88E-09 5.93E-09 5.98E-09 6.03E-09 6.08E-09 6.13E-09 6.19E-09 6.25E-09 6.31E-09 6.37E-09 6.43E-09 6.49E-09 6.55E-09 6.61E-09 6.67E-09 6.73E-09 6.79E-09 6.85E-09 6.91E-09 6.96E-09 7.02E-09 7.07E-09 7.12E-09 7.17E-09 7.22E-09 7.26E-09 7.31E-09 7.35E-09 7.39E-09 7.43E-09 7.47E-09 7.52E-09 7.56E-09 7.60E-09 7.64E-09 7.69E-09 7.73E-09 7.78E-09 + 3.70E-09 3.75E-09 3.79E-09 3.84E-09 3.88E-09 3.92E-09 3.96E-09 3.99E-09 4.03E-09 4.07E-09 4.11E-09 4.15E-09 4.19E-09 4.23E-09 4.28E-09 4.33E-09 4.38E-09 4.44E-09 4.50E-09 4.56E-09 4.63E-09 4.69E-09 4.76E-09 4.83E-09 4.90E-09 4.97E-09 5.04E-09 5.11E-09 5.17E-09 5.23E-09 5.29E-09 5.35E-09 5.40E-09 5.45E-09 5.50E-09 5.54E-09 5.58E-09 5.62E-09 5.66E-09 5.70E-09 5.74E-09 5.78E-09 5.81E-09 5.86E-09 5.90E-09 5.94E-09 5.99E-09 6.04E-09 6.10E-09 6.15E-09 6.21E-09 6.27E-09 6.34E-09 6.41E-09 6.47E-09 6.54E-09 6.61E-09 6.67E-09 6.74E-09 6.80E-09 6.86E-09 6.91E-09 6.97E-09 7.02E-09 7.07E-09 7.11E-09 7.15E-09 7.19E-09 7.22E-09 7.26E-09 7.29E-09 7.32E-09 7.35E-09 7.38E-09 7.42E-09 7.45E-09 7.49E-09 7.53E-09 7.57E-09 7.62E-09 + 3.81E-09 3.85E-09 3.89E-09 3.93E-09 3.97E-09 4.00E-09 4.02E-09 4.05E-09 4.08E-09 4.10E-09 4.13E-09 4.16E-09 4.20E-09 4.23E-09 4.27E-09 4.32E-09 4.37E-09 4.43E-09 4.49E-09 4.55E-09 4.62E-09 4.69E-09 4.76E-09 4.84E-09 4.91E-09 4.99E-09 5.06E-09 5.13E-09 5.20E-09 5.26E-09 5.32E-09 5.38E-09 5.43E-09 5.47E-09 5.51E-09 5.55E-09 5.58E-09 5.61E-09 5.64E-09 5.67E-09 5.69E-09 5.72E-09 5.75E-09 5.78E-09 5.82E-09 5.86E-09 5.90E-09 5.95E-09 6.00E-09 6.06E-09 6.12E-09 6.18E-09 6.25E-09 6.32E-09 6.39E-09 6.46E-09 6.54E-09 6.61E-09 6.68E-09 6.74E-09 6.80E-09 6.86E-09 6.91E-09 6.96E-09 7.00E-09 7.04E-09 7.08E-09 7.11E-09 7.13E-09 7.16E-09 7.18E-09 7.20E-09 7.22E-09 7.24E-09 7.27E-09 7.29E-09 7.32E-09 7.36E-09 7.40E-09 7.44E-09 + 3.92E-09 3.96E-09 4.00E-09 4.03E-09 4.05E-09 4.08E-09 4.09E-09 4.11E-09 4.13E-09 4.14E-09 4.16E-09 4.18E-09 4.20E-09 4.23E-09 4.27E-09 4.31E-09 4.36E-09 4.41E-09 4.47E-09 4.54E-09 4.61E-09 4.68E-09 4.76E-09 4.84E-09 4.92E-09 5.00E-09 5.08E-09 5.15E-09 5.22E-09 5.29E-09 5.35E-09 5.40E-09 5.45E-09 5.49E-09 5.52E-09 5.55E-09 5.58E-09 5.60E-09 5.61E-09 5.63E-09 5.65E-09 5.66E-09 5.68E-09 5.71E-09 5.73E-09 5.77E-09 5.80E-09 5.85E-09 5.90E-09 5.95E-09 6.02E-09 6.08E-09 6.16E-09 6.23E-09 6.31E-09 6.38E-09 6.46E-09 6.54E-09 6.61E-09 6.68E-09 6.74E-09 6.80E-09 6.85E-09 6.90E-09 6.94E-09 6.97E-09 7.00E-09 7.02E-09 7.04E-09 7.05E-09 7.06E-09 7.07E-09 7.08E-09 7.10E-09 7.11E-09 7.13E-09 7.16E-09 7.18E-09 7.22E-09 7.26E-09 + 4.03E-09 4.07E-09 4.10E-09 4.13E-09 4.14E-09 4.16E-09 4.17E-09 4.17E-09 4.18E-09 4.18E-09 4.19E-09 4.20E-09 4.22E-09 4.24E-09 4.27E-09 4.30E-09 4.35E-09 4.40E-09 4.46E-09 4.53E-09 4.60E-09 4.68E-09 4.76E-09 4.85E-09 4.93E-09 5.02E-09 5.10E-09 5.18E-09 5.25E-09 5.31E-09 5.37E-09 5.43E-09 5.47E-09 5.50E-09 5.53E-09 5.55E-09 5.57E-09 5.58E-09 5.59E-09 5.59E-09 5.60E-09 5.61E-09 5.61E-09 5.63E-09 5.65E-09 5.67E-09 5.71E-09 5.75E-09 5.79E-09 5.85E-09 5.91E-09 5.98E-09 6.06E-09 6.14E-09 6.22E-09 6.30E-09 6.38E-09 6.46E-09 6.54E-09 6.61E-09 6.68E-09 6.74E-09 6.79E-09 6.83E-09 6.87E-09 6.89E-09 6.91E-09 6.93E-09 6.94E-09 6.94E-09 6.94E-09 6.94E-09 6.94E-09 6.95E-09 6.95E-09 6.96E-09 6.98E-09 7.00E-09 7.03E-09 7.07E-09 + 4.15E-09 4.19E-09 4.21E-09 4.23E-09 4.24E-09 4.24E-09 4.24E-09 4.24E-09 4.23E-09 4.22E-09 4.22E-09 4.22E-09 4.23E-09 4.24E-09 4.27E-09 4.30E-09 4.34E-09 4.39E-09 4.45E-09 4.52E-09 4.60E-09 4.68E-09 4.76E-09 4.85E-09 4.94E-09 5.03E-09 5.12E-09 5.20E-09 5.27E-09 5.34E-09 5.40E-09 5.45E-09 5.49E-09 5.52E-09 5.54E-09 5.55E-09 5.56E-09 5.56E-09 5.56E-09 5.55E-09 5.55E-09 5.54E-09 5.54E-09 5.55E-09 5.56E-09 5.58E-09 5.61E-09 5.64E-09 5.69E-09 5.74E-09 5.81E-09 5.88E-09 5.96E-09 6.04E-09 6.13E-09 6.21E-09 6.30E-09 6.39E-09 6.47E-09 6.54E-09 6.61E-09 6.67E-09 6.72E-09 6.76E-09 6.79E-09 6.81E-09 6.83E-09 6.83E-09 6.83E-09 6.82E-09 6.81E-09 6.80E-09 6.79E-09 6.79E-09 6.79E-09 6.79E-09 6.80E-09 6.82E-09 6.84E-09 6.88E-09 + 4.27E-09 4.30E-09 4.32E-09 4.33E-09 4.33E-09 4.33E-09 4.32E-09 4.30E-09 4.28E-09 4.27E-09 4.26E-09 4.25E-09 4.25E-09 4.25E-09 4.27E-09 4.30E-09 4.33E-09 4.38E-09 4.44E-09 4.51E-09 4.59E-09 4.68E-09 4.77E-09 4.86E-09 4.95E-09 5.05E-09 5.14E-09 5.22E-09 5.30E-09 5.37E-09 5.42E-09 5.47E-09 5.51E-09 5.53E-09 5.55E-09 5.55E-09 5.55E-09 5.54E-09 5.53E-09 5.51E-09 5.50E-09 5.48E-09 5.47E-09 5.47E-09 5.47E-09 5.48E-09 5.50E-09 5.54E-09 5.58E-09 5.64E-09 5.70E-09 5.77E-09 5.85E-09 5.94E-09 6.03E-09 6.12E-09 6.22E-09 6.30E-09 6.39E-09 6.47E-09 6.54E-09 6.60E-09 6.64E-09 6.68E-09 6.71E-09 6.73E-09 6.73E-09 6.73E-09 6.72E-09 6.70E-09 6.68E-09 6.66E-09 6.64E-09 6.63E-09 6.61E-09 6.61E-09 6.61E-09 6.62E-09 6.65E-09 6.68E-09 + 4.40E-09 4.42E-09 4.44E-09 4.44E-09 4.43E-09 4.42E-09 4.40E-09 4.37E-09 4.34E-09 4.31E-09 4.29E-09 4.27E-09 4.26E-09 4.26E-09 4.27E-09 4.29E-09 4.33E-09 4.38E-09 4.44E-09 4.51E-09 4.59E-09 4.67E-09 4.77E-09 4.87E-09 4.97E-09 5.06E-09 5.16E-09 5.24E-09 5.32E-09 5.39E-09 5.45E-09 5.49E-09 5.53E-09 5.55E-09 5.55E-09 5.55E-09 5.54E-09 5.52E-09 5.50E-09 5.47E-09 5.44E-09 5.42E-09 5.40E-09 5.38E-09 5.38E-09 5.38E-09 5.40E-09 5.43E-09 5.47E-09 5.53E-09 5.59E-09 5.67E-09 5.75E-09 5.84E-09 5.93E-09 6.03E-09 6.13E-09 6.22E-09 6.31E-09 6.39E-09 6.46E-09 6.52E-09 6.57E-09 6.60E-09 6.62E-09 6.63E-09 6.63E-09 6.62E-09 6.60E-09 6.58E-09 6.55E-09 6.52E-09 6.49E-09 6.46E-09 6.44E-09 6.42E-09 6.42E-09 6.43E-09 6.45E-09 6.48E-09 + 4.52E-09 4.54E-09 4.55E-09 4.55E-09 4.53E-09 4.51E-09 4.48E-09 4.44E-09 4.40E-09 4.36E-09 4.33E-09 4.30E-09 4.28E-09 4.27E-09 4.28E-09 4.29E-09 4.33E-09 4.37E-09 4.43E-09 4.50E-09 4.58E-09 4.67E-09 4.77E-09 4.87E-09 4.98E-09 5.08E-09 5.17E-09 5.26E-09 5.34E-09 5.41E-09 5.47E-09 5.51E-09 5.54E-09 5.56E-09 5.56E-09 5.55E-09 5.53E-09 5.50E-09 5.47E-09 5.43E-09 5.39E-09 5.35E-09 5.32E-09 5.30E-09 5.29E-09 5.29E-09 5.30E-09 5.32E-09 5.36E-09 5.41E-09 5.48E-09 5.55E-09 5.64E-09 5.74E-09 5.83E-09 5.93E-09 6.04E-09 6.13E-09 6.22E-09 6.31E-09 6.38E-09 6.44E-09 6.48E-09 6.52E-09 6.53E-09 6.54E-09 6.53E-09 6.51E-09 6.48E-09 6.45E-09 6.41E-09 6.36E-09 6.32E-09 6.29E-09 6.26E-09 6.24E-09 6.22E-09 6.23E-09 6.24E-09 6.27E-09 + 4.65E-09 4.67E-09 4.67E-09 4.66E-09 4.63E-09 4.60E-09 4.56E-09 4.51E-09 4.46E-09 4.41E-09 4.37E-09 4.33E-09 4.30E-09 4.29E-09 4.28E-09 4.30E-09 4.32E-09 4.37E-09 4.43E-09 4.50E-09 4.58E-09 4.67E-09 4.78E-09 4.88E-09 4.99E-09 5.09E-09 5.19E-09 5.28E-09 5.37E-09 5.44E-09 5.49E-09 5.53E-09 5.56E-09 5.57E-09 5.56E-09 5.55E-09 5.52E-09 5.48E-09 5.43E-09 5.38E-09 5.33E-09 5.29E-09 5.25E-09 5.22E-09 5.19E-09 5.19E-09 5.19E-09 5.21E-09 5.25E-09 5.30E-09 5.36E-09 5.44E-09 5.53E-09 5.63E-09 5.73E-09 5.84E-09 5.94E-09 6.04E-09 6.14E-09 6.22E-09 6.29E-09 6.35E-09 6.40E-09 6.43E-09 6.44E-09 6.44E-09 6.42E-09 6.40E-09 6.36E-09 6.31E-09 6.26E-09 6.21E-09 6.16E-09 6.11E-09 6.07E-09 6.04E-09 6.03E-09 6.02E-09 6.03E-09 6.06E-09 + 4.78E-09 4.79E-09 4.79E-09 4.77E-09 4.74E-09 4.69E-09 4.64E-09 4.58E-09 4.52E-09 4.46E-09 4.41E-09 4.36E-09 4.32E-09 4.30E-09 4.29E-09 4.30E-09 4.32E-09 4.36E-09 4.42E-09 4.49E-09 4.58E-09 4.68E-09 4.78E-09 4.89E-09 5.00E-09 5.11E-09 5.21E-09 5.31E-09 5.39E-09 5.46E-09 5.51E-09 5.55E-09 5.57E-09 5.58E-09 5.57E-09 5.54E-09 5.50E-09 5.45E-09 5.40E-09 5.34E-09 5.28E-09 5.22E-09 5.17E-09 5.13E-09 5.10E-09 5.08E-09 5.08E-09 5.10E-09 5.13E-09 5.18E-09 5.25E-09 5.33E-09 5.42E-09 5.52E-09 5.63E-09 5.74E-09 5.84E-09 5.95E-09 6.04E-09 6.13E-09 6.21E-09 6.27E-09 6.31E-09 6.33E-09 6.34E-09 6.34E-09 6.31E-09 6.28E-09 6.23E-09 6.18E-09 6.11E-09 6.05E-09 5.99E-09 5.93E-09 5.89E-09 5.85E-09 5.82E-09 5.81E-09 5.82E-09 5.84E-09 + 4.91E-09 4.92E-09 4.91E-09 4.88E-09 4.84E-09 4.79E-09 4.73E-09 4.66E-09 4.59E-09 4.52E-09 4.45E-09 4.39E-09 4.35E-09 4.32E-09 4.30E-09 4.30E-09 4.32E-09 4.36E-09 4.42E-09 4.49E-09 4.58E-09 4.68E-09 4.78E-09 4.90E-09 5.01E-09 5.12E-09 5.23E-09 5.33E-09 5.41E-09 5.48E-09 5.53E-09 5.57E-09 5.59E-09 5.59E-09 5.57E-09 5.53E-09 5.49E-09 5.43E-09 5.36E-09 5.29E-09 5.22E-09 5.15E-09 5.09E-09 5.04E-09 5.00E-09 4.98E-09 4.98E-09 4.99E-09 5.02E-09 5.07E-09 5.13E-09 5.21E-09 5.31E-09 5.41E-09 5.52E-09 5.63E-09 5.74E-09 5.85E-09 5.95E-09 6.04E-09 6.11E-09 6.17E-09 6.22E-09 6.24E-09 6.24E-09 6.23E-09 6.20E-09 6.16E-09 6.10E-09 6.04E-09 5.96E-09 5.89E-09 5.82E-09 5.75E-09 5.70E-09 5.65E-09 5.62E-09 5.60E-09 5.60E-09 5.62E-09 + 5.04E-09 5.04E-09 5.03E-09 4.99E-09 4.95E-09 4.88E-09 4.81E-09 4.73E-09 4.65E-09 4.57E-09 4.49E-09 4.43E-09 4.37E-09 4.33E-09 4.31E-09 4.31E-09 4.33E-09 4.36E-09 4.42E-09 4.49E-09 4.58E-09 4.68E-09 4.79E-09 4.90E-09 5.02E-09 5.14E-09 5.25E-09 5.34E-09 5.43E-09 5.50E-09 5.55E-09 5.59E-09 5.60E-09 5.59E-09 5.57E-09 5.53E-09 5.47E-09 5.40E-09 5.33E-09 5.24E-09 5.16E-09 5.09E-09 5.01E-09 4.96E-09 4.91E-09 4.88E-09 4.87E-09 4.88E-09 4.90E-09 4.95E-09 5.02E-09 5.10E-09 5.19E-09 5.30E-09 5.41E-09 5.53E-09 5.64E-09 5.75E-09 5.86E-09 5.95E-09 6.02E-09 6.08E-09 6.12E-09 6.14E-09 6.14E-09 6.12E-09 6.09E-09 6.03E-09 5.97E-09 5.89E-09 5.81E-09 5.73E-09 5.65E-09 5.57E-09 5.50E-09 5.45E-09 5.41E-09 5.39E-09 5.39E-09 5.40E-09 + 5.17E-09 5.17E-09 5.15E-09 5.11E-09 5.05E-09 4.98E-09 4.90E-09 4.81E-09 4.72E-09 4.63E-09 4.54E-09 4.46E-09 4.40E-09 4.35E-09 4.33E-09 4.32E-09 4.33E-09 4.36E-09 4.42E-09 4.49E-09 4.58E-09 4.68E-09 4.79E-09 4.91E-09 5.03E-09 5.15E-09 5.26E-09 5.36E-09 5.45E-09 5.52E-09 5.57E-09 5.60E-09 5.61E-09 5.60E-09 5.57E-09 5.52E-09 5.45E-09 5.37E-09 5.29E-09 5.20E-09 5.10E-09 5.02E-09 4.94E-09 4.87E-09 4.81E-09 4.78E-09 4.76E-09 4.76E-09 4.79E-09 4.83E-09 4.90E-09 4.98E-09 5.08E-09 5.19E-09 5.30E-09 5.42E-09 5.54E-09 5.65E-09 5.76E-09 5.85E-09 5.93E-09 5.98E-09 6.02E-09 6.04E-09 6.03E-09 6.01E-09 5.97E-09 5.91E-09 5.83E-09 5.75E-09 5.66E-09 5.56E-09 5.47E-09 5.38E-09 5.31E-09 5.25E-09 5.20E-09 5.17E-09 5.17E-09 5.18E-09 + 5.30E-09 5.29E-09 5.27E-09 5.22E-09 5.16E-09 5.08E-09 4.98E-09 4.88E-09 4.78E-09 4.68E-09 4.59E-09 4.50E-09 4.43E-09 4.37E-09 4.34E-09 4.33E-09 4.33E-09 4.37E-09 4.42E-09 4.49E-09 4.58E-09 4.69E-09 4.80E-09 4.92E-09 5.05E-09 5.17E-09 5.28E-09 5.38E-09 5.47E-09 5.54E-09 5.59E-09 5.62E-09 5.62E-09 5.60E-09 5.57E-09 5.51E-09 5.43E-09 5.35E-09 5.25E-09 5.15E-09 5.05E-09 4.95E-09 4.86E-09 4.78E-09 4.72E-09 4.67E-09 4.65E-09 4.65E-09 4.67E-09 4.72E-09 4.78E-09 4.86E-09 4.96E-09 5.07E-09 5.19E-09 5.31E-09 5.44E-09 5.55E-09 5.66E-09 5.75E-09 5.83E-09 5.89E-09 5.92E-09 5.94E-09 5.93E-09 5.90E-09 5.85E-09 5.78E-09 5.69E-09 5.60E-09 5.50E-09 5.39E-09 5.29E-09 5.20E-09 5.11E-09 5.04E-09 4.99E-09 4.96E-09 4.95E-09 4.96E-09 + 5.43E-09 5.42E-09 5.39E-09 5.33E-09 5.26E-09 5.17E-09 5.07E-09 4.96E-09 4.85E-09 4.74E-09 4.63E-09 4.54E-09 4.46E-09 4.40E-09 4.35E-09 4.34E-09 4.34E-09 4.37E-09 4.42E-09 4.49E-09 4.58E-09 4.69E-09 4.81E-09 4.93E-09 5.06E-09 5.18E-09 5.30E-09 5.40E-09 5.49E-09 5.56E-09 5.60E-09 5.63E-09 5.63E-09 5.61E-09 5.56E-09 5.50E-09 5.41E-09 5.32E-09 5.21E-09 5.10E-09 4.99E-09 4.88E-09 4.78E-09 4.69E-09 4.62E-09 4.57E-09 4.54E-09 4.54E-09 4.56E-09 4.60E-09 4.66E-09 4.75E-09 4.85E-09 4.96E-09 5.08E-09 5.21E-09 5.33E-09 5.45E-09 5.56E-09 5.65E-09 5.73E-09 5.79E-09 5.82E-09 5.83E-09 5.82E-09 5.78E-09 5.72E-09 5.65E-09 5.55E-09 5.45E-09 5.34E-09 5.23E-09 5.11E-09 5.01E-09 4.92E-09 4.84E-09 4.78E-09 4.74E-09 4.72E-09 4.73E-09 + 5.56E-09 5.55E-09 5.51E-09 5.45E-09 5.37E-09 5.27E-09 5.16E-09 5.04E-09 4.92E-09 4.79E-09 4.68E-09 4.58E-09 4.49E-09 4.42E-09 4.37E-09 4.35E-09 4.35E-09 4.37E-09 4.42E-09 4.50E-09 4.59E-09 4.69E-09 4.81E-09 4.94E-09 5.07E-09 5.19E-09 5.31E-09 5.42E-09 5.50E-09 5.57E-09 5.62E-09 5.64E-09 5.64E-09 5.61E-09 5.56E-09 5.49E-09 5.39E-09 5.29E-09 5.17E-09 5.05E-09 4.93E-09 4.81E-09 4.70E-09 4.60E-09 4.53E-09 4.47E-09 4.44E-09 4.43E-09 4.44E-09 4.48E-09 4.55E-09 4.63E-09 4.73E-09 4.85E-09 4.97E-09 5.10E-09 5.22E-09 5.35E-09 5.46E-09 5.55E-09 5.63E-09 5.68E-09 5.72E-09 5.72E-09 5.71E-09 5.66E-09 5.60E-09 5.51E-09 5.41E-09 5.30E-09 5.18E-09 5.06E-09 4.94E-09 4.82E-09 4.72E-09 4.63E-09 4.57E-09 4.52E-09 4.50E-09 4.51E-09 + 5.69E-09 5.67E-09 5.63E-09 5.56E-09 5.47E-09 5.36E-09 5.24E-09 5.12E-09 4.98E-09 4.85E-09 4.73E-09 4.61E-09 4.52E-09 4.44E-09 4.39E-09 4.36E-09 4.36E-09 4.38E-09 4.43E-09 4.50E-09 4.59E-09 4.70E-09 4.82E-09 4.95E-09 5.08E-09 5.21E-09 5.33E-09 5.43E-09 5.52E-09 5.59E-09 5.63E-09 5.65E-09 5.65E-09 5.61E-09 5.55E-09 5.47E-09 5.37E-09 5.26E-09 5.13E-09 5.00E-09 4.87E-09 4.74E-09 4.62E-09 4.52E-09 4.43E-09 4.37E-09 4.33E-09 4.32E-09 4.33E-09 4.37E-09 4.43E-09 4.51E-09 4.62E-09 4.73E-09 4.86E-09 4.99E-09 5.12E-09 5.24E-09 5.35E-09 5.45E-09 5.53E-09 5.58E-09 5.61E-09 5.62E-09 5.59E-09 5.54E-09 5.47E-09 5.38E-09 5.27E-09 5.15E-09 5.02E-09 4.89E-09 4.76E-09 4.63E-09 4.52E-09 4.43E-09 4.36E-09 4.31E-09 4.28E-09 4.29E-09 + 5.82E-09 5.80E-09 5.75E-09 5.67E-09 5.58E-09 5.46E-09 5.33E-09 5.19E-09 5.05E-09 4.91E-09 4.78E-09 4.65E-09 4.55E-09 4.46E-09 4.40E-09 4.37E-09 4.36E-09 4.38E-09 4.43E-09 4.50E-09 4.60E-09 4.71E-09 4.83E-09 4.96E-09 5.09E-09 5.22E-09 5.34E-09 5.45E-09 5.54E-09 5.60E-09 5.65E-09 5.66E-09 5.65E-09 5.61E-09 5.55E-09 5.46E-09 5.35E-09 5.23E-09 5.09E-09 4.95E-09 4.81E-09 4.67E-09 4.54E-09 4.43E-09 4.34E-09 4.27E-09 4.22E-09 4.21E-09 4.22E-09 4.25E-09 4.31E-09 4.40E-09 4.50E-09 4.62E-09 4.75E-09 4.88E-09 5.01E-09 5.14E-09 5.25E-09 5.35E-09 5.42E-09 5.48E-09 5.51E-09 5.51E-09 5.48E-09 5.43E-09 5.35E-09 5.25E-09 5.13E-09 5.00E-09 4.86E-09 4.72E-09 4.58E-09 4.45E-09 4.33E-09 4.23E-09 4.15E-09 4.09E-09 4.06E-09 4.06E-09 + 5.95E-09 5.92E-09 5.86E-09 5.78E-09 5.68E-09 5.55E-09 5.42E-09 5.27E-09 5.12E-09 4.97E-09 4.82E-09 4.69E-09 4.58E-09 4.49E-09 4.42E-09 4.38E-09 4.37E-09 4.39E-09 4.44E-09 4.51E-09 4.60E-09 4.71E-09 4.84E-09 4.97E-09 5.10E-09 5.23E-09 5.35E-09 5.46E-09 5.55E-09 5.62E-09 5.66E-09 5.67E-09 5.66E-09 5.61E-09 5.54E-09 5.45E-09 5.33E-09 5.20E-09 5.05E-09 4.90E-09 4.75E-09 4.60E-09 4.47E-09 4.35E-09 4.25E-09 4.17E-09 4.12E-09 4.10E-09 4.10E-09 4.14E-09 4.20E-09 4.28E-09 4.39E-09 4.51E-09 4.64E-09 4.77E-09 4.90E-09 5.03E-09 5.15E-09 5.24E-09 5.32E-09 5.37E-09 5.40E-09 5.40E-09 5.36E-09 5.31E-09 5.22E-09 5.11E-09 4.99E-09 4.85E-09 4.70E-09 4.55E-09 4.40E-09 4.26E-09 4.14E-09 4.03E-09 3.94E-09 3.88E-09 3.85E-09 3.84E-09 + 6.07E-09 6.04E-09 5.98E-09 5.89E-09 5.78E-09 5.65E-09 5.50E-09 5.34E-09 5.18E-09 5.02E-09 4.87E-09 4.73E-09 4.61E-09 4.52E-09 4.44E-09 4.40E-09 4.39E-09 4.40E-09 4.44E-09 4.51E-09 4.61E-09 4.72E-09 4.84E-09 4.98E-09 5.11E-09 5.24E-09 5.37E-09 5.48E-09 5.57E-09 5.63E-09 5.67E-09 5.68E-09 5.66E-09 5.61E-09 5.53E-09 5.43E-09 5.31E-09 5.17E-09 5.01E-09 4.85E-09 4.69E-09 4.54E-09 4.39E-09 4.26E-09 4.16E-09 4.07E-09 4.02E-09 3.99E-09 3.99E-09 4.03E-09 4.09E-09 4.17E-09 4.27E-09 4.40E-09 4.53E-09 4.66E-09 4.80E-09 4.93E-09 5.04E-09 5.14E-09 5.22E-09 5.27E-09 5.29E-09 5.29E-09 5.25E-09 5.19E-09 5.10E-09 4.98E-09 4.85E-09 4.70E-09 4.54E-09 4.38E-09 4.23E-09 4.08E-09 3.94E-09 3.83E-09 3.74E-09 3.67E-09 3.63E-09 3.63E-09 + 6.19E-09 6.16E-09 6.09E-09 6.00E-09 5.88E-09 5.74E-09 5.59E-09 5.42E-09 5.25E-09 5.08E-09 4.92E-09 4.77E-09 4.65E-09 4.54E-09 4.46E-09 4.42E-09 4.40E-09 4.41E-09 4.45E-09 4.52E-09 4.61E-09 4.72E-09 4.85E-09 4.99E-09 5.12E-09 5.26E-09 5.38E-09 5.49E-09 5.58E-09 5.64E-09 5.68E-09 5.69E-09 5.66E-09 5.61E-09 5.53E-09 5.42E-09 5.29E-09 5.14E-09 4.97E-09 4.81E-09 4.64E-09 4.47E-09 4.32E-09 4.18E-09 4.07E-09 3.98E-09 3.92E-09 3.89E-09 3.89E-09 3.92E-09 3.97E-09 4.06E-09 4.16E-09 4.29E-09 4.42E-09 4.56E-09 4.69E-09 4.82E-09 4.94E-09 5.04E-09 5.11E-09 5.16E-09 5.19E-09 5.18E-09 5.14E-09 5.07E-09 4.97E-09 4.85E-09 4.71E-09 4.55E-09 4.39E-09 4.22E-09 4.05E-09 3.90E-09 3.75E-09 3.63E-09 3.53E-09 3.46E-09 3.42E-09 3.41E-09 + 6.31E-09 6.27E-09 6.20E-09 6.10E-09 5.98E-09 5.83E-09 5.67E-09 5.49E-09 5.32E-09 5.14E-09 4.97E-09 4.82E-09 4.68E-09 4.57E-09 4.48E-09 4.43E-09 4.41E-09 4.42E-09 4.46E-09 4.53E-09 4.62E-09 4.73E-09 4.86E-09 4.99E-09 5.13E-09 5.27E-09 5.39E-09 5.50E-09 5.59E-09 5.65E-09 5.69E-09 5.69E-09 5.67E-09 5.61E-09 5.52E-09 5.40E-09 5.26E-09 5.11E-09 4.94E-09 4.76E-09 4.58E-09 4.41E-09 4.25E-09 4.10E-09 3.98E-09 3.88E-09 3.82E-09 3.78E-09 3.78E-09 3.81E-09 3.87E-09 3.95E-09 4.05E-09 4.18E-09 4.31E-09 4.45E-09 4.59E-09 4.72E-09 4.84E-09 4.94E-09 5.01E-09 5.06E-09 5.08E-09 5.07E-09 5.02E-09 4.95E-09 4.84E-09 4.72E-09 4.57E-09 4.40E-09 4.23E-09 4.05E-09 3.88E-09 3.72E-09 3.57E-09 3.44E-09 3.33E-09 3.26E-09 3.21E-09 3.20E-09 + 6.43E-09 6.39E-09 6.31E-09 6.21E-09 6.07E-09 5.92E-09 5.75E-09 5.57E-09 5.38E-09 5.19E-09 5.02E-09 4.86E-09 4.71E-09 4.60E-09 4.51E-09 4.45E-09 4.42E-09 4.43E-09 4.47E-09 4.53E-09 4.63E-09 4.74E-09 4.87E-09 5.00E-09 5.14E-09 5.28E-09 5.40E-09 5.51E-09 5.60E-09 5.66E-09 5.70E-09 5.70E-09 5.67E-09 5.60E-09 5.51E-09 5.39E-09 5.24E-09 5.08E-09 4.90E-09 4.71E-09 4.52E-09 4.34E-09 4.17E-09 4.02E-09 3.89E-09 3.79E-09 3.72E-09 3.68E-09 3.68E-09 3.70E-09 3.76E-09 3.84E-09 3.95E-09 4.07E-09 4.21E-09 4.35E-09 4.49E-09 4.62E-09 4.74E-09 4.84E-09 4.91E-09 4.96E-09 4.97E-09 4.96E-09 4.91E-09 4.83E-09 4.72E-09 4.59E-09 4.43E-09 4.26E-09 4.08E-09 3.89E-09 3.71E-09 3.54E-09 3.38E-09 3.25E-09 3.14E-09 3.06E-09 3.01E-09 2.99E-09 + 6.55E-09 6.50E-09 6.42E-09 6.31E-09 6.17E-09 6.01E-09 5.83E-09 5.64E-09 5.44E-09 5.25E-09 5.07E-09 4.90E-09 4.75E-09 4.62E-09 4.53E-09 4.47E-09 4.44E-09 4.44E-09 4.48E-09 4.54E-09 4.63E-09 4.75E-09 4.87E-09 5.01E-09 5.15E-09 5.29E-09 5.42E-09 5.53E-09 5.61E-09 5.67E-09 5.70E-09 5.70E-09 5.67E-09 5.60E-09 5.50E-09 5.37E-09 5.22E-09 5.04E-09 4.86E-09 4.66E-09 4.47E-09 4.28E-09 4.10E-09 3.95E-09 3.81E-09 3.70E-09 3.63E-09 3.59E-09 3.58E-09 3.60E-09 3.65E-09 3.74E-09 3.84E-09 3.97E-09 4.10E-09 4.24E-09 4.38E-09 4.52E-09 4.64E-09 4.73E-09 4.81E-09 4.85E-09 4.87E-09 4.85E-09 4.80E-09 4.71E-09 4.60E-09 4.46E-09 4.29E-09 4.12E-09 3.93E-09 3.74E-09 3.55E-09 3.37E-09 3.20E-09 3.06E-09 2.95E-09 2.86E-09 2.81E-09 2.79E-09 + 6.66E-09 6.61E-09 6.52E-09 6.40E-09 6.26E-09 6.09E-09 5.90E-09 5.71E-09 5.51E-09 5.30E-09 5.11E-09 4.94E-09 4.78E-09 4.65E-09 4.55E-09 4.48E-09 4.45E-09 4.45E-09 4.49E-09 4.55E-09 4.64E-09 4.75E-09 4.88E-09 5.02E-09 5.16E-09 5.30E-09 5.43E-09 5.54E-09 5.62E-09 5.68E-09 5.71E-09 5.71E-09 5.67E-09 5.59E-09 5.49E-09 5.35E-09 5.19E-09 5.01E-09 4.82E-09 4.62E-09 4.42E-09 4.22E-09 4.04E-09 3.87E-09 3.73E-09 3.62E-09 3.54E-09 3.49E-09 3.48E-09 3.50E-09 3.55E-09 3.64E-09 3.74E-09 3.86E-09 4.00E-09 4.14E-09 4.29E-09 4.42E-09 4.54E-09 4.64E-09 4.71E-09 4.75E-09 4.77E-09 4.74E-09 4.69E-09 4.60E-09 4.48E-09 4.33E-09 4.16E-09 3.98E-09 3.78E-09 3.58E-09 3.38E-09 3.20E-09 3.03E-09 2.88E-09 2.76E-09 2.67E-09 2.61E-09 2.59E-09 + 6.77E-09 6.71E-09 6.62E-09 6.50E-09 6.35E-09 6.17E-09 5.98E-09 5.78E-09 5.57E-09 5.36E-09 5.16E-09 4.98E-09 4.81E-09 4.68E-09 4.57E-09 4.50E-09 4.47E-09 4.46E-09 4.50E-09 4.56E-09 4.65E-09 4.76E-09 4.89E-09 5.03E-09 5.17E-09 5.31E-09 5.44E-09 5.54E-09 5.63E-09 5.69E-09 5.72E-09 5.71E-09 5.67E-09 5.59E-09 5.48E-09 5.34E-09 5.17E-09 4.98E-09 4.78E-09 4.57E-09 4.37E-09 4.16E-09 3.97E-09 3.80E-09 3.65E-09 3.54E-09 3.45E-09 3.40E-09 3.38E-09 3.40E-09 3.46E-09 3.54E-09 3.64E-09 3.77E-09 3.90E-09 4.05E-09 4.19E-09 4.32E-09 4.44E-09 4.54E-09 4.61E-09 4.65E-09 4.66E-09 4.64E-09 4.58E-09 4.48E-09 4.36E-09 4.21E-09 4.03E-09 3.84E-09 3.64E-09 3.43E-09 3.23E-09 3.03E-09 2.86E-09 2.70E-09 2.58E-09 2.48E-09 2.42E-09 2.40E-09 + 6.87E-09 6.81E-09 6.72E-09 6.59E-09 6.43E-09 6.25E-09 6.05E-09 5.84E-09 5.62E-09 5.41E-09 5.20E-09 5.01E-09 4.85E-09 4.71E-09 4.60E-09 4.52E-09 4.48E-09 4.48E-09 4.51E-09 4.57E-09 4.66E-09 4.77E-09 4.90E-09 5.04E-09 5.18E-09 5.32E-09 5.44E-09 5.55E-09 5.64E-09 5.70E-09 5.72E-09 5.71E-09 5.66E-09 5.58E-09 5.47E-09 5.32E-09 5.15E-09 4.96E-09 4.75E-09 4.53E-09 4.32E-09 4.10E-09 3.91E-09 3.73E-09 3.58E-09 3.46E-09 3.37E-09 3.31E-09 3.29E-09 3.31E-09 3.36E-09 3.44E-09 3.55E-09 3.67E-09 3.81E-09 3.95E-09 4.09E-09 4.23E-09 4.35E-09 4.44E-09 4.52E-09 4.56E-09 4.56E-09 4.54E-09 4.47E-09 4.37E-09 4.24E-09 4.09E-09 3.90E-09 3.71E-09 3.50E-09 3.28E-09 3.07E-09 2.87E-09 2.69E-09 2.53E-09 2.40E-09 2.31E-09 2.24E-09 2.21E-09 + 6.97E-09 6.91E-09 6.81E-09 6.68E-09 6.51E-09 6.33E-09 6.12E-09 5.90E-09 5.68E-09 5.46E-09 5.25E-09 5.05E-09 4.88E-09 4.73E-09 4.62E-09 4.54E-09 4.50E-09 4.49E-09 4.52E-09 4.58E-09 4.67E-09 4.78E-09 4.91E-09 5.05E-09 5.19E-09 5.33E-09 5.45E-09 5.56E-09 5.65E-09 5.70E-09 5.72E-09 5.71E-09 5.66E-09 5.57E-09 5.45E-09 5.30E-09 5.13E-09 4.93E-09 4.71E-09 4.49E-09 4.27E-09 4.05E-09 3.85E-09 3.66E-09 3.51E-09 3.38E-09 3.29E-09 3.23E-09 3.21E-09 3.22E-09 3.27E-09 3.35E-09 3.45E-09 3.58E-09 3.72E-09 3.86E-09 4.00E-09 4.14E-09 4.25E-09 4.35E-09 4.42E-09 4.46E-09 4.47E-09 4.44E-09 4.37E-09 4.27E-09 4.13E-09 3.97E-09 3.78E-09 3.58E-09 3.36E-09 3.14E-09 2.93E-09 2.72E-09 2.53E-09 2.37E-09 2.23E-09 2.13E-09 2.06E-09 2.03E-09 + 7.07E-09 7.00E-09 6.90E-09 6.76E-09 6.59E-09 6.40E-09 6.19E-09 5.97E-09 5.74E-09 5.51E-09 5.29E-09 5.09E-09 4.91E-09 4.76E-09 4.64E-09 4.56E-09 4.51E-09 4.50E-09 4.53E-09 4.59E-09 4.68E-09 4.79E-09 4.92E-09 5.06E-09 5.20E-09 5.33E-09 5.46E-09 5.57E-09 5.65E-09 5.70E-09 5.73E-09 5.71E-09 5.66E-09 5.57E-09 5.44E-09 5.29E-09 5.10E-09 4.90E-09 4.68E-09 4.45E-09 4.22E-09 4.00E-09 3.79E-09 3.60E-09 3.44E-09 3.31E-09 3.21E-09 3.15E-09 3.12E-09 3.14E-09 3.18E-09 3.26E-09 3.37E-09 3.49E-09 3.63E-09 3.77E-09 3.91E-09 4.05E-09 4.17E-09 4.26E-09 4.33E-09 4.37E-09 4.37E-09 4.34E-09 4.27E-09 4.16E-09 4.02E-09 3.85E-09 3.66E-09 3.45E-09 3.23E-09 3.00E-09 2.78E-09 2.57E-09 2.38E-09 2.21E-09 2.07E-09 1.97E-09 1.90E-09 1.86E-09 + 7.16E-09 7.09E-09 6.98E-09 6.84E-09 6.67E-09 6.47E-09 6.25E-09 6.02E-09 5.79E-09 5.56E-09 5.33E-09 5.13E-09 4.94E-09 4.79E-09 4.67E-09 4.58E-09 4.53E-09 4.52E-09 4.54E-09 4.60E-09 4.69E-09 4.80E-09 4.92E-09 5.06E-09 5.20E-09 5.34E-09 5.47E-09 5.57E-09 5.66E-09 5.71E-09 5.73E-09 5.71E-09 5.65E-09 5.56E-09 5.43E-09 5.27E-09 5.08E-09 4.87E-09 4.65E-09 4.41E-09 4.18E-09 3.95E-09 3.73E-09 3.54E-09 3.37E-09 3.24E-09 3.13E-09 3.07E-09 3.04E-09 3.06E-09 3.10E-09 3.18E-09 3.28E-09 3.40E-09 3.54E-09 3.68E-09 3.83E-09 3.96E-09 4.08E-09 4.18E-09 4.24E-09 4.28E-09 4.28E-09 4.24E-09 4.17E-09 4.06E-09 3.92E-09 3.74E-09 3.55E-09 3.33E-09 3.10E-09 2.87E-09 2.65E-09 2.43E-09 2.23E-09 2.06E-09 1.92E-09 1.81E-09 1.73E-09 1.70E-09 + 7.24E-09 7.17E-09 7.06E-09 6.92E-09 6.74E-09 6.54E-09 6.32E-09 6.08E-09 5.84E-09 5.60E-09 5.37E-09 5.16E-09 4.97E-09 4.81E-09 4.69E-09 4.60E-09 4.55E-09 4.53E-09 4.55E-09 4.61E-09 4.70E-09 4.81E-09 4.93E-09 5.07E-09 5.21E-09 5.35E-09 5.47E-09 5.58E-09 5.66E-09 5.71E-09 5.73E-09 5.71E-09 5.65E-09 5.55E-09 5.42E-09 5.25E-09 5.06E-09 4.84E-09 4.61E-09 4.37E-09 4.13E-09 3.90E-09 3.68E-09 3.48E-09 3.31E-09 3.17E-09 3.07E-09 3.00E-09 2.97E-09 2.98E-09 3.02E-09 3.10E-09 3.20E-09 3.32E-09 3.46E-09 3.60E-09 3.74E-09 3.88E-09 4.00E-09 4.09E-09 4.16E-09 4.19E-09 4.19E-09 4.15E-09 4.08E-09 3.96E-09 3.81E-09 3.64E-09 3.44E-09 3.21E-09 2.98E-09 2.75E-09 2.52E-09 2.30E-09 2.09E-09 1.92E-09 1.77E-09 1.66E-09 1.58E-09 1.54E-09 + 7.32E-09 7.25E-09 7.14E-09 6.99E-09 6.81E-09 6.60E-09 6.37E-09 6.13E-09 5.89E-09 5.65E-09 5.41E-09 5.20E-09 5.00E-09 4.84E-09 4.71E-09 4.62E-09 4.56E-09 4.55E-09 4.57E-09 4.62E-09 4.71E-09 4.81E-09 4.94E-09 5.08E-09 5.22E-09 5.35E-09 5.48E-09 5.58E-09 5.66E-09 5.71E-09 5.73E-09 5.70E-09 5.64E-09 5.54E-09 5.41E-09 5.24E-09 5.04E-09 4.82E-09 4.58E-09 4.34E-09 4.09E-09 3.86E-09 3.63E-09 3.43E-09 3.25E-09 3.11E-09 3.00E-09 2.93E-09 2.90E-09 2.91E-09 2.95E-09 3.02E-09 3.12E-09 3.25E-09 3.38E-09 3.52E-09 3.67E-09 3.80E-09 3.92E-09 4.01E-09 4.08E-09 4.11E-09 4.11E-09 4.06E-09 3.98E-09 3.87E-09 3.72E-09 3.54E-09 3.33E-09 3.10E-09 2.87E-09 2.63E-09 2.39E-09 2.17E-09 1.96E-09 1.78E-09 1.63E-09 1.51E-09 1.43E-09 1.39E-09 + 7.40E-09 7.32E-09 7.21E-09 7.05E-09 6.87E-09 6.66E-09 6.43E-09 6.18E-09 5.94E-09 5.69E-09 5.45E-09 5.23E-09 5.03E-09 4.87E-09 4.73E-09 4.64E-09 4.58E-09 4.56E-09 4.58E-09 4.63E-09 4.72E-09 4.82E-09 4.95E-09 5.09E-09 5.22E-09 5.36E-09 5.48E-09 5.59E-09 5.67E-09 5.71E-09 5.72E-09 5.70E-09 5.63E-09 5.53E-09 5.39E-09 5.22E-09 5.02E-09 4.79E-09 4.55E-09 4.31E-09 4.06E-09 3.81E-09 3.58E-09 3.38E-09 3.20E-09 3.05E-09 2.94E-09 2.87E-09 2.83E-09 2.84E-09 2.88E-09 2.95E-09 3.05E-09 3.17E-09 3.31E-09 3.45E-09 3.59E-09 3.72E-09 3.84E-09 3.93E-09 4.00E-09 4.03E-09 4.02E-09 3.98E-09 3.90E-09 3.78E-09 3.62E-09 3.44E-09 3.23E-09 3.00E-09 2.76E-09 2.52E-09 2.28E-09 2.05E-09 1.84E-09 1.65E-09 1.50E-09 1.38E-09 1.30E-09 1.25E-09 + 7.47E-09 7.39E-09 7.27E-09 7.11E-09 6.93E-09 6.71E-09 6.48E-09 6.23E-09 5.98E-09 5.73E-09 5.49E-09 5.26E-09 5.06E-09 4.89E-09 4.76E-09 4.66E-09 4.60E-09 4.58E-09 4.59E-09 4.64E-09 4.73E-09 4.83E-09 4.96E-09 5.09E-09 5.23E-09 5.36E-09 5.49E-09 5.59E-09 5.67E-09 5.71E-09 5.72E-09 5.69E-09 5.63E-09 5.52E-09 5.38E-09 5.20E-09 5.00E-09 4.77E-09 4.53E-09 4.27E-09 4.02E-09 3.77E-09 3.54E-09 3.33E-09 3.15E-09 3.00E-09 2.88E-09 2.81E-09 2.77E-09 2.78E-09 2.81E-09 2.89E-09 2.99E-09 3.11E-09 3.24E-09 3.38E-09 3.52E-09 3.65E-09 3.77E-09 3.86E-09 3.92E-09 3.95E-09 3.95E-09 3.90E-09 3.81E-09 3.69E-09 3.53E-09 3.35E-09 3.13E-09 2.90E-09 2.66E-09 2.41E-09 2.17E-09 1.93E-09 1.72E-09 1.53E-09 1.37E-09 1.25E-09 1.17E-09 1.13E-09 + 7.54E-09 7.45E-09 7.33E-09 7.17E-09 6.98E-09 6.76E-09 6.53E-09 6.28E-09 6.02E-09 5.76E-09 5.52E-09 5.29E-09 5.09E-09 4.92E-09 4.78E-09 4.68E-09 4.61E-09 4.59E-09 4.61E-09 4.66E-09 4.74E-09 4.84E-09 4.96E-09 5.10E-09 5.24E-09 5.37E-09 5.49E-09 5.59E-09 5.67E-09 5.71E-09 5.72E-09 5.69E-09 5.62E-09 5.51E-09 5.37E-09 5.19E-09 4.98E-09 4.75E-09 4.50E-09 4.24E-09 3.99E-09 3.74E-09 3.50E-09 3.29E-09 3.10E-09 2.95E-09 2.83E-09 2.76E-09 2.72E-09 2.72E-09 2.76E-09 2.83E-09 2.92E-09 3.04E-09 3.18E-09 3.32E-09 3.46E-09 3.59E-09 3.70E-09 3.79E-09 3.85E-09 3.88E-09 3.87E-09 3.82E-09 3.74E-09 3.61E-09 3.45E-09 3.26E-09 3.04E-09 2.81E-09 2.56E-09 2.31E-09 2.06E-09 1.83E-09 1.61E-09 1.42E-09 1.26E-09 1.14E-09 1.05E-09 1.01E-09 + 7.59E-09 7.51E-09 7.38E-09 7.22E-09 7.03E-09 6.81E-09 6.57E-09 6.32E-09 6.06E-09 5.80E-09 5.55E-09 5.32E-09 5.12E-09 4.94E-09 4.80E-09 4.69E-09 4.63E-09 4.61E-09 4.62E-09 4.67E-09 4.75E-09 4.85E-09 4.97E-09 5.10E-09 5.24E-09 5.37E-09 5.49E-09 5.59E-09 5.67E-09 5.71E-09 5.71E-09 5.68E-09 5.61E-09 5.50E-09 5.35E-09 5.17E-09 4.96E-09 4.73E-09 4.48E-09 4.22E-09 3.96E-09 3.70E-09 3.47E-09 3.25E-09 3.06E-09 2.91E-09 2.79E-09 2.71E-09 2.67E-09 2.67E-09 2.70E-09 2.77E-09 2.87E-09 2.99E-09 3.12E-09 3.26E-09 3.39E-09 3.52E-09 3.64E-09 3.73E-09 3.79E-09 3.81E-09 3.80E-09 3.75E-09 3.66E-09 3.54E-09 3.37E-09 3.18E-09 2.96E-09 2.72E-09 2.47E-09 2.22E-09 1.97E-09 1.73E-09 1.51E-09 1.32E-09 1.16E-09 1.03E-09 9.430000E-10 8.950000E-10 + 7.65E-09 7.56E-09 7.43E-09 7.27E-09 7.07E-09 6.85E-09 6.61E-09 6.35E-09 6.09E-09 5.83E-09 5.58E-09 5.35E-09 5.14E-09 4.96E-09 4.82E-09 4.71E-09 4.65E-09 4.62E-09 4.63E-09 4.68E-09 4.76E-09 4.86E-09 4.98E-09 5.11E-09 5.24E-09 5.38E-09 5.49E-09 5.59E-09 5.66E-09 5.70E-09 5.71E-09 5.68E-09 5.60E-09 5.49E-09 5.34E-09 5.16E-09 4.94E-09 4.71E-09 4.45E-09 4.19E-09 3.93E-09 3.67E-09 3.43E-09 3.21E-09 3.02E-09 2.87E-09 2.75E-09 2.66E-09 2.62E-09 2.62E-09 2.65E-09 2.72E-09 2.82E-09 2.93E-09 3.06E-09 3.20E-09 3.34E-09 3.47E-09 3.58E-09 3.67E-09 3.72E-09 3.75E-09 3.74E-09 3.68E-09 3.59E-09 3.46E-09 3.30E-09 3.10E-09 2.88E-09 2.64E-09 2.39E-09 2.13E-09 1.88E-09 1.64E-09 1.42E-09 1.23E-09 1.06E-09 9.340000E-10 8.440000E-10 7.950000E-10 + 7.69E-09 7.60E-09 7.48E-09 7.31E-09 7.11E-09 6.89E-09 6.65E-09 6.39E-09 6.12E-09 5.86E-09 5.61E-09 5.37E-09 5.16E-09 4.98E-09 4.84E-09 4.73E-09 4.66E-09 4.63E-09 4.64E-09 4.69E-09 4.76E-09 4.87E-09 4.98E-09 5.12E-09 5.25E-09 5.38E-09 5.49E-09 5.59E-09 5.66E-09 5.70E-09 5.70E-09 5.67E-09 5.59E-09 5.48E-09 5.33E-09 5.14E-09 4.93E-09 4.69E-09 4.43E-09 4.17E-09 3.90E-09 3.65E-09 3.40E-09 3.18E-09 2.99E-09 2.83E-09 2.71E-09 2.63E-09 2.58E-09 2.58E-09 2.61E-09 2.68E-09 2.77E-09 2.88E-09 3.01E-09 3.15E-09 3.29E-09 3.41E-09 3.52E-09 3.61E-09 3.67E-09 3.69E-09 3.68E-09 3.62E-09 3.53E-09 3.40E-09 3.23E-09 3.03E-09 2.81E-09 2.57E-09 2.32E-09 2.06E-09 1.80E-09 1.56E-09 1.34E-09 1.14E-09 9.770000E-10 8.470000E-10 7.560000E-10 7.050000E-10 + 7.73E-09 7.64E-09 7.51E-09 7.35E-09 7.15E-09 6.92E-09 6.68E-09 6.42E-09 6.15E-09 5.89E-09 5.63E-09 5.40E-09 5.19E-09 5.01E-09 4.86E-09 4.75E-09 4.68E-09 4.65E-09 4.66E-09 4.70E-09 4.77E-09 4.87E-09 4.99E-09 5.12E-09 5.25E-09 5.38E-09 5.49E-09 5.59E-09 5.66E-09 5.70E-09 5.70E-09 5.66E-09 5.58E-09 5.47E-09 5.31E-09 5.13E-09 4.91E-09 4.67E-09 4.41E-09 4.15E-09 3.88E-09 3.62E-09 3.38E-09 3.16E-09 2.96E-09 2.80E-09 2.68E-09 2.59E-09 2.55E-09 2.54E-09 2.57E-09 2.64E-09 2.73E-09 2.84E-09 2.97E-09 3.11E-09 3.24E-09 3.36E-09 3.47E-09 3.56E-09 3.61E-09 3.64E-09 3.62E-09 3.56E-09 3.47E-09 3.34E-09 3.17E-09 2.97E-09 2.75E-09 2.50E-09 2.25E-09 1.99E-09 1.73E-09 1.49E-09 1.27E-09 1.07E-09 9.020000E-10 7.710000E-10 6.790000E-10 6.260000E-10 + 7.77E-09 7.68E-09 7.54E-09 7.38E-09 7.18E-09 6.95E-09 6.70E-09 6.44E-09 6.18E-09 5.91E-09 5.66E-09 5.42E-09 5.21E-09 5.02E-09 4.88E-09 4.77E-09 4.70E-09 4.66E-09 4.67E-09 4.71E-09 4.78E-09 4.88E-09 5.00E-09 5.12E-09 5.25E-09 5.38E-09 5.49E-09 5.59E-09 5.65E-09 5.69E-09 5.69E-09 5.65E-09 5.57E-09 5.46E-09 5.30E-09 5.11E-09 4.89E-09 4.65E-09 4.40E-09 4.13E-09 3.86E-09 3.60E-09 3.36E-09 3.14E-09 2.94E-09 2.78E-09 2.65E-09 2.57E-09 2.52E-09 2.51E-09 2.54E-09 2.60E-09 2.69E-09 2.81E-09 2.93E-09 3.07E-09 3.20E-09 3.32E-09 3.43E-09 3.51E-09 3.57E-09 3.59E-09 3.57E-09 3.51E-09 3.42E-09 3.28E-09 3.11E-09 2.92E-09 2.69E-09 2.45E-09 2.19E-09 1.93E-09 1.67E-09 1.43E-09 1.20E-09 1.01E-09 8.380000E-10 7.050000E-10 6.120000E-10 5.590000E-10 + 7.79E-09 7.70E-09 7.57E-09 7.40E-09 7.20E-09 6.97E-09 6.73E-09 6.47E-09 6.20E-09 5.93E-09 5.68E-09 5.44E-09 5.23E-09 5.04E-09 4.89E-09 4.78E-09 4.71E-09 4.68E-09 4.68E-09 4.72E-09 4.79E-09 4.89E-09 5.00E-09 5.13E-09 5.26E-09 5.38E-09 5.49E-09 5.58E-09 5.65E-09 5.68E-09 5.68E-09 5.64E-09 5.56E-09 5.44E-09 5.29E-09 5.10E-09 4.88E-09 4.64E-09 4.38E-09 4.11E-09 3.85E-09 3.59E-09 3.34E-09 3.12E-09 2.92E-09 2.76E-09 2.63E-09 2.54E-09 2.50E-09 2.49E-09 2.52E-09 2.58E-09 2.67E-09 2.78E-09 2.90E-09 3.03E-09 3.16E-09 3.28E-09 3.39E-09 3.47E-09 3.52E-09 3.54E-09 3.52E-09 3.47E-09 3.37E-09 3.23E-09 3.07E-09 2.87E-09 2.64E-09 2.39E-09 2.14E-09 1.88E-09 1.62E-09 1.38E-09 1.15E-09 9.520000E-10 7.830000E-10 6.510000E-10 5.560000E-10 5.020000E-10 + 7.82E-09 7.72E-09 7.59E-09 7.42E-09 7.22E-09 6.99E-09 6.74E-09 6.48E-09 6.22E-09 5.95E-09 5.70E-09 5.46E-09 5.25E-09 5.06E-09 4.91E-09 4.80E-09 4.73E-09 4.69E-09 4.70E-09 4.73E-09 4.80E-09 4.90E-09 5.01E-09 5.13E-09 5.26E-09 5.38E-09 5.49E-09 5.58E-09 5.64E-09 5.68E-09 5.67E-09 5.63E-09 5.55E-09 5.43E-09 5.28E-09 5.09E-09 4.87E-09 4.63E-09 4.37E-09 4.10E-09 3.83E-09 3.57E-09 3.33E-09 3.10E-09 2.91E-09 2.74E-09 2.62E-09 2.53E-09 2.48E-09 2.47E-09 2.50E-09 2.56E-09 2.64E-09 2.75E-09 2.87E-09 3.00E-09 3.13E-09 3.25E-09 3.35E-09 3.43E-09 3.48E-09 3.50E-09 3.48E-09 3.42E-09 3.33E-09 3.19E-09 3.02E-09 2.82E-09 2.60E-09 2.35E-09 2.09E-09 1.83E-09 1.58E-09 1.33E-09 1.11E-09 9.090000E-10 7.400000E-10 6.070000E-10 5.120000E-10 4.560000E-10 + 7.83E-09 7.74E-09 7.60E-09 7.43E-09 7.23E-09 7.01E-09 6.76E-09 6.50E-09 6.23E-09 5.97E-09 5.71E-09 5.48E-09 5.26E-09 5.08E-09 4.93E-09 4.81E-09 4.74E-09 4.71E-09 4.71E-09 4.74E-09 4.81E-09 4.90E-09 5.01E-09 5.13E-09 5.26E-09 5.38E-09 5.49E-09 5.57E-09 5.64E-09 5.67E-09 5.66E-09 5.62E-09 5.54E-09 5.42E-09 5.26E-09 5.07E-09 4.86E-09 4.61E-09 4.36E-09 4.09E-09 3.82E-09 3.56E-09 3.32E-09 3.09E-09 2.90E-09 2.73E-09 2.61E-09 2.52E-09 2.47E-09 2.46E-09 2.48E-09 2.54E-09 2.63E-09 2.73E-09 2.85E-09 2.98E-09 3.11E-09 3.22E-09 3.32E-09 3.40E-09 3.45E-09 3.47E-09 3.45E-09 3.39E-09 3.29E-09 3.16E-09 2.99E-09 2.79E-09 2.56E-09 2.32E-09 2.06E-09 1.80E-09 1.54E-09 1.30E-09 1.08E-09 8.760000E-10 7.070000E-10 5.740000E-10 4.780000E-10 4.220000E-10 + 7.84E-09 7.74E-09 7.61E-09 7.44E-09 7.24E-09 7.01E-09 6.77E-09 6.51E-09 6.24E-09 5.98E-09 5.73E-09 5.49E-09 5.28E-09 5.09E-09 4.94E-09 4.83E-09 4.76E-09 4.72E-09 4.72E-09 4.76E-09 4.82E-09 4.91E-09 5.02E-09 5.14E-09 5.26E-09 5.38E-09 5.48E-09 5.57E-09 5.63E-09 5.66E-09 5.65E-09 5.61E-09 5.53E-09 5.41E-09 5.25E-09 5.06E-09 4.84E-09 4.60E-09 4.35E-09 4.08E-09 3.82E-09 3.56E-09 3.31E-09 3.09E-09 2.89E-09 2.73E-09 2.60E-09 2.51E-09 2.46E-09 2.45E-09 2.47E-09 2.53E-09 2.61E-09 2.72E-09 2.84E-09 2.96E-09 3.09E-09 3.20E-09 3.30E-09 3.38E-09 3.42E-09 3.44E-09 3.42E-09 3.36E-09 3.26E-09 3.12E-09 2.96E-09 2.76E-09 2.53E-09 2.29E-09 2.03E-09 1.77E-09 1.52E-09 1.28E-09 1.05E-09 8.540000E-10 6.860000E-10 5.520000E-10 4.570000E-10 4.000000E-10 + 7.84E-09 7.74E-09 7.61E-09 7.44E-09 7.24E-09 7.02E-09 6.77E-09 6.51E-09 6.25E-09 5.99E-09 5.74E-09 5.50E-09 5.29E-09 5.11E-09 4.96E-09 4.84E-09 4.77E-09 4.73E-09 4.73E-09 4.77E-09 4.83E-09 4.92E-09 5.02E-09 5.14E-09 5.26E-09 5.37E-09 5.48E-09 5.56E-09 5.62E-09 5.65E-09 5.64E-09 5.60E-09 5.52E-09 5.40E-09 5.24E-09 5.05E-09 4.83E-09 4.60E-09 4.34E-09 4.08E-09 3.81E-09 3.56E-09 3.31E-09 3.09E-09 2.90E-09 2.73E-09 2.60E-09 2.51E-09 2.46E-09 2.45E-09 2.47E-09 2.53E-09 2.61E-09 2.71E-09 2.83E-09 2.95E-09 3.07E-09 3.18E-09 3.28E-09 3.36E-09 3.40E-09 3.42E-09 3.39E-09 3.33E-09 3.24E-09 3.10E-09 2.93E-09 2.73E-09 2.51E-09 2.27E-09 2.01E-09 1.76E-09 1.50E-09 1.26E-09 1.04E-09 8.420000E-10 6.750000E-10 5.420000E-10 4.460000E-10 3.890000E-10 + 7.83E-09 7.74E-09 7.60E-09 7.44E-09 7.24E-09 7.02E-09 6.77E-09 6.52E-09 6.26E-09 6.00E-09 5.75E-09 5.51E-09 5.30E-09 5.12E-09 4.97E-09 4.86E-09 4.78E-09 4.75E-09 4.74E-09 4.78E-09 4.84E-09 4.92E-09 5.03E-09 5.14E-09 5.26E-09 5.37E-09 5.47E-09 5.55E-09 5.61E-09 5.64E-09 5.63E-09 5.58E-09 5.50E-09 5.38E-09 5.23E-09 5.04E-09 4.83E-09 4.59E-09 4.34E-09 4.07E-09 3.81E-09 3.56E-09 3.32E-09 3.09E-09 2.90E-09 2.74E-09 2.61E-09 2.52E-09 2.47E-09 2.46E-09 2.48E-09 2.53E-09 2.61E-09 2.71E-09 2.82E-09 2.94E-09 3.06E-09 3.17E-09 3.27E-09 3.34E-09 3.38E-09 3.40E-09 3.37E-09 3.31E-09 3.22E-09 3.08E-09 2.91E-09 2.72E-09 2.50E-09 2.26E-09 2.00E-09 1.75E-09 1.50E-09 1.26E-09 1.04E-09 8.410000E-10 6.750000E-10 5.430000E-10 4.470000E-10 3.900000E-10 + 7.82E-09 7.72E-09 7.59E-09 7.43E-09 7.23E-09 7.01E-09 6.77E-09 6.52E-09 6.26E-09 6.00E-09 5.75E-09 5.52E-09 5.31E-09 5.13E-09 4.98E-09 4.87E-09 4.80E-09 4.76E-09 4.76E-09 4.79E-09 4.85E-09 4.93E-09 5.03E-09 5.14E-09 5.26E-09 5.37E-09 5.46E-09 5.54E-09 5.60E-09 5.62E-09 5.62E-09 5.57E-09 5.49E-09 5.37E-09 5.22E-09 5.03E-09 4.82E-09 4.58E-09 4.33E-09 4.07E-09 3.81E-09 3.56E-09 3.32E-09 3.10E-09 2.91E-09 2.75E-09 2.62E-09 2.53E-09 2.48E-09 2.47E-09 2.49E-09 2.54E-09 2.62E-09 2.71E-09 2.82E-09 2.94E-09 3.06E-09 3.17E-09 3.26E-09 3.33E-09 3.37E-09 3.39E-09 3.36E-09 3.30E-09 3.20E-09 3.07E-09 2.90E-09 2.71E-09 2.49E-09 2.25E-09 2.00E-09 1.75E-09 1.50E-09 1.26E-09 1.05E-09 8.510000E-10 6.860000E-10 5.550000E-10 4.600000E-10 4.020000E-10 + 7.80E-09 7.71E-09 7.58E-09 7.41E-09 7.22E-09 7.00E-09 6.76E-09 6.51E-09 6.25E-09 6.00E-09 5.75E-09 5.53E-09 5.32E-09 5.14E-09 4.99E-09 4.88E-09 4.81E-09 4.77E-09 4.77E-09 4.80E-09 4.85E-09 4.94E-09 5.03E-09 5.14E-09 5.25E-09 5.36E-09 5.46E-09 5.53E-09 5.59E-09 5.61E-09 5.60E-09 5.56E-09 5.48E-09 5.36E-09 5.21E-09 5.02E-09 4.81E-09 4.58E-09 4.33E-09 4.08E-09 3.82E-09 3.57E-09 3.33E-09 3.12E-09 2.93E-09 2.77E-09 2.64E-09 2.55E-09 2.50E-09 2.49E-09 2.50E-09 2.55E-09 2.63E-09 2.72E-09 2.83E-09 2.95E-09 3.06E-09 3.17E-09 3.26E-09 3.33E-09 3.37E-09 3.38E-09 3.35E-09 3.29E-09 3.20E-09 3.06E-09 2.90E-09 2.71E-09 2.49E-09 2.25E-09 2.01E-09 1.76E-09 1.51E-09 1.28E-09 1.06E-09 8.720000E-10 7.080000E-10 5.780000E-10 4.840000E-10 4.270000E-10 + 7.77E-09 7.68E-09 7.55E-09 7.39E-09 7.20E-09 6.98E-09 6.75E-09 6.50E-09 6.25E-09 6.00E-09 5.75E-09 5.53E-09 5.33E-09 5.15E-09 5.00E-09 4.89E-09 4.82E-09 4.78E-09 4.78E-09 4.81E-09 4.86E-09 4.94E-09 5.04E-09 5.14E-09 5.25E-09 5.36E-09 5.45E-09 5.52E-09 5.58E-09 5.60E-09 5.59E-09 5.54E-09 5.46E-09 5.35E-09 5.20E-09 5.01E-09 4.81E-09 4.58E-09 4.33E-09 4.08E-09 3.83E-09 3.58E-09 3.35E-09 3.13E-09 2.95E-09 2.79E-09 2.67E-09 2.58E-09 2.53E-09 2.51E-09 2.53E-09 2.57E-09 2.65E-09 2.74E-09 2.85E-09 2.96E-09 3.07E-09 3.17E-09 3.26E-09 3.33E-09 3.37E-09 3.38E-09 3.35E-09 3.29E-09 3.20E-09 3.07E-09 2.90E-09 2.71E-09 2.50E-09 2.27E-09 2.02E-09 1.78E-09 1.54E-09 1.31E-09 1.09E-09 9.030000E-10 7.410000E-10 6.130000E-10 5.190000E-10 4.620000E-10 + 7.74E-09 7.65E-09 7.52E-09 7.36E-09 7.17E-09 6.96E-09 6.73E-09 6.49E-09 6.24E-09 5.99E-09 5.75E-09 5.53E-09 5.33E-09 5.16E-09 5.01E-09 4.91E-09 4.83E-09 4.79E-09 4.79E-09 4.82E-09 4.87E-09 4.95E-09 5.04E-09 5.14E-09 5.25E-09 5.35E-09 5.44E-09 5.51E-09 5.56E-09 5.59E-09 5.57E-09 5.53E-09 5.45E-09 5.33E-09 5.19E-09 5.01E-09 4.80E-09 4.58E-09 4.34E-09 4.09E-09 3.84E-09 3.60E-09 3.37E-09 3.16E-09 2.97E-09 2.82E-09 2.69E-09 2.61E-09 2.56E-09 2.54E-09 2.56E-09 2.60E-09 2.67E-09 2.76E-09 2.87E-09 2.97E-09 3.08E-09 3.18E-09 3.27E-09 3.33E-09 3.37E-09 3.38E-09 3.36E-09 3.30E-09 3.20E-09 3.07E-09 2.91E-09 2.72E-09 2.51E-09 2.29E-09 2.05E-09 1.81E-09 1.57E-09 1.34E-09 1.13E-09 9.440000E-10 7.850000E-10 6.580000E-10 5.660000E-10 5.100000E-10 + 7.70E-09 7.61E-09 7.49E-09 7.33E-09 7.14E-09 6.93E-09 6.71E-09 6.47E-09 6.22E-09 5.98E-09 5.75E-09 5.53E-09 5.33E-09 5.16E-09 5.02E-09 4.91E-09 4.84E-09 4.80E-09 4.80E-09 4.82E-09 4.88E-09 4.95E-09 5.04E-09 5.14E-09 5.24E-09 5.34E-09 5.43E-09 5.50E-09 5.55E-09 5.57E-09 5.56E-09 5.52E-09 5.44E-09 5.32E-09 5.18E-09 5.00E-09 4.80E-09 4.58E-09 4.34E-09 4.10E-09 3.85E-09 3.62E-09 3.39E-09 3.18E-09 3.00E-09 2.85E-09 2.73E-09 2.64E-09 2.59E-09 2.57E-09 2.59E-09 2.63E-09 2.70E-09 2.79E-09 2.89E-09 3.00E-09 3.10E-09 3.20E-09 3.28E-09 3.35E-09 3.38E-09 3.39E-09 3.37E-09 3.31E-09 3.21E-09 3.09E-09 2.93E-09 2.74E-09 2.54E-09 2.31E-09 2.08E-09 1.84E-09 1.61E-09 1.39E-09 1.18E-09 9.959999E-10 8.400000E-10 7.150000E-10 6.240000E-10 5.680000E-10 + 7.66E-09 7.57E-09 7.44E-09 7.29E-09 7.11E-09 6.90E-09 6.68E-09 6.45E-09 6.21E-09 5.97E-09 5.74E-09 5.53E-09 5.34E-09 5.17E-09 5.03E-09 4.92E-09 4.85E-09 4.81E-09 4.81E-09 4.83E-09 4.88E-09 4.96E-09 5.04E-09 5.14E-09 5.24E-09 5.34E-09 5.42E-09 5.49E-09 5.54E-09 5.56E-09 5.54E-09 5.50E-09 5.42E-09 5.31E-09 5.17E-09 4.99E-09 4.80E-09 4.58E-09 4.35E-09 4.11E-09 3.87E-09 3.64E-09 3.42E-09 3.21E-09 3.04E-09 2.89E-09 2.77E-09 2.68E-09 2.63E-09 2.62E-09 2.63E-09 2.67E-09 2.74E-09 2.82E-09 2.92E-09 3.02E-09 3.13E-09 3.22E-09 3.30E-09 3.36E-09 3.40E-09 3.41E-09 3.38E-09 3.32E-09 3.23E-09 3.11E-09 2.95E-09 2.77E-09 2.57E-09 2.35E-09 2.12E-09 1.89E-09 1.66E-09 1.44E-09 1.24E-09 1.06E-09 9.050000E-10 7.820000E-10 6.930000E-10 6.380000E-10 + 7.60E-09 7.52E-09 7.40E-09 7.24E-09 7.07E-09 6.87E-09 6.65E-09 6.42E-09 6.19E-09 5.96E-09 5.73E-09 5.52E-09 5.33E-09 5.17E-09 5.04E-09 4.93E-09 4.86E-09 4.82E-09 4.82E-09 4.84E-09 4.89E-09 4.96E-09 5.04E-09 5.14E-09 5.24E-09 5.33E-09 5.41E-09 5.48E-09 5.52E-09 5.54E-09 5.53E-09 5.48E-09 5.41E-09 5.30E-09 5.16E-09 4.99E-09 4.80E-09 4.58E-09 4.36E-09 4.13E-09 3.89E-09 3.66E-09 3.45E-09 3.25E-09 3.08E-09 2.93E-09 2.81E-09 2.73E-09 2.68E-09 2.66E-09 2.68E-09 2.72E-09 2.78E-09 2.86E-09 2.96E-09 3.06E-09 3.16E-09 3.25E-09 3.33E-09 3.39E-09 3.42E-09 3.43E-09 3.40E-09 3.34E-09 3.25E-09 3.13E-09 2.98E-09 2.80E-09 2.61E-09 2.39E-09 2.17E-09 1.94E-09 1.72E-09 1.50E-09 1.31E-09 1.13E-09 9.809999E-10 8.610000E-10 7.730000E-10 7.190000E-10 + 7.55E-09 7.46E-09 7.34E-09 7.19E-09 7.02E-09 6.83E-09 6.61E-09 6.39E-09 6.16E-09 5.94E-09 5.72E-09 5.52E-09 5.33E-09 5.17E-09 5.04E-09 4.94E-09 4.87E-09 4.83E-09 4.83E-09 4.85E-09 4.90E-09 4.96E-09 5.04E-09 5.14E-09 5.23E-09 5.32E-09 5.40E-09 5.46E-09 5.51E-09 5.52E-09 5.51E-09 5.47E-09 5.39E-09 5.29E-09 5.15E-09 4.99E-09 4.80E-09 4.59E-09 4.37E-09 4.14E-09 3.91E-09 3.69E-09 3.48E-09 3.29E-09 3.12E-09 2.98E-09 2.86E-09 2.78E-09 2.73E-09 2.72E-09 2.73E-09 2.77E-09 2.83E-09 2.91E-09 3.00E-09 3.10E-09 3.19E-09 3.28E-09 3.36E-09 3.41E-09 3.45E-09 3.45E-09 3.43E-09 3.37E-09 3.28E-09 3.16E-09 3.02E-09 2.84E-09 2.65E-09 2.44E-09 2.22E-09 2.00E-09 1.78E-09 1.58E-09 1.38E-09 1.21E-09 1.07E-09 9.500000E-10 8.640000E-10 8.110000E-10 + 7.48E-09 7.40E-09 7.28E-09 7.14E-09 6.97E-09 6.78E-09 6.58E-09 6.36E-09 6.14E-09 5.92E-09 5.71E-09 5.51E-09 5.33E-09 5.17E-09 5.05E-09 4.95E-09 4.88E-09 4.84E-09 4.84E-09 4.86E-09 4.90E-09 4.97E-09 5.05E-09 5.13E-09 5.22E-09 5.31E-09 5.39E-09 5.45E-09 5.49E-09 5.51E-09 5.49E-09 5.45E-09 5.38E-09 5.28E-09 5.14E-09 4.98E-09 4.80E-09 4.60E-09 4.38E-09 4.16E-09 3.94E-09 3.72E-09 3.52E-09 3.33E-09 3.17E-09 3.03E-09 2.92E-09 2.84E-09 2.79E-09 2.77E-09 2.79E-09 2.82E-09 2.88E-09 2.96E-09 3.05E-09 3.14E-09 3.23E-09 3.32E-09 3.39E-09 3.45E-09 3.48E-09 3.48E-09 3.46E-09 3.40E-09 3.32E-09 3.20E-09 3.06E-09 2.89E-09 2.70E-09 2.50E-09 2.29E-09 2.07E-09 1.86E-09 1.66E-09 1.47E-09 1.30E-09 1.16E-09 1.05E-09 9.650000E-10 9.130000E-10 + 7.41E-09 7.33E-09 7.22E-09 7.08E-09 6.92E-09 6.73E-09 6.53E-09 6.32E-09 6.11E-09 5.89E-09 5.69E-09 5.50E-09 5.32E-09 5.17E-09 5.05E-09 4.95E-09 4.89E-09 4.85E-09 4.84E-09 4.86E-09 4.91E-09 4.97E-09 5.05E-09 5.13E-09 5.22E-09 5.30E-09 5.37E-09 5.43E-09 5.47E-09 5.49E-09 5.48E-09 5.44E-09 5.36E-09 5.26E-09 5.13E-09 4.98E-09 4.80E-09 4.61E-09 4.40E-09 4.18E-09 3.97E-09 3.76E-09 3.56E-09 3.38E-09 3.22E-09 3.08E-09 2.98E-09 2.90E-09 2.85E-09 2.84E-09 2.85E-09 2.88E-09 2.94E-09 3.01E-09 3.10E-09 3.19E-09 3.28E-09 3.36E-09 3.43E-09 3.48E-09 3.51E-09 3.52E-09 3.49E-09 3.44E-09 3.36E-09 3.24E-09 3.11E-09 2.94E-09 2.76E-09 2.56E-09 2.36E-09 2.15E-09 1.95E-09 1.75E-09 1.57E-09 1.41E-09 1.27E-09 1.16E-09 1.08E-09 1.03E-09 + 7.33E-09 7.26E-09 7.15E-09 7.01E-09 6.86E-09 6.68E-09 6.48E-09 6.28E-09 6.07E-09 5.87E-09 5.67E-09 5.48E-09 5.32E-09 5.17E-09 5.05E-09 4.96E-09 4.89E-09 4.86E-09 4.85E-09 4.87E-09 4.91E-09 4.97E-09 5.05E-09 5.13E-09 5.21E-09 5.29E-09 5.36E-09 5.42E-09 5.46E-09 5.47E-09 5.46E-09 5.42E-09 5.35E-09 5.25E-09 5.13E-09 4.98E-09 4.80E-09 4.62E-09 4.42E-09 4.21E-09 4.00E-09 3.80E-09 3.61E-09 3.43E-09 3.28E-09 3.15E-09 3.04E-09 2.97E-09 2.92E-09 2.91E-09 2.92E-09 2.95E-09 3.00E-09 3.08E-09 3.16E-09 3.24E-09 3.33E-09 3.41E-09 3.48E-09 3.53E-09 3.55E-09 3.56E-09 3.54E-09 3.48E-09 3.40E-09 3.29E-09 3.16E-09 3.00E-09 2.83E-09 2.64E-09 2.44E-09 2.24E-09 2.04E-09 1.85E-09 1.67E-09 1.52E-09 1.38E-09 1.28E-09 1.20E-09 1.15E-09 + 7.25E-09 7.18E-09 7.07E-09 6.94E-09 6.79E-09 6.62E-09 6.43E-09 6.24E-09 6.04E-09 5.84E-09 5.65E-09 5.47E-09 5.31E-09 5.17E-09 5.05E-09 4.96E-09 4.90E-09 4.87E-09 4.86E-09 4.88E-09 4.92E-09 4.97E-09 5.04E-09 5.12E-09 5.20E-09 5.28E-09 5.35E-09 5.40E-09 5.44E-09 5.45E-09 5.44E-09 5.40E-09 5.33E-09 5.24E-09 5.12E-09 4.97E-09 4.81E-09 4.63E-09 4.43E-09 4.24E-09 4.04E-09 3.84E-09 3.66E-09 3.49E-09 3.34E-09 3.21E-09 3.11E-09 3.04E-09 3.00E-09 2.98E-09 2.99E-09 3.02E-09 3.07E-09 3.14E-09 3.22E-09 3.30E-09 3.38E-09 3.46E-09 3.53E-09 3.57E-09 3.60E-09 3.60E-09 3.58E-09 3.53E-09 3.45E-09 3.35E-09 3.22E-09 3.07E-09 2.90E-09 2.71E-09 2.52E-09 2.33E-09 2.14E-09 1.96E-09 1.79E-09 1.64E-09 1.51E-09 1.41E-09 1.33E-09 1.28E-09 + 7.17E-09 7.09E-09 6.99E-09 6.87E-09 6.72E-09 6.56E-09 6.38E-09 6.19E-09 6.00E-09 5.81E-09 5.63E-09 5.45E-09 5.30E-09 5.16E-09 5.05E-09 4.97E-09 4.91E-09 4.87E-09 4.87E-09 4.88E-09 4.92E-09 4.98E-09 5.04E-09 5.12E-09 5.19E-09 5.27E-09 5.33E-09 5.39E-09 5.42E-09 5.43E-09 5.42E-09 5.38E-09 5.32E-09 5.23E-09 5.11E-09 4.97E-09 4.82E-09 4.64E-09 4.46E-09 4.26E-09 4.07E-09 3.88E-09 3.71E-09 3.55E-09 3.40E-09 3.28E-09 3.18E-09 3.12E-09 3.07E-09 3.06E-09 3.07E-09 3.10E-09 3.15E-09 3.21E-09 3.29E-09 3.37E-09 3.45E-09 3.52E-09 3.58E-09 3.63E-09 3.65E-09 3.65E-09 3.63E-09 3.58E-09 3.51E-09 3.41E-09 3.28E-09 3.14E-09 2.98E-09 2.80E-09 2.62E-09 2.43E-09 2.25E-09 2.07E-09 1.91E-09 1.77E-09 1.64E-09 1.54E-09 1.47E-09 1.42E-09 + 7.07E-09 7.00E-09 6.91E-09 6.79E-09 6.65E-09 6.49E-09 6.32E-09 6.14E-09 5.96E-09 5.78E-09 5.60E-09 5.44E-09 5.29E-09 5.16E-09 5.05E-09 4.97E-09 4.91E-09 4.88E-09 4.87E-09 4.89E-09 4.93E-09 4.98E-09 5.04E-09 5.11E-09 5.19E-09 5.26E-09 5.32E-09 5.37E-09 5.40E-09 5.41E-09 5.40E-09 5.37E-09 5.30E-09 5.22E-09 5.11E-09 4.97E-09 4.82E-09 4.66E-09 4.48E-09 4.29E-09 4.11E-09 3.93E-09 3.76E-09 3.61E-09 3.47E-09 3.35E-09 3.26E-09 3.20E-09 3.16E-09 3.14E-09 3.15E-09 3.18E-09 3.23E-09 3.29E-09 3.36E-09 3.43E-09 3.51E-09 3.58E-09 3.64E-09 3.68E-09 3.71E-09 3.71E-09 3.69E-09 3.64E-09 3.57E-09 3.47E-09 3.35E-09 3.22E-09 3.06E-09 2.89E-09 2.72E-09 2.54E-09 2.36E-09 2.20E-09 2.04E-09 1.90E-09 1.78E-09 1.69E-09 1.62E-09 1.58E-09 + 6.98E-09 6.91E-09 6.82E-09 6.70E-09 6.57E-09 6.42E-09 6.26E-09 6.09E-09 5.91E-09 5.74E-09 5.57E-09 5.42E-09 5.28E-09 5.15E-09 5.05E-09 4.97E-09 4.92E-09 4.89E-09 4.88E-09 4.90E-09 4.93E-09 4.98E-09 5.04E-09 5.11E-09 5.18E-09 5.24E-09 5.30E-09 5.35E-09 5.38E-09 5.39E-09 5.38E-09 5.35E-09 5.29E-09 5.21E-09 5.10E-09 4.97E-09 4.83E-09 4.67E-09 4.50E-09 4.33E-09 4.15E-09 3.98E-09 3.82E-09 3.67E-09 3.54E-09 3.43E-09 3.34E-09 3.28E-09 3.24E-09 3.23E-09 3.24E-09 3.26E-09 3.31E-09 3.37E-09 3.44E-09 3.51E-09 3.58E-09 3.64E-09 3.70E-09 3.74E-09 3.77E-09 3.77E-09 3.75E-09 3.70E-09 3.64E-09 3.54E-09 3.43E-09 3.30E-09 3.15E-09 2.99E-09 2.82E-09 2.65E-09 2.49E-09 2.33E-09 2.18E-09 2.05E-09 1.93E-09 1.84E-09 1.78E-09 1.74E-09 + 6.87E-09 6.81E-09 6.72E-09 6.62E-09 6.49E-09 6.35E-09 6.19E-09 6.03E-09 5.87E-09 5.70E-09 5.54E-09 5.40E-09 5.26E-09 5.14E-09 5.05E-09 4.97E-09 4.92E-09 4.89E-09 4.89E-09 4.90E-09 4.93E-09 4.98E-09 5.04E-09 5.10E-09 5.17E-09 5.23E-09 5.29E-09 5.33E-09 5.36E-09 5.37E-09 5.36E-09 5.33E-09 5.27E-09 5.20E-09 5.10E-09 4.98E-09 4.84E-09 4.69E-09 4.53E-09 4.36E-09 4.20E-09 4.03E-09 3.88E-09 3.74E-09 3.62E-09 3.51E-09 3.43E-09 3.37E-09 3.33E-09 3.32E-09 3.33E-09 3.35E-09 3.40E-09 3.45E-09 3.52E-09 3.58E-09 3.65E-09 3.71E-09 3.77E-09 3.81E-09 3.83E-09 3.83E-09 3.81E-09 3.77E-09 3.71E-09 3.62E-09 3.51E-09 3.38E-09 3.24E-09 3.09E-09 2.93E-09 2.77E-09 2.62E-09 2.46E-09 2.32E-09 2.20E-09 2.09E-09 2.01E-09 1.94E-09 1.90E-09 + 6.77E-09 6.71E-09 6.63E-09 6.52E-09 6.41E-09 6.27E-09 6.13E-09 5.97E-09 5.82E-09 5.66E-09 5.51E-09 5.37E-09 5.25E-09 5.14E-09 5.05E-09 4.98E-09 4.93E-09 4.90E-09 4.89E-09 4.91E-09 4.94E-09 4.98E-09 5.04E-09 5.10E-09 5.16E-09 5.22E-09 5.27E-09 5.31E-09 5.34E-09 5.35E-09 5.34E-09 5.31E-09 5.26E-09 5.18E-09 5.09E-09 4.98E-09 4.85E-09 4.71E-09 4.55E-09 4.40E-09 4.24E-09 4.09E-09 3.95E-09 3.81E-09 3.70E-09 3.60E-09 3.52E-09 3.46E-09 3.43E-09 3.41E-09 3.42E-09 3.45E-09 3.49E-09 3.54E-09 3.60E-09 3.67E-09 3.73E-09 3.79E-09 3.84E-09 3.87E-09 3.90E-09 3.90E-09 3.88E-09 3.84E-09 3.78E-09 3.70E-09 3.60E-09 3.48E-09 3.34E-09 3.20E-09 3.05E-09 2.90E-09 2.75E-09 2.61E-09 2.48E-09 2.36E-09 2.26E-09 2.18E-09 2.12E-09 2.08E-09 + 6.66E-09 6.60E-09 6.52E-09 6.43E-09 6.32E-09 6.19E-09 6.05E-09 5.91E-09 5.77E-09 5.62E-09 5.48E-09 5.35E-09 5.23E-09 5.13E-09 5.04E-09 4.98E-09 4.93E-09 4.91E-09 4.90E-09 4.91E-09 4.94E-09 4.98E-09 5.03E-09 5.09E-09 5.15E-09 5.21E-09 5.25E-09 5.29E-09 5.32E-09 5.33E-09 5.32E-09 5.29E-09 5.24E-09 5.17E-09 5.09E-09 4.98E-09 4.86E-09 4.72E-09 4.58E-09 4.44E-09 4.29E-09 4.15E-09 4.01E-09 3.89E-09 3.78E-09 3.69E-09 3.61E-09 3.56E-09 3.53E-09 3.51E-09 3.52E-09 3.54E-09 3.58E-09 3.63E-09 3.69E-09 3.75E-09 3.81E-09 3.87E-09 3.91E-09 3.95E-09 3.97E-09 3.97E-09 3.95E-09 3.91E-09 3.86E-09 3.78E-09 3.69E-09 3.57E-09 3.45E-09 3.32E-09 3.18E-09 3.03E-09 2.89E-09 2.76E-09 2.64E-09 2.53E-09 2.43E-09 2.36E-09 2.30E-09 2.27E-09 + 6.54E-09 6.49E-09 6.42E-09 6.33E-09 6.23E-09 6.11E-09 5.98E-09 5.85E-09 5.71E-09 5.58E-09 5.45E-09 5.32E-09 5.21E-09 5.12E-09 5.04E-09 4.98E-09 4.93E-09 4.91E-09 4.91E-09 4.92E-09 4.94E-09 4.98E-09 5.03E-09 5.08E-09 5.14E-09 5.19E-09 5.24E-09 5.27E-09 5.30E-09 5.31E-09 5.30E-09 5.27E-09 5.23E-09 5.16E-09 5.08E-09 4.98E-09 4.87E-09 4.74E-09 4.61E-09 4.48E-09 4.34E-09 4.21E-09 4.08E-09 3.96E-09 3.86E-09 3.78E-09 3.71E-09 3.66E-09 3.63E-09 3.62E-09 3.62E-09 3.65E-09 3.68E-09 3.73E-09 3.78E-09 3.84E-09 3.89E-09 3.95E-09 3.99E-09 4.02E-09 4.04E-09 4.04E-09 4.03E-09 3.99E-09 3.94E-09 3.87E-09 3.78E-09 3.68E-09 3.56E-09 3.43E-09 3.30E-09 3.17E-09 3.04E-09 2.92E-09 2.80E-09 2.70E-09 2.61E-09 2.54E-09 2.49E-09 2.46E-09 + 6.42E-09 6.37E-09 6.31E-09 6.23E-09 6.13E-09 6.02E-09 5.90E-09 5.78E-09 5.66E-09 5.53E-09 5.41E-09 5.30E-09 5.19E-09 5.11E-09 5.03E-09 4.98E-09 4.94E-09 4.92E-09 4.91E-09 4.92E-09 4.95E-09 4.98E-09 5.03E-09 5.08E-09 5.13E-09 5.18E-09 5.22E-09 5.25E-09 5.28E-09 5.29E-09 5.28E-09 5.25E-09 5.21E-09 5.15E-09 5.08E-09 4.98E-09 4.88E-09 4.77E-09 4.64E-09 4.52E-09 4.39E-09 4.27E-09 4.15E-09 4.04E-09 3.95E-09 3.87E-09 3.81E-09 3.76E-09 3.73E-09 3.72E-09 3.73E-09 3.75E-09 3.78E-09 3.83E-09 3.88E-09 3.93E-09 3.98E-09 4.03E-09 4.07E-09 4.10E-09 4.12E-09 4.12E-09 4.11E-09 4.07E-09 4.02E-09 3.96E-09 3.88E-09 3.78E-09 3.67E-09 3.56E-09 3.44E-09 3.32E-09 3.19E-09 3.08E-09 2.97E-09 2.88E-09 2.80E-09 2.73E-09 2.68E-09 2.65E-09 + 6.30E-09 6.26E-09 6.20E-09 6.12E-09 6.03E-09 5.93E-09 5.83E-09 5.71E-09 5.60E-09 5.48E-09 5.37E-09 5.27E-09 5.17E-09 5.09E-09 5.03E-09 4.97E-09 4.94E-09 4.92E-09 4.92E-09 4.93E-09 4.95E-09 4.98E-09 5.02E-09 5.07E-09 5.12E-09 5.16E-09 5.20E-09 5.23E-09 5.26E-09 5.26E-09 5.26E-09 5.23E-09 5.20E-09 5.14E-09 5.07E-09 4.99E-09 4.89E-09 4.79E-09 4.68E-09 4.56E-09 4.44E-09 4.33E-09 4.22E-09 4.13E-09 4.04E-09 3.97E-09 3.91E-09 3.87E-09 3.84E-09 3.83E-09 3.84E-09 3.86E-09 3.89E-09 3.93E-09 3.97E-09 4.02E-09 4.07E-09 4.12E-09 4.15E-09 4.18E-09 4.20E-09 4.20E-09 4.19E-09 4.16E-09 4.11E-09 4.05E-09 3.98E-09 3.89E-09 3.79E-09 3.69E-09 3.58E-09 3.46E-09 3.35E-09 3.25E-09 3.15E-09 3.06E-09 2.99E-09 2.93E-09 2.88E-09 2.86E-09 + 6.17E-09 6.14E-09 6.08E-09 6.01E-09 5.93E-09 5.84E-09 5.75E-09 5.64E-09 5.54E-09 5.43E-09 5.33E-09 5.24E-09 5.15E-09 5.08E-09 5.02E-09 4.97E-09 4.94E-09 4.92E-09 4.92E-09 4.93E-09 4.95E-09 4.98E-09 5.02E-09 5.06E-09 5.11E-09 5.15E-09 5.18E-09 5.21E-09 5.23E-09 5.24E-09 5.24E-09 5.22E-09 5.18E-09 5.13E-09 5.07E-09 4.99E-09 4.91E-09 4.81E-09 4.71E-09 4.60E-09 4.50E-09 4.40E-09 4.30E-09 4.21E-09 4.13E-09 4.07E-09 4.01E-09 3.98E-09 3.95E-09 3.95E-09 3.95E-09 3.97E-09 4.00E-09 4.03E-09 4.08E-09 4.12E-09 4.16E-09 4.21E-09 4.24E-09 4.27E-09 4.28E-09 4.28E-09 4.27E-09 4.25E-09 4.20E-09 4.15E-09 4.08E-09 4.00E-09 3.91E-09 3.82E-09 3.72E-09 3.61E-09 3.51E-09 3.42E-09 3.33E-09 3.25E-09 3.18E-09 3.13E-09 3.09E-09 3.07E-09 + 6.05E-09 6.01E-09 5.96E-09 5.90E-09 5.83E-09 5.75E-09 5.66E-09 5.57E-09 5.48E-09 5.38E-09 5.29E-09 5.21E-09 5.13E-09 5.07E-09 5.01E-09 4.97E-09 4.94E-09 4.93E-09 4.93E-09 4.94E-09 4.96E-09 4.98E-09 5.02E-09 5.06E-09 5.09E-09 5.13E-09 5.17E-09 5.19E-09 5.21E-09 5.22E-09 5.21E-09 5.20E-09 5.16E-09 5.12E-09 5.06E-09 5.00E-09 4.92E-09 4.83E-09 4.74E-09 4.65E-09 4.55E-09 4.46E-09 4.38E-09 4.30E-09 4.23E-09 4.17E-09 4.12E-09 4.09E-09 4.07E-09 4.06E-09 4.07E-09 4.08E-09 4.11E-09 4.14E-09 4.18E-09 4.22E-09 4.26E-09 4.30E-09 4.33E-09 4.35E-09 4.37E-09 4.37E-09 4.36E-09 4.34E-09 4.30E-09 4.25E-09 4.19E-09 4.12E-09 4.04E-09 3.95E-09 3.86E-09 3.77E-09 3.68E-09 3.59E-09 3.52E-09 3.44E-09 3.38E-09 3.34E-09 3.30E-09 3.28E-09 + 5.92E-09 5.89E-09 5.84E-09 5.79E-09 5.73E-09 5.66E-09 5.58E-09 5.50E-09 5.41E-09 5.33E-09 5.25E-09 5.18E-09 5.11E-09 5.05E-09 5.01E-09 4.97E-09 4.95E-09 4.93E-09 4.93E-09 4.94E-09 4.96E-09 4.98E-09 5.01E-09 5.05E-09 5.08E-09 5.12E-09 5.15E-09 5.17E-09 5.19E-09 5.19E-09 5.19E-09 5.18E-09 5.15E-09 5.11E-09 5.06E-09 5.00E-09 4.93E-09 4.86E-09 4.78E-09 4.69E-09 4.61E-09 4.53E-09 4.45E-09 4.38E-09 4.32E-09 4.27E-09 4.23E-09 4.20E-09 4.18E-09 4.18E-09 4.18E-09 4.20E-09 4.22E-09 4.25E-09 4.29E-09 4.32E-09 4.36E-09 4.39E-09 4.42E-09 4.44E-09 4.45E-09 4.46E-09 4.45E-09 4.43E-09 4.40E-09 4.35E-09 4.30E-09 4.24E-09 4.17E-09 4.09E-09 4.01E-09 3.93E-09 3.85E-09 3.77E-09 3.70E-09 3.64E-09 3.59E-09 3.55E-09 3.52E-09 3.50E-09 + 5.78E-09 5.76E-09 5.72E-09 5.68E-09 5.62E-09 5.56E-09 5.49E-09 5.42E-09 5.35E-09 5.28E-09 5.21E-09 5.15E-09 5.09E-09 5.04E-09 5.00E-09 4.97E-09 4.95E-09 4.94E-09 4.94E-09 4.94E-09 4.96E-09 4.98E-09 5.01E-09 5.04E-09 5.07E-09 5.10E-09 5.13E-09 5.15E-09 5.16E-09 5.17E-09 5.17E-09 5.16E-09 5.13E-09 5.10E-09 5.06E-09 5.01E-09 4.95E-09 4.88E-09 4.81E-09 4.74E-09 4.67E-09 4.60E-09 4.53E-09 4.47E-09 4.42E-09 4.37E-09 4.34E-09 4.31E-09 4.30E-09 4.30E-09 4.30E-09 4.31E-09 4.34E-09 4.36E-09 4.39E-09 4.42E-09 4.46E-09 4.49E-09 4.51E-09 4.53E-09 4.54E-09 4.54E-09 4.54E-09 4.52E-09 4.49E-09 4.46E-09 4.41E-09 4.36E-09 4.30E-09 4.23E-09 4.16E-09 4.09E-09 4.02E-09 3.96E-09 3.90E-09 3.84E-09 3.80E-09 3.76E-09 3.73E-09 3.72E-09 + 5.65E-09 5.63E-09 5.60E-09 5.56E-09 5.51E-09 5.46E-09 5.41E-09 5.35E-09 5.29E-09 5.23E-09 5.17E-09 5.12E-09 5.07E-09 5.03E-09 4.99E-09 4.97E-09 4.95E-09 4.94E-09 4.94E-09 4.95E-09 4.96E-09 4.98E-09 5.01E-09 5.03E-09 5.06E-09 5.09E-09 5.11E-09 5.13E-09 5.14E-09 5.15E-09 5.15E-09 5.14E-09 5.12E-09 5.09E-09 5.05E-09 5.01E-09 4.96E-09 4.91E-09 4.85E-09 4.79E-09 4.73E-09 4.67E-09 4.61E-09 4.56E-09 4.52E-09 4.48E-09 4.45E-09 4.43E-09 4.42E-09 4.42E-09 4.42E-09 4.43E-09 4.45E-09 4.48E-09 4.50E-09 4.53E-09 4.56E-09 4.58E-09 4.61E-09 4.62E-09 4.63E-09 4.64E-09 4.63E-09 4.62E-09 4.59E-09 4.56E-09 4.52E-09 4.48E-09 4.43E-09 4.37E-09 4.32E-09 4.26E-09 4.20E-09 4.14E-09 4.09E-09 4.05E-09 4.01E-09 3.98E-09 3.96E-09 3.94E-09 + 5.51E-09 5.50E-09 5.47E-09 5.44E-09 5.40E-09 5.36E-09 5.32E-09 5.27E-09 5.22E-09 5.17E-09 5.13E-09 5.08E-09 5.04E-09 5.01E-09 4.98E-09 4.96E-09 4.95E-09 4.94E-09 4.94E-09 4.95E-09 4.96E-09 4.98E-09 5.00E-09 5.02E-09 5.05E-09 5.07E-09 5.09E-09 5.11E-09 5.12E-09 5.12E-09 5.12E-09 5.12E-09 5.10E-09 5.08E-09 5.05E-09 5.02E-09 4.98E-09 4.93E-09 4.88E-09 4.84E-09 4.79E-09 4.74E-09 4.70E-09 4.65E-09 4.62E-09 4.59E-09 4.57E-09 4.55E-09 4.54E-09 4.54E-09 4.54E-09 4.55E-09 4.57E-09 4.59E-09 4.61E-09 4.64E-09 4.66E-09 4.68E-09 4.70E-09 4.71E-09 4.72E-09 4.73E-09 4.72E-09 4.71E-09 4.70E-09 4.67E-09 4.64E-09 4.60E-09 4.56E-09 4.52E-09 4.47E-09 4.42E-09 4.38E-09 4.33E-09 4.29E-09 4.25E-09 4.22E-09 4.20E-09 4.18E-09 4.17E-09 + 5.38E-09 5.36E-09 5.35E-09 5.32E-09 5.29E-09 5.26E-09 5.23E-09 5.19E-09 5.16E-09 5.12E-09 5.08E-09 5.05E-09 5.02E-09 5.00E-09 4.98E-09 4.96E-09 4.95E-09 4.95E-09 4.95E-09 4.96E-09 4.97E-09 4.98E-09 5.00E-09 5.02E-09 5.03E-09 5.05E-09 5.07E-09 5.08E-09 5.09E-09 5.10E-09 5.10E-09 5.10E-09 5.08E-09 5.07E-09 5.05E-09 5.02E-09 4.99E-09 4.96E-09 4.92E-09 4.88E-09 4.85E-09 4.81E-09 4.78E-09 4.75E-09 4.72E-09 4.70E-09 4.68E-09 4.67E-09 4.66E-09 4.66E-09 4.67E-09 4.68E-09 4.69E-09 4.71E-09 4.72E-09 4.74E-09 4.76E-09 4.78E-09 4.80E-09 4.81E-09 4.82E-09 4.82E-09 4.82E-09 4.81E-09 4.80E-09 4.78E-09 4.76E-09 4.73E-09 4.70E-09 4.66E-09 4.63E-09 4.59E-09 4.56E-09 4.52E-09 4.49E-09 4.46E-09 4.44E-09 4.42E-09 4.41E-09 4.40E-09 + 5.24E-09 5.23E-09 5.22E-09 5.20E-09 5.18E-09 5.16E-09 5.14E-09 5.11E-09 5.09E-09 5.06E-09 5.04E-09 5.02E-09 5.00E-09 4.98E-09 4.97E-09 4.96E-09 4.95E-09 4.95E-09 4.95E-09 4.96E-09 4.97E-09 4.98E-09 4.99E-09 5.01E-09 5.02E-09 5.04E-09 5.05E-09 5.06E-09 5.07E-09 5.08E-09 5.08E-09 5.07E-09 5.07E-09 5.06E-09 5.04E-09 5.03E-09 5.01E-09 4.98E-09 4.96E-09 4.93E-09 4.91E-09 4.88E-09 4.86E-09 4.84E-09 4.82E-09 4.81E-09 4.79E-09 4.79E-09 4.78E-09 4.79E-09 4.79E-09 4.80E-09 4.81E-09 4.82E-09 4.84E-09 4.85E-09 4.87E-09 4.88E-09 4.89E-09 4.90E-09 4.91E-09 4.91E-09 4.91E-09 4.91E-09 4.90E-09 4.89E-09 4.87E-09 4.86E-09 4.83E-09 4.81E-09 4.79E-09 4.76E-09 4.74E-09 4.71E-09 4.69E-09 4.67E-09 4.66E-09 4.65E-09 4.64E-09 4.63E-09 + 5.10E-09 5.10E-09 5.09E-09 5.08E-09 5.07E-09 5.06E-09 5.05E-09 5.04E-09 5.02E-09 5.01E-09 5.00E-09 4.98E-09 4.97E-09 4.97E-09 4.96E-09 4.95E-09 4.95E-09 4.95E-09 4.96E-09 4.96E-09 4.97E-09 4.98E-09 4.99E-09 5.00E-09 5.01E-09 5.02E-09 5.03E-09 5.04E-09 5.05E-09 5.05E-09 5.05E-09 5.05E-09 5.05E-09 5.05E-09 5.04E-09 5.03E-09 5.02E-09 5.01E-09 5.00E-09 4.98E-09 4.97E-09 4.96E-09 4.94E-09 4.93E-09 4.92E-09 4.92E-09 4.91E-09 4.91E-09 4.91E-09 4.91E-09 4.91E-09 4.92E-09 4.93E-09 4.94E-09 4.95E-09 4.96E-09 4.97E-09 4.98E-09 4.99E-09 5.00E-09 5.00E-09 5.01E-09 5.01E-09 5.01E-09 5.01E-09 5.00E-09 4.99E-09 4.98E-09 4.97E-09 4.96E-09 4.94E-09 4.93E-09 4.92E-09 4.90E-09 4.89E-09 4.88E-09 4.88E-09 4.87E-09 4.87E-09 4.87E-09 + 4.96E-09 4.96E-09 4.96E-09 4.96E-09 4.96E-09 4.96E-09 4.96E-09 4.96E-09 4.96E-09 4.95E-09 4.95E-09 4.95E-09 4.95E-09 4.95E-09 4.95E-09 4.95E-09 4.95E-09 4.96E-09 4.96E-09 4.97E-09 4.97E-09 4.98E-09 4.98E-09 4.99E-09 5.00E-09 5.00E-09 5.01E-09 5.02E-09 5.02E-09 5.03E-09 5.03E-09 5.03E-09 5.04E-09 5.04E-09 5.04E-09 5.04E-09 5.04E-09 5.04E-09 5.03E-09 5.03E-09 5.03E-09 5.03E-09 5.03E-09 5.03E-09 5.02E-09 5.03E-09 5.03E-09 5.03E-09 5.03E-09 5.03E-09 5.04E-09 5.04E-09 5.05E-09 5.06E-09 5.06E-09 5.07E-09 5.08E-09 5.08E-09 5.09E-09 5.09E-09 5.10E-09 5.10E-09 5.11E-09 5.11E-09 5.11E-09 5.11E-09 5.11E-09 5.11E-09 5.11E-09 5.11E-09 5.10E-09 5.10E-09 5.10E-09 5.10E-09 5.10E-09 5.09E-09 5.09E-09 5.09E-09 5.10E-09 5.10E-09 + 4.82E-09 4.83E-09 4.84E-09 4.84E-09 4.85E-09 4.86E-09 4.87E-09 4.88E-09 4.89E-09 4.90E-09 4.91E-09 4.92E-09 4.93E-09 4.94E-09 4.94E-09 4.95E-09 4.96E-09 4.96E-09 4.97E-09 4.97E-09 4.97E-09 4.98E-09 4.98E-09 4.98E-09 4.99E-09 4.99E-09 4.99E-09 4.99E-09 5.00E-09 5.00E-09 5.01E-09 5.01E-09 5.02E-09 5.03E-09 5.03E-09 5.04E-09 5.05E-09 5.06E-09 5.07E-09 5.08E-09 5.09E-09 5.10E-09 5.11E-09 5.12E-09 5.13E-09 5.13E-09 5.14E-09 5.15E-09 5.15E-09 5.16E-09 5.16E-09 5.17E-09 5.17E-09 5.17E-09 5.18E-09 5.18E-09 5.18E-09 5.18E-09 5.18E-09 5.19E-09 5.19E-09 5.20E-09 5.20E-09 5.21E-09 5.21E-09 5.22E-09 5.23E-09 5.24E-09 5.24E-09 5.25E-09 5.26E-09 5.27E-09 5.28E-09 5.29E-09 5.30E-09 5.31E-09 5.31E-09 5.32E-09 5.33E-09 5.33E-09 diff --git a/autotest/disu_util.py b/autotest/disu_util.py new file mode 100644 index 00000000000..8f865f1dad0 --- /dev/null +++ b/autotest/disu_util.py @@ -0,0 +1,96 @@ + +import numpy as np + +def get_disu_kwargs(nlay, nrow, ncol, delr, delc, tp, botm): + def get_nn(k, i, j): + return k * nrow * ncol + i * ncol + j + nodes = nlay * nrow * ncol + iac = np.zeros((nodes), dtype=np.int) + ja = [] + area = np.zeros((nodes), dtype=np.float) + top = np.zeros((nodes), dtype=np.float) + bot = np.zeros((nodes), dtype=np.float) + ihc = [] + cl12 = [] + hwva = [] + for k in range(nlay): + for i in range(nrow): + for j in range(ncol): + # diagonal + n = get_nn(k, i, j) + ja.append(n) + iac[n] += 1 + area[n] = delr[i] * delc[j] + ihc.append(n + 1) + cl12.append(n + 1) + hwva.append(n + 1) + if k == 0: + top[n] = tp + else: + top[n] = botm[k - 1] + bot[n] = botm[k] + # up + if k > 0: + ja.append(get_nn(k - 1, i, j)) + iac[n] += 1 + ihc.append(0) + dz = botm[k - 1] - botm[k] + cl12.append(.5 * dz) + hwva.append(delr[i] * delc[j]) + # back + if i > 0: + ja.append(get_nn(k, i - 1, j)) + iac[n] += 1 + ihc.append(1) + cl12.append(.5 * delc[i]) + hwva.append(delr[j]) + # left + if j > 0: + ja.append(get_nn(k, i, j - 1)) + iac[n] += 1 + ihc.append(1) + cl12.append(.5 * delr[j]) + hwva.append(delc[i]) + # right + if j < ncol - 1: + ja.append(get_nn(k, i, j + 1)) + iac[n] += 1 + ihc.append(1) + cl12.append(.5 * delr[j]) + hwva.append(delc[i]) + # front + if i < nrow - 1: + ja.append(get_nn(k, i + 1, j)) + iac[n] += 1 + ihc.append(1) + cl12.append(.5 * delc[i]) + hwva.append(delr[j]) + # bottom + if k < nlay - 1: + ja.append(get_nn(k + 1, i, j)) + iac[n] += 1 + ihc.append(0) + if k == 0: + dz = tp - botm[k] + else: + dz = botm[k - 1] - botm[k] + cl12.append(.5 * dz) + hwva.append(delr[i] * delc[j]) + ja = np.array(ja, dtype=np.int) + nja = ja.shape[0] + hwva = np.array(hwva, dtype=np.float) + kw = {} + kw['nodes'] = nodes + kw['nja'] = nja + kw['nvert'] = None + kw['top'] = top + kw['bot'] = bot + kw['area'] = area + kw['iac'] = iac + kw['ja'] = ja + kw['ihc'] = ihc + kw['cl12'] = cl12 + kw['hwva'] = hwva + return kw + + diff --git a/autotest/simulation.py b/autotest/simulation.py index 7ec85809e73..87c317f340c 100644 --- a/autotest/simulation.py +++ b/autotest/simulation.py @@ -27,7 +27,8 @@ class Simulation(object): def __init__(self, name, exfunc=None, exe_dict=None, htol=None, - idxsim=None): + idxsim=None, cmp_verbose=True, require_failure=None, + bmifunc=None): delFiles = True for idx, arg in enumerate(sys.argv): if arg.lower() == '--keep': @@ -35,7 +36,7 @@ def __init__(self, name, exfunc=None, exe_dict=None, htol=None, elif arg[2:].lower() in list(targets.target_dict.keys()): key = arg[2:].lower() exe0 = targets.target_dict[key] - exe = os.path.join(os.path.dirname(exe0), sys.argv[idx+1]) + exe = os.path.join(os.path.dirname(exe0), sys.argv[idx + 1]) msg = 'replacing {} executable '.format(key) + \ '"{}" with '.format(targets.target_dict[key]) + \ '"{}".'.format(exe) @@ -57,8 +58,6 @@ def __init__(self, name, exfunc=None, exe_dict=None, htol=None, print(msg) targets.target_dict[key] = exe - - msg = sfmt.format('Initializing test', name) print(msg) self.name = name @@ -66,6 +65,8 @@ def __init__(self, name, exfunc=None, exe_dict=None, htol=None, self.simpath = None self.inpt = None self.outp = None + self.coutp = None + self.bmifunc = bmifunc # set htol for comparisons if htol is None: @@ -75,6 +76,12 @@ def __init__(self, name, exfunc=None, exe_dict=None, htol=None, # set index for multi-simulation comparisons self.idxsim = idxsim + # set compare verbosity + self.cmp_verbose = cmp_verbose + + # set allow failure + self.require_failure = require_failure + sysinfo = platform.system() self.delFiles = delFiles if sysinfo.lower() == 'windows': @@ -95,13 +102,16 @@ def set_model(self, pth): self.simpath = pth - # get MNODFLOW6 output file names + # get MODFLOW 6 output file names fpth = os.path.join(pth, 'mfsim.nam') mf6inp, mf6outp = pymake.get_mf6_files(fpth) self.outp = mf6outp # determine comparison model self.action = pymake.get_mf6_comparison(pth) + if self.action is not None: + if 'mf6' in self.action: + cinp, self.coutp = pymake.get_mf6_files(fpth) def setup(self, src, dst): msg = sfmt.format('Setup test', self.name) @@ -157,7 +167,13 @@ def run(self): print(msg) success = False - assert success + if self.require_failure is None: + assert success + else: + if self.require_failure: + assert success is False + else: + assert success is True self.nam_cmp = None if success: @@ -169,14 +185,22 @@ def run(self): cpth = os.path.join(self.simpath, self.action) key = self.action.lower().replace('.cmp', '') exe = os.path.abspath(targets.target_dict[key]) - npth = pymake.get_namefiles(cpth)[0] - nam = os.path.basename(npth) + if 'mf6' in key or 'libmf6' in key: + nam = None + else: + npth = pymake.get_namefiles(cpth)[0] + nam = os.path.basename(npth) self.nam_cmp = nam try: - success_cmp, buff = flopy.run_model(exe, nam, - model_ws=cpth, - silent=False, - report=True) + if self.bmifunc is None: + success_cmp, buff = flopy.run_model(exe, nam, + model_ws=cpth, + silent=False, + report=True) + else: + success_cmp, buff = self.bmifunc(exe, + self.idxsim, + model_ws=cpth) msg = sfmt.format('Comparison run', self.name + '/' + key) if success: @@ -249,7 +273,17 @@ def compare(self): os.path.basename(pth)) print(txt) else: - files2.append(None) + if self.coutp is not None: + for file2 in self.coutp: + ext = os.path.splitext(file2)[1][1:] + + if ext.lower() in ['hds', 'hed', 'bhd', 'ahd']: + # simulation file + pth = os.path.join(cpth, file2) + files2.append(pth) + + else: + files2.append(None) if self.nam_cmp is None: pth = None @@ -286,9 +320,9 @@ def compare(self): files1=file1, files2=file2, htol=self.htol, - difftol=False, + difftol=True, # Change to true to have list of all nodes exceeding htol - verbose=True, + verbose=self.cmp_verbose, exfile=exfile) msg = sfmt.format('{} comparison {}'.format(extdict[ext], ipos + 1), @@ -324,3 +358,11 @@ def teardown(self): else: print('Retaining test files') return + + +def bmi_return(success, model_ws): + """ + parse libmf6.so and libmf6.dll stdout file + """ + fpth = os.path.join(model_ws, 'mfsim.stdout') + return success, open(fpth).readlines() diff --git a/autotest/targets.py b/autotest/targets.py index c925a1e141d..f9db66e0beb 100644 --- a/autotest/targets.py +++ b/autotest/targets.py @@ -12,9 +12,11 @@ def target_pth(target, pth): return target target_ext = '' +target_so = '.so' sysinfo = platform.system() if sysinfo.lower() == 'windows': target_ext = '.exe' + target_so = '.dll' # paths to executables for previous versions of MODFLOW ebindir = os.path.join(os.path.expanduser('~'), '.local', 'bin') @@ -41,6 +43,11 @@ def target_pth(target, pth): # add MODFLOW 6 to dictionary of valid executable targets target_dict[os.path.basename(target)] = target +# create MODFLOW 6 so/dll target name +tprog = 'libmf6{}'.format(target_so) +ttarg = os.path.join(bindir, tprog) +target_dict['libmf6'] = ttarg + # add MODFLOW 5 to 6 converter to dictionary of valid executable targets tprog = 'mf5to6{}'.format(target_ext) ttarg = os.path.join(bindir, tprog) diff --git a/autotest/test000_setup.py b/autotest/test000_setup.py index 24be96ce32a..23f210f7db0 100644 --- a/autotest/test000_setup.py +++ b/autotest/test000_setup.py @@ -2,25 +2,18 @@ import sys import platform import shutil -import flopy import pymake +os.environ["TRAVIS"] = "1" -# update these for new versions -mf2005dir = 'MF2005.1_12u' -mf2005url = "https://water.usgs.gov/ogw/modflow/MODFLOW-2005_v1.12.00/{}.zip".format(mf2005dir) -mfnwtdir = 'MODFLOW-NWT_1.1.3' -mfnwturl = "https://water.usgs.gov/ogw/modflow-nwt/{0}.zip".format(mfnwtdir) -mfusgdir = 'mfusg.1_4' -mfusgurl = 'https://water.usgs.gov/ogw/mfusg/{0}.zip'.format(mfusgdir) -mflgrdir = 'mflgr.2_0' -mflgrurl = 'https://water.usgs.gov/ogw/modflow-lgr/modflow-lgr-v2.0.0/mflgrv2_0_00.zip' +if 'TRAVIS' in os.environ: + os.environ['PYMAKE_DOUBLE'] = '1' # paths to executables for previous versions of MODFLOW -ebindir = os.path.abspath(os.path.join(os.path.expanduser('~'), '.local', 'bin')) - -fc = 'gfortran' -cc = 'gcc' +ebindir = os.path.abspath( + os.path.join(os.path.expanduser('~'), '.local', 'bin')) +if not os.path.exists(ebindir): + os.makedirs(ebindir) # make sure exe extension is used on windows eext = '' @@ -28,6 +21,17 @@ if sysinfo.lower() == 'windows': eext = '.exe' +download_version = '3.0' +mfexe_pth = 'temp/mfexes' + + +def relpath_fallback(pth): + try: + # throws ValueError on Windows if pth is on a different drive + return os.path.relpath(pth) + except ValueError: + return os.path.abspath(pth) + def create_dir(pth): # remove pth directory if it exists @@ -40,9 +44,10 @@ def create_dir(pth): msg = 'could not create... {}'.format(os.path.abspath(pth)) assert os.path.exists(pth), msg - + return + def test_create_dirs(): pths = [os.path.join('..', 'bin'), os.path.join('temp')] @@ -52,243 +57,135 @@ def test_create_dirs(): return -def set_compiler(): - fct = fc - cct = cc - # parse command line arguments to see if user specified options - # relative to building the target - msg = '' - for idx, arg in enumerate(sys.argv): - if arg.lower() == '--ifort': - if len(msg) > 0: - msg += '\n' - msg += '{} - '.format(arg.lower()) + \ - '{} will be built with ifort.'.format(starget) - fct = 'ifort' - elif arg.lower() == '--icc': - if len(msg) > 0: - msg += '\n' - msg += '{} - '.format(arg.lower()) + \ - '{} will be built with cl.'.format(starget) - cct = 'icc' - elif arg.lower() == '--cl': - if len(msg) > 0: - msg += '\n' - msg += '{} - '.format(arg.lower()) + \ - '{} will be built with cl.'.format(starget) - cct = 'cl' - elif arg.lower() == '--clang': - if len(msg) > 0: - msg += '\n' - msg += '{} - '.format(arg.lower()) + \ - '{} will be built with clang.'.format(starget) - cct = 'clang' - if len(msg) > 0: - print(msg) - - return fct, cct +def getmfexes(pth='.', version='', pltfrm=None): + """ + Get the latest MODFLOW binary executables from a github site + (https://github.com/MODFLOW-USGS/executables) for the specified + operating system and put them in the specified path. -def test_build_modflow(): - starget = 'MODFLOW-2005' + Parameters + ---------- + pth : str + Location to put the executables (default is current working directory) - fct, cct = set_compiler() + version : str + Version of the MODFLOW-USGS/executables release to use. - # set up target - target = os.path.abspath(os.path.join(ebindir, 'mf2005dbl')) - target += eext - - rebuild = rebuild_exe(target, starget) - if not rebuild: - return - - # get current directory - cpth = os.getcwd() - - # create temporary path - dstpth = os.path.join('tempbin') - print('create...{}'.format(dstpth)) - if not os.path.exists(dstpth): - os.makedirs(dstpth) - os.chdir(dstpth) - - # Set dir name - dirname = mf2005dir - srcdir = os.path.join(dirname, 'src') - - # Download the MODFLOW-2005 distribution - url = mf2005url - pymake.download_and_unzip(url) - - # compile code - print('compiling...{}'.format(os.path.relpath(target))) - pymake.main(srcdir, target, fct, cct, makeclean=True, - expedite=False, dryrun=False, double=True, debug=False) - - msg = '{} does not exist.'.format(os.path.relpath(target)) - assert os.path.isfile(target), msg + pltfrm : str + Platform that will run the executables. Valid values include mac, + linux, win32 and win64. If platform is None, then routine will + download the latest appropriate zipfile from the github repository + based on the platform running this script. - # change back to original path - os.chdir(cpth) + """ - # Clean up downloaded directory - print('delete...{}'.format(dstpth)) - if os.path.isdir(dstpth): - shutil.rmtree(dstpth) + # Determine the platform in order to construct the zip file name + if pltfrm is None: + if sys.platform.lower() == 'darwin': + pltfrm = 'mac' + elif sys.platform.lower().startswith('linux'): + pltfrm = 'linux' + elif 'win' in sys.platform.lower(): + is_64bits = sys.maxsize > 2 ** 32 + if is_64bits: + pltfrm = 'win64' + else: + pltfrm = 'win32' + else: + errmsg = ('Could not determine platform' + '. sys.platform is {}'.format(sys.platform)) + raise Exception(errmsg) + else: + assert pltfrm in ['mac', 'linux', 'win32', 'win64'] + zipname = '{}.zip'.format(pltfrm) + + # Determine path for file download and then download and unzip + url = ('https://github.com/MODFLOW-USGS/executables/' + 'releases/download/{}/'.format(version)) + assets = {p: url + p for p in ['mac.zip', 'linux.zip', + 'win32.zip', 'win64.zip']} + download_url = assets[zipname] + pymake.download_and_unzip(download_url, pth, verify=False) return -def test_build_mfnwt(): - starget = 'MODFLOW-NWT' +def test_getmfexes(): + yield getmfexes, mfexe_pth, download_version + return - fct, cct = set_compiler() - # set up target - target = os.path.abspath(os.path.join(ebindir, 'mfnwtdbl')) - target += eext - - rebuild = rebuild_exe(target, starget) - if not rebuild: - return - - # get current directory - cpth = os.getcwd() - - # create temporary path - dstpth = os.path.join('tempbin') - print('create...{}'.format(dstpth)) - if not os.path.exists(dstpth): - os.makedirs(dstpth) - os.chdir(dstpth) - - # Set dir name - dirname = mfnwtdir - srcdir = os.path.join(dirname, 'src') - - # Download the MODFLOW-NWT distribution - url = mfnwturl - pymake.download_and_unzip(url) - - # compile code - print('compiling...{}'.format(os.path.relpath(target))) - pymake.main(srcdir, target, fct, cct, makeclean=True, - expedite=False, dryrun=False, double=True, debug=False) - - msg = '{} does not exist.'.format(os.path.relpath(target)) - assert os.path.isfile(target), msg +def copy_app_in_mfexe(target): + found = False + if os.path.isdir(mfexe_pth): + if target in os.listdir(mfexe_pth): + srcpth = os.path.join(mfexe_pth, target) + dstpth = os.path.join(ebindir, target) + print('copying {} -> {}'.format(srcpth, dstpth)) + shutil.copy(srcpth, dstpth) + found = True - # change back to original path - os.chdir(cpth) + return found - # Clean up downloaded directory - print('delete...{}'.format(dstpth)) - if os.path.isdir(dstpth): - shutil.rmtree(dstpth) +def test_build_modflow(): + found = copy_app_in_mfexe('mf2005dbl' + eext) + if not found: + pymake.build_apps('mf2005') return -def test_build_usg(): - starget = 'MODFLOW-USG' - - fct, cct = set_compiler() +def test_build_mfnwt(): + found = copy_app_in_mfexe('mfnwtdbl' + eext) + if not found: + pymake.build_apps('mfnwt') + return - # set up target - target = os.path.abspath(os.path.join(ebindir, 'mfusgdbl')) - target += eext - - rebuild = rebuild_exe(target, starget) - if not rebuild: - return - - # get current directory - cpth = os.getcwd() - - # create temporary path - dstpth = os.path.join('tempbin') - print('create...{}'.format(dstpth)) - if not os.path.exists(dstpth): - os.makedirs(dstpth) - os.chdir(dstpth) - - # Set dir name - dirname = mfusgdir - srcdir = os.path.join(dirname, 'src') - - # Download the MODFLOW-USG distribution - url = mfusgurl - pymake.download_and_unzip(url) - - # compile code - print('compiling...{}'.format(os.path.relpath(target))) - pymake.main(srcdir, target, fct, cct, makeclean=True, - expedite=False, dryrun=False, double=True, debug=False) - - msg = '{} does not exist.'.format(os.path.relpath(target)) - assert os.path.isfile(target), msg - # change back to original path - os.chdir(cpth) +def test_build_usg(): + found = copy_app_in_mfexe('mfusgdbl' + eext) + if not found: + pymake.build_apps('mfusg') - # Clean up downloaded directory - print('delete...{}'.format(dstpth)) - if os.path.isdir(dstpth): - shutil.rmtree(dstpth) +def test_build_lgr(): + found = copy_app_in_mfexe('mflgrdbl' + eext) + if not found: + pymake.build_apps('mflgr') return -def test_build_lgr(): - starget = 'MODFLOW-LGR' - - fct, cct = set_compiler() +def test_build_modflow6(): + # determine if app should be build + for idx, arg in enumerate(sys.argv): + if arg.lower() == '--nomf6': + txt = 'Command line cancel of MODFLOW 6 build' + print(txt) + return - # set up target - target = os.path.abspath(os.path.join(ebindir, 'mflgrdbl')) + # set source and target paths + srcdir = os.path.join('..', 'src') + target = os.path.join('..', 'bin', 'mf6') target += eext - - rebuild = rebuild_exe(target, starget) - if not rebuild: - return - - # get current directory - cpth = os.getcwd() - - # create temporary path - dstpth = os.path.join('tempbin') - print('create...{}'.format(dstpth)) - if not os.path.exists(dstpth): - os.makedirs(dstpth) - os.chdir(dstpth) - - # Set dir name - dirname = mflgrdir - srcdir = os.path.join(dirname, 'src') - - # Download the MODFLOW-LGR distribution - url = mflgrurl - pymake.download_and_unzip(url) - - # compile code - print('compiling...{}'.format(os.path.relpath(target))) - pymake.main(srcdir, target, fct, cct, makeclean=True, - expedite=False, dryrun=False, double=True, debug=False) - - msg = '{} does not exist.'.format(os.path.relpath(target)) - assert os.path.isfile(target), msg + fc, cc = pymake.set_compiler('mf6') - # change back to original path - os.chdir(cpth) + fflags = None + if fc == 'gfortran': + # some flags to check for errors in the code + # add -Werror for compilation to terminate if errors are found + fflags = ('-Wtabs -Wline-truncation -Wunused-label ' + '-Wunused-variable -pedantic -std=f2008') + #fflags = None - # Clean up downloaded directory - print('delete...{}'.format(dstpth)) - if os.path.isdir(dstpth): - shutil.rmtree(dstpth) + pymake.main(srcdir, target, fc=fc, cc=cc, include_subdirs=True, + fflags=fflags) - return + msg = '{} does not exist.'.format(relpath_fallback(target)) + assert os.path.isfile(target), msg -def test_build_modflow6(): + +def test_build_modflow6_so(): # determine if app should be build for idx, arg in enumerate(sys.argv): if arg.lower() == '--nomf6': @@ -297,14 +194,25 @@ def test_build_modflow6(): return # set source and target paths - srcdir = os.path.join('..', 'src') - target = os.path.join('..', 'bin', 'mf6') + srcdir = os.path.join('..', 'srcbmi') + comdir = os.path.join('..', 'src') + excludefiles = [os.path.join(comdir, 'mf6.f90')] + target = os.path.join('..', 'bin', 'libmf6.so') target += eext - srcdir2 = None + fc, cc = pymake.set_compiler('mf6') + + fflags = None + if fc == 'gfortran': + # some flags to check for errors in the code + # add -Werror for compilation to terminate if errors are found + fflags = ('-Wtabs -Wline-truncation -Wunused-label ' + '-Wunused-variable -pedantic -std=f2008') - build(srcdir, srcdir2, target, 'MODFLOW 6') + pymake.main(srcdir, target, fc=fc, cc=cc, include_subdirs=True, + fflags=fflags, srcdir2=comdir, excludefiles=excludefiles, + sharedobject=True) - msg = '{} does not exist.'.format(os.path.relpath(target)) + msg = '{} does not exist.'.format(relpath_fallback(target)) assert os.path.isfile(target), msg @@ -320,15 +228,15 @@ def test_build_mf5to6(): srcdir = os.path.join('..', 'utils', 'mf5to6', 'src') target = os.path.join('..', 'bin', 'mf5to6') target += eext - srcdir2 = None extrafiles = os.path.join('..', 'utils', 'mf5to6', 'pymake', 'extrafiles.txt') + fc, cc = pymake.set_compiler('mf6') # build modflow 5 to 6 converter - build(srcdir, srcdir2, target, 'MODFLOW 5 to 6 converter', - extrafiles=extrafiles) + pymake.main(srcdir, target, fc=fc, cc=cc, include_subdirs=True, + extrafiles=extrafiles) - msg = '{} does not exist.'.format(os.path.relpath(target)) + msg = '{} does not exist.'.format(relpath_fallback(target)) assert os.path.isfile(target), msg @@ -344,92 +252,33 @@ def test_build_zonebudget(): srcdir = os.path.join('..', 'utils', 'zonebudget', 'src') target = os.path.join('..', 'bin', 'zbud6') target += eext - srcdir2 = None extrafiles = os.path.join('..', 'utils', 'zonebudget', 'pymake', 'extrafiles.txt') + fc, cc = pymake.set_compiler('mf6') - build(srcdir, srcdir2, target, 'ZONEBUDGET for MODFLOW 6', - extrafiles=extrafiles) - - msg = '{} does not exist.'.format(os.path.relpath(target)) - assert os.path.isfile(target), msg - - -def rebuild_exe(target, starget): - rebuild = True - epth = os.path.basename(target) - exe_exists = flopy.which(epth) - if exe_exists is not None: - print('No need to build {}'.format(starget) + - ' since it exists in the current path') - rebuild = False - return rebuild - - -def build(srcdir, srcdir2, target, starget, extrafiles=None): - """ - Build a specified target - """ - debug = False fflags = None + if fc == 'gfortran': + # some flags to check for errors in the code + # add -Werror for compilation to terminate if errors are found + fflags = ('-Wtabs -Wline-truncation -Wunused-label ' + '-Wunused-variable -pedantic -std=f2008') + #fflags = None - fct, cct = set_compiler() - - # parse remaining command line arguments to see if user specified options - # relative to building the target - msg = '' - for idx, arg in enumerate(sys.argv): - if arg.lower() == '--debug': - debug = True - msg += '{} - '.format(arg.lower()) + \ - '{} will be built with debug flags.'.format(starget) - elif arg.lower() == '--fflags': - if len(sys.argv) > idx + 1: - t = sys.argv[idx + 1:] - fflags = '' - for tt in t: - fflags += tt + ' ' - break - if len(msg) > 0: - print(msg) - - # write message to log - txt = 'checking if {} should be built'.format(starget) - print(txt) - # determine if executable should be built - for idx, arg in enumerate(sys.argv): - if arg.lower() == '--nobuild': - print('{} will not be built'.format(starget)) - return - - # make sure exe extension is used on windows - sysinfo = platform.system() - if sysinfo.lower() == 'windows': - filename, fileext = os.path.splitext(target) - if fileext.lower() != '.exe': - target += '.exe' + pymake.main(srcdir, target, fc=fc, cc=cc, extrafiles=extrafiles, + fflags=fflags) - # call main -- note that this form allows main to be called - # from python as a function. - success = pymake.pymake.main(srcdir, target, fct, cct, - include_subdirs=True, - srcdir2=srcdir2, - debug=debug, extrafiles=extrafiles, - fflags=fflags) - - msg = 'Could not build {}'.format(target) - assert success == 0, msg - - return + msg = '{} does not exist.'.format(relpath_fallback(target)) + assert os.path.isfile(target), msg if __name__ == "__main__": test_create_dirs() + getmfexes(pth=mfexe_pth, version=download_version) test_build_modflow() test_build_mfnwt() test_build_usg() test_build_lgr() test_build_modflow6() + test_build_modflow6_so() test_build_mf5to6() test_build_zonebudget() - diff --git a/autotest/test_gwf_auxvars.py b/autotest/test_gwf_auxvars.py new file mode 100644 index 00000000000..8f791fa0454 --- /dev/null +++ b/autotest/test_gwf_auxvars.py @@ -0,0 +1,294 @@ +import os +import sys +import numpy as np + +try: + import pymake +except: + msg = 'Error. Pymake package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install https://github.com/modflowpy/pymake/zipball/master' + raise Exception(msg) + +try: + import flopy +except: + msg = 'Error. FloPy package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install flopy' + raise Exception(msg) + +from framework import testing_framework +from simulation import Simulation + +ex = ['aux01'] +exdirs = [] +for s in ex: + exdirs.append(os.path.join('temp', s)) +auxvar1 = 101. +auxvar2 = 102. + + +def get_model(idx, dir): + + nlay, nrow, ncol = 1, 10, 10 + nper = 3 + perlen = [1., 1., 1.] + nstp = [10, 10, 10] + tsmult = [1., 1., 1.] + + lenx = 300. + delr = delc = lenx / float(nrow) + strt = 100. + + nouter, ninner = 100, 300 + hclose, rclose, relax = 1e-9, 1e-3, 0.97 + + tdis_rc = [] + for i in range(nper): + tdis_rc.append((perlen[i], nstp[i], tsmult[i])) + + name = ex[idx] + + # build MODFLOW 6 files + ws = dir + sim = flopy.mf6.MFSimulation(sim_name=name, version='mf6', + exe_name='mf6', + sim_ws=ws) + # create tdis package + tdis = flopy.mf6.ModflowTdis(sim, time_units='DAYS', + nper=nper, perioddata=tdis_rc) + + # create gwf model + gwf = flopy.mf6.ModflowGwf(sim, modelname=name) + + # create iterative model solution and register the gwf model with it + ims = flopy.mf6.ModflowIms(sim, print_option='SUMMARY', + outer_hclose=hclose, + outer_maximum=nouter, + under_relaxation='DBD', + inner_maximum=ninner, + inner_hclose=hclose, rcloserecord=rclose, + linear_acceleration='BICGSTAB', + scaling_method='NONE', + reordering_method='NONE', + relaxation_factor=relax) + sim.register_ims_package(ims, [gwf.name]) + + dis = flopy.mf6.ModflowGwfdis(gwf, nlay=nlay, nrow=nrow, ncol=ncol, + delr=delr, delc=delc, + top=90., botm=0.) + + # initial conditions + ic = flopy.mf6.ModflowGwfic(gwf, strt=strt) + + # node property flow + npf = flopy.mf6.ModflowGwfnpf(gwf, save_flows=True, + icelltype=1, + k=1.0, + k33=0.01) + # storage + sto = flopy.mf6.ModflowGwfsto(gwf, save_flows=True, + iconvert=1, + ss=0., sy=0.1, + steady_state={0: False}, + transient={0: True}) + + # chd files + chdlist0 = [] + chdlist0.append([(0, 0, 0), 100.]) + chdlist0.append([(0, nrow-1, ncol-1), 95.]) + + chdspdict = {0: chdlist0} + chd = flopy.mf6.ModflowGwfchd(gwf, + stress_period_data=chdspdict, + save_flows=False, + filename='{}.chd'.format(name)) + + # MAW + wellbottom = 50. + wellrecarray = [[0, 0.1, wellbottom, 100., 'THIEM', 1, auxvar1, auxvar2]] + wellconnectionsrecarray = [[0, 0, (0, 5, 5), 100., wellbottom, 1., 0.1]] + wellperiodrecarray = [[0, 'rate', -0.1]] + maw = flopy.mf6.ModflowGwfmaw(gwf, filename='{}.maw'.format(name), + print_input=True, print_head=True, + print_flows=True, save_flows=True, + budget_filerecord='aux01.maw.bud', + packagedata=wellrecarray, + auxiliary=['aux1', 'aux2'], + connectiondata=wellconnectionsrecarray, + perioddata=wellperiodrecarray) + #maw.remove() + + # [] [] + packagedata = [[0, (0, 5, ncol-2), delr, 10., 0.001, 98., 1., 1., 0.3, 1, 1.0, 0, auxvar1, auxvar2], + [1, (0, 5, ncol-1), delr, 10., 0.001, 97., 1., 1., 0.3, 1, 1.0, 0, auxvar1, auxvar2]] + connectiondata = [[0, -1], + [1, 0]] + sfr = flopy.mf6.ModflowGwfsfr(gwf, + print_input=True, print_stage=True, + print_flows=True, save_flows=True, + budget_filerecord='aux01.sfr.bud', + unit_conversion=128390.00, + nreaches=len(packagedata), + packagedata=packagedata, + auxiliary=['aux1', 'aux2'], + connectiondata=connectiondata) + #sfr.remove() + + # [] [] + packagedata = [[0, 100., 1, auxvar1, auxvar2, 'lake1'], + [1, 100., 1, auxvar1, auxvar2, 'lake2']] + # + connectiondata = [[0, 0, (0, 1, 1), 'vertical', 'none', 0., 0., 0., 0.], + [1, 0, (0, 2, 2), 'vertical', 'none', 0., 0., 0., 0.]] + lak = flopy.mf6.ModflowGwflak(gwf, + boundnames=True, + surfdep=1., + print_input=True, print_stage=True, + print_flows=True, save_flows=True, + budget_filerecord='aux01.lak.bud', + nlakes=len(packagedata), + packagedata=packagedata, + auxiliary=['aux1', 'aux2'], + connectiondata=connectiondata) + #lak.remove() + + # [] + packagedata = [[0, (0, nrow - 1, 5), 1, -1, .1, .01, .01, .1, .01, 3.5, 'uz1'], + [1, (0, nrow - 1, 6), 1, -1, .1, .01, .01, .1, .01, 3.5, 'uz1'], + [2, (0, nrow - 1, 7), 1, -1, .1, .01, .01, .1, .01, 3.5, 'uz1'], + [3, (0, nrow - 1, 8), 1, -1, .1, .01, .01, .1, .01, 3.5, 'uz1']] + # [] + perioddata = [] + for p in packagedata: + perioddata.append((p[0], 0.001, 0., 1., 0., 0., 0., 0., auxvar1, auxvar2)) + uzf = flopy.mf6.ModflowGwfuzf(gwf, + boundnames=True, + print_input=True, + print_flows=True, save_flows=True, + budget_filerecord='aux01.uzf.bud', + nuzfcells=len(packagedata), + ntrailwaves=15, + nwavesets=40, + packagedata=packagedata, + auxiliary=['aux1', 'aux2'], + perioddata=perioddata) + + # output control + oc = flopy.mf6.ModflowGwfoc(gwf, + budget_filerecord='{}.cbc'.format(name), + head_filerecord='{}.hds'.format(name), + headprintrecord=[ + ('COLUMNS', 10, 'WIDTH', 15, + 'DIGITS', 6, 'GENERAL')], + saverecord=[('HEAD', 'ALL'), + ('BUDGET', 'ALL')], + printrecord=[('HEAD', 'ALL'), + ('BUDGET', 'ALL')], + filename='{}.oc'.format(name)) + + return sim + + +def build_models(): + for idx, dir in enumerate(exdirs): + sim = get_model(idx, dir) + sim.write_simulation() + return + + +def eval_model(sim): + print('evaluating model...') + + # maw budget aux variables + fpth = os.path.join(sim.simpath, 'aux01.maw.bud') + bobj = flopy.utils.CellBudgetFile(fpth, precision='double') + records = bobj.get_data(text='auxiliary') + for r in records: + assert np.allclose(r['AUX1'], auxvar1) + assert np.allclose(r['AUX2'], auxvar2) + + # sfr budget aux variables + fpth = os.path.join(sim.simpath, 'aux01.sfr.bud') + bobj = flopy.utils.CellBudgetFile(fpth, precision='double') + records = bobj.get_data(text='auxiliary') + for r in records: + assert np.allclose(r['AUX1'], auxvar1) + assert np.allclose(r['AUX2'], auxvar2) + + # lak budget aux variables + fpth = os.path.join(sim.simpath, 'aux01.maw.bud') + bobj = flopy.utils.CellBudgetFile(fpth, precision='double') + records = bobj.get_data(text='auxiliary') + for r in records: + assert np.allclose(r['AUX1'], auxvar1) + assert np.allclose(r['AUX2'], auxvar2) + + # uzf budget aux variables + fpth = os.path.join(sim.simpath, 'aux01.uzf.bud') + bobj = flopy.utils.CellBudgetFile(fpth, precision='double') + records = bobj.get_data(text='auxiliary') + for r in records: + assert np.allclose(r['AUX1'], auxvar1) + assert np.allclose(r['AUX2'], auxvar2) + + # gwf budget maw aux variables + fpth = os.path.join(sim.simpath, 'aux01.cbc') + bobj = flopy.utils.CellBudgetFile(fpth, precision='double') + records = bobj.get_data(text='maw') + for r in records: + assert np.allclose(r['AUX1'], auxvar1) + assert np.allclose(r['AUX2'], auxvar2) + records = bobj.get_data(text='sfr') + for r in records: + assert np.allclose(r['AUX1'], auxvar1) + assert np.allclose(r['AUX2'], auxvar2) + records = bobj.get_data(text='lak') + for r in records: + assert np.allclose(r['AUX1'], auxvar1) + assert np.allclose(r['AUX2'], auxvar2) + records = bobj.get_data(text='uzf') + for r in records: + assert np.allclose(r['AUX1'], auxvar1) + assert np.allclose(r['AUX2'], auxvar2) + + return + + +# - No need to change any code below +def test_mf6model(): + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + yield test.run_mf6, Simulation(dir, exfunc=eval_model, idxsim=idx) + + return + + +def main(): + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + sim = Simulation(dir, exfunc=eval_model, idxsim=idx) + test.run_mf6(sim) + + return + + +if __name__ == "__main__": + # print message + print('standalone run of {}'.format(os.path.basename(__file__))) + + # run main routine + main() diff --git a/autotest/test_gwf_csub_dbgeo01.py b/autotest/test_gwf_csub_dbgeo01.py new file mode 100644 index 00000000000..cbbb72979c3 --- /dev/null +++ b/autotest/test_gwf_csub_dbgeo01.py @@ -0,0 +1,341 @@ +import os +import numpy as np + +try: + import flopy +except: + msg = 'Error. FloPy package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install flopy' + raise Exception(msg) + +from framework import testing_framework +from simulation import Simulation + +ex = ['csub_dbgeo01a'] +exdirs = [] +for s in ex: + exdirs.append(os.path.join('temp', s)) +ddir = 'data' + +ndcell = [19] +strt = [0.] +chdh = [0] +gso = [True] +bso = [True] +# sstate = [None, True] + +# run all examples on Travis +# travis = [True for idx in range(len(exdirs))] +# the delay bed problems only run on the development version of MODFLOW-2005 +# set travis to True when version 1.13.0 is released +travis = [False for idx in range(len(exdirs))] + +# set replace_exe to None to use default executable +replace_exe = {'mf2005': 'mf2005devdbl'} + +# comparison data +compdataa = [0.6829965295, 1.3552260620, 2.0163615680, 2.6662194730, + 3.3047615550, 3.9320942150, 4.5484650870, 5.1542570520, + 5.7499797990, 6.3362591640, 6.9138245770, 7.4834950010, + 8.0461637950, 8.6027829980, 9.1543475090, 9.7018796520, + 10.2464145700, 10.7889868300, 11.3306186100, 11.8723096200, + 12.4150289800, 12.9597090600, 13.5072412800, 14.0584737000, + 14.6142102900, 15.1752116300, 15.7421966800, 16.3158455400, + 16.8968027900, 17.4856812200, 18.0830657300, 18.6895172900, + 19.3055766500, 19.9317679500, 20.5686019500, 21.2165789800, + 21.8761915600, 22.5479266700, 23.2322678200, 23.9296967200, + 24.6406948800, 25.3657448400, 26.1053314000, 26.8599425100, + 27.6300702200, 28.4162113200, 29.2188679600, 30.0385480600, + 30.8757655600, 31.7310404400, 32.6048985000, 33.4978707400, + 34.4104923500, 35.3433011400, 36.2968353000, 37.2716304000, + 38.2682154600, 39.2871078800, 40.3288072900, 41.3937880000, + 42.4824901100, 43.5953091600, 44.7325843800, 45.8945855500, + 47.0814986400, 48.2934103700, 49.5302919900, 50.7919824900, + 52.0781717600, 53.3883838800, 54.7219611100, 56.0780489100, + 57.4555824900, 58.8532751700, 60.2696090000, 61.7028279600, + 63.1509339500, 64.6116859300, 66.0826023000, 67.5609666300, + 69.0438370300, 70.5280589700, 72.0102819100, 73.4869793800, + 74.9544728300, 76.4089589400, 77.8465405400, 79.2632606700, + 80.6551399000, 82.0182164100, 83.3485884600, 84.6424588900, + 85.8961809100, 87.1063045100, 88.2696228000, 89.3832170600, + 90.4444998100, 91.4512546100, 92.4016715000, 93.2943770700] + +compdata = {0: compdataa} + +# static model data +# spatial discretization +nlay, nrow, ncol = 1, 1, 3 +delr, delc = 1., 1. +top = 0. +bots = [-100.] +botm = [top] + bots + +# temporal discretization +nper = 1 +perlen = [1000. for i in range(nper)] +nstp = [100 for i in range(nper)] +tsmult = [1.05 for i in range(nper)] +steady = [False for i in range(nper)] +tdis_rc = [] +for idx in range(nper): + tdis_rc.append((perlen[idx], nstp[idx], tsmult[idx])) + +hnoflo = 1e30 +hdry = -1e30 + +# idomain data +ib = 1 + +# npf and sto data +hk = 1e6 +laytyp = [1] +ss = 0. +sy = 0.2 + +# solver data +nouter, ninner = 50, 100 +hclose, rclose, relax = 1e-6, 1e-6, 0.97 + +# sub data +cc = 100. +cr = 1. +void = 0.82 +theta = void / (1. + void) +kv = 0.025 +sgm = 1.7 +sgs = 2.2 +ini_stress = 1.0 +thick = 1. + + +# calculate geostatic and effective stress +def calc_stress(sgm0, sgs0, h, bt): + geo = [] + for k in range(nlay): + top = bt[k] + bot = bt[k + 1] + ht = h + if ht > top: + gs = (top - bot) * sgs0 + elif ht < bot: + gs = (top - bot) * sgm0 + else: + gs = ((top - ht) * sgm0) + ((ht - bot) * sgs0) + geo.append(gs) + # calculate total geostatic stress at bottom of layer + for k in range(1, nlay): + geo[k] += geo[k - 1] + # calculate effective stress at the bottom of the layer + es = [] + for k in range(nlay): + es.append(geo[k] - (h - bt[k + 1])) + return geo, es + + +def get_model(idx, dir): + c6 = [] + for j in range(0, ncol, 2): + c6.append([(0, 0, j), chdh[idx]]) + cd6 = {0: c6} + + geo, es = calc_stress(sgm, sgs, strt[idx], botm) + sub6 = [[0, (0, 0, 1), 'delay', -1., thick, + 1., cc, cr, theta, kv, 1.]] + + name = ex[idx] + + # build MODFLOW 6 files + ws = dir + sim = flopy.mf6.MFSimulation(sim_name=name, version='mf6', + exe_name='mf6', + sim_ws=ws) + # create tdis package + tdis = flopy.mf6.ModflowTdis(sim, time_units='DAYS', + nper=nper, perioddata=tdis_rc) + + # create gwf model + gwf = flopy.mf6.ModflowGwf(sim, modelname=name) + + # create iterative model solution and register the gwf model with it + ims = flopy.mf6.ModflowIms(sim, print_option='SUMMARY', + outer_hclose=hclose, + outer_maximum=nouter, + under_relaxation='NONE', + inner_maximum=ninner, + inner_hclose=hclose, rcloserecord=rclose, + linear_acceleration='CG', + scaling_method='NONE', + reordering_method='NONE', + relaxation_factor=relax) + sim.register_ims_package(ims, [gwf.name]) + + dis = flopy.mf6.ModflowGwfdis(gwf, nlay=nlay, nrow=nrow, ncol=ncol, + delr=delr, delc=delc, + top=top, botm=bots, + filename='{}.dis'.format(name)) + + # initial conditions + ic = flopy.mf6.ModflowGwfic(gwf, strt=strt[idx], + filename='{}.ic'.format(name)) + + # node property flow + npf = flopy.mf6.ModflowGwfnpf(gwf, save_flows=False, + icelltype=laytyp, + k=hk, + k33=hk) + # storage + sto = flopy.mf6.ModflowGwfsto(gwf, save_flows=False, iconvert=laytyp, + ss=ss, sy=sy, + storagecoefficient=True, + transient={0: True}) + + # chd files + chd = flopy.mf6.modflow.mfgwfchd.ModflowGwfchd(gwf, + maxbound=len(c6), + stress_period_data=cd6, + save_flows=False) + + # csub files + opth = '{}.csub.obs'.format(name) + ibcsv = '{}.ib.strain.csv'.format(name) + skcsv = '{}.sk.strain.csv'.format(name) + csub = flopy.mf6.ModflowGwfcsub(gwf, + print_input=True, + ndelaycells=ndcell[idx], + strainib_filerecord=ibcsv, + straincg_filerecord=skcsv, + effective_stress_lag=True, + # compression_indices=True, + ninterbeds=1, + sgs=sgs, sgm=sgm, packagedata=sub6, + beta=0., cg_ske_cr=0.) + orecarray = {} + orecarray['csub_obs.csv'] = [('tcomp', 'interbed-compaction', (0, 0, 1)), + ('gs', 'gstress-cell', (0, 0, 1)), + ('es', 'estress-cell', (0, 0, 1)), + ('pcs', 'delay-preconstress', (0, 0)), + ('sk', 'sk', (0, 0, 1))] + csub_obs_package = csub.obs.initialize(filename=opth, digits=10, + print_input=True, + continuous=orecarray) + + # output control + oc = flopy.mf6.ModflowGwfoc(gwf, + budget_filerecord='{}.cbc'.format(name), + head_filerecord='{}.hds'.format(name), + headprintrecord=[ + ('COLUMNS', 10, 'WIDTH', 15, + 'DIGITS', 6, 'GENERAL')], + saverecord=[('HEAD', 'ALL')], + printrecord=[('HEAD', 'LAST'), + ('BUDGET', 'ALL')]) + + mc = None + + return sim, mc + + +def eval_sub(sim): + print('evaluating subsidence...') + + # MODFLOW 6 total compaction results + fpth = os.path.join(sim.simpath, 'csub_obs.csv') + try: + tc = np.genfromtxt(fpth, names=True, delimiter=',') + except: + assert False, 'could not load data from "{}"'.format(fpth) + + # set comparison data + tc0 = compdata[sim.idxsim] + + # calculate maximum absolute error + diff = tc['TCOMP'] - tc0[:] + diffmax = np.abs(diff).max() + dtol = 1e-6 + msg = 'maximum absolute total-compaction difference ({}) '.format(diffmax) + + # write summary + fpth = os.path.join(sim.simpath, + '{}.comp.cmp.out'.format(os.path.basename(sim.name))) + f = open(fpth, 'w') + line = '{:>15s}'.format('TOTIM') + line += ' {:>15s}'.format('CSUB') + line += ' {:>15s}'.format('MF') + line += ' {:>15s}'.format('DIFF') + f.write(line + '\n') + for i in range(diff.shape[0]): + line = '{:15g}'.format(tc0[i]) + line += ' {:15g}'.format(tc['TCOMP'][i]) + line += ' {:15g}'.format(tc0[i]) + line += ' {:15g}'.format(diff[i]) + f.write(line + '\n') + f.close() + + if diffmax > dtol: + sim.success = False + msg += 'exceeds {}'.format(dtol) + assert diffmax < dtol, msg + else: + sim.success = True + print(' ' + msg) + + return + + +# - No need to change any code below +def build_models(): + for idx, dir in enumerate(exdirs): + sim, mc = get_model(idx, dir) + sim.write_simulation() + if mc is not None: + mc.write_input() + return + + +def test_mf6model(): + # determine if running on Travis + is_travis = 'TRAVIS' in os.environ + r_exe = None + if not is_travis: + if replace_exe is not None: + r_exe = replace_exe + + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + if is_travis and not travis[idx]: + continue + yield test.run_mf6, Simulation(dir, exfunc=eval_sub, + exe_dict=r_exe, idxsim=idx) + + return + + +def main(): + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + sim = Simulation(dir, exfunc=eval_sub, exe_dict=replace_exe, + idxsim=idx) + test.run_mf6(sim) + return + + +# use python testmf6_csub_sub01.py --mf2005 mf2005devdbl +if __name__ == "__main__": + # print message + print('standalone run of {}'.format(os.path.basename(__file__))) + + # run main routine + main() diff --git a/autotest/test_gwf_csub_inelastic.py b/autotest/test_gwf_csub_inelastic.py new file mode 100644 index 00000000000..0f1db60a2e5 --- /dev/null +++ b/autotest/test_gwf_csub_inelastic.py @@ -0,0 +1,297 @@ +import os +import numpy as np + +try: + import pymake +except: + msg = 'Error. Pymake package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install https://github.com/modflowpy/pymake/zipball/master' + raise Exception(msg) + +try: + import flopy +except: + msg = 'Error. FloPy package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install flopy' + raise Exception(msg) + +from framework import testing_framework +from simulation import Simulation + +paktest = 'csub' +budtol = 1e-2 + +ex = ['csub_de01a'] +exdirs = [] +for s in ex: + exdirs.append(os.path.join('temp', s)) +ddir = 'data' + +updatemat = [None, True] +# run all examples on Travis +travis = [True for idx in range(len(exdirs))] + +# set replace_exe to None to use default executable +replace_exe = None + +# static model data +# spatial discretization +nlay, nrow, ncol = 2, 1, 3 +shape3d = (nlay, nrow, ncol) +size3d = nlay * nrow * ncol +delr, delc = 1., 1. +top = 100. +botm = [2., 0.] + +# temporal discretization +nper = 1 +tdis_rc = [(200., 5000, 1.)] + +strt6 = 99.4 + +hk = 1e6 +laytyp = [1] +ss = 0. +sy = 0. + +nouter, ninner = 1000, 300 +hclose, rclose, relax = 1e-9, 1e-4, 0.97 + +ib = 1 + +chd_ts = [(0., 99.4), (55.9140, 80.), (90.3227, 30.), (145.1615, 98.), + (200., 20.), (1000., 20.)] +c6 = [[(0, 0, j), 'CHD'] for j in range(0, ncol, 2)] +cd6 = {0: c6} + +# sub data +cc = 0.20 +cr = 0.01 +void = 0.5 +theta = void / (1. + void) +kv = -999. +sgm = 1 +sgs = 1. +ini_stress = 20. +thick = [1.] + +sub6 = [[0, (1, 0, 1), 'nodelay', ini_stress, thick[0], + 1., cc, cr, theta, kv, ini_stress]] + + +def build_mf6(idx, ws, update=None): + name = ex[idx] + sim = flopy.mf6.MFSimulation(sim_name=name, version='mf6', + exe_name='mf6', + sim_ws=ws) + # create tdis package + tdis = flopy.mf6.ModflowTdis(sim, time_units='DAYS', + nper=nper, perioddata=tdis_rc) + + # create gwf model + gwf = flopy.mf6.ModflowGwf(sim, modelname=name) + + # create iterative model solution and register the gwf model with it + ims = flopy.mf6.ModflowIms(sim, print_option='SUMMARY', + outer_hclose=hclose, + outer_maximum=nouter, + under_relaxation='NONE', + inner_maximum=ninner, + inner_hclose=hclose, rcloserecord=rclose, + linear_acceleration='CG', + scaling_method='NONE', + reordering_method='NONE', + relaxation_factor=relax) + sim.register_ims_package(ims, [gwf.name]) + + dis = flopy.mf6.ModflowGwfdis(gwf, nlay=nlay, nrow=nrow, ncol=ncol, + delr=delr, delc=delc, + top=top, botm=botm, + filename='{}.dis'.format(name)) + + # initial conditions + ic = flopy.mf6.ModflowGwfic(gwf, strt=strt6, + filename='{}.ic'.format(name)) + + # node property flow + npf = flopy.mf6.ModflowGwfnpf(gwf, save_flows=False, + icelltype=laytyp, + k=hk, + k33=hk) + # storage + sto = flopy.mf6.ModflowGwfsto(gwf, save_flows=False, iconvert=laytyp, + ss=0., sy=sy, + transient={0: True}) + + # chd files + chd = flopy.mf6.modflow.mfgwfchd.ModflowGwfchd(gwf, + maxbound=len(c6), + stress_period_data=cd6, + save_flows=False) + # initialize time series + chnam = '{}.ch.ts'.format(name) + chd.ts.initialize(filename=chnam, timeseries=chd_ts, + time_series_namerecord=['CHD'], + interpolation_methodrecord=['linear']) + + # csub files + opth = '{}.csub.obs'.format(name) + csub = flopy.mf6.ModflowGwfcsub(gwf, + print_input=True, + update_material_properties=update, + save_flows=True, + ninterbeds=1, + beta=0., + cg_ske_cr=0., + sgm=sgm, + sgs=sgs, + packagedata=sub6) + orecarray = {} + orecarray['csub_obs.csv'] = [('es', 'estress-cell', (1, 0, 1)), + ('theta', 'theta', (0,)), + ('comp', 'interbed-compaction', (0,)), + ('pcs', 'preconstress-cell', (1, 0, 1)), + ('sk', 'sk', (0,)), + ('ske', 'ske', (0,)),] + csub_obs_package = csub.obs.initialize(filename=opth, digits=10, + print_input=True, + continuous=orecarray) + + # output control + oc = flopy.mf6.ModflowGwfoc(gwf, + budget_filerecord='{}.cbc'.format(name), + head_filerecord='{}.hds'.format(name), + headprintrecord=[ + ('COLUMNS', 10, 'WIDTH', 15, + 'DIGITS', 6, 'GENERAL')], + saverecord=[('HEAD', 'LAST')], + printrecord=[('BUDGET', 'ALL')]) + return sim + + +def get_model(idx, dir): + name = ex[idx] + ws = dir + + # build MODFLOW 6 files + sim = build_mf6(idx, ws) + + ws = os.path.join(dir, 'mf6') + mc = build_mf6(idx, ws, update=True) + + return sim, mc + + +def calc_comp2void(comp): + b0 = thick[0] + e0 = void + return e0 - comp * (1. + e0) / b0 + + +def calc_void(theta): + return theta / (1. - theta) + + +def eval_void(sim): + print('evaluating void ratio...') + + fpth = os.path.join(sim.simpath, 'csub_obs.csv') + cd = np.genfromtxt(fpth, delimiter=',', names=True) + + fpth = os.path.join(sim.simpath, 'mf6', 'csub_obs.csv') + cd2 = np.genfromtxt(fpth, delimiter=',', names=True) + + v = calc_comp2void(cd['COMP']) + v2 = calc_void(cd2['THETA']) + + # calculate maximum absolute error + diff = v - v2 + diffmax = np.abs(diff).max() + dtol = 0.002 + msg = 'maximum absolute void ratio difference ({}) '.format(diffmax) + + # write summary + fpth = os.path.join(sim.simpath, + '{}.comp.cmp.out'.format(os.path.basename(sim.name))) + f = open(fpth, 'w') + line = '{:>15s}'.format('TOTIM') + line += ' {:>15s}'.format('VOID') + line += ' {:>15s}'.format('MF') + line += ' {:>15s}'.format('DIFF') + f.write(line + '\n') + for i in range(diff.shape[0]): + line = '{:15g}'.format(cd['time'][i]) + line += ' {:15g}'.format(v[i]) + line += ' {:15g}'.format(v[i]) + line += ' {:15g}'.format(diff[i]) + f.write(line + '\n') + f.close() + + if diffmax > dtol: + sim.success = False + msg += 'exceeds {}'.format(dtol) + assert diffmax < dtol, msg + else: + sim.success = True + print(' ' + msg) + + return + + +# - No need to change any code below +def build_models(): + for idx, dir in enumerate(exdirs): + sim, mc = get_model(idx, dir) + sim.write_simulation() + if mc is not None: + mc.write_simulation() + return + + +def test_mf6model(): + # determine if running on Travis + is_travis = 'TRAVIS' in os.environ + r_exe = None + if not is_travis: + if replace_exe is not None: + r_exe = replace_exe + + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + if is_travis and not travis[idx]: + continue + yield test.run_mf6, Simulation(dir, exfunc=eval_void, + idxsim=idx) + + return + + +def main(): + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + sim = Simulation(dir, exfunc=eval_void, + idxsim=idx) + test.run_mf6(sim) + return + + +if __name__ == "__main__": + # print message + print('standalone run of {}'.format(os.path.basename(__file__))) + + # run main routine + main() diff --git a/autotest/test_gwf_csub_sk01.py b/autotest/test_gwf_csub_sk01.py new file mode 100644 index 00000000000..90769993206 --- /dev/null +++ b/autotest/test_gwf_csub_sk01.py @@ -0,0 +1,538 @@ +import os +import numpy as np + +try: + import pymake +except: + msg = 'Error. Pymake package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install https://github.com/modflowpy/pymake/zipball/master' + raise Exception(msg) + +try: + import flopy +except: + msg = 'Error. FloPy package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install flopy' + raise Exception(msg) + +from framework import testing_framework +from simulation import Simulation + +ex = ['csub_sk01a', 'csub_sk01b', 'csub_sk01c'] +exdirs = [] +for s in ex: + exdirs.append(os.path.join('temp', s)) +cvopt = [None, None, None] +constantcv = [True, True, True] +ndelaybeds = [0, 0, 0] + +cmppths = ['mf2005', 'mfnwt', 'mfnwt'] +tops = [0., 0., 150.] +newtons = [False, True, True] + +ddir = 'data' + +## run all examples on Travis +# travis = [False for idx in range(len(exdirs))] +travis = [True, True, True] + +# set replace_exe to None to use default executable +replace_exe = None + +htol = [None, None, 0.3] +dtol = 1e-3 +budtol = 0.01 + +bud_lst = ['CSUB-CGELASTIC_IN', 'CSUB-CGELASTIC_OUT', + 'CSUB-WATERCOMP_IN', 'CSUB-WATERCOMP_OUT'] + +# static model data +nlay, nrow, ncol = 3, 10, 10 +nper = 31 +perlen = [1.] + [365.2500000 for i in range(nper - 1)] +nstp = [1] + [6 for i in range(nper - 1)] +tsmult = [1.0] + [1.3 for i in range(nper - 1)] +steady = [True] + [False for i in range(nper - 1)] +delr, delc = 1000., 2000. +top = 0. +botm = [-100, -150., -350.] +zthick = [top - botm[0], + botm[0] - botm[1], + botm[1] - botm[2]] +strt = 100. +hnoflo = 1e30 +hdry = -1e30 + +# calculate hk +hk1fact = 1. / zthick[1] +hk1 = np.ones((nrow, ncol), dtype=np.float) * 0.5 * hk1fact +hk1[0, :] = 1000. * hk1fact +hk1[-1, :] = 1000. * hk1fact +hk1[:, 0] = 1000. * hk1fact +hk1[:, -1] = 1000. * hk1fact +hk = [20., hk1, 5.] + +# calculate vka +vka = [1e6, 7.5e-5, 1e6] + +# set rest of npf variables +laytyp = [1, 0, 0] +laytypu = [4, 0, 0] +sy = 0. # [0.1, 0., 0.] + +nouter, ninner = 500, 300 +hclose, rclose, relax = 1e-9, 1e-6, 1. + +tdis_rc = [] +for idx in range(nper): + tdis_rc.append((perlen[idx], nstp[idx], tsmult[idx])) + +# all cells are active +ib = 1 + +# chd data +c = [] +c6 = [] +ccol = [3, 4, 5, 6] +for j in ccol: + c.append([0, nrow - 1, j, strt, strt]) + c6.append([(0, nrow - 1, j), strt]) +cd = {0: c} +cd6 = {0: c6} +maxchd = len(cd[0]) + +# pumping well data +wr = [0, 0, 0, 0, 1, 1, 2, 2, 3, 3] +wc = [0, 1, 8, 9, 0, 9, 0, 9, 0, 0] +wrp = [2, 2, 3, 3] +wcp = [5, 6, 5, 6] +wq = [-14000., -8000., -5000., -3000.] +d = [] +d6 = [] +for r, c, q in zip(wrp, wcp, wq): + d.append([2, r, c, q]) + d6.append([(2, r, c), q]) +wd = {1: d} +wd6 = {1: d6} +maxwel = len(wd[1]) + +# recharge data +q = 3000. / (delr * delc) +v = np.zeros((nrow, ncol), dtype=np.float) +for r, c in zip(wr, wc): + v[r, c] = q +rech = {0: v} + +# static ibc and sub data +sgm = 0. +sgs = 0. +omega = 1.0 +void = 0.82 +theta = void / (1. + void) +sw = 4.65120000e-10 * 9806.65000000 * theta + +# no delay bed data +nndb = 3 +lnd = [0, 1, 2] +hc = [botm[-1] for k in range(nlay)] +thicknd0 = [zthick[0], zthick[1], zthick[2]] +ccnd0 = [6e-6, 3e-6, 6e-6] +crnd0 = [6e-6, 3e-6, 6e-6] +sfv = [] +sfe = [] +for k in range(nlay): + sfv.append(ccnd0[k] * thicknd0[k]) + sfe.append(crnd0[k] * thicknd0[k]) + +# sub output data +ds15 = [0, 0, 0, 2052, 0, 0, 0, 0, 0, 0, 0, 0] +ds16 = [0, nper - 1, 0, nstp[-1] - 1, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1] + + +# SUB package problem 3 +def get_model(idx, dir): + name = ex[idx] + newton = newtons[idx] + + maxibc = 0 + + # build MODFLOW 6 files + ws = dir + sim = flopy.mf6.MFSimulation(sim_name=name, version='mf6', + exe_name='mf6', + sim_ws=ws) + # create tdis package + tdis = flopy.mf6.ModflowTdis(sim, time_units='DAYS', + nper=nper, perioddata=tdis_rc) + + # create gwf model + newtonoptions = None + imsla = 'CG' + if newton: + newtonoptions = '' + imsla = 'BICGSTAB' + gwf = flopy.mf6.ModflowGwf(sim, modelname=name, + newtonoptions=newtonoptions) + + # create iterative model solution and register the gwf model with it + ims = flopy.mf6.ModflowIms(sim, print_option='SUMMARY', + outer_hclose=hclose, + outer_maximum=nouter, + under_relaxation='NONE', + inner_maximum=ninner, + inner_hclose=hclose, rcloserecord=rclose, + linear_acceleration=imsla, + scaling_method='NONE', + reordering_method='NONE', + relaxation_factor=relax) + sim.register_ims_package(ims, [gwf.name]) + + dis = flopy.mf6.ModflowGwfdis(gwf, nlay=nlay, nrow=nrow, ncol=ncol, + delr=delr, delc=delc, + top=tops[idx], botm=botm, + filename='{}.dis'.format(name)) + + # initial conditions + ic = flopy.mf6.ModflowGwfic(gwf, strt=strt, + filename='{}.ic'.format(name)) + + # node property flow + npf = flopy.mf6.ModflowGwfnpf(gwf, save_flows=False, + # dev_modflowusg_upstream_weighted_saturation=True, + icelltype=laytyp, + cvoptions=cvopt[idx], + k=hk, + k33=vka) + # storage + sto = flopy.mf6.ModflowGwfsto(gwf, save_flows=False, iconvert=laytyp, + ss=0., sy=sy, + storagecoefficient=True, + steady_state={0: True}, + transient={1: True}) + + # recharge + rch = flopy.mf6.ModflowGwfrcha(gwf, readasarrays=True, recharge=rech) + + # wel file + wel = flopy.mf6.ModflowGwfwel(gwf, print_input=True, print_flows=True, + maxbound=maxwel, + stress_period_data=wd6, + save_flows=False) + + # chd files + chd = flopy.mf6.modflow.mfgwfchd.ModflowGwfchd(gwf, + maxbound=maxchd, + stress_period_data=cd6, + save_flows=False) + # csub files + opth = '{}.csub.obs'.format(name) + csub = flopy.mf6.ModflowGwfcsub(gwf, head_based=True, + save_flows=True, + ninterbeds=0, + cg_theta=theta, + cg_ske_cr=crnd0, + packagedata=None) + obspos = [(0, 4, 4), (1, 4, 4), (2, 4, 4)] + obstype = ['compaction-cell', 'csub-cell'] + obstag = ['tcomp', 'csub'] + obsarr = [] + for iobs, cobs in enumerate(obstype): + for jobs, otup in enumerate(obspos): + otag = '{}{}'.format(obstag[iobs], jobs + 1) + obsarr.append((otag, cobs, otup)) + + obsarr2 = [] + obstype2 = ['csub', 'inelastic-csub', 'elastic-csub', 'sk', 'ske', + 'thickness', 'theta', 'interbed-compaction', + 'inelastic-compaction', 'elastic-compaction', + 'delay-flowtop', 'delay-flowbot'] + iobs = 0 + for cobs in obstype2: + iobs += 1 + otag = 'obs{:03d}'.format(iobs) + obsarr2.append((otag, cobs, (0,))) + + obstype3 = ['delay-preconstress', 'delay-head', 'delay-gstress', + 'delay-estress', 'delay-compaction', 'delay-thickness', + 'delay-theta'] + for cobs in obstype3: + iobs += 1 + otag = 'obs{:03d}'.format(iobs) + obsarr2.append((otag, cobs, (0,), (0,))) + + obsarr3 = [] + obstype4 = ['gstress-cell', 'estress-cell', 'thickness-cell', + 'coarse-csub', 'wcomp-csub-cell', 'coarse-compaction', + 'coarse-theta', 'coarse-thickness', 'csub-cell', + 'ske-cell', 'sk-cell', 'theta-cell', 'compaction-cell'] + for cobs in obstype4: + iobs += 1 + otag = 'obs{:03d}'.format(iobs) + obsarr3.append((otag, cobs, obspos[-1])) + + orecarray = {} + orecarray['csub_obs.csv'] = obsarr + orecarray['interbed_obs.csv'] = obsarr2 + orecarray['coarse_cell_obs.csv'] = obsarr3 + + csub_obs_package = csub.obs.initialize(filename=opth, digits=10, + print_input=True, + continuous=orecarray) + + # output control + oc = flopy.mf6.ModflowGwfoc(gwf, + budget_filerecord='{}.cbc'.format(name), + head_filerecord='{}.hds'.format(name), + headprintrecord=[ + ('COLUMNS', 10, 'WIDTH', 15, + 'DIGITS', 6, 'GENERAL')], + saverecord=[('HEAD', 'ALL'), + ('BUDGET', 'ALL')], + printrecord=[('HEAD', 'LAST'), + ('BUDGET', 'ALL')]) + + # build MODFLOW-2005 files + cpth = cmppths[idx] + ws = os.path.join(dir, cpth) + mc = flopy.modflow.Modflow(name, model_ws=ws, version=cpth) + dis = flopy.modflow.ModflowDis(mc, nlay=nlay, nrow=nrow, ncol=ncol, + nper=nper, perlen=perlen, nstp=nstp, + tsmult=tsmult, steady=steady, delr=delr, + delc=delc, top=tops[idx], botm=botm) + bas = flopy.modflow.ModflowBas(mc, ibound=ib, strt=strt, hnoflo=hnoflo, + stoper=0.01) + if newton: + if cpth == 'mfnwt': + upw = flopy.modflow.ModflowUpw(mc, laytyp=laytyp, + hk=hk, vka=vka, + ss=sw, sy=sy, + hdry=hdry) + else: + lpf = flopy.modflow.ModflowLpf(mc, laytyp=laytypu, + hk=hk, vka=vka, + ss=sw, sy=sy, + hdry=hdry, constantcv=True) + else: + lpf = flopy.modflow.ModflowLpf(mc, laytyp=laytyp, hk=hk, vka=vka, + ss=sw, sy=sy, + constantcv=constantcv[idx], + storagecoefficient=False, + hdry=hdry) + chd = flopy.modflow.ModflowChd(mc, stress_period_data=cd) + rch = flopy.modflow.ModflowRch(mc, rech=rech) + wel = flopy.modflow.ModflowWel(mc, stress_period_data=wd) + sub = flopy.modflow.ModflowSub(mc, ndb=0, nndb=nndb, ipakcb=1001, + isuboc=1, ln=lnd, + hc=hc, sfe=sfe, sfv=sfv, + ids15=ds15, ids16=ds16) + oc = flopy.modflow.ModflowOc(mc, stress_period_data=None, + save_every=1, + save_types=['save head', 'save budget', + 'print budget']) + if newton: + if cpth == 'mfnwt': + fluxtol = (float(nlay * nrow * ncol) - 4.) * rclose + nwt = flopy.modflow.ModflowNwt(mc, + headtol=hclose, fluxtol=fluxtol, + maxiterout=nouter, linmeth=2, + maxitinner=ninner, + unitnumber=132, + options='SPECIFIED', + backflag=0, idroptol=0) + else: + sms = flopy.modflow.ModflowSms(mc, hclose=hclose, + hiclose=hclose, + mxiter=nouter, iter1=ninner, + rclosepcgu=rclose, + relaxpcgu=relax, + unitnumber=132) + else: + pcg = flopy.modflow.ModflowPcg(mc, mxiter=nouter, iter1=ninner, + hclose=hclose, rclose=rclose, + relax=relax) + + return sim, mc + + +def eval_comp(sim): + print('evaluating compaction...') + + # MODFLOW 6 total compaction results + fpth = os.path.join(sim.simpath, 'csub_obs.csv') + try: + tc = np.genfromtxt(fpth, names=True, delimiter=',') + except: + assert False, 'could not load data from "{}"'.format(fpth) + + # MODFLOW-2005 total compaction results + cpth = cmppths[sim.idxsim] + fn = '{}.total_comp.hds'.format(os.path.basename(sim.name)) + fpth = os.path.join(sim.simpath, cpth, fn) + try: + sobj = flopy.utils.HeadFile(fpth, text='LAYER COMPACTION') + tc0 = sobj.get_ts((2, 4, 4)) + except: + assert False, 'could not load data from "{}"'.format(fpth) + + # calculate maximum absolute error + diff = tc['TCOMP3'] - tc0[:, 1] + diffmax = np.abs(diff).max() + msg = 'maximum absolute total-compaction difference ({}) '.format(diffmax) + + # write summary + fpth = os.path.join(sim.simpath, + '{}.comp.cmp.out'.format(os.path.basename(sim.name))) + f = open(fpth, 'w') + for i in range(diff.shape[0]): + line = '{:10.2g}'.format(tc0[i, 0]) + line += '{:10.2g}'.format(tc['TCOMP3'][i]) + line += '{:10.2g}'.format(tc0[i, 1]) + line += '{:10.2g}'.format(diff[i]) + f.write(line + '\n') + f.close() + + if diffmax > dtol: + sim.success = False + msg += 'exceeds {}'.format(dtol) + assert diffmax < dtol, msg + else: + sim.success = True + print(' ' + msg) + + # get results from listing file + fpth = os.path.join(sim.simpath, + '{}.lst'.format(os.path.basename(sim.name))) + budl = flopy.utils.Mf6ListBudget(fpth) + names = list(bud_lst) + d0 = budl.get_budget(names=names)[0] + dtype = d0.dtype + nbud = d0.shape[0] + + # get results from cbc file + cbc_bud = ['CSUB-CGELASTIC', 'CSUB-WATERCOMP'] + d = np.recarray(nbud, dtype=dtype) + for key in bud_lst: + d[key] = 0. + fpth = os.path.join(sim.simpath, + '{}.cbc'.format(os.path.basename(sim.name))) + cobj = flopy.utils.CellBudgetFile(fpth, precision='double') + kk = cobj.get_kstpkper() + times = cobj.get_times() + for idx, (k, t) in enumerate(zip(kk, times)): + for text in cbc_bud: + qin = 0. + qout = 0. + v = cobj.get_data(kstpkper=k, text=text)[0] + for kk in range(v.shape[0]): + for ii in range(v.shape[1]): + for jj in range(v.shape[2]): + vv = v[kk, ii, jj] + if vv < 0.: + qout -= vv + else: + qin += vv + d['totim'][idx] = t + d['time_step'][idx] = k[0] + d['stress_period'] = k[1] + key = '{}_IN'.format(text) + d[key][idx] = qin + key = '{}_OUT'.format(text) + d[key][idx] = qout + + diff = np.zeros((nbud, len(bud_lst)), dtype=np.float) + for idx, key in enumerate(bud_lst): + diff[:, idx] = d0[key] - d[key] + diffmax = np.abs(diff).max() + msg = 'maximum absolute total-budget difference ({}) '.format(diffmax) + + # write summary + fpth = os.path.join(sim.simpath, + '{}.bud.cmp.out'.format(os.path.basename(sim.name))) + f = open(fpth, 'w') + for i in range(diff.shape[0]): + if i == 0: + line = '{:>10s}'.format('TIME') + for idx, key in enumerate(bud_lst): + line += '{:>25s}'.format(key + '_LST') + line += '{:>25s}'.format(key + '_CBC') + line += '{:>25s}'.format(key + '_DIF') + f.write(line + '\n') + line = '{:10g}'.format(d['totim'][i]) + for idx, key in enumerate(bud_lst): + line += '{:25g}'.format(d0[key][i]) + line += '{:25g}'.format(d[key][i]) + line += '{:25g}'.format(diff[i, idx]) + f.write(line + '\n') + f.close() + + if diffmax > budtol: + sim.success = False + msg += 'exceeds {}'.format(dtol) + assert diffmax < dtol, msg + else: + sim.success = True + print(' ' + msg) + + return + + +# - No need to change any code below +def build_models(): + for idx, dir in enumerate(exdirs): + sim, mc = get_model(idx, dir) + sim.write_simulation() + if mc is not None: + mc.write_input() + return + + +def test_mf6model(): + # determine if running on Travis + is_travis = 'TRAVIS' in os.environ + r_exe = None + if not is_travis: + if replace_exe is not None: + r_exe = replace_exe + + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + if is_travis and not travis[idx]: + continue + yield test.run_mf6, Simulation(dir, exfunc=eval_comp, + exe_dict=r_exe, + htol=htol[idx], + idxsim=idx) + + return + + +def main(): + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + sim = Simulation(dir, exfunc=eval_comp, + exe_dict=replace_exe, htol=htol[idx], idxsim=idx) + test.run_mf6(sim) + + return + + +if __name__ == "__main__": + # print message + print('standalone run of {}'.format(os.path.basename(__file__))) + + # run main routine + main() diff --git a/autotest/test_gwf_csub_sk02.py b/autotest/test_gwf_csub_sk02.py new file mode 100644 index 00000000000..e9772462366 --- /dev/null +++ b/autotest/test_gwf_csub_sk02.py @@ -0,0 +1,514 @@ +import os +import numpy as np + +try: + import pymake +except: + msg = 'Error. Pymake package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install https://github.com/modflowpy/pymake/zipball/master' + raise Exception(msg) + +try: + import flopy +except: + msg = 'Error. FloPy package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install flopy' + raise Exception(msg) + +from framework import testing_framework +from simulation import Simulation + +ex = ['csub_sk02a', 'csub_sk02b', 'csub_sk02c', 'csub_sk02d'] +exdirs = [] +for s in ex: + exdirs.append(os.path.join('temp', s)) +constantcv = [True for idx in range(len(exdirs))] + +cmppths = ['mfnwt' for idx in range(len(exdirs))] +tops = [150. for idx in range(len(exdirs))] +newtons = [True for idx in range(len(exdirs))] +ump = [None, None, True, True] +iump = [0, 0, 1, 1] +eslag = [True for idx in range(len(exdirs))] +icrcc = [0, 1, 0, 1] + +ddir = 'data' + +## run all examples on Travis +travis = [True for idx in range(len(exdirs))] + +# set replace_exe to None to use default executable +replace_exe = None + +htol = [None for idx in range(len(exdirs))] +dtol = 1e-3 + +bud_lst = ['CSUB-CGELASTIC_IN', 'CSUB-CGELASTIC_OUT', + 'CSUB-WATERCOMP_IN', 'CSUB-WATERCOMP_OUT'] + +# static model data +nlay, nrow, ncol = 3, 10, 10 +nper = 31 +perlen = [1.] + [365.2500000 for i in range(nper - 1)] +nstp = [1] + [6 for i in range(nper - 1)] +tsmult = [1.0] + [1.3 for i in range(nper - 1)] +steady = [True] + [False for i in range(nper - 1)] +delr, delc = 1000., 2000. +top = 150. +botm = [-100, -150., -350.] +zthick = [top - botm[0], + botm[0] - botm[1], + botm[1] - botm[2]] +strt = 100. +hnoflo = 1e30 +hdry = -1e30 + +# calculate hk +hk1fact = 1. / zthick[1] +hk1 = np.ones((nrow, ncol), dtype=np.float) * 0.5 * hk1fact +hk1[0, :] = 1000. * hk1fact +hk1[-1, :] = 1000. * hk1fact +hk1[:, 0] = 1000. * hk1fact +hk1[:, -1] = 1000. * hk1fact +hk = [20., hk1, 5.] + +# calculate vka +vka = [1e6, 7.5e-5, 1e6] + +# set rest of npf variables +laytyp = [1, 0, 0] +laytypu = [4, 0, 0] +sy = [0.1, 0., 0.] + +nouter, ninner = 500, 300 +hclose, rclose, relax = 1e-9, 1e-6, 1. + +tdis_rc = [] +for idx in range(nper): + tdis_rc.append((perlen[idx], nstp[idx], tsmult[idx])) + +# all cells are active +ib = 1 + +# chd data +c = [] +c6 = [] +ccol = [3, 4, 5, 6] +for j in ccol: + c.append([0, nrow - 1, j, strt, strt]) + c6.append([(0, nrow - 1, j), strt]) +cd = {0: c} +cd6 = {0: c6} +maxchd = len(cd[0]) + +# pumping well data +wr = [0, 0, 0, 0, 1, 1, 2, 2, 3, 3] +wc = [0, 1, 8, 9, 0, 9, 0, 9, 0, 0] +wrp = [2, 2, 3, 3] +wcp = [5, 6, 5, 6] +wq = [-14000., -8000., -5000., -3000.] +d = [] +d6 = [] +for r, c, q in zip(wrp, wcp, wq): + d.append([2, r, c, q]) + d6.append([(2, r, c), q]) +wd = {1: d} +wd6 = {1: d6} +maxwel = len(wd[1]) + +# recharge data +q = 3000. / (delr * delc) +v = np.zeros((nrow, ncol), dtype=np.float) +for r, c in zip(wr, wc): + v[r, c] = q +rech = {0: v} + +# static ibc and sub data +sgm = 1.7 +sgs = 2.0 +void = 0.82 +ini_stress = 15.0 +theta = void / (1. + void) +sw = 4.65120000e-10 * 9806.65000000 * theta + +# no delay bed data +lnd = [0, 1, 2] +thicknd0 = [zthick[0], zthick[1], zthick[2]] +cr = [0.01, 0.005, 0.01] +sske = [6e-6, 3e-6, 6e-6] + +# subwt output data +ds16 = [0, 0, 0, 2052, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] +ds17 = [0, 10000, 0, 10000, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] + + +# SUB package problem 3 +def get_model(idx, dir): + name = ex[idx] + newton = newtons[idx] + + # build MODFLOW 6 files + ws = dir + sim = flopy.mf6.MFSimulation(sim_name=name, version='mf6', + exe_name='mf6', + sim_ws=ws) + # create tdis package + tdis = flopy.mf6.ModflowTdis(sim, time_units='DAYS', + nper=nper, perioddata=tdis_rc) + + # create gwf model + newtonoptions = None + imsla = 'CG' + if newton: + newtonoptions = '' + imsla = 'BICGSTAB' + if icrcc[idx] == 0: + sc = cr + compression_indices = True + else: + sc = sske + compression_indices = None + # water compressibility cannot be compared for cases where the material + # properties are adjusted since the porosity changes in mf6 + if iump[idx] == 0: + beta = 4.6512e-10 + wc = sw + else: + beta = 0. + wc = 0. + + gwf = flopy.mf6.ModflowGwf(sim, modelname=name, + newtonoptions=newtonoptions) + + # create iterative model solution and register the gwf model with it + ims = flopy.mf6.ModflowIms(sim, print_option='SUMMARY', + outer_hclose=hclose, + outer_maximum=nouter, + under_relaxation='NONE', + inner_maximum=ninner, + inner_hclose=hclose, rcloserecord=rclose, + linear_acceleration=imsla, + scaling_method='NONE', + reordering_method='NONE', + relaxation_factor=relax) + sim.register_ims_package(ims, [gwf.name]) + + dis = flopy.mf6.ModflowGwfdis(gwf, nlay=nlay, nrow=nrow, ncol=ncol, + delr=delr, delc=delc, + top=top, botm=botm, + filename='{}.dis'.format(name)) + + # initial conditions + ic = flopy.mf6.ModflowGwfic(gwf, strt=strt, + filename='{}.ic'.format(name)) + + # node property flow + npf = flopy.mf6.ModflowGwfnpf(gwf, save_flows=False, + # dev_modflowusg_upstream_weighted_saturation=True, + icelltype=laytyp, + k=hk, + k33=vka) + # storage + sto = flopy.mf6.ModflowGwfsto(gwf, save_flows=False, iconvert=laytyp, + ss=0., sy=sy, + storagecoefficient=True, + steady_state={0: True}, + transient={1: True}) + + # recharge + rch = flopy.mf6.ModflowGwfrcha(gwf, readasarrays=True, recharge=rech) + + # wel file + wel = flopy.mf6.ModflowGwfwel(gwf, print_input=True, print_flows=True, + maxbound=maxwel, + stress_period_data=wd6, + save_flows=False) + + # chd files + chd = flopy.mf6.modflow.mfgwfchd.ModflowGwfchd(gwf, + maxbound=maxchd, + stress_period_data=cd6, + save_flows=False) + # ibc files + opth = '{}.csub.obs'.format(name) + csub = flopy.mf6.ModflowGwfcsub(gwf, + update_material_properties=ump[idx], + effective_stress_lag=eslag[idx], + save_flows=True, + ninterbeds=0, + compression_indices=compression_indices, + sgm=sgm, + sgs=sgs, + cg_theta=theta, + cg_ske_cr=sc, + beta=beta, + packagedata=None) + orecarray = {} + orecarray['csub_obs.csv'] = [('tcomp1', 'compaction-cell', (0, 4, 4)), + ('tcomp2', 'compaction-cell', (1, 4, 4)), + ('tcomp3', 'compaction-cell', (2, 4, 4))] + csub_obs_package = csub.obs.initialize(filename=opth, digits=10, + print_input=True, + continuous=orecarray) + + # output control + oc = flopy.mf6.ModflowGwfoc(gwf, + budget_filerecord='{}.cbc'.format(name), + head_filerecord='{}.hds'.format(name), + headprintrecord=[ + ('COLUMNS', 10, 'WIDTH', 15, + 'DIGITS', 6, 'GENERAL')], + saverecord=[('HEAD', 'LAST'), + ('BUDGET', 'LAST')], + printrecord=[('HEAD', 'LAST'), + ('BUDGET', 'LAST')]) + + # build MODFLOW-2005 files + cpth = cmppths[idx] + ws = os.path.join(dir, cpth) + mc = flopy.modflow.Modflow(name, model_ws=ws, version=cpth) + dis = flopy.modflow.ModflowDis(mc, nlay=nlay, nrow=nrow, ncol=ncol, + nper=nper, perlen=perlen, nstp=nstp, + tsmult=tsmult, steady=steady, delr=delr, + delc=delc, top=top, botm=botm) + bas = flopy.modflow.ModflowBas(mc, ibound=ib, strt=strt, hnoflo=hnoflo, + stoper=0.01) + if newton: + if cpth == 'mfnwt': + upw = flopy.modflow.ModflowUpw(mc, laytyp=laytyp, + hk=hk, vka=vka, + ss=wc, sy=sy, + hdry=hdry) + else: + lpf = flopy.modflow.ModflowLpf(mc, laytyp=laytypu, + hk=hk, vka=vka, + ss=wc, sy=sy, + hdry=hdry, constantcv=True) + else: + lpf = flopy.modflow.ModflowLpf(mc, laytyp=laytyp, hk=hk, vka=vka, + ss=sw, sy=sy, + constantcv=constantcv[idx], + storagecoefficient=False, + hdry=hdry) + chd = flopy.modflow.ModflowChd(mc, stress_period_data=cd) + rch = flopy.modflow.ModflowRch(mc, rech=rech) + wel = flopy.modflow.ModflowWel(mc, stress_period_data=wd) + swt = flopy.modflow.ModflowSwt(mc, iswtoc=1, nsystm=3, + ithk=1, ivoid=iump[idx], + icrcc=icrcc[idx], + istpcs=1, lnwt=lnd, + cc=sc, cr=sc, + sse=sc, ssv=sc, + thick=thicknd0, + void=void, pcsoff=ini_stress, sgs=sgs, + gl0=0., ids16=ds16, ids17=ds17) + oc = flopy.modflow.ModflowOc(mc, stress_period_data=None) + if newton: + if cpth == 'mfnwt': + fluxtol = (float(nlay * nrow * ncol) - 4.) * rclose + nwt = flopy.modflow.ModflowNwt(mc, + headtol=hclose, fluxtol=fluxtol, + maxiterout=nouter, linmeth=2, + maxitinner=ninner, + unitnumber=132, + options='SPECIFIED', + backflag=0, idroptol=0) + else: + sms = flopy.modflow.ModflowSms(mc, hclose=hclose, + hiclose=hclose, + mxiter=nouter, iter1=ninner, + rclosepcgu=rclose, + relaxpcgu=relax, + unitnumber=132) + else: + pcg = flopy.modflow.ModflowPcg(mc, mxiter=nouter, iter1=ninner, + hclose=hclose, rclose=rclose, + relax=relax) + + return sim, mc + + +def eval_comp(sim): + print('evaluating compaction...') + + # MODFLOW 6 total compaction results + fpth = os.path.join(sim.simpath, 'csub_obs.csv') + try: + tc = np.genfromtxt(fpth, names=True, delimiter=',') + except: + assert False, 'could not load data from "{}"'.format(fpth) + + # MODFLOW-2005 total compaction results + cpth = cmppths[sim.idxsim] + fn = '{}.swt_total_comp.hds'.format(os.path.basename(sim.name)) + fpth = os.path.join(sim.simpath, cpth, fn) + try: + sobj = flopy.utils.HeadFile(fpth, text='LAYER COMPACTION') + tc0 = sobj.get_ts((2, 4, 4)) + except: + assert False, 'could not load data from "{}"'.format(fpth) + + # calculate maximum absolute error + diff = tc['TCOMP3'] - tc0[:, 1] + diffmax = np.abs(diff).max() + msg = 'maximum absolute total-compaction difference ({}) '.format(diffmax) + + # write summary + fpth = os.path.join(sim.simpath, + '{}.comp.cmp.out'.format(os.path.basename(sim.name))) + f = open(fpth, 'w') + for i in range(diff.shape[0]): + line = '{:10.2g}'.format(tc0[i, 0]) + line += '{:10.2g}'.format(tc['TCOMP3'][i]) + line += '{:10.2g}'.format(tc0[i, 1]) + line += '{:10.2g}'.format(diff[i]) + f.write(line + '\n') + f.close() + + if diffmax > dtol: + sim.success = False + msg += 'exceeds {}'.format(dtol) + assert diffmax < dtol, msg + else: + sim.success = True + print(' ' + msg) + + # get results from listing file + fpth = os.path.join(sim.simpath, + '{}.lst'.format(os.path.basename(sim.name))) + budl = flopy.utils.Mf6ListBudget(fpth) + names = list(bud_lst) + d0 = budl.get_budget(names=names)[0] + dtype = d0.dtype + nbud = d0.shape[0] + + # get results from cbc file + cbc_bud = ['CSUB-CGELASTIC', 'CSUB-WATERCOMP'] + d = np.recarray(nbud, dtype=dtype) + for key in bud_lst: + d[key] = 0. + fpth = os.path.join(sim.simpath, + '{}.cbc'.format(os.path.basename(sim.name))) + cobj = flopy.utils.CellBudgetFile(fpth, precision='double') + kk = cobj.get_kstpkper() + times = cobj.get_times() + for idx, (k, t) in enumerate(zip(kk, times)): + for text in cbc_bud: + qin = 0. + qout = 0. + v = cobj.get_data(kstpkper=k, text=text)[0] + for kk in range(v.shape[0]): + for ii in range(v.shape[1]): + for jj in range(v.shape[2]): + vv = v[kk, ii, jj] + if vv < 0.: + qout -= vv + else: + qin += vv + d['totim'][idx] = t + d['time_step'][idx] = k[0] + d['stress_period'] = k[1] + key = '{}_IN'.format(text) + d[key][idx] = qin + key = '{}_OUT'.format(text) + d[key][idx] = qout + + diff = np.zeros((nbud, len(bud_lst)), dtype=np.float) + for idx, key in enumerate(bud_lst): + diff[:, idx] = d0[key] - d[key] + diffmax = np.abs(diff).max() + msg = 'maximum absolute total-budget difference ({}) '.format(diffmax) + + # write summary + fpth = os.path.join(sim.simpath, + '{}.bud.cmp.out'.format(os.path.basename(sim.name))) + f = open(fpth, 'w') + for i in range(diff.shape[0]): + if i == 0: + line = '{:>10s}'.format('TIME') + for idx, key in enumerate(bud_lst): + line += '{:>25s}'.format(key + '_LST') + line += '{:>25s}'.format(key + '_CBC') + line += '{:>25s}'.format(key + '_DIF') + f.write(line + '\n') + line = '{:10g}'.format(d['totim'][i]) + for idx, key in enumerate(bud_lst): + line += '{:25g}'.format(d0[key][i]) + line += '{:25g}'.format(d[key][i]) + line += '{:25g}'.format(diff[i, idx]) + f.write(line + '\n') + f.close() + + if diffmax > dtol: + sim.success = False + msg += 'exceeds {}'.format(dtol) + assert diffmax < dtol, msg + else: + sim.success = True + print(' ' + msg) + + return + + +# - No need to change any code below +def build_models(): + for idx, dir in enumerate(exdirs): + sim, mc = get_model(idx, dir) + sim.write_simulation() + if mc is not None: + mc.write_input() + return + + +def test_mf6model(): + # determine if running on Travis + is_travis = 'TRAVIS' in os.environ + r_exe = None + if not is_travis: + if replace_exe is not None: + r_exe = replace_exe + + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + if is_travis and not travis[idx]: + continue + yield test.run_mf6, Simulation(dir, exfunc=eval_comp, + exe_dict=r_exe, + htol=htol[idx], + idxsim=idx) + + return + + +def main(): + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + sim = Simulation(dir, exfunc=eval_comp, + exe_dict=replace_exe, htol=htol[idx], idxsim=idx) + test.run_mf6(sim) + + return + + +if __name__ == "__main__": + # print message + print('standalone run of {}'.format(os.path.basename(__file__))) + + # run main routine + main() diff --git a/autotest/test_gwf_csub_sk03.py b/autotest/test_gwf_csub_sk03.py new file mode 100644 index 00000000000..5fab80282c6 --- /dev/null +++ b/autotest/test_gwf_csub_sk03.py @@ -0,0 +1,591 @@ +import os +import numpy as np +import datetime + +try: + import pymake +except: + msg = 'Error. Pymake package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install https://github.com/modflowpy/pymake/zipball/master' + raise Exception(msg) + +try: + import flopy +except: + msg = 'Error. FloPy package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install flopy' + raise Exception(msg) + +from framework import testing_framework +from simulation import Simulation + +ex = ['csub_sk03a'] +exdirs = [] +for s in ex: + exdirs.append(os.path.join('temp', s)) +constantcv = [True for idx in range(len(exdirs))] + +cmppths = ['mfnwt' for idx in range(len(exdirs))] +newtons = [True for idx in range(len(exdirs))] + +icrcc = [0, 1, 0, 1] + +ddir = 'data' + +## run all examples on Travis +travis = [True for idx in range(len(exdirs))] + +# set replace_exe to None to use default executable +replace_exe = None + +htol = [None for idx in range(len(exdirs))] +dtol = 1e-3 + +bud_lst = ['CSUB-CGELASTIC_IN', 'CSUB-CGELASTIC_OUT', + 'CSUB-WATERCOMP_IN', 'CSUB-WATERCOMP_OUT'] + +# static model data +# temporal discretization +nper = 2 +sec2day = 86400. +day2sec = 1. / sec2day +nsec = 33 * 60 +perlen = np.array([1., nsec]) +totim = perlen.sum() - perlen[0] +nstp = [1, nsec * 2] +tsmult = [1.0, 1.00] +steady = [True] + [False for i in range(nper - 1)] + +# spatial discretization +ft2m = 1. / 3.28081 +nlay, nrow, ncol = 3, 21, 20 +delr = np.ones(ncol, dtype=np.float) * 0.5 +for idx in range(1, ncol): + delr[idx] = min(delr[idx - 1] * 1.2, 15.) +delc = 50. +top = 0. +botm = np.array([-40, -70., -100.], dtype=np.float) * ft2m +zthick = [top - botm[0], + botm[0] - botm[1], + botm[1] - botm[2]] +strt = -35. * ft2m +hnoflo = 1e30 +hdry = -1e30 + +# calculate hk +hk = np.array([5., 0.001, 15.]) * ft2m * day2sec + +# calculate vka +vka = hk.copy() * .1 + +# set rest of npf variables +laytyp = [1, 0, 0] +sy = [0.1, 0.05, 0.25] + +nouter, ninner = 500, 300 +hclose, rclose, relax = 1e-9, 1e-6, 1. + +tdis_rc = [] +for idx in range(nper): + tdis_rc.append((perlen[idx], nstp[idx], tsmult[idx])) + +# all cells are active +ib = 1 + +# chd data +finish = strt - totim * 0.026 / (60. * 60. * 3.28081) +c = [] +c6 = [] +ccol = [ncol - 1] +for k in [0, nlay - 1]: + for i in range(nrow): + for j in ccol: + c.append([k, i, j, strt, strt]) + c6.append([(k, i, j), 'chd']) +cd = {0: c} +cd6 = {0: c6} +maxchd = len(cd[0]) + +# static csub and subwt data +ump = True +sgm = 1.7 +sgs = 2.0 +ini_stress = 15.0 +theta = [.25, .5, .30] +beta = 4.65120000e-10 + +# no delay bed data +lnd = [0, 1, 2] +thicknd0 = [zthick[0], zthick[1], zthick[2]] +sske = np.array([1.e-5, 2.e-4, 9.e-8]) / ft2m + +gl0 = np.zeros((nrow, ncol), dtype=np.float) +jj = 0 +gl0[0, jj] = 1.86 +sig0 = np.zeros((nlay, nrow, ncol), dtype=np.float) +sig0[0, 0, jj] = 1.86 +tsnames = [] +sig0 = [] +for i in range(nrow): + tsname = 'TLR{:02d}'.format(i + 1) + tsnames.append(tsname) + sig0.append([(0, i, 0), tsname]) +tsname = 'FR' +tsnames.append(tsname) +sig0.append([(0, 9, 0), tsname]) + +datestart = datetime.datetime.strptime('03/21/1938 00:00:00', + "%m/%d/%Y %H:%M:%S") +train1 = 2.9635 # 3.9009 +train2 = 2.8274 +fcar1 = 0.8165 +fcar2 = 1.63293447 +fcar3 = 2.8274 # 2.9635 #2.4494 +icnt = np.zeros((nrow), dtype=np.int) +v = [] +tstime = [] +i0 = 0 +dt = 15. +t = [] +ton = 6. * 60. +for i in range(nrow + 1): + vv = 0. + t.append(vv) +tstime.append(ton) +v.append(t) +ton += 1. +train = train1 +fend = train1 # fcar3 +fremain = 0. +while True: + if i0 < nrow: + icnt[i0] = 1 + t = [] + for i in range(nrow): + vv = 0. + if icnt[i] > 0 and icnt[i] < 7: + if i == i0: + vv = train + elif i == i0 - 5: + vv = fend + else: + vv = train # fcar3 + t.append(vv) + t.append(fremain) + ton += dt + tstime.append(ton) + v.append(t) + if i0 == 13: + ton += 525 + tstime.append(ton) + v.append(t) + if icnt[9] >= 6: + train = train2 + fend = train2 # fcar2 + fremain = fcar1 + icnt[icnt > 0] += 1 + i0 += 1 + if icnt[nrow - 1] == 7: + break +tsv = np.array(v) + +# sig0 = [[(0, 0, 0), tsname]] + +# subwt output data +ds16 = [0, 0, 0, 2052, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] +ds17 = [0, 10000, 0, 10000, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] + + +# SUB package problem 3 +def get_model(idx, dir): + name = ex[idx] + newton = newtons[idx] + + # build MODFLOW 6 files + ws = dir + sim = flopy.mf6.MFSimulation(sim_name=name, version='mf6', + exe_name='mf6', + sim_ws=ws) + # create tdis package + tdis = flopy.mf6.ModflowTdis(sim, time_units='SECONDS', + nper=nper, perioddata=tdis_rc) + + # create gwf model + newtonoptions = None + imsla = 'CG' + if newton: + newtonoptions = '' + imsla = 'BICGSTAB' + + sc = sske + compression_indices = None + + gwf = flopy.mf6.ModflowGwf(sim, modelname=name, + newtonoptions=newtonoptions) + + # create iterative model solution and register the gwf model with it + ims = flopy.mf6.ModflowIms(sim, print_option='SUMMARY', + outer_hclose=hclose, + outer_maximum=nouter, + under_relaxation='NONE', + inner_maximum=ninner, + inner_hclose=hclose, rcloserecord=rclose, + linear_acceleration=imsla, + scaling_method='NONE', + reordering_method='NONE', + relaxation_factor=relax) + sim.register_ims_package(ims, [gwf.name]) + + dis = flopy.mf6.ModflowGwfdis(gwf, nlay=nlay, nrow=nrow, ncol=ncol, + delr=delr, delc=delc, + top=top, botm=botm) + + # initial conditions + ic = flopy.mf6.ModflowGwfic(gwf, strt=strt, + filename='{}.ic'.format(name)) + + # node property flow + npf = flopy.mf6.ModflowGwfnpf(gwf, save_flows=True, + save_specific_discharge=True, + # dev_modflowusg_upstream_weighted_saturation=True, + icelltype=laytyp, + k=hk, + k33=vka) + # gwf obs + jj = 10 + obs_recarray = {'gwf_obs.csv': [('t1_1_1', 'HEAD', (0, 10, 0)), + ('t2_1_1', 'HEAD', (1, 10, 0)), + ('t3_1_1', 'HEAD', (2, 10, 0)), + ('w1_1_1', 'HEAD', (0, 10, jj)), + ('w2_1_1', 'HEAD', (1, 10, jj)), + ('w3_1_1', 'HEAD', (2, 10, jj)), + ('ICF1_1_1', 'FLOW-JA-FACE', (0, 10, 0), + (0, 10, 1)), + ('ICF2_1_1', 'FLOW-JA-FACE', (1, 10, 0), + (1, 10, 1)), + ('ICF3_1_1', 'FLOW-JA-FACE', (2, 10, 0), + (2, 10, 1))], + 'gwf_calib_obs.csv': [('w3_1_1', 'HEAD', (2, 10, jj))] + } + obs_package = flopy.mf6.ModflowUtlobs(gwf, pname='head_obs', + digits=10, print_input=True, + continuous=obs_recarray) + # storage + sto = flopy.mf6.ModflowGwfsto(gwf, save_flows=False, iconvert=laytyp, + ss=0., sy=sy, + storagecoefficient=True, + steady_state={0: True}, + transient={1: True}) + + # create chd time series + chnam = '{}.ch.ts'.format(name) + chd_ts = [(0., strt), (1., strt), (perlen.sum(), finish)] + + # chd files + chd = flopy.mf6.modflow.mfgwfchd.ModflowGwfchd(gwf, + maxbound=maxchd, + stress_period_data=cd6, + save_flows=False) + # initialize time series + chd.ts.initialize(filename=chnam, timeseries=chd_ts, + time_series_namerecord=['CHD'], + interpolation_methodrecord=['linear']) + + # create load time series file with load + csub_ts = [] + csubnam = '{}.load.ts'.format(name) + + fopth = os.path.join(ws, 'ts.csv') + fo = open(fopth, 'w') + + line2 = 'TIME' + for tsname in tsnames: + line2 += ',{}'.format(tsname) + fo.write('{}\n'.format(line2)) + + d = [0.] + line = ' {:12.6e}'.format(0.) + dateon = datestart + datetime.timedelta(seconds=0) + datestr = dateon.strftime("%m/%d/%Y %H:%M:%S") + line2 = '{}'.format(datestr) + for tsname in tsnames: + d.append(0.) + line2 += ',0.0000' + csub_ts.append(tuple(d)) + fo.write('{}\n'.format(line2)) + + ton = 1. + d = [ton] + dateon = datestart + datetime.timedelta(seconds=ton) + datestr = dateon.strftime("%m/%d/%Y %H:%M:%S") + line2 = '{}'.format(datestr) + for tsname in tsnames: + d.append(0.) + line2 += ',0.0000' + csub_ts.append(tuple(d)) + fo.write('{}\n'.format(line2)) + + for i in range(tsv.shape[0]): + ton = tstime[i] + d = [ton] + dateon = datestart + datetime.timedelta(seconds=ton) + datestr = dateon.strftime("%m/%d/%Y %H:%M:%S") + line2 = '{}'.format(datestr) + for j in range(tsv.shape[1]): + d.append(tsv[i, j]) + line2 += ',{:6.4f}'.format(tsv[i, j]) + csub_ts.append(tuple(d)) + fo.write('{}\n'.format(line2)) + + ton += 1 + d = [ton] + dateon = datestart + datetime.timedelta(seconds=ton) + datestr = dateon.strftime("%m/%d/%Y %H:%M:%S") + line2 = '{}'.format(datestr) + for tsname in tsnames: + if tsname == 'FR': + d.append(fcar1) + line2 += ',{:6.4f}'.format(fcar1) + else: + d.append(0.) + line2 += ',0.0000' + csub_ts.append(tuple(d)) + fo.write('{}\n'.format(line2)) + + ton += (i + 1.) * 86400. + d = [ton] + dateon = datestart + datetime.timedelta(minutes=29) + datestr = dateon.strftime("%m/%d/%Y %H:%M:%S") + line2 = '{}'.format(datestr) + for tsname in tsnames: + if tsname == 'FR': + d.append(fcar1) + line2 += ',{:6.4f}'.format(fcar1) + else: + d.append(0.) + line2 += ',0.0000' + csub_ts.append(tuple(d)) + fo.write('{}\n'.format(line2)) + + ton = 100. * sec2day + d = [ton] + dateon = datestart + datetime.timedelta(minutes=30) + datestr = dateon.strftime("%m/%d/%Y %H:%M:%S") + line2 = '{}'.format(datestr) + for tsname in tsnames: + if tsname == 'FR': + d.append(fcar1) + line2 += ',{:6.4f}'.format(fcar1) + else: + d.append(fcar1) + line2 += ',0.0000' + csub_ts.append(tuple(d)) + fo.write('{}\n'.format(line2)) + + # close ts,csv + fo.close() + + # csub files + opth = '{}.csub.obs'.format(name) + csub = flopy.mf6.ModflowGwfcsub(gwf, + print_input=True, + update_material_properties=ump, + effective_stress_lag=True, + save_flows=True, + ninterbeds=0, + maxsig0=len(sig0), + compression_indices=compression_indices, + sgm=sgm, + sgs=sgs, + cg_theta=theta, + cg_ske_cr=sc, + beta=beta, + packagedata=None, + stress_period_data={0: sig0}) + # initialize time series + csub.ts.initialize(filename=csubnam, timeseries=csub_ts, + time_series_namerecord=tsnames, + interpolation_methodrecord=['linear' for t in tsnames]) + + # add observations + orecarray = {} + jj = 10 + orecarray['csub_obs.csv'] = [('tc1', 'compaction-cell', (0, 10, 0)), + ('tc2', 'compaction-cell', (1, 10, 0)), + ('tc3', 'compaction-cell', (2, 10, 0)), + ('wc1', 'compaction-cell', (0, 10, jj)), + ('wc2', 'compaction-cell', (1, 10, jj)), + ('wc3', 'compaction-cell', (2, 10, jj)), + ('tes3', 'estress-cell', (2, 10, 0)), + ('fes3', 'estress-cell', (2, 9, 0)), + ('tgs3', 'gstress-cell', (2, 10, 0)), + ('fgs3', 'gstress-cell', (2, 9, 0))] + csub_obs_package = csub.obs.initialize(filename=opth, digits=10, + print_input=True, + continuous=orecarray) + + # output control + oc = flopy.mf6.ModflowGwfoc(gwf, + budget_filerecord='{}.cbc'.format(name), + head_filerecord='{}.hds'.format(name), + headprintrecord=[ + ('COLUMNS', 10, 'WIDTH', 15, + 'DIGITS', 6, 'GENERAL')], + saverecord=[('HEAD', 'ALL'), + ('BUDGET', 'ALL')], + printrecord=[('HEAD', 'ALL'), + ('BUDGET', 'ALL')]) + mc = None + + return sim, mc + + +def eval_comp(sim): + print('evaluating compaction...') + + # MODFLOW 6 total compaction results + fpth = os.path.join(sim.simpath, 'csub_obs.csv') + try: + tc = np.genfromtxt(fpth, names=True, delimiter=',') + except: + assert False, 'could not load data from "{}"'.format(fpth) + + # get results from listing file + fpth = os.path.join(sim.simpath, + '{}.lst'.format(os.path.basename(sim.name))) + budl = flopy.utils.Mf6ListBudget(fpth) + names = list(bud_lst) + d0 = budl.get_budget(names=names)[0] + dtype = d0.dtype + nbud = d0.shape[0] + + # get results from cbc file + cbc_bud = ['CSUB-CGELASTIC', 'CSUB-WATERCOMP'] + d = np.recarray(nbud, dtype=dtype) + for key in bud_lst: + d[key] = 0. + fpth = os.path.join(sim.simpath, + '{}.cbc'.format(os.path.basename(sim.name))) + cobj = flopy.utils.CellBudgetFile(fpth, precision='double') + kk = cobj.get_kstpkper() + times = cobj.get_times() + for idx, (k, t) in enumerate(zip(kk, times)): + for text in cbc_bud: + qin = 0. + qout = 0. + v = cobj.get_data(kstpkper=k, text=text)[0] + for kk in range(v.shape[0]): + for ii in range(v.shape[1]): + for jj in range(v.shape[2]): + vv = v[kk, ii, jj] + if vv < 0.: + qout -= vv + else: + qin += vv + d['totim'][idx] = t + d['time_step'][idx] = k[0] + d['stress_period'] = k[1] + key = '{}_IN'.format(text) + d[key][idx] = qin + key = '{}_OUT'.format(text) + d[key][idx] = qout + + diff = np.zeros((nbud, len(bud_lst)), dtype=np.float) + for idx, key in enumerate(bud_lst): + diff[:, idx] = d0[key] - d[key] + diffmax = np.abs(diff).max() + msg = 'maximum absolute total-budget difference ({}) '.format(diffmax) + + # write summary + fpth = os.path.join(sim.simpath, + '{}.bud.cmp.out'.format(os.path.basename(sim.name))) + f = open(fpth, 'w') + for i in range(diff.shape[0]): + if i == 0: + line = '{:>10s}'.format('TIME') + for idx, key in enumerate(bud_lst): + line += '{:>25s}'.format(key + '_LST') + line += '{:>25s}'.format(key + '_CBC') + line += '{:>25s}'.format(key + '_DIF') + f.write(line + '\n') + line = '{:10g}'.format(d['totim'][i]) + for idx, key in enumerate(bud_lst): + line += '{:25g}'.format(d0[key][i]) + line += '{:25g}'.format(d[key][i]) + line += '{:25g}'.format(diff[i, idx]) + f.write(line + '\n') + f.close() + + if diffmax > dtol: + sim.success = False + msg += 'exceeds {}'.format(dtol) + assert diffmax < dtol, msg + else: + sim.success = True + print(' ' + msg) + + return + + +# - No need to change any code below +def build_models(): + for idx, dir in enumerate(exdirs): + sim, mc = get_model(idx, dir) + sim.write_simulation() + if mc is not None: + mc.write_input() + return + + +def test_mf6model(): + # determine if running on Travis + is_travis = 'TRAVIS' in os.environ + r_exe = None + if not is_travis: + if replace_exe is not None: + r_exe = replace_exe + + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + if is_travis and not travis[idx]: + continue + yield test.run_mf6, Simulation(dir, exfunc=eval_comp, + exe_dict=r_exe, + htol=htol[idx], + idxsim=idx) + + return + + +def main(): + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + sim = Simulation(dir, exfunc=eval_comp, + exe_dict=replace_exe, htol=htol[idx], idxsim=idx) + test.run_mf6(sim) + + return + + +if __name__ == "__main__": + # print message + print('standalone run of {}'.format(os.path.basename(__file__))) + + # run main routine + main() diff --git a/autotest/test_gwf_csub_sub01.py b/autotest/test_gwf_csub_sub01.py new file mode 100644 index 00000000000..d45adf3dfac --- /dev/null +++ b/autotest/test_gwf_csub_sub01.py @@ -0,0 +1,445 @@ +import os +import numpy as np + +try: + import pymake +except: + msg = 'Error. Pymake package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install https://github.com/modflowpy/pymake/zipball/master' + raise Exception(msg) + +try: + import flopy +except: + msg = 'Error. FloPy package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install flopy' + raise Exception(msg) + +from framework import testing_framework +from simulation import Simulation + +paktest = 'csub' +budtol = 1e-2 + +ex = ['csub_sub01a', 'csub_sub01b'] +exdirs = [] +for s in ex: + exdirs.append(os.path.join('temp', s)) +ddir = 'data' + +compression_indices = [None, True] + +ndcell = [19] * len(ex) + +# run all examples on Travis +# travis = [True for idx in range(len(exdirs))] +# the delay bed problems only run on the development version of MODFLOW-2005 +# set travis to True when version 1.13.0 is released +travis = [False for idx in range(len(exdirs))] + +# set replace_exe to None to use default executable +replace_exe = {'mf2005': 'mf2005devdbl'} + +# static model data +# spatial discretization +nlay, nrow, ncol = 1, 1, 3 +shape3d = (nlay, nrow, ncol) +size3d = nlay * nrow * ncol +delr, delc = 1., 1. +top = 0. +botm = [-100.] + +# temporal discretization +nper = 1 +perlen = [1000. for i in range(nper)] +nstp = [100 for i in range(nper)] +tsmult = [1.05 for i in range(nper)] +steady = [False for i in range(nper)] + +strt = 0. +strt6 = 1. +hnoflo = 1e30 +hdry = -1e30 +hk = 1e6 +laytyp = [0] +S = 1e-4 +sy = 0. + +nouter, ninner = 1000, 300 +hclose, rclose, relax = 1e-6, 1e-6, 0.97 + +tdis_rc = [] +for idx in range(nper): + tdis_rc.append((perlen[idx], nstp[idx], tsmult[idx])) + +ib = 1 + +c = [] +c6 = [] +for j in range(0, ncol, 2): + c.append([0, 0, j, strt, strt]) + c6.append([(0, 0, j), strt]) +cd = {0: c} +cd6 = {0: c6} + +# sub data +ndb = 1 +nndb = 0 +cc = 100. +cr = 1. +void = 0.82 +theta = void / (1. + void) +kv = 0.025 +sgm = 0. +sgs = 0. +ini_stress = 1.0 +thick = [1.] +sfe = cr * thick[0] +sfv = cc * thick[0] +lnd = [0] +ldnd = [0] +dp = [[kv, cr, cc]] +ss = S / (100. - thick[0]) + +ds15 = [0, 0, 0, 2052, 0, 0, 0, 0, 0, 0, 0, 0] +ds16 = [0, 0, 0, 100, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1] + + +def get_model(idx, dir): + name = ex[idx] + + # build MODFLOW 6 files + ws = dir + sim = flopy.mf6.MFSimulation(sim_name=name, version='mf6', + exe_name='mf6', + sim_ws=ws) + # create tdis package + tdis = flopy.mf6.ModflowTdis(sim, time_units='DAYS', + nper=nper, perioddata=tdis_rc) + + # create gwf model + gwf = flopy.mf6.ModflowGwf(sim, modelname=name) + + # create iterative model solution and register the gwf model with it + ims = flopy.mf6.ModflowIms(sim, print_option='SUMMARY', + outer_hclose=hclose, + outer_maximum=nouter, + under_relaxation='NONE', + inner_maximum=ninner, + inner_hclose=hclose, rcloserecord=rclose, + linear_acceleration='CG', + scaling_method='NONE', + reordering_method='NONE', + relaxation_factor=relax) + sim.register_ims_package(ims, [gwf.name]) + + dis = flopy.mf6.ModflowGwfdis(gwf, nlay=nlay, nrow=nrow, ncol=ncol, + delr=delr, delc=delc, + top=top, botm=botm, + filename='{}.dis'.format(name)) + + # initial conditions + ic = flopy.mf6.ModflowGwfic(gwf, strt=strt, + filename='{}.ic'.format(name)) + + # node property flow + npf = flopy.mf6.ModflowGwfnpf(gwf, save_flows=False, + icelltype=laytyp, + k=hk, + k33=hk) + # storage + sto = flopy.mf6.ModflowGwfsto(gwf, save_flows=False, iconvert=laytyp, + ss=0., sy=sy, + storagecoefficient=True, + transient={0: True}) + + # chd files + chd = flopy.mf6.modflow.mfgwfchd.ModflowGwfchd(gwf, + maxbound=len(c6), + stress_period_data=cd6, + save_flows=False) + + # csub files + ci = compression_indices[idx] + if ci is None: + sub6 = [[0, (0, 0, 1), 'delay', ini_stress, thick[0], + 1., cc, cr, theta, kv, ini_stress]] + else: + sub6 = [[0, (0, 0, 1), 'delay', ini_stress, thick[0], + 1., 230.258658761733000, 2.302586587617330, + theta, kv, ini_stress]] + + opth = '{}.csub.obs'.format(name) + cnvgpth = '{}.csub.cnvg.csv'.format(name) + csub = flopy.mf6.ModflowGwfcsub(gwf, head_based=True, + compression_indices=ci, + print_input=True, + save_flows=True, + package_convergence_filerecord=cnvgpth, + effective_stress_lag=True, + ndelaycells=ndcell[idx], + ninterbeds=1, + beta=0., cg_ske_cr=ss, + packagedata=sub6) + orecarray = {} + orecarray['csub_obs.csv'] = [('tcomp', 'compaction-cell', (0, 0, 1)), + ('sk', 'sk', (0, 0, 1))] + csub_obs_package = csub.obs.initialize(filename=opth, digits=10, + print_input=True, + continuous=orecarray) + + # output control + oc = flopy.mf6.ModflowGwfoc(gwf, + budget_filerecord='{}.cbc'.format(name), + head_filerecord='{}.hds'.format(name), + headprintrecord=[ + ('COLUMNS', 10, 'WIDTH', 15, + 'DIGITS', 6, 'GENERAL')], + saverecord=[('HEAD', 'ALL'), + ('BUDGET', 'ALL')], + printrecord=[('HEAD', 'ALL'), + ('BUDGET', 'ALL')]) + + # build MODFLOW-2005 files + ws = os.path.join(dir, 'mf2005') + mc = flopy.modflow.Modflow(name, model_ws=ws) + dis = flopy.modflow.ModflowDis(mc, nlay=nlay, nrow=nrow, ncol=ncol, + nper=nper, perlen=perlen, nstp=nstp, + tsmult=tsmult, steady=steady, delr=delr, + delc=delc, top=top, botm=botm) + bas = flopy.modflow.ModflowBas(mc, ibound=ib, strt=strt, hnoflo=hnoflo, + stoper=0.01) + lpf = flopy.modflow.ModflowLpf(mc, laytyp=laytyp, hk=hk, vka=hk, ss=S, + sy=sy, constantcv=True, + storagecoefficient=True, + hdry=hdry) + chd = flopy.modflow.ModflowChd(mc, stress_period_data=cd) + sub = flopy.modflow.ModflowSub(mc, ndb=ndb, nndb=nndb, nn=10, idbit=1, + isuboc=1, ln=lnd, ldn=ldnd, rnb=[1.], + dp=dp, dz=thick, + dhc=ini_stress, dstart=ini_stress, + hc=ini_stress, sfe=sfe, sfv=sfv, + ids15=ds15, ids16=ds16) + oc = flopy.modflow.ModflowOc(mc, stress_period_data=None, + save_every=1, + save_types=['save head', 'save budget', + 'print budget']) + pcg = flopy.modflow.ModflowPcg(mc, mxiter=nouter, iter1=ninner, + hclose=hclose, rclose=rclose, + relax=relax, ihcofadd=1) + + return sim, mc + + +def eval_sub(sim): + print('evaluating subsidence...') + + # MODFLOW 6 total compaction results + fpth = os.path.join(sim.simpath, 'csub_obs.csv') + try: + tc = np.genfromtxt(fpth, names=True, delimiter=',') + except: + assert False, 'could not load data from "{}"'.format(fpth) + + # MODFLOW-2005 total compaction results + fpth = os.path.join(sim.simpath, 'mf2005', + '{}.total_comp.hds'.format(ex[sim.idxsim])) + try: + sobj = flopy.utils.HeadFile(fpth, text='LAYER COMPACTION') + tc0 = sobj.get_ts((0, 0, 1)) + except: + assert False, 'could not load data from "{}"'.format(fpth) + + # calculate maximum absolute error + diff = tc['TCOMP'] - tc0[:, 1] + diffmax = np.abs(diff).max() + dtol = 1e-6 + msg = 'maximum absolute total-compaction difference ({}) '.format(diffmax) + + # write summary + fpth = os.path.join(sim.simpath, + '{}.comp.cmp.out'.format(os.path.basename(sim.name))) + f = open(fpth, 'w') + line = '{:>15s}'.format('TOTIM') + line += ' {:>15s}'.format('CSUB') + line += ' {:>15s}'.format('MF') + line += ' {:>15s}'.format('DIFF') + f.write(line + '\n') + for i in range(diff.shape[0]): + line = '{:15g}'.format(tc0[i, 0]) + line += ' {:15g}'.format(tc['TCOMP'][i]) + line += ' {:15g}'.format(tc0[i, 1]) + line += ' {:15g}'.format(diff[i]) + f.write(line + '\n') + f.close() + + if diffmax > dtol: + sim.success = False + msg += 'exceeds {}'.format(dtol) + assert diffmax < dtol, msg + else: + sim.success = True + print(' ' + msg) + + # compare budgets + cbc_compare(sim) + + return + + +# compare cbc and lst budgets +def cbc_compare(sim): + # open cbc file + fpth = os.path.join(sim.simpath, + '{}.cbc'.format(os.path.basename(sim.name))) + cobj = flopy.utils.CellBudgetFile(fpth, precision='double') + + # build list of cbc data to retrieve + avail = cobj.get_unique_record_names() + cbc_bud = [] + bud_lst = [] + for t in avail: + if isinstance(t, bytes): + t = t.decode() + t = t.strip() + if paktest in t.lower(): + cbc_bud.append(t) + bud_lst.append('{}_IN'.format(t)) + bud_lst.append('{}_OUT'.format(t)) + + # get results from listing file + fpth = os.path.join(sim.simpath, + '{}.lst'.format(os.path.basename(sim.name))) + budl = flopy.utils.Mf6ListBudget(fpth) + names = list(bud_lst) + d0 = budl.get_budget(names=names)[0] + dtype = d0.dtype + nbud = d0.shape[0] + d = np.recarray(nbud, dtype=dtype) + for key in bud_lst: + d[key] = 0. + + # get data from cbc dile + kk = cobj.get_kstpkper() + times = cobj.get_times() + for idx, (k, t) in enumerate(zip(kk, times)): + for text in cbc_bud: + qin = 0. + qout = 0. + v = cobj.get_data(kstpkper=k, text=text)[0] + if isinstance(v, np.recarray): + vt = np.zeros(size3d, dtype=np.float) + for jdx, node in enumerate(v['node']): + vt[node - 1] += v['q'][jdx] + v = vt.reshape(shape3d) + for kk in range(v.shape[0]): + for ii in range(v.shape[1]): + for jj in range(v.shape[2]): + vv = v[kk, ii, jj] + if vv < 0.: + qout -= vv + else: + qin += vv + d['totim'][idx] = t + d['time_step'][idx] = k[0] + d['stress_period'] = k[1] + key = '{}_IN'.format(text) + d[key][idx] = qin + key = '{}_OUT'.format(text) + d[key][idx] = qout + + diff = np.zeros((nbud, len(bud_lst)), dtype=np.float) + for idx, key in enumerate(bud_lst): + diff[:, idx] = d0[key] - d[key] + diffmax = np.abs(diff).max() + msg = 'maximum absolute total-budget difference ({}) '.format(diffmax) + + # write summary + fpth = os.path.join(sim.simpath, + '{}.bud.cmp.out'.format(os.path.basename(sim.name))) + f = open(fpth, 'w') + for i in range(diff.shape[0]): + if i == 0: + line = '{:>10s}'.format('TIME') + for idx, key in enumerate(bud_lst): + line += '{:>25s}'.format(key + '_LST') + line += '{:>25s}'.format(key + '_CBC') + line += '{:>25s}'.format(key + '_DIF') + f.write(line + '\n') + line = '{:10g}'.format(d['totim'][i]) + for idx, key in enumerate(bud_lst): + line += '{:25g}'.format(d0[key][i]) + line += '{:25g}'.format(d[key][i]) + line += '{:25g}'.format(diff[i, idx]) + f.write(line + '\n') + f.close() + + if diffmax > budtol: + sim.success = False + msg += 'exceeds {}'.format(dtol) + assert diffmax < dtol, msg + else: + sim.success = True + print(' ' + msg) + + return + + +# - No need to change any code below +def build_models(): + for idx, dir in enumerate(exdirs): + sim, mc = get_model(idx, dir) + sim.write_simulation() + if mc is not None: + mc.write_input() + return + + +def test_mf6model(): + # determine if running on Travis + is_travis = 'TRAVIS' in os.environ + r_exe = None + if not is_travis: + if replace_exe is not None: + r_exe = replace_exe + + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + if is_travis and not travis[idx]: + continue + yield test.run_mf6, Simulation(dir, exfunc=eval_sub, + exe_dict=r_exe, idxsim=idx) + + return + + +def main(): + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + sim = Simulation(dir, exfunc=eval_sub, exe_dict=replace_exe, + idxsim=idx) + test.run_mf6(sim) + return + + +# use python testmf6_csub_sub01.py --mf2005 mf2005devdbl +if __name__ == "__main__": + # print message + print('standalone run of {}'.format(os.path.basename(__file__))) + + # run main routine + main() diff --git a/autotest/test_gwf_csub_sub01_adjmat.py b/autotest/test_gwf_csub_sub01_adjmat.py new file mode 100644 index 00000000000..19f26ffe455 --- /dev/null +++ b/autotest/test_gwf_csub_sub01_adjmat.py @@ -0,0 +1,497 @@ +import os +import numpy as np + +try: + import pymake +except: + msg = 'Error. Pymake package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install https://github.com/modflowpy/pymake/zipball/master' + raise Exception(msg) + +try: + import flopy +except: + msg = 'Error. FloPy package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install flopy' + raise Exception(msg) + +from framework import testing_framework +from simulation import Simulation + +paktest = 'csub' +budtol = 1e-2 + +compdir = 'mf6' +ex = ['csub_sub01_adj'] +exdirs = [] +for s in ex: + exdirs.append(os.path.join('temp', s)) +ddir = 'data' + +compression_indices = [None] + +ndcell = [19] * len(ex) + +# run all examples on Travis +# travis = [True for idx in range(len(exdirs))] +# the delay bed problems only run on the development version of MODFLOW-2005 +# set travis to True when version 1.13.0 is released +travis = [True for idx in range(len(exdirs))] + +# set replace_exe to None to use default executable +replace_exe = None + +# static model data +# spatial discretization +nlay, nrow, ncol = 1, 1, 3 +shape3d = (nlay, nrow, ncol) +size3d = nlay * nrow * ncol +delr, delc = 1., 1. +top = 0. +botm = [-100.] + +# temporal discretization +nper = 1 +perlen = [1000. for i in range(nper)] +nstp = [100 for i in range(nper)] +tsmult = [1.05 for i in range(nper)] +steady = [False for i in range(nper)] + +strt = 0. +strt6 = 1. +hnoflo = 1e30 +hdry = -1e30 +hk = 1e6 +laytyp = [0] +S = 1e-4 +sy = 0. + +nouter, ninner = 1000, 500 +hclose, rclose, relax = 1e-12, 1e-6, 0.97 + +tdis_rc = [] +for idx in range(nper): + tdis_rc.append((perlen[idx], nstp[idx], tsmult[idx])) + +ib = 1 + +c = [] +c6 = [] +for j in range(0, ncol, 2): + c.append([0, 0, j, strt, strt]) + c6.append([(0, 0, j), strt]) +cd = {0: c} +cd6 = {0: c6} + +# sub data +ndb = 1 +nndb = 0 +cc = 1.e-2 +cr = 1.e-5 +theta = 0.45 +void = theta / (1. - theta) +kv = 2.5e-6 +sgm = 0. +sgs = 0. +ini_stress = 1.0 +thick = [1.] +sub6 = [[0, (0, 0, 1), 'delay', ini_stress, thick[0], + 1., cc, cr, theta, kv, ini_stress]] + + +def get_model(idx, dir): + sim = build_model(idx, dir, adjustmat=True) + + # build MODFLOW-6 with constant material properties + pth = os.path.join(dir, compdir) + mc = build_model(idx, pth, None) + + return sim, mc + + +def build_model(idx, dir, adjustmat=False): + name = ex[idx] + + # build MODFLOW 6 files + ws = dir + sim = flopy.mf6.MFSimulation(sim_name=name, version='mf6', + exe_name='mf6', + sim_ws=ws) + sim.name_file.memory_print_option = 'all' + + # create tdis package + tdis = flopy.mf6.ModflowTdis(sim, time_units='DAYS', + nper=nper, perioddata=tdis_rc) + + # create gwf model + gwf = flopy.mf6.ModflowGwf(sim, modelname=name) + + # create iterative model solution and register the gwf model with it + ims = flopy.mf6.ModflowIms(sim, print_option='SUMMARY', + outer_hclose=hclose, + outer_maximum=nouter, + under_relaxation='NONE', + inner_maximum=ninner, + inner_hclose=hclose, + rcloserecord=[rclose, 'strict'], + linear_acceleration='bicgstab', + scaling_method='NONE', + reordering_method='NONE', + relaxation_factor=relax) + sim.register_ims_package(ims, [gwf.name]) + + dis = flopy.mf6.ModflowGwfdis(gwf, nlay=nlay, nrow=nrow, ncol=ncol, + delr=delr, delc=delc, + top=top, botm=botm, + filename='{}.dis'.format(name)) + + # initial conditions + ic = flopy.mf6.ModflowGwfic(gwf, strt=strt, + filename='{}.ic'.format(name)) + + # node property flow + npf = flopy.mf6.ModflowGwfnpf(gwf, save_flows=False, + icelltype=laytyp, + k=hk, + k33=hk) + # storage + sto = flopy.mf6.ModflowGwfsto(gwf, save_flows=False, iconvert=laytyp, + ss=0., sy=sy, + storagecoefficient=True, + transient={0: True}) + + # chd files + chd = flopy.mf6.modflow.mfgwfchd.ModflowGwfchd(gwf, + maxbound=len(c6), + stress_period_data=cd6, + save_flows=False) + + # csub files + opth = '{}.csub.obs'.format(name) + csub = flopy.mf6.ModflowGwfcsub(gwf, head_based=True, + update_material_properties=adjustmat, + print_input=True, + save_flows=True, + ndelaycells=ndcell[idx], + ninterbeds=1, + beta=0., cg_ske_cr=0., + packagedata=sub6) + obs = [('tcomp', 'compaction-cell', (0, 0, 1)), + ('thick', 'thickness', (0,)), + ('theta', 'theta', (0,)), + ('sk', 'sk', (0, 0, 1))] + tags = ['dbcomp', 'dbthick', 'dbporo'] + for jdx, otype in enumerate(['delay-compaction', + 'delay-thickness', + 'delay-theta']): + for n in range(ndcell[idx]): + tag = '{}{:02d}'.format(tags[jdx], n + 1) + obs.append((tag, otype, (0, n))) + orecarray = {} + orecarray['csub_obs.csv'] = obs + + csub_obs_package = csub.obs.initialize(filename=opth, digits=10, + print_input=True, + continuous=orecarray) + + # output control + oc = flopy.mf6.ModflowGwfoc(gwf, + budget_filerecord='{}.cbc'.format(name), + head_filerecord='{}.hds'.format(name), + headprintrecord=[ + ('COLUMNS', 10, 'WIDTH', 15, + 'DIGITS', 6, 'GENERAL')], + saverecord=[('HEAD', 'ALL'), + ('BUDGET', 'ALL')], + printrecord=[('HEAD', 'ALL'), + ('BUDGET', 'ALL')]) + + return sim + +def calc_theta_thick(comp, thickini=1.): + e0 = void + strain = -comp / thickini + e = e0 + strain * (1. + e0) + poro = e / (1. + e) + b = thickini - comp + return poro, b + + +def eval_sub(sim): + print('evaluating subsidence...') + + # MODFLOW 6 compaction results + fpth = os.path.join(sim.simpath, 'csub_obs.csv') + try: + tc = np.genfromtxt(fpth, names=True, delimiter=',') + except: + assert False, 'could not load data from "{}"'.format(fpth) + + # MODFLOW 6 base compaction results + fpth = os.path.join(sim.simpath, compdir, 'csub_obs.csv') + try: + tcb = np.genfromtxt(fpth, names=True, delimiter=',') + except: + assert False, 'could not load data from "{}"'.format(fpth) + + + # calculate maximum absolute error + diff = tc['TCOMP'] - tcb['TCOMP'] + diffmax = np.abs(diff).max() + dtol = 1e-6 + msg = 'maximum absolute total-compaction difference ({}) '.format(diffmax) + + # write summary + fpth = os.path.join(sim.simpath, + '{}.comp.cmp.out'.format(os.path.basename(sim.name))) + f = open(fpth, 'w') + line = '{:>15s}'.format('TOTIM') + line += ' {:>15s}'.format('CSUB') + line += ' {:>15s}'.format('MF') + line += ' {:>15s}'.format('DIFF') + f.write(line + '\n') + for i in range(diff.shape[0]): + line = '{:15g}'.format(tc['time'][i]) + line += ' {:15g}'.format(tc['TCOMP'][i]) + line += ' {:15g}'.format(tcb['TCOMP'][i]) + line += ' {:15g}'.format(diff[i]) + f.write(line + '\n') + f.close() + + if diffmax > dtol: + sim.success = False + msg += 'exceeds {:15.7g}'.format(dtol) + assert diffmax < dtol, msg + else: + sim.success = True + print(' ' + msg) + + # calculate theta and porosity from total interbed compaction + comp = tc['TCOMP'] + dtype = [('THICK', np.float), ('THETA', np.float)] + ovalsi = np.zeros((comp.shape[0]), dtype=dtype) + ovalsi['THICK'] = tc['THICK'] + ovalsi['THETA'] = tc['THETA'] + calc = np.zeros((comp.shape[0]), dtype=dtype) + calc['THETA'], calc['THICK'] = calc_theta_thick(comp) + + for key in calc.dtype.names: + diff = calc[key] - ovalsi[key] + diffmax = np.abs(diff).max() + msg = 'maximum absolute interbed {} '.format(key) + \ + 'difference ({:15.7g}) '.format(diffmax) + if diffmax > dtol: + sim.success = False + msg += 'exceeds {:15.7g}'.format(dtol) + assert diffmax < dtol, msg + else: + sim.success = True + print(' ' + msg) + + # calculate theta and porosity from interbed cell compaction + calci = np.zeros((comp.shape[0]), dtype=dtype) + thickini = 1./ndcell[sim.idxsim] + for n in range(ndcell[sim.idxsim]): + tagc = 'DBCOMP{:02d}'.format(n+1) + tagb = 'DBTHICK{:02d}'.format(n+1) + tagp = 'DBPORO{:02d}'.format(n+1) + comp = tc[tagc] + ovals = np.zeros((comp.shape[0]), dtype=dtype) + ovals['THICK'] = tc[tagb] + ovals['THETA'] = tc[tagp] + calc = np.zeros((comp.shape[0]), dtype=dtype) + calc['THETA'], calc['THICK'] = calc_theta_thick(comp, + thickini=thickini) + for key in calc.dtype.names: + diff = calc[key] - ovals[key] + diffmax = np.abs(diff).max() + msg = 'maximum absolute {}({}) difference '.format(key, n+1) + \ + '({:15.7g}) '.format(diffmax) + if diffmax > dtol: + sim.success = False + msg += 'exceeds {:15.7g}'.format(dtol) + assert diffmax < dtol, msg + else: + sim.success = True + print(' ' + msg) + calci['THICK'] += calc['THICK'] + calci['THETA'] += calc['THICK'] * calc['THETA'] + + # finialize weighted theta and + calci['THETA'] /= calci['THICK'] + for key in calci.dtype.names: + diff = calci[key] - ovalsi[key] + diffmax = np.abs(diff).max() + msg = 'maximum absolute interbed {} difference '.format(key) + \ + '({:15.7g}) '.format(diffmax) + msg += 'calculated from individual interbed cell values ' + if diffmax > dtol: + sim.success = False + msg += 'exceeds {:15.7g}'.format(dtol) + assert diffmax < dtol, msg + else: + sim.success = True + print(' ' + msg) + + # compare budgets + cbc_compare(sim) + + return + + +# compare cbc and lst budgets +def cbc_compare(sim): + # open cbc file + fpth = os.path.join(sim.simpath, + '{}.cbc'.format(os.path.basename(sim.name))) + cobj = flopy.utils.CellBudgetFile(fpth, precision='double') + + # build list of cbc data to retrieve + avail = cobj.get_unique_record_names() + cbc_bud = [] + bud_lst = [] + for t in avail: + if isinstance(t, bytes): + t = t.decode() + t = t.strip() + if paktest in t.lower(): + cbc_bud.append(t) + bud_lst.append('{}_IN'.format(t)) + bud_lst.append('{}_OUT'.format(t)) + + # get results from listing file + fpth = os.path.join(sim.simpath, + '{}.lst'.format(os.path.basename(sim.name))) + budl = flopy.utils.Mf6ListBudget(fpth) + names = list(bud_lst) + d0 = budl.get_budget(names=names)[0] + dtype = d0.dtype + nbud = d0.shape[0] + d = np.recarray(nbud, dtype=dtype) + for key in bud_lst: + d[key] = 0. + + # get data from cbc dile + kk = cobj.get_kstpkper() + times = cobj.get_times() + for idx, (k, t) in enumerate(zip(kk, times)): + for text in cbc_bud: + qin = 0. + qout = 0. + v = cobj.get_data(kstpkper=k, text=text)[0] + if isinstance(v, np.recarray): + vt = np.zeros(size3d, dtype=np.float) + for jdx, node in enumerate(v['node']): + vt[node - 1] += v['q'][jdx] + v = vt.reshape(shape3d) + for kk in range(v.shape[0]): + for ii in range(v.shape[1]): + for jj in range(v.shape[2]): + vv = v[kk, ii, jj] + if vv < 0.: + qout -= vv + else: + qin += vv + d['totim'][idx] = t + d['time_step'][idx] = k[0] + d['stress_period'] = k[1] + key = '{}_IN'.format(text) + d[key][idx] = qin + key = '{}_OUT'.format(text) + d[key][idx] = qout + + diff = np.zeros((nbud, len(bud_lst)), dtype=np.float) + for idx, key in enumerate(bud_lst): + diff[:, idx] = d0[key] - d[key] + diffmax = np.abs(diff).max() + msg = 'maximum absolute total-budget difference ({}) '.format(diffmax) + + # write summary + fpth = os.path.join(sim.simpath, + '{}.bud.cmp.out'.format(os.path.basename(sim.name))) + f = open(fpth, 'w') + for i in range(diff.shape[0]): + if i == 0: + line = '{:>10s}'.format('TIME') + for idx, key in enumerate(bud_lst): + line += '{:>25s}'.format(key + '_LST') + line += '{:>25s}'.format(key + '_CBC') + line += '{:>25s}'.format(key + '_DIF') + f.write(line + '\n') + line = '{:10g}'.format(d['totim'][i]) + for idx, key in enumerate(bud_lst): + line += '{:25g}'.format(d0[key][i]) + line += '{:25g}'.format(d[key][i]) + line += '{:25g}'.format(diff[i, idx]) + f.write(line + '\n') + f.close() + + if diffmax > budtol: + sim.success = False + msg += 'exceeds {}'.format(dtol) + assert diffmax < dtol, msg + else: + sim.success = True + print(' ' + msg) + + return + + +# - No need to change any code below +def build_models(): + for idx, dir in enumerate(exdirs): + sim, mc = get_model(idx, dir) + sim.write_simulation() + if mc is not None: + mc.write_simulation() + return + + +def test_mf6model(): + # determine if running on Travis + is_travis = 'TRAVIS' in os.environ + r_exe = None + if not is_travis: + if replace_exe is not None: + r_exe = replace_exe + + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + if is_travis and not travis[idx]: + continue + yield test.run_mf6, Simulation(dir, exfunc=eval_sub, + exe_dict=r_exe, idxsim=idx) + + return + + +def main(): + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + sim = Simulation(dir, exfunc=eval_sub, exe_dict=replace_exe, + idxsim=idx) + test.run_mf6(sim) + return + + +# use python testmf6_csub_sub01.py --mf2005 mf2005devdbl +if __name__ == "__main__": + # print message + print('standalone run of {}'.format(os.path.basename(__file__))) + + # run main routine + main() diff --git a/autotest/test_gwf_csub_sub01_elastic.py b/autotest/test_gwf_csub_sub01_elastic.py new file mode 100644 index 00000000000..8a9ef900253 --- /dev/null +++ b/autotest/test_gwf_csub_sub01_elastic.py @@ -0,0 +1,401 @@ +import os +import numpy as np + +try: + import pymake +except: + msg = 'Error. Pymake package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install https://github.com/modflowpy/pymake/zipball/master' + raise Exception(msg) + +try: + import flopy +except: + msg = 'Error. FloPy package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install flopy' + raise Exception(msg) + +from framework import testing_framework +from simulation import Simulation + +cmppth = 'mf6' + +paktest = 'csub' +dtol = 1e-3 +budtol = 1e-2 + +ex = ['csub_sub01_elasa'] +exdirs = [] +for s in ex: + exdirs.append(os.path.join('temp', s)) +ddir = 'data' + +ndcell = [19] + +# run all examples on Travis +travis = [True for idx in range(len(exdirs))] + +# set replace_exe to None to use default executable +replace_exe = None + +# static model data +# spatial discretization +nlay, nrow, ncol = 1, 1, 3 +shape3d = (nlay, nrow, ncol) +size3d = nlay * nrow * ncol +delr, delc = 1., 1. +top = 0. +botm = [-100.] + +# temporal discretization +nper = 1 +perlen = [1000. for i in range(nper)] +nstp = [100 for i in range(nper)] +tsmult = [1.05 for i in range(nper)] +steady = [False for i in range(nper)] +tdis_rc = [] +for idx in range(nper): + tdis_rc.append((perlen[idx], nstp[idx], tsmult[idx])) + +strt = 0. +strt6 = 1. +hnoflo = 1e30 +hdry = -1e30 +hk = 1e6 +laytyp = [0] +S = 1e-4 +sy = 0. + +nouter, ninner = 1000, 300 +hclose, rclose, relax = 1e-6, 1e-6, 0.97 + +ib = 1 + +c = [] +c6 = [] +for j in range(0, ncol, 2): + c.append([0, 0, j, strt, strt]) + c6.append([(0, 0, j), strt]) +cd = {0: c} +cd6 = {0: c6} + +# sub data +ndb = 1 +nndb = 0 +cc = 100. +cr = 100. +void = 0.82 +theta = void / (1. + void) +kv = 0.025 +sgm = 0. +sgs = 0. +ini_stress = 1.0 +thick = [1.] +sfe = cr * thick[0] +sfv = cc * thick[0] +lnd = [0] +ldnd = [0] +dp = [[kv, cr, cc]] + +sub6 = [[0, (0, 0, 1), 'delay', ini_stress, thick[0], + 1., cc, cr, theta, kv, ini_stress]] + +def build_mf6(idx, ws, newton=None): + name = ex[idx] + + # build MODFLOW 6 files + sim = flopy.mf6.MFSimulation(sim_name=name, version='mf6', + exe_name='mf6', + sim_ws=ws) + # create tdis package + tdis = flopy.mf6.ModflowTdis(sim, time_units='DAYS', + nper=nper, perioddata=tdis_rc) + + # create gwf model + gwf = flopy.mf6.ModflowGwf(sim, modelname=name, newtonoptions=newton) + + # create iterative model solution and register the gwf model with it + ims = flopy.mf6.ModflowIms(sim, print_option='SUMMARY', + complexity='complex') + sim.register_ims_package(ims, [gwf.name]) + + dis = flopy.mf6.ModflowGwfdis(gwf, nlay=nlay, nrow=nrow, ncol=ncol, + delr=delr, delc=delc, + top=top, botm=botm, + filename='{}.dis'.format(name)) + + # initial conditions + ic = flopy.mf6.ModflowGwfic(gwf, strt=strt, + filename='{}.ic'.format(name)) + + # node property flow + npf = flopy.mf6.ModflowGwfnpf(gwf, save_flows=False, + icelltype=laytyp, + k=hk, + k33=hk) + # storage + sto = flopy.mf6.ModflowGwfsto(gwf, save_flows=False, iconvert=laytyp, + ss=0., sy=sy, + storagecoefficient=True, + transient={0: True}) + + # chd files + chd = flopy.mf6.modflow.mfgwfchd.ModflowGwfchd(gwf, + maxbound=len(c6), + stress_period_data=cd6, + save_flows=False) + + # csub files + opth = '{}.csub.obs'.format(name) + csub = flopy.mf6.ModflowGwfcsub(gwf, head_based=True, + save_flows=True, + effective_stress_lag=True, + ndelaycells=ndcell[idx], + ninterbeds=1, + beta=0., cg_ske_cr=0., + packagedata=sub6) + orecarray = {} + orecarray['csub_obs.csv'] = [('tcomp', 'compaction-cell', (0, 0, 1))] + csub_obs_package = csub.obs.initialize(filename=opth, digits=10, + print_input=True, + continuous=orecarray) + + # output control + oc = flopy.mf6.ModflowGwfoc(gwf, + budget_filerecord='{}.cbc'.format(name), + head_filerecord='{}.hds'.format(name), + headprintrecord=[ + ('COLUMNS', 10, 'WIDTH', 15, + 'DIGITS', 6, 'GENERAL')], + saverecord=[('HEAD', 'ALL'), + ('BUDGET', 'ALL')], + printrecord=[('HEAD', 'ALL'), + ('BUDGET', 'ALL')]) + return sim + +def get_model(idx, dir): + ws = dir + sim = build_mf6(idx, ws) + + ws = os.path.join(ws, cmppth) + mc = build_mf6(idx, ws, newton='') + + return sim, mc + + +def eval_sub(sim): + print('evaluating subsidence...') + + # MODFLOW 6 total compaction results + fpth = os.path.join(sim.simpath, 'csub_obs.csv') + try: + tc = np.genfromtxt(fpth, names=True, delimiter=',') + except: + assert False, 'could not load data from "{}"'.format(fpth) + + # MODFLOW 6 with newton-raphson + fpth = os.path.join(sim.simpath, cmppth, 'csub_obs.csv') + try: + tci = np.genfromtxt(fpth, names=True, delimiter=',') + except: + assert False, 'could not load data from "{}"'.format(fpth) + + diffmax = -1e20 + tagmax = None + for tag in tc.dtype.names[1:]: + diff = tc[tag] - tci[tag] + diffmaxt = np.abs(diff).max() + if diffmaxt > diffmax: + diffmax = diffmaxt + tagmax = tag + + msg = 'maximum compaction difference ' + \ + '({}) in tag: {}'.format(diffmax, tagmax) + + # write summary + fpth = os.path.join(sim.simpath, + '{}.comp.cmp.out'.format(os.path.basename(sim.name))) + f = open(fpth, 'w') + line = '{:>15s}'.format('TOTIM') + for tag in tc.dtype.names[1:]: + line += ' {:>15s}'.format('{}_SK'.format(tag)) + line += ' {:>15s}'.format('{}_SKIB'.format(tag)) + line += ' {:>15s}'.format('{}_DIFF'.format(tag)) + f.write(line + '\n') + for i in range(diff.shape[0]): + line = '{:15g}'.format(tc['time'][i]) + for tag in tc.dtype.names[1:]: + line += ' {:15g}'.format(tc[tag][i]) + line += ' {:15g}'.format(tci[tag][i]) + line += ' {:15g}'.format(tc[tag][i]-tci[tag][i]) + f.write(line + '\n') + f.close() + + if diffmax > dtol: + sim.success = False + msg += 'exceeds {}'.format(dtol) + assert diffmax < dtol, msg + else: + sim.success = True + print(' ' + msg) + + # compare budgets + cbc_compare(sim) + + return + + +# compare cbc and lst budgets +def cbc_compare(sim): + # open cbc file + fpth = os.path.join(sim.simpath, + '{}.cbc'.format(os.path.basename(sim.name))) + cobj = flopy.utils.CellBudgetFile(fpth, precision='double') + + # build list of cbc data to retrieve + avail = cobj.get_unique_record_names() + cbc_bud = [] + bud_lst = [] + for t in avail: + if isinstance(t, bytes): + t = t.decode() + t = t.strip() + if paktest in t.lower(): + cbc_bud.append(t) + bud_lst.append('{}_IN'.format(t)) + bud_lst.append('{}_OUT'.format(t)) + + # get results from listing file + fpth = os.path.join(sim.simpath, + '{}.lst'.format(os.path.basename(sim.name))) + budl = flopy.utils.Mf6ListBudget(fpth) + names = list(bud_lst) + d0 = budl.get_budget(names=names)[0] + dtype = d0.dtype + nbud = d0.shape[0] + d = np.recarray(nbud, dtype=dtype) + for key in bud_lst: + d[key] = 0. + + + # get data from cbc dile + kk = cobj.get_kstpkper() + times = cobj.get_times() + for idx, (k, t) in enumerate(zip(kk, times)): + for text in cbc_bud: + qin = 0. + qout = 0. + v = cobj.get_data(kstpkper=k, text=text)[0] + if isinstance(v, np.recarray): + vt = np.zeros(size3d, dtype=np.float) + for jdx, node in enumerate(v['node']): + vt[node - 1] += v['q'][jdx] + v = vt.reshape(shape3d) + for kk in range(v.shape[0]): + for ii in range(v.shape[1]): + for jj in range(v.shape[2]): + vv = v[kk, ii, jj] + if vv < 0.: + qout -= vv + else: + qin += vv + d['totim'][idx] = t + d['time_step'][idx] = k[0] + d['stress_period'] = k[1] + key = '{}_IN'.format(text) + d[key][idx] = qin + key = '{}_OUT'.format(text) + d[key][idx] = qout + + diff = np.zeros((nbud, len(bud_lst)), dtype=np.float) + for idx, key in enumerate(bud_lst): + diff[:, idx] = d0[key] - d[key] + diffmax = np.abs(diff).max() + msg = 'maximum absolute total-budget difference ({}) '.format(diffmax) + + # write summary + fpth = os.path.join(sim.simpath, + '{}.bud.cmp.out'.format(os.path.basename(sim.name))) + f = open(fpth, 'w') + for i in range(diff.shape[0]): + if i == 0: + line = '{:>10s}'.format('TIME') + for idx, key in enumerate(bud_lst): + line += '{:>25s}'.format(key + '_LST') + line += '{:>25s}'.format(key + '_CBC') + line += '{:>25s}'.format(key + '_DIF') + f.write(line + '\n') + line = '{:10g}'.format(d['totim'][i]) + for idx, key in enumerate(bud_lst): + line += '{:25g}'.format(d0[key][i]) + line += '{:25g}'.format(d[key][i]) + line += '{:25g}'.format(diff[i, idx]) + f.write(line + '\n') + f.close() + + if diffmax > budtol: + sim.success = False + msg += 'exceeds {}'.format(dtol) + assert diffmax < dtol, msg + else: + sim.success = True + print(' ' + msg) + + return + + +# - No need to change any code below +def build_models(): + for idx, dir in enumerate(exdirs): + sim, mc = get_model(idx, dir) + sim.write_simulation() + if mc is not None: + mc.write_simulation() + return + + +def test_mf6model(): + # determine if running on Travis + is_travis = 'TRAVIS' in os.environ + r_exe = None + if not is_travis: + if replace_exe is not None: + r_exe = replace_exe + + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + if is_travis and not travis[idx]: + continue + yield test.run_mf6, Simulation(dir, exfunc=eval_sub, idxsim=idx) + + return + + +def main(): + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + sim = Simulation(dir, exfunc=eval_sub, idxsim=idx) + test.run_mf6(sim) + return + + +if __name__ == "__main__": + # print message + print('standalone run of {}'.format(os.path.basename(__file__))) + + # run main routine + main() diff --git a/autotest/test_gwf_csub_sub01_pch.py b/autotest/test_gwf_csub_sub01_pch.py new file mode 100644 index 00000000000..8004f356001 --- /dev/null +++ b/autotest/test_gwf_csub_sub01_pch.py @@ -0,0 +1,418 @@ +import os +import numpy as np + +try: + import pymake +except: + msg = 'Error. Pymake package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install https://github.com/modflowpy/pymake/zipball/master' + raise Exception(msg) + +try: + import flopy +except: + msg = 'Error. FloPy package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install flopy' + raise Exception(msg) + +from framework import testing_framework +from simulation import Simulation + +paktest = 'csub' +budtol = 1e-2 + +compdir = 'mf6' +ex = ['csub_sub01_pch'] +exdirs = [] +for s in ex: + exdirs.append(os.path.join('temp', s)) +ddir = 'data' + +ndcell = [19] * len(ex) + +# run all examples on Travis +# travis = [True for idx in range(len(exdirs))] +# the delay bed problems only run on the development version of MODFLOW-2005 +# set travis to True when version 1.13.0 is released +travis = [True for idx in range(len(exdirs))] + +# set replace_exe to None to use default executable +replace_exe = None + +# static model data +# spatial discretization +nlay, nrow, ncol = 1, 1, 3 +shape3d = (nlay, nrow, ncol) +size3d = nlay * nrow * ncol +delr, delc = 1., 1. +top = 0. +botm = [-100.] + +# temporal discretization +nper = 1 +perlen = [1000. for i in range(nper)] +nstp = [100 for i in range(nper)] +tsmult = [1.05 for i in range(nper)] +steady = [False for i in range(nper)] + +strt = 0. +strt6 = 1. +hnoflo = 1e30 +hdry = -1e30 +hk = 1e6 +laytyp = [0] +S = 1e-4 +sy = 0. + +nouter, ninner = 1000, 500 +hclose, rclose, relax = 1e-12, 1e-6, 0.97 + +tdis_rc = [] +for idx in range(nper): + tdis_rc.append((perlen[idx], nstp[idx], tsmult[idx])) + +ib = 1 + +c = [] +c6 = [] +for j in range(0, ncol, 2): + c.append([0, 0, j, strt, strt]) + c6.append([(0, 0, j), strt]) +cd = {0: c} +cd6 = {0: c6} + +# sub data +ndb = 1 +nndb = 0 +cc = 1.e-2 +cr = 1.e-5 +theta = 0.45 +void = theta / (1. - theta) +kv = 2.5e-6 +sgm = 0. +sgs = 0. +ini_stress = 1.0 +ini_head = 1.0 +thick = [1.] + + +def get_model(idx, dir): + sim = build_model(idx, dir, pch=True) + + # build MODFLOW-6 with constant material properties + pth = os.path.join(dir, compdir) + mc = build_model(idx, pth) + + return sim, mc + + +def build_model(idx, dir, pch=None): + name = ex[idx] + + # build MODFLOW 6 files + ws = dir + sim = flopy.mf6.MFSimulation(sim_name=name, version='mf6', + exe_name='mf6', + sim_ws=ws) + sim.name_file.memory_print_option = 'all' + + # create tdis package + tdis = flopy.mf6.ModflowTdis(sim, time_units='DAYS', + nper=nper, perioddata=tdis_rc) + + # create gwf model + gwf = flopy.mf6.ModflowGwf(sim, modelname=name) + + # create iterative model solution and register the gwf model with it + ims = flopy.mf6.ModflowIms(sim, print_option='SUMMARY', + outer_hclose=hclose, + outer_maximum=nouter, + under_relaxation='NONE', + inner_maximum=ninner, + inner_hclose=hclose, + rcloserecord=[rclose, 'strict'], + linear_acceleration='bicgstab', + scaling_method='NONE', + reordering_method='NONE', + relaxation_factor=relax) + sim.register_ims_package(ims, [gwf.name]) + + dis = flopy.mf6.ModflowGwfdis(gwf, nlay=nlay, nrow=nrow, ncol=ncol, + delr=delr, delc=delc, + top=top, botm=botm, + filename='{}.dis'.format(name)) + + # initial conditions + ic = flopy.mf6.ModflowGwfic(gwf, strt=strt, + filename='{}.ic'.format(name)) + + # node property flow + npf = flopy.mf6.ModflowGwfnpf(gwf, save_flows=False, + icelltype=laytyp, + k=hk, + k33=hk) + # storage + sto = flopy.mf6.ModflowGwfsto(gwf, save_flows=False, iconvert=laytyp, + ss=0., sy=sy, + storagecoefficient=True, + transient={0: True}) + + # chd files + chd = flopy.mf6.modflow.mfgwfchd.ModflowGwfchd(gwf, + maxbound=len(c6), + stress_period_data=cd6, + save_flows=False) + + # csub files + if pch is None: + sub6 = [[0, (0, 0, 1), 'delay', -ini_stress, thick[0], + 1., cc, cr, theta, kv, ini_head]] + else: + sub6 = [[0, (0, 0, 1), 'delay', ini_stress, thick[0], + 1., cc, cr, theta, kv, ini_head]] + + opth = '{}.csub.obs'.format(name) + csub = flopy.mf6.ModflowGwfcsub(gwf, + initial_preconsolidation_head=pch, + print_input=True, + save_flows=True, + ndelaycells=ndcell[idx], + ninterbeds=1, + beta=0., cg_ske_cr=0., + packagedata=sub6) + obs = [('tcomp', 'compaction-cell', (0, 0, 1)), + ('thick', 'thickness', (0,)), + ('theta', 'theta', (0,)), + ('sk', 'sk', (0, 0, 1))] + orecarray = {} + orecarray['csub_obs.csv'] = obs + + csub_obs_package = csub.obs.initialize(filename=opth, digits=10, + print_input=True, + continuous=orecarray) + + # output control + oc = flopy.mf6.ModflowGwfoc(gwf, + budget_filerecord='{}.cbc'.format(name), + head_filerecord='{}.hds'.format(name), + headprintrecord=[ + ('COLUMNS', 10, 'WIDTH', 15, + 'DIGITS', 6, 'GENERAL')], + saverecord=[('HEAD', 'ALL'), + ('BUDGET', 'ALL')], + printrecord=[('HEAD', 'ALL'), + ('BUDGET', 'ALL')]) + + return sim + + +def eval_sub(sim): + print('evaluating subsidence...') + + # MODFLOW 6 compaction results + fpth = os.path.join(sim.simpath, 'csub_obs.csv') + try: + tc = np.genfromtxt(fpth, names=True, delimiter=',') + except: + assert False, 'could not load data from "{}"'.format(fpth) + + # MODFLOW 6 base compaction results + fpth = os.path.join(sim.simpath, compdir, 'csub_obs.csv') + try: + tcb = np.genfromtxt(fpth, names=True, delimiter=',') + except: + assert False, 'could not load data from "{}"'.format(fpth) + + # calculate maximum absolute error + diff = tc['TCOMP'] - tcb['TCOMP'] + diffmax = np.abs(diff).max() + dtol = 1e-6 + msg = 'maximum absolute total-compaction difference ({}) '.format(diffmax) + + # write summary + fpth = os.path.join(sim.simpath, + '{}.comp.cmp.out'.format(os.path.basename(sim.name))) + f = open(fpth, 'w') + line = '{:>15s}'.format('TOTIM') + line += ' {:>15s}'.format('CSUB') + line += ' {:>15s}'.format('MF') + line += ' {:>15s}'.format('DIFF') + f.write(line + '\n') + for i in range(diff.shape[0]): + line = '{:15g}'.format(tc['time'][i]) + line += ' {:15g}'.format(tc['TCOMP'][i]) + line += ' {:15g}'.format(tcb['TCOMP'][i]) + line += ' {:15g}'.format(diff[i]) + f.write(line + '\n') + f.close() + + if diffmax > dtol: + sim.success = False + msg += 'exceeds {:15.7g}'.format(dtol) + assert diffmax < dtol, msg + else: + sim.success = True + print(' ' + msg) + + # compare budgets + cbc_compare(sim) + + return + + +# compare cbc and lst budgets +def cbc_compare(sim): + # open cbc file + fpth = os.path.join(sim.simpath, + '{}.cbc'.format(os.path.basename(sim.name))) + cobj = flopy.utils.CellBudgetFile(fpth, precision='double') + + # build list of cbc data to retrieve + avail = cobj.get_unique_record_names() + cbc_bud = [] + bud_lst = [] + for t in avail: + if isinstance(t, bytes): + t = t.decode() + t = t.strip() + if paktest in t.lower(): + cbc_bud.append(t) + bud_lst.append('{}_IN'.format(t)) + bud_lst.append('{}_OUT'.format(t)) + + # get results from listing file + fpth = os.path.join(sim.simpath, + '{}.lst'.format(os.path.basename(sim.name))) + budl = flopy.utils.Mf6ListBudget(fpth) + names = list(bud_lst) + d0 = budl.get_budget(names=names)[0] + dtype = d0.dtype + nbud = d0.shape[0] + d = np.recarray(nbud, dtype=dtype) + for key in bud_lst: + d[key] = 0. + + # get data from cbc dile + kk = cobj.get_kstpkper() + times = cobj.get_times() + for idx, (k, t) in enumerate(zip(kk, times)): + for text in cbc_bud: + qin = 0. + qout = 0. + v = cobj.get_data(kstpkper=k, text=text)[0] + if isinstance(v, np.recarray): + vt = np.zeros(size3d, dtype=np.float) + for jdx, node in enumerate(v['node']): + vt[node - 1] += v['q'][jdx] + v = vt.reshape(shape3d) + for kk in range(v.shape[0]): + for ii in range(v.shape[1]): + for jj in range(v.shape[2]): + vv = v[kk, ii, jj] + if vv < 0.: + qout -= vv + else: + qin += vv + d['totim'][idx] = t + d['time_step'][idx] = k[0] + d['stress_period'] = k[1] + key = '{}_IN'.format(text) + d[key][idx] = qin + key = '{}_OUT'.format(text) + d[key][idx] = qout + + diff = np.zeros((nbud, len(bud_lst)), dtype=np.float) + for idx, key in enumerate(bud_lst): + diff[:, idx] = d0[key] - d[key] + diffmax = np.abs(diff).max() + msg = 'maximum absolute total-budget difference ({}) '.format(diffmax) + + # write summary + fpth = os.path.join(sim.simpath, + '{}.bud.cmp.out'.format(os.path.basename(sim.name))) + f = open(fpth, 'w') + for i in range(diff.shape[0]): + if i == 0: + line = '{:>10s}'.format('TIME') + for idx, key in enumerate(bud_lst): + line += '{:>25s}'.format(key + '_LST') + line += '{:>25s}'.format(key + '_CBC') + line += '{:>25s}'.format(key + '_DIF') + f.write(line + '\n') + line = '{:10g}'.format(d['totim'][i]) + for idx, key in enumerate(bud_lst): + line += '{:25g}'.format(d0[key][i]) + line += '{:25g}'.format(d[key][i]) + line += '{:25g}'.format(diff[i, idx]) + f.write(line + '\n') + f.close() + + if diffmax > budtol: + sim.success = False + msg += 'exceeds {}'.format(dtol) + assert diffmax < dtol, msg + else: + sim.success = True + print(' ' + msg) + + return + + +# - No need to change any code below +def build_models(): + for idx, dir in enumerate(exdirs): + sim, mc = get_model(idx, dir) + sim.write_simulation() + if mc is not None: + mc.write_simulation() + return + + +def test_mf6model(): + # determine if running on Travis + is_travis = 'TRAVIS' in os.environ + r_exe = None + if not is_travis: + if replace_exe is not None: + r_exe = replace_exe + + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + if is_travis and not travis[idx]: + continue + yield test.run_mf6, Simulation(dir, exfunc=eval_sub, + exe_dict=r_exe, idxsim=idx) + + return + + +def main(): + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + sim = Simulation(dir, exfunc=eval_sub, exe_dict=replace_exe, + idxsim=idx) + test.run_mf6(sim) + return + + +# use python testmf6_csub_sub01.py --mf2005 mf2005devdbl +if __name__ == "__main__": + # print message + print('standalone run of {}'.format(os.path.basename(__file__))) + + # run main routine + main() diff --git a/autotest/test_gwf_csub_sub02.py b/autotest/test_gwf_csub_sub02.py new file mode 100644 index 00000000000..f0a4ca7e85d --- /dev/null +++ b/autotest/test_gwf_csub_sub02.py @@ -0,0 +1,275 @@ +import os + +try: + import pymake +except: + msg = 'Error. Pymake package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install https://github.com/modflowpy/pymake/zipball/master' + raise Exception(msg) + +try: + import flopy +except: + msg = 'Error. FloPy package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install flopy' + raise Exception(msg) + +from framework import testing_framework +from simulation import Simulation + +ex = ['csub_sub02a', 'csub_sub02b', 'csub_sub02c', 'csub_sub02d', + 'csub_sub02e'] +exdirs = [] +for s in ex: + exdirs.append(os.path.join('temp', s)) +ddir = 'data' +cg_ske = 1.14e-3 / (500. - 20.) +cg_S = cg_ske * (500. - 20.) +ss = [cg_S, cg_S, cg_ske, cg_ske, cg_S] +storagecoeff = [True, True, False, False, True] +cdelay = [False, True, False, True, True] +ndelaycells = [None, 19, None, 19, 19] + +# run all examples on Travis +# travis = [True for idx in range(len(exdirs))] +# the delay bed problems only run on the development version of MODFLOW-2005 +# set travis to True when version 1.13.0 is released +travis = [True, False, True, False, False] + +# set replace_exe to None to use default executable +replace_exe = {'mf2005': 'mf2005devdbl'} + +# static model data +nlay, nrow, ncol = 1, 1, 1 +nper = 10 +perlen = [182.625 for i in range(nper)] +nstp = [10 for i in range(nper)] +tsmult = [1.05 for i in range(nper)] +steady = [False for i in range(nper)] +delr, delc = 1000., 1000. +top = -100. +botm = [-600.] +strt = 0. +hnoflo = 1e30 +hdry = -1e30 +hk = 1e6 +laytyp = [0] +sy = 0. + +nouter, ninner = 1000, 300 +hclose, rclose, relax = 1e-6, 1e-6, 0.97 + +tdis_rc = [] +for idx in range(nper): + tdis_rc.append((perlen[idx], nstp[idx], tsmult[idx])) + +ib = 1 + +wd = {} +wd6 = {} +for i in range(nper): + if i % 2 == 0: + q = -118.3 + else: + q = 23.66 + d = [[0, 0, 0, q]] + d6 = [[(0, 0, 0), q]] + wd[i] = d + wd6[i] = d6 + +# sub data +cc = 0.005 +cr = 5e-5 +void = 0.82 +theta = void / (1. + void) +kv = 9.72e-6 +sgm = 0. +sgs = 0. +ini_stress = 0.0 +thick = [20.] +sfe = cr * thick[0] +sfv = cc * thick[0] +lnd = [0] +ldnd = [0] +dp = [[kv, cr, cc]] + +ds15 = [0, 2052, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] +ds16 = [0, 9, 0, 9, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1] + + +def get_model(idx, dir): + name = ex[idx] + + ss = 1.14e-3 + sc6 = True + if not storagecoeff[idx]: + ss /= (top - botm[0]) + sc6 = None + + if cdelay[idx]: + nndb = 0 + ndb = 1 + cdelays = 'delay' + else: + nndb = 1 + ndb = 0 + cdelays = 'nodelay' + + sub6 = [[0, (0, 0, 0), cdelays, ini_stress, thick[0], + 1., cc, cr, theta, kv, 0.]] + + # build MODFLOW 6 files + ws = dir + sim = flopy.mf6.MFSimulation(sim_name=name, version='mf6', + exe_name='mf6', + sim_ws=ws) + # create tdis package + tdis = flopy.mf6.ModflowTdis(sim, time_units='DAYS', + nper=nper, perioddata=tdis_rc) + + # create gwf model + gwf = flopy.mf6.ModflowGwf(sim, modelname=name, + model_nam_file='{}.nam'.format(name)) + + # create iterative model solution and register the gwf model with it + ims = flopy.mf6.ModflowIms(sim, print_option='SUMMARY', + outer_hclose=hclose, + outer_maximum=nouter, + under_relaxation='NONE', + inner_maximum=ninner, + inner_hclose=hclose, rcloserecord=rclose, + linear_acceleration='CG', + scaling_method='NONE', + reordering_method='NONE', + relaxation_factor=relax) + sim.register_ims_package(ims, [gwf.name]) + + dis = flopy.mf6.ModflowGwfdis(gwf, nlay=nlay, nrow=nrow, ncol=ncol, + delr=delr, delc=delc, + top=top, botm=botm, + filename='{}.dis'.format(name)) + + # initial conditions + ic = flopy.mf6.ModflowGwfic(gwf, strt=strt, + filename='{}.ic'.format(name)) + + # node property flow + npf = flopy.mf6.ModflowGwfnpf(gwf, save_flows=False, + icelltype=laytyp, + k=hk, + k33=hk) + # storage + sto = flopy.mf6.ModflowGwfsto(gwf, save_flows=False, iconvert=laytyp, + ss=0., sy=sy, + storagecoefficient=sc6, + transient={0: True}) + + # wel files + wel = flopy.mf6.ModflowGwfwel(gwf, print_input=True, print_flows=True, + maxbound=1, + stress_period_data=wd6, + save_flows=False) + + # csub files + csub = flopy.mf6.ModflowGwfcsub(gwf, head_based=True, + ndelaycells=ndelaycells[idx], + ninterbeds=1, + beta=0., cg_ske_cr=cg_ske, + packagedata=sub6) + + # output control + oc = flopy.mf6.ModflowGwfoc(gwf, + budget_filerecord='{}.cbc'.format(name), + head_filerecord='{}.hds'.format(name), + headprintrecord=[ + ('COLUMNS', 10, 'WIDTH', 15, + 'DIGITS', 6, 'GENERAL')], + saverecord=[('HEAD', 'LAST')], + printrecord=[('HEAD', 'LAST'), + ('BUDGET', 'LAST')]) + + # build MODFLOW-2005 files + ws = os.path.join(dir, 'mf2005') + mc = flopy.modflow.Modflow(name, model_ws=ws) + dis = flopy.modflow.ModflowDis(mc, nlay=nlay, nrow=nrow, ncol=ncol, + nper=nper, perlen=perlen, nstp=nstp, + tsmult=tsmult, steady=steady, delr=delr, + delc=delc, top=top, botm=botm) + bas = flopy.modflow.ModflowBas(mc, ibound=ib, strt=strt, hnoflo=hnoflo, + stoper=0.01) + lpf = flopy.modflow.ModflowLpf(mc, laytyp=laytyp, hk=hk, vka=hk, ss=ss, + sy=sy, constantcv=True, + storagecoefficient=storagecoeff[idx], + hdry=hdry) + wel = flopy.modflow.ModflowWel(mc, stress_period_data=wd) + sub = flopy.modflow.ModflowSub(mc, ndb=ndb, nndb=nndb, nn=10, idbit=1, + isuboc=1, ln=lnd, ldn=ldnd, rnb=[1.], + dp=dp, dz=thick, + dhc=ini_stress, dstart=ini_stress, + hc=ini_stress, sfe=sfe, sfv=sfv, + ids15=ds15, ids16=ds16) + oc = flopy.modflow.ModflowOc(mc, stress_period_data=None) + pcg = flopy.modflow.ModflowPcg(mc, mxiter=nouter, iter1=ninner, + hclose=hclose, rclose=rclose, + relax=relax, ihcofadd=1) + + return sim, mc + + +# - No need to change any code below +def build_models(): + for idx, dir in enumerate(exdirs): + sim, mc = get_model(idx, dir) + sim.write_simulation() + if mc is not None: + mc.write_input() + return + + +def test_mf6model(): + # determine if running on Travis + is_travis = 'TRAVIS' in os.environ + r_exe = None + if not is_travis: + if replace_exe is not None: + r_exe = replace_exe + + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + if is_travis and not travis[idx]: + continue + yield test.run_mf6, Simulation(dir, exe_dict=r_exe) + + return + + +def main(): + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for dir in exdirs: + sim = Simulation(dir, exe_dict=replace_exe) + test.run_mf6(sim) + + return + + +# use python test_gwf_csub_sub02.py --mf2005 mf2005devdbl +if __name__ == "__main__": + # print message + print('standalone run of {}'.format(os.path.basename(__file__))) + + # run main routine + main() diff --git a/autotest/test_gwf_csub_sub03.py b/autotest/test_gwf_csub_sub03.py new file mode 100644 index 00000000000..bc6362c139a --- /dev/null +++ b/autotest/test_gwf_csub_sub03.py @@ -0,0 +1,506 @@ +import os +import numpy as np + +try: + import pymake +except: + msg = 'Error. Pymake package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install https://github.com/modflowpy/pymake/zipball/master' + raise Exception(msg) + +try: + import flopy +except: + msg = 'Error. FloPy package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install flopy' + raise Exception(msg) + +from framework import testing_framework +from simulation import Simulation + +ex = ['csub_sub03a', 'csub_sub03b'] +exdirs = [] +for s in ex: + exdirs.append(os.path.join('temp', s)) +cvopt = [None, None, None] +constantcv = [True, True] +ndelaybeds = [0, 2] +ndelaycells = [None, 39] + +ddir = 'data' + +## run all examples on Travis +# travis = [False for idx in range(len(exdirs))] +travis = [True, False] + +# set replace_exe to None to use default executable +replace_exe = {'mf2005': 'mf2005devdbl'} + +htol = [None, None, None] +dtol = 1e-3 + +bud_lst = ['CSUB-ELASTIC_IN', 'CSUB-INELASTIC_IN', + 'CSUB-ELASTIC_OUT', 'CSUB-INELASTIC_OUT'] + +# static model data +nlay, nrow, ncol = 3, 10, 10 +nper = 31 +perlen = [1.] + [365.2500000 for i in range(nper - 1)] +nstp = [1] + [6 for i in range(nper - 1)] +tsmult = [1.0] + [1.3 for i in range(nper - 1)] +steady = [True] + [False for i in range(nper - 1)] +delr, delc = 1000., 2000. +top = 0. +botm = [-100, -150., -350.] +zthick = [top - botm[0], + botm[0] - botm[1], + botm[1] - botm[2]] +strt = 0. +hnoflo = 1e30 +hdry = -1e30 + +# calculate hk +hk1fact = 1. / zthick[1] +hk1 = np.ones((nrow, ncol), dtype=np.float) * 0.5 * hk1fact +hk1[0, :] = 1000. * hk1fact +hk1[-1, :] = 1000. * hk1fact +hk1[:, 0] = 1000. * hk1fact +hk1[:, -1] = 1000. * hk1fact +hk = [20., hk1, 5.] + +# calculate vka +vka = [1e6, 7.5e-5, 1e6] + +# set rest of npf variables +laytyp = [0, 0, 0] #[1, 0, 0] +ffrac = [.6, 0., .6] +sy = [0.1, 0., 0.] +ss = [3e-6, 0., 3e-6] + +nouter, ninner = 500, 300 +hclose, rclose, relax = 1e-9, 1e-6, 1. + +tdis_rc = [] +for idx in range(nper): + tdis_rc.append((perlen[idx], nstp[idx], tsmult[idx])) + +# all cells are active +ib = 1 + +# chd data +c = [] +c6 = [] +ccol = [3, 4, 5, 6] +for j in ccol: + c.append([0, nrow - 1, j, strt, strt]) + c6.append([(0, nrow - 1, j), strt]) +cd = {0: c} +cd6 = {0: c6} +maxchd = len(cd[0]) + +# pumping well data +wr = [0, 0, 0, 0, 1, 1, 2, 2, 3, 3] +wc = [0, 1, 8, 9, 0, 9, 0, 9, 0, 0] +wrp = [2, 2, 3, 3] +wcp = [5, 6, 5, 6] +wq = [-14000., -8000., -5000., -3000.] +d = [] +d6 = [] +for r, c, q in zip(wrp, wcp, wq): + d.append([2, r, c, q]) + d6.append([(2, r, c), q]) +wd = {1: d} +wd6 = {1: d6} +maxwel = len(wd[1]) + +# recharge data +q = 3000. / (delr * delc) +v = np.zeros((nrow, ncol), dtype=np.float) +for r, c in zip(wr, wc): + v[r, c] = q +rech = {0: v} + +# static ibc and sub data +sgm = 0. +sgs = 0. +omega = 1.0 + +# no delay bed data +nndb = 3 +lnd = [0, 1, 2] +hc = [-7., -7., -7.] +thicknd0 = [15., 50., 30.] +ccnd0 = [6e-4, 3e-4, 6e-4] +crnd0 = [6e-6, 3e-6, 6e-6] +sfv = [] +sfe = [] +for k in range(nlay): + sfv.append(ccnd0[k] * thicknd0[k]) + sfe.append(crnd0[k] * thicknd0[k]) + +# delay bed data +nmz = 1 +ldnd = [0, 2] +kv = 1e-6 +void = 0.82 +theta = void / (1. + void) +cc = 6e-4 +cr = 6e-6 +dp = [[kv, cr, cc]] +rnb = [7.635, 17.718] +dhc = [-7., -7.] +dz = [5.894, 5.08] +nz = [1, 1] +dstart = [] +for k in ldnd: + pth = os.path.join(ddir, 'ibc03_dstart{}.ref'.format(k + 1)) + v = np.genfromtxt(pth) + dstart.append(v.copy()) + +# sub output data +ds15 = [0, 0, 0, 2052, 0, 0, 0, 0, 0, 0, 0, 0] +ds16 = [0, nper - 1, 0, nstp[-1] - 1, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1] + + +# SUB package problem 3 +def get_model(idx, dir): + name = ex[idx] + + # ibc packagedata container counter + sub6 = [] + ibcno = 0 + + # create no delay bed packagedata entries + if nndb > 0: + cdelays = 'nodelay' + for kdx, k in enumerate(lnd): + for i in range(nrow): + for j in range(ncol): + # skip constant head cells + if k == 0 and i == nrow - 1 and j in ccol: + continue + tag = '{:02d}_{:02d}_{:02d}'.format(k+1, i+1, j+1) + # create nodelay entry + # no delay beds + b = thicknd0[kdx] + d = [ibcno, (k, i, j), cdelays, hc[idx], + b, 1., ccnd0[kdx], crnd0[kdx], theta, + 999., -999., tag] + sub6.append(d) + ibcno += 1 + + # create delay bed packagedata entries and coarse-grained material storage + S = [] + ndb = ndelaybeds[idx] + if ndb > 0: + cdelays = 'delay' + for kdx, k in enumerate(ldnd): + for i in range(nrow): + for j in range(ncol): + # skip constant head cells + if k == 0 and i == nrow - 1 and j in ccol: + continue + tag = '{:02d}_{:02d}_{:02d}'.format(k+1, i+1, j+1) + # create nodelay entry + d = [ibcno, (k, i, j), cdelays, dhc[kdx], dz[kdx], + rnb[kdx], cc, cr, theta, kv, dstart[kdx][i, j], + tag] + sub6.append(d) + ibcno += 1 + + # create S for aquifer, delay beds, and no-delay beds + for k in range(nlay): + sst = (1. - ffrac[k]) * zthick[k] * ss[k] + S.append(sst) + else: + # create S for aquifer and no-delay beds + for k in range(nlay): + sst = (zthick[k] - thicknd0[k]) * ss[k] + S.append(sst) + + maxibc = len(sub6) + + + # build MODFLOW 6 files + ws = dir + sim = flopy.mf6.MFSimulation(sim_name=name, + version='mf6', + exe_name='mf6', + sim_ws=ws) + # create tdis package + tdis = flopy.mf6.ModflowTdis(sim, time_units='DAYS', + nper=nper, perioddata=tdis_rc) + + # create gwf model + gwf = flopy.mf6.ModflowGwf(sim, modelname=name) + + # create iterative model solution and register the gwf model with it + ims = flopy.mf6.ModflowIms(sim, print_option='SUMMARY', + outer_hclose=hclose, + outer_maximum=nouter, + under_relaxation='NONE', + inner_maximum=ninner, + inner_hclose=hclose, rcloserecord=rclose, + linear_acceleration='CG', + scaling_method='NONE', + reordering_method='NONE', + relaxation_factor=relax) + sim.register_ims_package(ims, [gwf.name]) + + dis = flopy.mf6.ModflowGwfdis(gwf, nlay=nlay, nrow=nrow, ncol=ncol, + delr=delr, delc=delc, + top=top, botm=botm, + filename='{}.dis'.format(name)) + + # initial conditions + ic = flopy.mf6.ModflowGwfic(gwf, strt=strt, + filename='{}.ic'.format(name)) + + # node property flow + npf = flopy.mf6.ModflowGwfnpf(gwf, save_flows=False, + icelltype=laytyp, + cvoptions=cvopt[idx], + k=hk, + k33=vka) + # storage + sto = flopy.mf6.ModflowGwfsto(gwf, save_flows=False, iconvert=laytyp, + #ss=S, sy=sy, + ss=0., sy=sy, + storagecoefficient=True, + steady_state={0: True}, + transient={1: True}) + + # recharge + rch = flopy.mf6.ModflowGwfrcha(gwf, readasarrays=True, recharge=rech) + + # wel file + wel = flopy.mf6.ModflowGwfwel(gwf, print_input=True, print_flows=True, + maxbound=maxwel, + stress_period_data=wd6, + save_flows=False) + + # chd files + chd = flopy.mf6.modflow.mfgwfchd.ModflowGwfchd(gwf, + maxbound=maxchd, + stress_period_data=cd6, + save_flows=False) + # csub files + opth = '{}.csub.obs'.format(name) + ibcsv = '{}.ib.strain.csv'.format(name) + skcsv = '{}.sk.strain.csv'.format(name) + copth = '{}.compaction.bin'.format(name) + csub = flopy.mf6.ModflowGwfcsub(gwf, + print_input=True, + boundnames=True, + head_based=True, + effective_stress_lag=True, + specified_initial_interbed_state=True, + save_flows=True, + strainib_filerecord=ibcsv, + straincg_filerecord=skcsv, + compaction_filerecord=copth, + ndelaycells=ndelaycells[idx], + ninterbeds=maxibc, + beta=0., cg_ske_cr=ss, + packagedata=sub6) + orecarray = {} + orecarray['csub_obs.csv'] = [('tcomp1', 'interbed-compaction', '01_05_05'), + ('tcomp2', 'interbed-compaction', '02_05_05'), + ('tcomp3', 'interbed-compaction', '03_05_05')] + csub_obs_package = csub.obs.initialize(filename=opth, digits=10, + print_input=True, + continuous=orecarray) + + # output control + oc = flopy.mf6.ModflowGwfoc(gwf, + budget_filerecord='{}.cbc'.format(name), + head_filerecord='{}.hds'.format(name), + headprintrecord=[ + ('COLUMNS', 10, 'WIDTH', 15, + 'DIGITS', 6, 'GENERAL')], + saverecord=[('HEAD', 'LAST'), + ('BUDGET', 'LAST')], + printrecord=[('HEAD', 'LAST'), + ('BUDGET', 'LAST')]) + + # build MODFLOW-2005 files + ws = os.path.join(dir, 'mf2005') + mc = flopy.modflow.Modflow(name, model_ws=ws) + dis = flopy.modflow.ModflowDis(mc, nlay=nlay, nrow=nrow, ncol=ncol, + nper=nper, perlen=perlen, nstp=nstp, + tsmult=tsmult, steady=steady, delr=delr, + delc=delc, top=top, botm=botm) + bas = flopy.modflow.ModflowBas(mc, ibound=ib, strt=strt, hnoflo=hnoflo, + stoper=0.01) + lpf = flopy.modflow.ModflowLpf(mc, laytyp=laytyp, hk=hk, vka=vka, + ss=S, sy=sy, + constantcv=constantcv[idx], + storagecoefficient=True, + hdry=hdry) + chd = flopy.modflow.ModflowChd(mc, stress_period_data=cd) + rch = flopy.modflow.ModflowRch(mc, rech=rech) + wel = flopy.modflow.ModflowWel(mc, stress_period_data=wd) + sub = flopy.modflow.ModflowSub(mc, ndb=ndb, nndb=nndb, nmz=nmz, nn=20, + idbit=1, ac2=omega, + isuboc=1, ln=lnd, ldn=ldnd, rnb=rnb, + dp=dp, dz=dz, nz=nz, + dhc=dhc, dstart=dstart, + hc=hc, sfe=sfe, sfv=sfv, + ids15=ds15, ids16=ds16) + oc = flopy.modflow.ModflowOc(mc, stress_period_data=None) + # sip = flopy.modflow.ModflowSip(mc, accl=1., mxiter=nouter, nparm=5, + # hclose=hclose, ipcalc=1, + # wseed=0., iprsip=1) + pcg = flopy.modflow.ModflowPcg(mc, mxiter=nouter, iter1=ninner, + hclose=hclose, rclose=rclose, + relax=relax) + + return sim, mc + + +def eval_comp(sim): + print('evaluating compaction...') + + # MODFLOW 6 total compaction results + fpth = os.path.join(sim.simpath, 'csub_obs.csv') + try: + tc = np.genfromtxt(fpth, names=True, delimiter=',') + except: + assert False, 'could not load data from "{}"'.format(fpth) + + # MODFLOW-2005 total compaction results + fn = '{}.total_comp.hds'.format(os.path.basename(sim.name)) + fpth = os.path.join(sim.simpath, 'mf2005', fn) + try: + sobj = flopy.utils.HeadFile(fpth, text='LAYER COMPACTION') + tc0 = sobj.get_ts((2, 4, 4)) + except: + assert False, 'could not load data from "{}"'.format(fpth) + + # calculate maximum absolute error + diff = tc['TCOMP3'] - tc0[:, 1] + diffmax = np.abs(diff).max() + msg = 'maximum absolute total-compaction difference ({}) '.format(diffmax) + + if diffmax > dtol: + sim.success = False + msg += 'exceeds {}'.format(dtol) + assert diffmax < dtol, msg + else: + sim.success = True + print(' ' + msg) + + # get results from listing file + fpth = os.path.join(sim.simpath, + '{}.lst'.format(os.path.basename(sim.name))) + budl = flopy.utils.Mf6ListBudget(fpth) + names = list(bud_lst) + d0 = budl.get_budget(names=names)[0] + dtype = d0.dtype + nbud = d0.shape[0] + + # get results from cbc file + cbc_bud = ['CSUB-ELASTIC', 'CSUB-INELASTIC'] + d = np.recarray(nbud, dtype=dtype) + for key in bud_lst: + d[key] = 0. + fpth = os.path.join(sim.simpath, + '{}.cbc'.format(os.path.basename(sim.name))) + cobj = flopy.utils.CellBudgetFile(fpth, precision='double') + kk = cobj.get_kstpkper() + times = cobj.get_times() + for idx, (k, t) in enumerate(zip(kk, times)): + for text in cbc_bud: + qin = 0. + qout = 0. + v = cobj.get_data(kstpkper=k, text=text)[0] + for vv in v['q']: + if vv < 0.: + qout -= vv + else: + qin += vv + d['totim'][idx] = t + d['time_step'][idx] = k[0] + d['stress_period'] = k[1] + key = '{}_IN'.format(text) + d[key][idx] = qin + key = '{}_OUT'.format(text) + d[key][idx] = qout + + diff = np.zeros((nbud, len(bud_lst)), dtype=np.float) + for idx, key in enumerate(bud_lst): + diff[:, idx] = d0[key] - d[key] + diffmax = np.abs(diff).max() + msg = 'maximum absolute total-budget difference ({}) '.format(diffmax) + + if diffmax > dtol: + sim.success = False + msg += 'exceeds {}'.format(dtol) + assert diffmax < dtol, msg + else: + sim.success = True + print(' ' + msg) + + return + + +# - No need to change any code below +def build_models(): + for idx, dir in enumerate(exdirs): + sim, mc = get_model(idx, dir) + sim.write_simulation() + if mc is not None: + mc.write_input() + return + + +def test_mf6model(): + # determine if running on Travis + is_travis = 'TRAVIS' in os.environ + r_exe = None + if not is_travis: + if replace_exe is not None: + r_exe = replace_exe + + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + if is_travis and not travis[idx]: + continue + yield test.run_mf6, Simulation(dir, exfunc=eval_comp, + exe_dict=r_exe, + htol=htol[idx]) + + return + + +def main(): + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + sim = Simulation(dir, exfunc=eval_comp, + exe_dict=replace_exe, htol=htol[idx]) + test.run_mf6(sim) + + return + + +# use python test_gwf_csub_sub03.py --mf2005 mf2005devdbl +if __name__ == "__main__": + # print message + print('standalone run of {}'.format(os.path.basename(__file__))) + + # run main routine + main() diff --git a/autotest/test_gwf_csub_subwt01.py b/autotest/test_gwf_csub_subwt01.py new file mode 100644 index 00000000000..fc9c800bf8a --- /dev/null +++ b/autotest/test_gwf_csub_subwt01.py @@ -0,0 +1,500 @@ +import os +import sys +import numpy as np + +try: + import pymake +except: + msg = 'Error. Pymake package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install https://github.com/modflowpy/pymake/zipball/master' + raise Exception(msg) + +try: + import flopy +except: + msg = 'Error. FloPy package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install flopy' + raise Exception(msg) + +from framework import testing_framework +from simulation import Simulation + +ex = ['csub_subwt01a', 'csub_subwt01b', 'csub_subwt01c', 'csub_subwt01d'] +exdirs = [] +for s in ex: + exdirs.append(os.path.join('temp', s)) +ddir = 'data' +cmppth = 'mf2005' + +htol = [None for n in ex] +dtol = 1e-3 +budtol = 1e-2 + +paktest = 'csub' + +ump = [None, True, None, True] +ivoid = [0, 1, 0, 1] +gs0 = [0., 0., 1700., 1700.] + +# set travis to True when version 1.13.0 is released +travis = [True for n in ex] + +# set replace_exe to None to use default executable +replace_exe = None + +# temporal discretization +nper = 3 +perlen = [1., 21915., 21915.] +nstp = [1, 60, 60] +tsmult = [1., 1., 1.] +steady = [True, False, False] + +# spatial discretization +nlay, nrow, ncol = 1, 1, 3 +shape3d = (nlay, nrow, ncol) +size3d = nlay * nrow * ncol + +delr, delc = 2000., 2000. +top = 150. +botm = [-350.] +strt = 100. + +hnoflo = 1e30 +hdry = -1e30 + +# upw data +laytyp = [1] +hk = [4.] +sy = [0.3] + +hstart = [100., 50.] + +chd0 = [(0, 0, 0, hstart[0]+1, hstart[0]+1), + (0, 0, 2, hstart[0], hstart[0])] +chd1 = [(0, 0, 0, hstart[1]+1, hstart[1]+1), + (0, 0, 2, hstart[1], hstart[1])] +cd = {0: chd0, 1: chd1, 2: chd0} + +chd6_0 = [((0, 0, 0), hstart[0]+1), + ((0, 0, 2), hstart[0])] +chd6_1 = [((0, 0, 0), hstart[1]+1), + ((0, 0, 2), hstart[1])] +cd6 = {0: chd6_0, 1: chd6_1, 2: chd6_0} + +nouter, ninner = 100, 300 +hclose, rclose, relax = 1e-6, 0.01, 0.97 +fluxtol = rclose + +tdis_rc = [] +for idx in range(nper): + tdis_rc.append((perlen[idx], nstp[idx], tsmult[idx])) + +# this used to work +# ib = np.zeros((nlay, nrow, ncol), dtype=np.int) +# for k in range(nlay): +ib = [1] + +# subwt data +cc = 0.25 +cr = 0.01 +void = 0.82 +theta = void / (1. + void) +kv = 999. +sgm = 1.7 +sgs = 2.0 +ini_stress = 0. #15.0 +delay_flag = 0 +thick = [45., 70., 50., 90.] + +zthick = [top - botm[0]] + +beta = 0. +#beta = 4.65120000e-10 +gammaw = 9806.65000000 +sw = beta * gammaw * theta +ss = [sw for k in range(nlay)] + +swt6 = [] +ibcno = 0 +for k in range(len(thick)): + for i in range(nrow): + for j in range(ncol): + iactive = 0 + if j == 1: + iactive = 1 + if iactive > 0: + tag = '{:02d}_{:02d}_{:02d}'.format(1, i + 1, j + 1) + d = [ibcno, (0, i, j), 'nodelay', ini_stress, thick[k], + 1., cc, cr, theta, + kv, 999., tag] + swt6.append(d) + ibcno += 1 + +ds16 = [0, 0, 0, 2052, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] +ds17 = [0, 10000, 0, 10000, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] + + +def get_model(idx, dir): + name = ex[idx] + + # build MODFLOW 6 files + ws = dir + sim = flopy.mf6.MFSimulation(sim_name=name, + memory_print_option='all', + version='mf6', + exe_name='mf6', + sim_ws=ws) + # create tdis package + tdis = flopy.mf6.ModflowTdis(sim, time_units='DAYS', + nper=nper, perioddata=tdis_rc) + + # create gwf model + gwf = flopy.mf6.ModflowGwf(sim, modelname=name, save_flows=True, + print_input=True) + + # create iterative model solution and register the gwf model with it + ims = flopy.mf6.ModflowIms(sim, print_option='SUMMARY', + outer_hclose=hclose, + outer_maximum=nouter, + under_relaxation='NONE', + inner_maximum=ninner, + inner_hclose=hclose, rcloserecord=rclose, + linear_acceleration='BICGSTAB', + scaling_method='NONE', + reordering_method='NONE', + relaxation_factor=relax) + sim.register_ims_package(ims, [gwf.name]) + + dis = flopy.mf6.ModflowGwfdis(gwf, nlay=nlay, nrow=nrow, ncol=ncol, + delr=delr, delc=delc, + top=top, botm=botm, + idomain=ib, + filename='{}.dis'.format(name)) + + # initial conditions + ic = flopy.mf6.ModflowGwfic(gwf, strt=strt, + filename='{}.ic'.format(name)) + + # node property flow + npf = flopy.mf6.ModflowGwfnpf(gwf, save_flows=False, + icelltype=laytyp, + k=hk, + k33=hk) + # storage + sto = flopy.mf6.ModflowGwfsto(gwf, save_flows=False, iconvert=laytyp, + ss=0., sy=sy, + steady_state={0: True}, + transient={1: True}) + + # chd files + chd = flopy.mf6.modflow.mfgwfchd.ModflowGwfchd(gwf, + maxbound=len(chd6_0), + stress_period_data=cd6, + save_flows=False) + + # csub files + gg = [] + for i in range(nrow): + for j in range(ncol): + gg.append([(0, i, j), gs0[idx]]) + sig0 = {0: gg} + opth = '{}.csub.obs'.format(name) + fcgstrain = '{}.csub.strain.cg.csv'.format(name) + fibstrain = '{}.csub.strain.ib.csv'.format(name) + csub = flopy.mf6.ModflowGwfcsub(gwf, + straincg_filerecord=fcgstrain, + strainib_filerecord=fibstrain, + boundnames=True, + compression_indices=True, + update_material_properties=ump[idx], + effective_stress_lag=True, + ninterbeds=len(swt6), + sgs=sgs, sgm=sgm, + beta=beta, + gammaw=gammaw, + cg_ske_cr=0., + cg_theta=theta, + packagedata=swt6, + maxsig0=len(gg), + stress_period_data=sig0) + orecarray = {} + orecarray['csub_obs.csv'] = [('w1l1', 'interbed-compaction', '01_01_02'), + ('w1l1t', 'csub-cell', (0, 0, 1))] + csub_obs_package = csub.obs.initialize(filename=opth, digits=10, + print_input=True, + continuous=orecarray) + + # output control + oc = flopy.mf6.ModflowGwfoc(gwf, + budget_filerecord='{}.cbc'.format(name), + head_filerecord='{}.hds'.format(name), + headprintrecord=[ + ('COLUMNS', 10, 'WIDTH', 15, + 'DIGITS', 6, 'GENERAL')], + saverecord=[('HEAD', 'ALL'), + ('BUDGET', 'ALL')], + printrecord=[('HEAD', 'LAST'), + ('BUDGET', 'ALL')]) + + # build MODFLOW-2005 files + ws = os.path.join(dir, cmppth) + mc = flopy.modflow.Modflow(name, model_ws=ws, version=cmppth) + dis = flopy.modflow.ModflowDis(mc, nlay=nlay, nrow=nrow, ncol=ncol, + nper=nper, perlen=perlen, nstp=nstp, + tsmult=tsmult, steady=steady, delr=delr, + delc=delc, top=top, botm=botm) + bas = flopy.modflow.ModflowBas(mc, ibound=ib, strt=strt, hnoflo=hnoflo) + lpf = flopy.modflow.ModflowLpf(mc, laytyp=laytyp, + hk=hk, vka=hk, + ss=ss, sy=sy, + hdry=hdry) + # upw = flopy.modflow.ModflowUpw(mc, laytyp=laytyp, + # hk=hk, vka=hk, + # ss=ss, sy=sy, + # hdry=hdry) + chd = flopy.modflow.ModflowChd(mc, stress_period_data=cd) + swt = flopy.modflow.ModflowSwt(mc, ipakcb=1001, + iswtoc=1, nsystm=4, + ithk=1, + ivoid=ivoid[idx], + istpcs=1, lnwt=[0, 0, 0, 0], + cc=cc, cr=cr, thick=thick, + void=void, pcsoff=ini_stress, sgs=sgs, + gl0=gs0[idx], ids16=ds16, ids17=ds17) + oc = flopy.modflow.ModflowOc(mc, stress_period_data=None, + save_every=1, + save_types=['save head', 'save budget', + 'print budget']) + pcg = flopy.modflow.ModflowPcg(mc, mxiter=nouter, iter1=ninner, + hclose=hclose, rclose=rclose, + relax=relax, ihcofadd=1) + # nwt = flopy.modflow.ModflowNwt(mc, + # headtol=hclose, fluxtol=fluxtol, + # maxiterout=nouter, linmeth=2, + # unitnumber=132, + # options='SPECIFIED', + # backflag=0, idroptol=0, + # hclosexmd=hclose, mxiterxmd=ninner, + # ibotav=1) + + return sim, mc + + +def eval_comp(sim): + + print('evaluating compaction...') + # MODFLOW 6 total compaction results + fpth = os.path.join(sim.simpath, 'csub_obs.csv') + try: + tc = np.genfromtxt(fpth, names=True, delimiter=',') + except: + assert False, 'could not load data from "{}"'.format(fpth) + + # MODFLOW-NWT total compaction results + cpth = cmppth + fn = '{}.swt_total_comp.hds'.format(os.path.basename(sim.name)) + fpth = os.path.join(sim.simpath, cpth, fn) + try: + sobj = flopy.utils.HeadFile(fpth, text='LAYER COMPACTION') + tc0 = sobj.get_ts((0, 0, 1)) + except: + assert False, 'could not load data from "{}"'.format(fpth) + + # calculate maximum absolute error + loctag = 'W1L1' + diff = tc[loctag] - tc0[:, 1] + diffmax = np.abs(diff).max() + msg = 'maximum absolute total-compaction difference ({}) '.format(diffmax) + + # write summary + fpth = os.path.join(sim.simpath, + '{}.comp.cmp.out'.format(os.path.basename(sim.name))) + f = open(fpth, 'w') + line = '{:>15s}'.format('TOTIM') + line += ' {:>15s}'.format('CSUB') + line += ' {:>15s}'.format('MF') + line += ' {:>15s}'.format('DIFF') + f.write(line + '\n') + for i in range(diff.shape[0]): + line = '{:15g}'.format(tc0[i, 0]) + line += ' {:15g}'.format(tc[loctag][i]) + line += ' {:15g}'.format(tc0[i, 1]) + line += ' {:15g}'.format(diff[i]) + f.write(line + '\n') + f.close() + + if diffmax > dtol: + sim.success = False + msg += 'exceeds {}'.format(dtol) + assert diffmax < dtol, msg + else: + sim.success = True + print(' ' + msg) + + # compare budgets + cbc_compare(sim) + + return + + +# compare cbc and lst budgets +def cbc_compare(sim): + print('evaluating cbc and budget...') + # open cbc file + fpth = os.path.join(sim.simpath, + '{}.cbc'.format(os.path.basename(sim.name))) + cobj = flopy.utils.CellBudgetFile(fpth, precision='double') + + # build list of cbc data to retrieve + avail = cobj.get_unique_record_names() + cbc_bud = [] + bud_lst = [] + for t in avail: + if isinstance(t, bytes): + t = t.decode() + t = t.strip() + if paktest in t.lower(): + cbc_bud.append(t) + bud_lst.append('{}_IN'.format(t)) + bud_lst.append('{}_OUT'.format(t)) + + # get results from listing file + fpth = os.path.join(sim.simpath, + '{}.lst'.format(os.path.basename(sim.name))) + budl = flopy.utils.Mf6ListBudget(fpth) + names = list(bud_lst) + d0 = budl.get_budget(names=names)[0] + dtype = d0.dtype + nbud = d0.shape[0] + d = np.recarray(nbud, dtype=dtype) + for key in bud_lst: + d[key] = 0. + + # get data from cbc dile + kk = cobj.get_kstpkper() + times = cobj.get_times() + for idx, (k, t) in enumerate(zip(kk, times)): + for text in cbc_bud: + qin = 0. + qout = 0. + v = cobj.get_data(kstpkper=k, text=text)[0] + if isinstance(v, np.recarray): + vt = np.zeros(size3d, dtype=np.float) + for jdx, node in enumerate(v['node']): + vt[node - 1] += v['q'][jdx] + v = vt.reshape(shape3d) + for kk in range(v.shape[0]): + for ii in range(v.shape[1]): + for jj in range(v.shape[2]): + vv = v[kk, ii, jj] + if vv < 0.: + qout -= vv + else: + qin += vv + d['totim'][idx] = t + d['time_step'][idx] = k[0] + d['stress_period'] = k[1] + key = '{}_IN'.format(text) + d[key][idx] = qin + key = '{}_OUT'.format(text) + d[key][idx] = qout + + diff = np.zeros((nbud, len(bud_lst)), dtype=np.float) + for idx, key in enumerate(bud_lst): + diff[:, idx] = d0[key] - d[key] + diffmax = np.abs(diff).max() + msg = 'maximum absolute total-budget difference ({}) '.format(diffmax) + + # write summary + fpth = os.path.join(sim.simpath, + '{}.bud.cmp.out'.format(os.path.basename(sim.name))) + f = open(fpth, 'w') + for i in range(diff.shape[0]): + if i == 0: + line = '{:>10s}'.format('TIME') + for idx, key in enumerate(bud_lst): + line += '{:>25s}'.format(key + '_LST') + line += '{:>25s}'.format(key + '_CBC') + line += '{:>25s}'.format(key + '_DIF') + f.write(line + '\n') + line = '{:10g}'.format(d['totim'][i]) + for idx, key in enumerate(bud_lst): + line += '{:25g}'.format(d0[key][i]) + line += '{:25g}'.format(d[key][i]) + line += '{:25g}'.format(diff[i, idx]) + f.write(line + '\n') + f.close() + + if diffmax > budtol: + sim.success = False + msg += 'exceeds {}'.format(dtol) + assert diffmax < dtol, msg + else: + sim.success = True + print(' ' + msg) + + return + + +# - No need to change any code below +def build_models(): + for idx, dir in enumerate(exdirs): + sim, mc = get_model(idx, dir) + sim.write_simulation() + if mc is not None: + mc.write_input() + return + + +def test_mf6model(): + # determine if running on Travis + is_travis = 'TRAVIS' in os.environ + r_exe = None + if not is_travis: + if replace_exe is not None: + r_exe = replace_exe + + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + if is_travis and not travis[idx]: + continue + yield test.run_mf6, Simulation(dir, exe_dict=r_exe, + exfunc=eval_comp, + htol=htol[idx]) + + return + + +def main(): + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for dir in exdirs: + sim = Simulation(dir, exe_dict=replace_exe, + exfunc=eval_comp, + htol=htol[idx]) + test.run_mf6(sim) + + return + + +if __name__ == "__main__": + # print message + print('standalone run of {}'.format(os.path.basename(__file__))) + + # run main routine + main() diff --git a/autotest/test_gwf_csub_subwt02.py b/autotest/test_gwf_csub_subwt02.py new file mode 100644 index 00000000000..70f655f1b7e --- /dev/null +++ b/autotest/test_gwf_csub_subwt02.py @@ -0,0 +1,626 @@ +import os +import sys +import numpy as np + +try: + import pymake +except: + msg = 'Error. Pymake package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install https://github.com/modflowpy/pymake/zipball/master' + raise Exception(msg) + +try: + import flopy +except: + msg = 'Error. FloPy package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install flopy' + raise Exception(msg) + +from framework import testing_framework +from simulation import Simulation + +ex = ['csub_subwt02a', 'csub_subwt02b', 'csub_subwt02c', 'csub_subwt02d'] +exdirs = [] +for s in ex: + exdirs.append(os.path.join('temp', s)) +ddir = 'data' +cmppth = 'mfnwt' + +htol = [None, None, None, None] +dtol = 1e-3 +budtol = 1e-2 + +paktest = 'csub' + +ump = [None, True, None, True] +ivoid = [0, 1, 0, 1] +gs0 = [0., 0., 1700., 1700.] + +# set travis to True when version 1.13.0 is released +travis = [True, True, True, True] + +# set replace_exe to None to use default executable +replace_exe = None + +# static model data +pth = os.path.join(ddir, 'ibc01_ibound.ref') +ib0 = np.genfromtxt(pth) + +# temporal discretization +nper = 3 +perlen = [1., 21915., 21915.] +nstp = [1, 60, 60] +tsmult = [1., 1., 1.] +steady = [True, False, False] + +# spatial discretization +nlay, nrow, ncol = 4, ib0.shape[0], ib0.shape[1] +shape3d = (nlay, nrow, ncol) +size3d = nlay * nrow * ncol +nactive = np.count_nonzero(ib0) * nlay + +delr, delc = 2000., 2000. +top = 150. +botm = [50., -100., -150., -350.] +strt = 100. + +hnoflo = 1e30 +hdry = -1e30 + +# upw data +laytyp = [1, 0, 0, 0] +hk = [4., 4., 1e-2, 4.] +k33 = [.4, .4, 1e-2, .4] +sy = [0.3, 0., 0., 0.] + +w1 = [(0, 0, 7, 2.2000000E+03), + (0, 1, 4, 2.2000000E+03), + (0, 1, 7, 2.2000000E+03), + (0, 1, 11, 2.2000000E+03), + (0, 2, 3, 2.2000000E+03), + (0, 3, 11, 2.2000000E+03), + (0, 4, 2, 2.2000000E+03), + (0, 4, 12, 2.2000000E+03), + (0, 5, 13, 2.2000000E+03), + (0, 6, 1, 2.2000000E+03), + (0, 13, 1, 2.2000000E+03), + (0, 13, 13, 2.2000000E+03), + (0, 15, 2, 2.2000000E+03), + (0, 15, 12, 2.2000000E+03), + (0, 16, 12, 2.2000000E+03), + (0, 17, 3, 2.2000000E+03), + (0, 17, 11, 2.2000000E+03), + (0, 18, 6, 2.2000000E+03)] +w2 = [(0, 0, 7, 2.2000000E+03), + (0, 1, 4, 2.2000000E+03), + (0, 1, 7, 2.2000000E+03), + (0, 1, 11, 2.2000000E+03), + (0, 2, 3, 2.2000000E+03), + (0, 3, 11, 2.2000000E+03), + (0, 4, 2, 2.2000000E+03), + (0, 4, 12, 2.2000000E+03), + (0, 5, 13, 2.2000000E+03), + (0, 6, 1, 2.2000000E+03), + (0, 13, 1, 2.2000000E+03), + (0, 13, 13, 2.2000000E+03), + (0, 15, 2, 2.2000000E+03), + (0, 15, 12, 2.2000000E+03), + (0, 16, 12, 2.2000000E+03), + (0, 17, 3, 2.2000000E+03), + (0, 17, 11, 2.2000000E+03), + (0, 18, 6, 2.2000000E+03), + (1, 8, 9, -7.2000000E+04), + (3, 11, 6, -7.2000000E+04)] +wd = {0: w1, 1: w2, 2: w1} + +ws2 = [((1, 8, 9), -7.2000000E+04), + ((3, 11, 6), -7.2000000E+04)] +ws3 = [((1, 8, 9), 0), + ((3, 11, 6), 0)] +wd6 = {1: ws2, 2: ws3} + +rch0 = [((0, 0, 7), 0.00055), + ((0, 1, 4), 0.00055), + ((0, 1, 7), 0.00055), + ((0, 1, 11), 0.00055), + ((0, 2, 3), 0.00055), + ((0, 3, 11), 0.00055), + ((0, 4, 2), 0.00055), + ((0, 4, 12), 0.00055), + ((0, 5, 13), 0.00055), + ((0, 6, 1), 0.00055), + ((0, 13, 1), 0.00055), + ((0, 13, 13), 0.00055), + ((0, 15, 2), 0.00055), + ((0, 15, 12), 0.00055), + ((0, 16, 12), 0.00055), + ((0, 17, 3), 0.00055), + ((0, 17, 11), 0.00055), + ((0, 18, 6), 0.00055)] +rch6 = {0: rch0} + +chd1 = [(0, 19, 7, 100.00000, 100.00000), + (0, 19, 8, 100.00000, 100.00000), + (1, 19, 7, 100.00000, 100.00000), + (1, 19, 8, 100.00000, 100.00000), + (2, 19, 7, 100.00000, 100.00000), + (2, 19, 8, 100.00000, 100.00000), + (3, 19, 7, 100.00000, 100.00000), + (3, 19, 8, 100.00000, 100.00000)] +cd = {0: chd1} + +chd6 = [((0, 19, 7), 100.00000), + ((0, 19, 8), 100.00000), + ((1, 19, 7), 100.00000), + ((1, 19, 8), 100.00000), + ((2, 19, 7), 100.00000), + ((2, 19, 8), 100.00000), + ((3, 19, 7), 100.00000), + ((3, 19, 8), 100.00000)] +cd6 = {0: chd6} + +nouter, ninner = 100, 300 +hclose, rclose, relax = 1e-6, 0.01, 0.97 +fluxtol = nactive * rclose + +tdis_rc = [] +for idx in range(nper): + tdis_rc.append((perlen[idx], nstp[idx], tsmult[idx])) + +# this used to work +# ib = np.zeros((nlay, nrow, ncol), dtype=np.int) +# for k in range(nlay): +# ib[k, :, :] = ib0.copy() +ib = [] +for k in range(nlay): + ib.append(ib0.astype(np.int).copy()) + +# subwt data +cc = 0.25 +cr = 0.01 +void = 0.82 +theta = void / (1. + void) +kv = 999. +sgm = 1.7 +sgs = 2.0 +ini_stress = 15.0 +delay_flag = 0 +thick = [45., 70., 50., 90.] + +zthick = [top - botm[0], + botm[0] - botm[1], + botm[1] - botm[2], + botm[2] - botm[3]] + +beta = 0. +# beta = 4.65120000e-10 +gammaw = 9806.65000000 +sw = beta * gammaw * theta +ss = [sw for k in range(nlay)] + +swt6 = [] +ibcno = 0 +for k in range(nlay): + for i in range(nrow): + for j in range(ncol): + iactive = 0 + if ib0[i, j] > 0: + iactive = 1 + if i == 19 and (j == 7 or j == 8): + iactive = 0 + if iactive > 0: + tag = '{:02d}_{:02d}_{:02d}'.format(k + 1, i + 1, j + 1) + d = [ibcno, (k, i, j), 'nodelay', ini_stress, thick[k], + 1., cc, cr, theta, + kv, 999., tag] + swt6.append(d) + ibcno += 1 + +ds16 = [0, 0, 0, 2052, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] +ds17 = [0, 10000, 0, 10000, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] + + +def get_model(idx, dir): + name = ex[idx] + + # build MODFLOW 6 files + ws = dir + sim = flopy.mf6.MFSimulation(sim_name=name, version='mf6', + exe_name='mf6', + sim_ws=ws) + # create tdis package + tdis = flopy.mf6.ModflowTdis(sim, time_units='DAYS', + nper=nper, perioddata=tdis_rc) + + # create gwf model + gwf = flopy.mf6.ModflowGwf(sim, modelname=name, save_flows=True, + newtonoptions='') + + # create iterative model solution and register the gwf model with it + ims = flopy.mf6.ModflowIms(sim, print_option='SUMMARY', + outer_hclose=hclose, + outer_maximum=nouter, + under_relaxation='NONE', + inner_maximum=ninner, + inner_hclose=hclose, rcloserecord=rclose, + linear_acceleration='BICGSTAB', + scaling_method='NONE', + reordering_method='NONE', + relaxation_factor=relax) + sim.register_ims_package(ims, [gwf.name]) + + dis = flopy.mf6.ModflowGwfdis(gwf, nlay=nlay, nrow=nrow, ncol=ncol, + delr=delr, delc=delc, + top=top, botm=botm, + idomain=ib, + filename='{}.dis'.format(name)) + + # initial conditions + ic = flopy.mf6.ModflowGwfic(gwf, strt=strt, + filename='{}.ic'.format(name)) + + # node property flow + npf = flopy.mf6.ModflowGwfnpf(gwf, save_flows=False, + icelltype=laytyp, + k=hk, + k33=k33) + # storage + sto = flopy.mf6.ModflowGwfsto(gwf, save_flows=False, iconvert=laytyp, + ss=0., sy=sy, + steady_state={0: True}, + transient={1: True}) + + # chd files + chd = flopy.mf6.modflow.mfgwfchd.ModflowGwfchd(gwf, + maxbound=len(chd6), + stress_period_data=cd6, + save_flows=False) + + # wel files + wel = flopy.mf6.ModflowGwfwel(gwf, print_input=True, print_flows=True, + maxbound=len(ws2), + stress_period_data=wd6, + save_flows=False) + # recharge file + flopy.mf6.ModflowGwfrch(gwf, print_input=True, print_flows=True, + maxbound=len(rch0), + stress_period_data=rch6, + save_flows=False) + + # csub files + gg = [] + for i in range(nrow): + for j in range(ncol): + if ib0[i, j] > 0: + gg.append([(0, i, j), gs0[idx]]) + sig0 = {0: gg} + opth = '{}.csub.obs'.format(name) + csub = flopy.mf6.ModflowGwfcsub(gwf, + # interbed_stress_offset=True, + boundnames=True, + compression_indices=True, + update_material_properties=ump[idx], + effective_stress_lag=True, + ninterbeds=len(swt6), + sgs=sgs, sgm=sgm, + beta=beta, + gammaw=gammaw, + cg_ske_cr=0., + cg_theta=theta, + packagedata=swt6, + maxsig0=len(gg), + stress_period_data=sig0) + + cobs = [('w1l1', 'interbed-compaction', '01_09_10'), + ('w1l2', 'interbed-compaction', '02_09_10'), + ('w1l3', 'interbed-compaction', '03_09_10'), + ('w1l4', 'interbed-compaction', '04_09_10'), + ('w2l1', 'interbed-compaction', '01_12_07'), + ('w2l2', 'interbed-compaction', '02_12_07'), + ('w2l3', 'interbed-compaction', '03_12_07'), + ('w2l4', 'interbed-compaction', '04_12_07'), + ('s1l1', 'coarse-compaction', (0, 8, 9)), + ('s1l2', 'coarse-compaction', (1, 8, 9)), + ('s1l3', 'coarse-compaction', (2, 8, 9)), + ('s1l4', 'coarse-compaction', (3, 8, 9)), + ('s2l1', 'coarse-compaction', (0, 11, 6)), + ('s2l2', 'coarse-compaction', (1, 11, 6)), + ('s2l3', 'coarse-compaction', (2, 11, 6)), + ('s2l4', 'coarse-compaction', (3, 11, 6)), + ('c1l1', 'compaction-cell', (0, 8, 9)), + ('c1l2', 'compaction-cell', (1, 8, 9)), + ('c1l3', 'compaction-cell', (2, 8, 9)), + ('c1l4', 'compaction-cell', (3, 8, 9)), + ('c2l1', 'compaction-cell', (0, 11, 6)), + ('c2l2', 'compaction-cell', (1, 11, 6)), + ('c2l3', 'compaction-cell', (2, 11, 6)), + ('c2l4', 'compaction-cell', (3, 11, 6)), + ('w2l4q', 'csub-cell', (3, 11, 6)), + ('gs1', 'gstress-cell', (0, 8, 9)), + ('es1', 'estress-cell', (0, 8, 9)), + ('pc1', 'preconstress-cell', (0, 8, 9)), + ('gs2', 'gstress-cell', (1, 8, 9)), + ('es2', 'estress-cell', (1, 8, 9)), + ('pc2', 'preconstress-cell', (1, 8, 9)), + ('gs3', 'gstress-cell', (2, 8, 9)), + ('es3', 'estress-cell', (2, 8, 9)), + ('pc3', 'preconstress-cell', (2, 8, 9)), + ('gs4', 'gstress-cell', (3, 8, 9)), + ('es4', 'estress-cell', (3, 8, 9)), + ('pc4', 'preconstress-cell', (3, 8, 9)), + ('sk1l2', 'ske-cell', (1, 8, 9)), + ('sk2l4', 'ske-cell', (3, 11, 6)), + ('t1l2', 'theta', '02_09_10')] + + + orecarray = {'csub_obs.csv': cobs} + csub_obs_package = csub.obs.initialize(filename=opth, digits=10, + print_input=True, + continuous=orecarray) + + # output control + oc = flopy.mf6.ModflowGwfoc(gwf, + budget_filerecord='{}.cbc'.format(name), + head_filerecord='{}.hds'.format(name), + headprintrecord=[ + ('COLUMNS', 10, 'WIDTH', 15, + 'DIGITS', 6, 'GENERAL')], + saverecord=[('HEAD', 'ALL'), + ('BUDGET', 'ALL')], + printrecord=[('HEAD', 'LAST'), + ('BUDGET', 'ALL')]) + + # build MODFLOW-2005 files + ws = os.path.join(dir, cmppth) + mc = flopy.modflow.Modflow(name, model_ws=ws, version=cmppth) + dis = flopy.modflow.ModflowDis(mc, nlay=nlay, nrow=nrow, ncol=ncol, + nper=nper, perlen=perlen, nstp=nstp, + tsmult=tsmult, steady=steady, delr=delr, + delc=delc, top=top, botm=botm) + bas = flopy.modflow.ModflowBas(mc, ibound=ib, strt=strt, hnoflo=hnoflo) + upw = flopy.modflow.ModflowUpw(mc, laytyp=laytyp, + hk=hk, vka=k33, + ss=ss, sy=sy, + hdry=hdry) + chd = flopy.modflow.ModflowChd(mc, stress_period_data=cd) + wel = flopy.modflow.ModflowWel(mc, stress_period_data=wd) + swt = flopy.modflow.ModflowSwt(mc, ipakcb=1001, + iswtoc=1, nsystm=4, + ithk=1, + ivoid=ivoid[idx], + istpcs=1, lnwt=[0, 1, 2, 3], + cc=cc, cr=cr, thick=thick, + void=void, pcsoff=ini_stress, sgs=sgs, + gl0=gs0[idx], ids16=ds16, ids17=ds17) + oc = flopy.modflow.ModflowOc(mc, stress_period_data=None, + save_every=1, + save_types=['save head', 'save budget', + 'print budget']) + nwt = flopy.modflow.ModflowNwt(mc, + headtol=hclose, fluxtol=fluxtol, + maxiterout=nouter, linmeth=2, + unitnumber=132, + options='SPECIFIED', + backflag=0, idroptol=0, + hclosexmd=hclose, mxiterxmd=ninner) + + return sim, mc + + +def eval_comp(sim): + print('evaluating compaction...') + # MODFLOW 6 total compaction results + fpth = os.path.join(sim.simpath, 'csub_obs.csv') + try: + tc = np.genfromtxt(fpth, names=True, delimiter=',') + except: + assert False, 'could not load data from "{}"'.format(fpth) + + # MODFLOW-NWT total compaction results + cpth = cmppth + fn = '{}.swt_total_comp.hds'.format(os.path.basename(sim.name)) + fpth = os.path.join(sim.simpath, cpth, fn) + try: + sobj = flopy.utils.HeadFile(fpth, text='LAYER COMPACTION') + tc0 = sobj.get_ts((3, 11, 6)) + except: + assert False, 'could not load data from "{}"'.format(fpth) + + # calculate maximum absolute error + loctag = 'W2L4' + diff = tc[loctag] - tc0[:, 1] + diffmax = np.abs(diff).max() + msg = 'maximum absolute total-compaction difference ({}) '.format(diffmax) + + # write summary + fpth = os.path.join(sim.simpath, + '{}.comp.cmp.out'.format(os.path.basename(sim.name))) + f = open(fpth, 'w') + line = '{:>15s}'.format('TOTIM') + line += ' {:>15s}'.format('CSUB') + line += ' {:>15s}'.format('MF') + line += ' {:>15s}'.format('DIFF') + f.write(line + '\n') + for i in range(diff.shape[0]): + line = '{:15g}'.format(tc0[i, 0]) + line += ' {:15g}'.format(tc[loctag][i]) + line += ' {:15g}'.format(tc0[i, 1]) + line += ' {:15g}'.format(diff[i]) + f.write(line + '\n') + f.close() + + if diffmax > dtol: + sim.success = False + msg += 'exceeds {}'.format(dtol) + assert diffmax < dtol, msg + else: + sim.success = True + print(' ' + msg) + + # compare budgets + cbc_compare(sim) + + return + + +# compare cbc and lst budgets +def cbc_compare(sim): + print('evaluating cbc and budget...') + # open cbc file + fpth = os.path.join(sim.simpath, + '{}.cbc'.format(os.path.basename(sim.name))) + cobj = flopy.utils.CellBudgetFile(fpth, precision='double') + + # build list of cbc data to retrieve + avail = cobj.get_unique_record_names() + cbc_bud = [] + bud_lst = [] + for t in avail: + if isinstance(t, bytes): + t = t.decode() + t = t.strip() + if paktest in t.lower(): + cbc_bud.append(t) + bud_lst.append('{}_IN'.format(t)) + bud_lst.append('{}_OUT'.format(t)) + + # get results from listing file + fpth = os.path.join(sim.simpath, + '{}.lst'.format(os.path.basename(sim.name))) + budl = flopy.utils.Mf6ListBudget(fpth) + names = list(bud_lst) + d0 = budl.get_budget(names=names)[0] + dtype = d0.dtype + nbud = d0.shape[0] + d = np.recarray(nbud, dtype=dtype) + for key in bud_lst: + d[key] = 0. + + # get data from cbc dile + kk = cobj.get_kstpkper() + times = cobj.get_times() + for idx, (k, t) in enumerate(zip(kk, times)): + for text in cbc_bud: + qin = 0. + qout = 0. + v = cobj.get_data(kstpkper=k, text=text)[0] + if isinstance(v, np.recarray): + vt = np.zeros(size3d, dtype=np.float) + for jdx, node in enumerate(v['node']): + vt[node - 1] += v['q'][jdx] + v = vt.reshape(shape3d) + for kk in range(v.shape[0]): + for ii in range(v.shape[1]): + for jj in range(v.shape[2]): + vv = v[kk, ii, jj] + if vv < 0.: + qout -= vv + else: + qin += vv + d['totim'][idx] = t + d['time_step'][idx] = k[0] + d['stress_period'] = k[1] + key = '{}_IN'.format(text) + d[key][idx] = qin + key = '{}_OUT'.format(text) + d[key][idx] = qout + + diff = np.zeros((nbud, len(bud_lst)), dtype=np.float) + for idx, key in enumerate(bud_lst): + diff[:, idx] = d0[key] - d[key] + diffmax = np.abs(diff).max() + msg = 'maximum absolute total-budget difference ({}) '.format(diffmax) + + # write summary + fpth = os.path.join(sim.simpath, + '{}.bud.cmp.out'.format(os.path.basename(sim.name))) + f = open(fpth, 'w') + for i in range(diff.shape[0]): + if i == 0: + line = '{:>10s}'.format('TIME') + for idx, key in enumerate(bud_lst): + line += '{:>25s}'.format(key + '_LST') + line += '{:>25s}'.format(key + '_CBC') + line += '{:>25s}'.format(key + '_DIF') + f.write(line + '\n') + line = '{:10g}'.format(d['totim'][i]) + for idx, key in enumerate(bud_lst): + line += '{:25g}'.format(d0[key][i]) + line += '{:25g}'.format(d[key][i]) + line += '{:25g}'.format(diff[i, idx]) + f.write(line + '\n') + f.close() + + if diffmax > budtol: + sim.success = False + msg += 'exceeds {}'.format(dtol) + assert diffmax < dtol, msg + else: + sim.success = True + print(' ' + msg) + + return + + +# - No need to change any code below +def build_models(): + for idx, dir in enumerate(exdirs): + sim, mc = get_model(idx, dir) + sim.write_simulation() + if mc is not None: + mc.write_input() + return + + +def test_mf6model(): + # determine if running on Travis + is_travis = 'TRAVIS' in os.environ + r_exe = None + if not is_travis: + if replace_exe is not None: + r_exe = replace_exe + + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + if is_travis and not travis[idx]: + continue + yield test.run_mf6, Simulation(dir, exe_dict=r_exe, + exfunc=eval_comp, + htol=htol[idx]) + + return + + +def main(): + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for dir in exdirs: + sim = Simulation(dir, exe_dict=replace_exe, + exfunc=eval_comp, + htol=htol[idx]) + test.run_mf6(sim) + + return + + +if __name__ == "__main__": + # print message + print('standalone run of {}'.format(os.path.basename(__file__))) + + # run main routine + main() diff --git a/autotest/test_gwf_csub_subwt03.py b/autotest/test_gwf_csub_subwt03.py new file mode 100644 index 00000000000..920674e5f5b --- /dev/null +++ b/autotest/test_gwf_csub_subwt03.py @@ -0,0 +1,570 @@ +import os +import sys +import numpy as np + +try: + import pymake +except: + msg = 'Error. Pymake package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install https://github.com/modflowpy/pymake/zipball/master' + raise Exception(msg) + +try: + import flopy +except: + msg = 'Error. FloPy package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install flopy' + raise Exception(msg) + +from framework import testing_framework +from simulation import Simulation + +ex = ['csub_subwt03a', 'csub_subwt03b', 'csub_subwt03c', 'csub_subwt03d'] +nex = len(ex) +exdirs = [os.path.join('temp', s) for s in ex] + +ddir = 'data' +cmppth = 'mf6' + +htol = None #0.1 +dtol = 1e-3 +budtol = 1e-2 + +paktest = 'csub' + +isnewton = 2 * [None, ''] +headbased = [True, True, False, False] +delay = 4 * [False] + +# set travis to True when version 1.13.0 is released +travis = [True for s in ex] + +# set replace_exe to None to use default executable +replace_exe = None + +# static model data +pth = os.path.join(ddir, 'ibc01_ibound.ref') +ib0 = np.genfromtxt(pth) + +# temporal discretization +nper = 3 +perlen = [1., 21915., 21915.] +nstp = [1, 60, 60] +tsmult = [1., 1., 1.] +steady = [True, False, False] +tdis_rc = [] +for idx in range(nper): + tdis_rc.append((perlen[idx], nstp[idx], tsmult[idx])) + +# spatial discretization +nlay, nrow, ncol = 4, ib0.shape[0], ib0.shape[1] +shape3d = (nlay, nrow, ncol) +size3d = nlay * nrow * ncol +nactive = np.count_nonzero(ib0) * nlay + +delr, delc = 2000., 2000. +top = 150. +botm = [50., -100., -150., -350.] +strt = 100. + +# create ibound/idomain +ib = [] +for k in range(nlay): + ib.append(ib0.astype(np.int).copy()) + +# upw data +laytyp = [1, 0, 0, 0] +hk = [4., 4., 1e-2, 4.] +sy = [0.3, 0., 0., 0.] + +# build well stress period data +wnlays = [ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 1, 3] +wnrows = [ 0, 1, 1, 1, 2, 3, 4, 4, 5, 6, + 13, 13, 15, 15, 16, 17, 17, 18, 8, 11] +wncols = [ 7, 4, 7, 11, 3, 11, 2, 12, 13, 1, + 1, 13, 2, 12, 12, 3, 11, 6, 9, 6] +wrates0 = [2.2e+3 for n in range(18)] + [0., 0.] +wrates1 = [2.2e+3 for n in range(18)] + [-7.2e+04, -7.2e+04] + +w0 = [] +w1 = [] +ws0 = [] +ws1 = [] +for idx, (k, i, j) in enumerate(zip(wnlays, wnrows, wncols)): + w0.append((k, i, j, wrates0[idx])) + w1.append((k, i, j, wrates1[idx])) + ws0.append(((k, i, j), wrates0[idx])) + ws1.append(((k, i, j), wrates1[idx])) +wd = {0: w0, 1: w1, 2: w0} +wd6 = {0: ws0, 1: ws1, 2: ws0} + +# build chd stress period data +chead = 100. +chd1 = [] +chd6 = [] +for k in range(nlay): + for j in [7, 8]: + chd1.append((k, 19, j, chead, chead)) + chd6.append(((k, 19, j), chead)) +cd = {0: chd1} +cd6 = {0: chd6} + +nouter, ninner = 100, 300 +hclose, rclose, relax = 1e-6, 0.01, 0.97 +fluxtol = nactive * rclose + +# subwt data +cc = 0.25 +cr = 0.25 +void = 0.82 +theta = void / (1. + void) +kv = 999. +sgm = 1.7 +sgs = 2.0 +thick = [45., 70., 50., 90.] + +zthick = [top - botm[0], + botm[0] - botm[1], + botm[1] - botm[2], + botm[2] - botm[3]] +zelv = np.array([top] + botm) + +beta = 0. +# beta = 4.65120000e-10 +gammaw = 9806.65000000 + +def get_ske(): + gsb = np.zeros((nlay), dtype=np.float) + ub = np.zeros((nlay), dtype=np.float) + esb = np.zeros((nlay), dtype=np.float) + ske = np.zeros((nlay), dtype=np.float) + + # calculate incremental geostatic stress and hydrostatic stress + for k in range(nlay): + zt = zelv[k] + zb = zelv[k+1] + b = zthick[k] + if strt >= zt: + gs = b * sgs + elif strt < zb: + gs = b * sgm + else: + gs = (zt - strt) * sgm + (strt - zb) * sgs + gsb[k] = gs + ub[k] = strt - zb + + # calculate geostatic and effective stress at the bottom of the layer + gsb = np.cumsum(gsb) + esb = gsb - ub + + # calculate ske + fact = 0.4342942 + ggammaw = 1. #gammaw * (60. * 60. * 24.)**2. + for k in range(nlay): + zt = zelv[k] + zb = zelv[k+1] + if strt >= zt: + z = 0.5 * (zt + zb) + elif strt < zb: + z = zb + else: + z = 0.5 * (strt + zb) + es = esb[k] - (z - zb) * (sgs - 1.) + ske[k] = fact * cr * ggammaw / (es * (1 + void)) + + return ske.tolist() + + +def get_interbed(headbased=False, delay=False): + if headbased: + ini_stress = strt - 15. + cg_ske_cr = get_ske() + else: + ini_stress = 15. + cg_ske_cr = [cr for k in range(nlay)] + + # create csub interbed data + swt6 = [] + csubno = 0 + for k in range(nlay): + bib = thick[k] + rnb = 1. + cdelay = 'nodelay' + vk = kv + if delay: + vk = hk[k] + if k != 2: + rnb = bib / 5. + bib = 5. + cdelay = 'delay' + for i in range(nrow): + for j in range(ncol): + iactive = 0 + if ib0[i, j] > 0: + iactive = 1 + if i == 19 and (j == 7 or j == 8): + iactive = 0 + if iactive > 0: + tag = '{:02d}_{:02d}_{:02d}'.format(k + 1, i + 1, j + 1) + d = [csubno, (k, i, j), cdelay, ini_stress, bib, + rnb, cg_ske_cr[k], cg_ske_cr[k], theta, + vk, strt, tag] + swt6.append(d) + csubno += 1 + return swt6 + + +def get_model(idx, dir): + sim = build_mf6(idx, dir) + + # build mf6 with interbeds + wsc = os.path.join(dir, 'mf6') + mc = build_mf6(idx, wsc, interbed=True) + + return sim, mc + + +# build MODFLOW 6 files +def build_mf6(idx, ws, interbed=False): + + name = ex[idx] + sim = flopy.mf6.MFSimulation(sim_name=name, version='mf6', + exe_name='mf6', + sim_ws=ws) + # create tdis package + tdis = flopy.mf6.ModflowTdis(sim, time_units='DAYS', + nper=nper, perioddata=tdis_rc) + + # create gwf model + gwf = flopy.mf6.ModflowGwf(sim, modelname=name, save_flows=True, + newtonoptions=isnewton[idx]) + + # create iterative model solution and register the gwf model with it + ims = flopy.mf6.ModflowIms(sim, print_option='SUMMARY', + outer_hclose=hclose, + outer_maximum=nouter, + under_relaxation='NONE', + inner_maximum=ninner, + inner_hclose=hclose, rcloserecord=rclose, + linear_acceleration='BICGSTAB', + scaling_method='NONE', + reordering_method='NONE', + relaxation_factor=relax) + sim.register_ims_package(ims, [gwf.name]) + + dis = flopy.mf6.ModflowGwfdis(gwf, nlay=nlay, nrow=nrow, ncol=ncol, + delr=delr, delc=delc, + top=top, botm=botm, + idomain=ib, + filename='{}.dis'.format(name)) + + # initial conditions + ic = flopy.mf6.ModflowGwfic(gwf, strt=strt, + filename='{}.ic'.format(name)) + + # node property flow + npf = flopy.mf6.ModflowGwfnpf(gwf, save_flows=False, + icelltype=laytyp, + k=hk, + k33=hk) + # storage + sto = flopy.mf6.ModflowGwfsto(gwf, save_flows=False, iconvert=laytyp, + ss=0., sy=sy, + steady_state={0: True}, + transient={1: True}) + + # chd files + chd = flopy.mf6.modflow.mfgwfchd.ModflowGwfchd(gwf, + maxbound=len(chd6), + stress_period_data=cd6, + save_flows=False) + + # wel files + wel = flopy.mf6.ModflowGwfwel(gwf, print_input=True, print_flows=True, + maxbound=len(ws1), + stress_period_data=wd6, + save_flows=False) + + # csub files + if interbed: + sswt6 = get_interbed(headbased=headbased[idx], delay=delay[idx]) + ninterbeds = len(sswt6) + else: + sswt6 = None + ninterbeds = 0 + if headbased[idx]: + eslag = True + ci = None + hb = True + ssgs = None + ssgm = None + cg_ske_cr = get_ske() + else: + eslag = True + ci = True + hb = None + ssgs = sgs + ssgm = sgm + cg_ske_cr = [cr for k in range(nlay)] + if interbed: + cg_ske_cr[2] = 0 + opth = '{}.csub.obs'.format(name) + csub = flopy.mf6.ModflowGwfcsub(gwf, + print_input=True, + effective_stress_lag=eslag, + head_based=hb, + boundnames=True, + compression_indices=ci, + ninterbeds=ninterbeds, + sgs=ssgs, sgm=ssgm, + beta=beta, + gammaw=gammaw, + cg_ske_cr=cg_ske_cr, + cg_theta=theta, + packagedata=sswt6) + orecarray = {} + orecarray['csub_obs.csv'] = [('wc01', 'compaction-cell', (1, 5, 8)), + ('wc02', 'compaction-cell', (3, 6, 11))] + csub_obs_package = csub.obs.initialize(filename=opth, digits=10, + print_input=True, + continuous=orecarray) + + # output control + oc = flopy.mf6.ModflowGwfoc(gwf, + budget_filerecord='{}.cbc'.format(name), + head_filerecord='{}.hds'.format(name), + headprintrecord=[ + ('COLUMNS', 10, 'WIDTH', 15, + 'DIGITS', 6, 'GENERAL')], + saverecord=[('HEAD', 'ALL'), + ('BUDGET', 'ALL')], + printrecord=[('HEAD', 'ALL'), + ('BUDGET', 'ALL')]) + return sim + + +def eval_comp(sim): + print('evaluating compaction...') + + # MODFLOW 6 without interbeds + fpth = os.path.join(sim.simpath, 'csub_obs.csv') + try: + tc = np.genfromtxt(fpth, names=True, delimiter=',') + except: + assert False, 'could not load data from "{}"'.format(fpth) + + # MODFLOW 6 with interbeds + fpth = os.path.join(sim.simpath, cmppth, 'csub_obs.csv') + try: + tci = np.genfromtxt(fpth, names=True, delimiter=',') + except: + assert False, 'could not load data from "{}"'.format(fpth) + + diffmax = 0. + tagmax = None + for tag in tc.dtype.names[1:]: + diff = tc[tag] - tci[tag] + diffmaxt = np.abs(diff).max() + if diffmaxt > diffmax: + diffmax = diffmaxt + tagmax = tag + + msg = 'maximum compaction difference ' + \ + '({}) in tag: {}'.format(diffmax, tagmax) + + # write summary + fpth = os.path.join(sim.simpath, + '{}.comp.cmp.out'.format(os.path.basename(sim.name))) + f = open(fpth, 'w') + line = '{:>15s}'.format('TOTIM') + for tag in tc.dtype.names[1:]: + line += ' {:>15s}'.format('{}_SK'.format(tag)) + line += ' {:>15s}'.format('{}_SKIB'.format(tag)) + line += ' {:>15s}'.format('{}_DIFF'.format(tag)) + f.write(line + '\n') + for i in range(diff.shape[0]): + line = '{:15g}'.format(tc['time'][i]) + for tag in tc.dtype.names[1:]: + line += ' {:15g}'.format(tc[tag][i]) + line += ' {:15g}'.format(tci[tag][i]) + line += ' {:15g}'.format(tc[tag][i]-tci[tag][i]) + f.write(line + '\n') + f.close() + + if diffmax > dtol: + sim.success = False + msg += 'exceeds {}'.format(dtol) + assert diffmax < dtol, msg + else: + sim.success = True + print(' ' + msg) + + # compare budgets + cbc_compare(sim) + + return + + +# compare cbc and lst budgets +def cbc_compare(sim): + print('evaluating cbc and budget...') + # open cbc file + fpth = os.path.join(sim.simpath, + '{}.cbc'.format(os.path.basename(sim.name))) + cobj = flopy.utils.CellBudgetFile(fpth, precision='double') + + # build list of cbc data to retrieve + avail = cobj.get_unique_record_names() + cbc_bud = [] + bud_lst = [] + for t in avail: + if isinstance(t, bytes): + t = t.decode() + t = t.strip() + if paktest in t.lower(): + cbc_bud.append(t) + bud_lst.append('{}_IN'.format(t)) + bud_lst.append('{}_OUT'.format(t)) + + # get results from listing file + fpth = os.path.join(sim.simpath, + '{}.lst'.format(os.path.basename(sim.name))) + budl = flopy.utils.Mf6ListBudget(fpth) + names = list(bud_lst) + d0 = budl.get_budget(names=names)[0] + dtype = d0.dtype + nbud = d0.shape[0] + d = np.recarray(nbud, dtype=dtype) + for key in bud_lst: + d[key] = 0. + + # get data from cbc dile + kk = cobj.get_kstpkper() + times = cobj.get_times() + for idx, (k, t) in enumerate(zip(kk, times)): + for text in cbc_bud: + qin = 0. + qout = 0. + v = cobj.get_data(kstpkper=k, text=text)[0] + if isinstance(v, np.recarray): + vt = np.zeros(size3d, dtype=np.float) + for jdx, node in enumerate(v['node']): + vt[node - 1] += v['q'][jdx] + v = vt.reshape(shape3d) + for kk in range(v.shape[0]): + for ii in range(v.shape[1]): + for jj in range(v.shape[2]): + vv = v[kk, ii, jj] + if vv < 0.: + qout -= vv + else: + qin += vv + d['totim'][idx] = t + d['time_step'][idx] = k[0] + d['stress_period'] = k[1] + key = '{}_IN'.format(text) + d[key][idx] = qin + key = '{}_OUT'.format(text) + d[key][idx] = qout + + diff = np.zeros((nbud, len(bud_lst)), dtype=np.float) + for idx, key in enumerate(bud_lst): + diff[:, idx] = d0[key] - d[key] + diffmax = np.abs(diff).max() + msg = 'maximum absolute total-budget difference ({}) '.format(diffmax) + + # write summary + fpth = os.path.join(sim.simpath, + '{}.bud.cmp.out'.format(os.path.basename(sim.name))) + f = open(fpth, 'w') + for i in range(diff.shape[0]): + if i == 0: + line = '{:>10s}'.format('TIME') + for idx, key in enumerate(bud_lst): + line += '{:>25s}'.format(key + '_LST') + line += '{:>25s}'.format(key + '_CBC') + line += '{:>25s}'.format(key + '_DIF') + f.write(line + '\n') + line = '{:10g}'.format(d['totim'][i]) + for idx, key in enumerate(bud_lst): + line += '{:25g}'.format(d0[key][i]) + line += '{:25g}'.format(d[key][i]) + line += '{:25g}'.format(diff[i, idx]) + f.write(line + '\n') + f.close() + + if diffmax > budtol: + sim.success = False + msg += 'exceeds {}'.format(dtol) + assert diffmax < dtol, msg + else: + sim.success = True + print(' ' + msg) + + return + + +# - No need to change any code below +def build_models(): + for idx, dir in enumerate(exdirs): + sim, mc = get_model(idx, dir) + sim.write_simulation() + if mc is not None: + mc.write_simulation() + return + + +def test_mf6model(): + # determine if running on Travis + is_travis = 'TRAVIS' in os.environ + r_exe = None + if not is_travis: + if replace_exe is not None: + r_exe = replace_exe + + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + if is_travis and not travis[idx]: + continue + yield test.run_mf6, Simulation(dir, exe_dict=r_exe, + exfunc=eval_comp, + cmp_verbose=False, + htol=htol) + + return + + +def main(): + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for dir in exdirs: + sim = Simulation(dir, exe_dict=replace_exe, + exfunc=eval_comp, + cmp_verbose=False, + htol=htol) + test.run_mf6(sim) + + return + + +# use python testmf6_csub_subwt03.py +if __name__ == "__main__": + # print message + print('standalone run of {}'.format(os.path.basename(__file__))) + + # run main routine + main() diff --git a/autotest/test_gwf_csub_wc01.py b/autotest/test_gwf_csub_wc01.py new file mode 100644 index 00000000000..e36db87553d --- /dev/null +++ b/autotest/test_gwf_csub_wc01.py @@ -0,0 +1,496 @@ +import os +import sys +import numpy as np + +try: + import pymake +except: + msg = 'Error. Pymake package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install https://github.com/modflowpy/pymake/zipball/master' + raise Exception(msg) + +try: + import flopy +except: + msg = 'Error. FloPy package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install flopy' + raise Exception(msg) + +from framework import testing_framework +from simulation import Simulation + +ex = ['csub_wc01a', 'csub_wc02b'] +exdirs = [os.path.join('temp', s) for s in ex] + +ddir = 'data' +cmppth = 'mf6' + +dtol = 1e-3 +budtol = 1e-2 + +paktest = 'csub' + +isnewton = [None, ''] + +# set travis to True when version 1.13.0 is released +travis = [True for s in ex] + +# set replace_exe to None to use default executable +replace_exe = None + +# static model data +pth = os.path.join(ddir, 'ibc01_ibound.ref') +ib0 = np.genfromtxt(pth) + +# temporal discretization +nper = 3 +perlen = [1., 21915., 21915.] +nstp = [1, 60, 60] +tsmult = [1., 1., 1.] +steady = [True, False, False] +tdis_rc = [] +for idx in range(nper): + tdis_rc.append((perlen[idx], nstp[idx], tsmult[idx])) + +# spatial discretization +nlay, nrow, ncol = 4, ib0.shape[0], ib0.shape[1] +shape3d = (nlay, nrow, ncol) +size3d = nlay * nrow * ncol +nactive = np.count_nonzero(ib0) * nlay + +delr, delc = 2000., 2000. +top = 150. +botm = [50., -100., -150., -350.] +strt = 100. + +# create ibound/idomain +ib = [] +for k in range(nlay): + ib.append(ib0.astype(np.int).copy()) + + +hnoflo = 1e30 +hdry = -1e30 + +# upw data +laytyp = [1, 0, 0, 0] +hk = [4., 4., 1e-2, 4.] +sy = [0., 0., 0., 0.] +# sy = [0.3, 0., 0., 0.] + +# build well stress period data +wnlays = [ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 1, 3] +wnrows = [ 0, 1, 1, 1, 2, 3, 4, 4, 5, 6, + 13, 13, 15, 15, 16, 17, 17, 18, 8, 11] +wncols = [ 7, 4, 7, 11, 3, 11, 2, 12, 13, 1, + 1, 13, 2, 12, 12, 3, 11, 6, 9, 6] +wrates0 = [2.2e+3 for n in range(18)] + [0., 0.] +wrates1 = [2.2e+3 for n in range(18)] + [-7.2e+03, -7.2e+03] + +w0 = [] +w1 = [] +ws0 = [] +ws1 = [] +for idx, (k, i, j) in enumerate(zip(wnlays, wnrows, wncols)): + w0.append((k, i, j, wrates0[idx])) + w1.append((k, i, j, wrates1[idx])) + ws0.append(((k, i, j), wrates0[idx])) + ws1.append(((k, i, j), wrates1[idx])) +wd = {0: w0, 1: w1, 2: w0} +wd6 = {0: ws0, 1: ws1, 2: ws0} + +# build chd stress period data +chead = 100. +chd1 = [] +chd6 = [] +for k in range(nlay): + for j in [7, 8]: + chd1.append((k, 19, j, chead, chead)) + chd6.append(((k, 19, j), chead)) +cd = {0: chd1} +cd6 = {0: chd6} + +nouter, ninner = 100, 300 +hclose, rclose, relax = 1e-6, 0.01, 0.97 +fluxtol = nactive * rclose + +# subwt data +cc = 0.0 +cr = 0.0 +void = 0.82 +theta = void / (1. + void) +kv = 999. +sgm = 1.7 +sgs = 2.0 +ini_stress = 15.0 +delay_flag = 0 +thick = [45., 70., 50., 90.] + +zthick = [top - botm[0], + botm[0] - botm[1], + botm[1] - botm[2], + botm[2] - botm[3]] + +# beta = 0. +beta = 4.65120000e-10 +gammaw = 9806.65000000 +sw = beta * gammaw * theta +ss = 0. +# ss = [sw for k in range(nlay)] + +swt6 = [] +csubno = 0 +for k in range(nlay): + for i in range(nrow): + for j in range(ncol): + iactive = 0 + if ib0[i, j] > 0: + iactive = 1 + if i == 19 and (j == 7 or j == 8): + iactive = 0 + if iactive > 0: + tag = '{:02d}_{:02d}_{:02d}'.format(k + 1, i + 1, j + 1) + d = [csubno, (k, i, j), 'nodelay', ini_stress, thick[k], + 1., cc, cr, theta, + kv, 999., tag] + swt6.append(d) + csubno += 1 + +ds16 = [0, 0, 0, 2052, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] +ds17 = [0, 10000, 0, 10000, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] + + +def get_model(idx, dir): + sim = build_mf6(idx, dir) + + # build mf6 with interbeds + wsc = os.path.join(dir, 'mf6') + mc = build_mf6(idx, wsc, interbed=True) + + return sim, mc + + +# build MODFLOW 6 files +def build_mf6(idx, ws, interbed=False): + + name = ex[idx] + sim = flopy.mf6.MFSimulation(sim_name=name, version='mf6', + exe_name='mf6', + sim_ws=ws) + # create tdis package + tdis = flopy.mf6.ModflowTdis(sim, time_units='DAYS', + nper=nper, perioddata=tdis_rc) + + # create gwf model + gwf = flopy.mf6.ModflowGwf(sim, modelname=name, save_flows=True, + newtonoptions=isnewton[idx]) + + # create iterative model solution and register the gwf model with it + ims = flopy.mf6.ModflowIms(sim, print_option='SUMMARY', + outer_hclose=hclose, + outer_maximum=nouter, + under_relaxation='NONE', + inner_maximum=ninner, + inner_hclose=hclose, rcloserecord=rclose, + linear_acceleration='BICGSTAB', + scaling_method='NONE', + reordering_method='NONE', + relaxation_factor=relax) + sim.register_ims_package(ims, [gwf.name]) + + dis = flopy.mf6.ModflowGwfdis(gwf, nlay=nlay, nrow=nrow, ncol=ncol, + delr=delr, delc=delc, + top=top, botm=botm, + idomain=ib, + filename='{}.dis'.format(name)) + + # initial conditions + ic = flopy.mf6.ModflowGwfic(gwf, strt=strt, + filename='{}.ic'.format(name)) + + # node property flow + npf = flopy.mf6.ModflowGwfnpf(gwf, save_flows=False, + icelltype=laytyp, + k=hk, + k33=hk) + # storage + sto = flopy.mf6.ModflowGwfsto(gwf, save_flows=False, iconvert=laytyp, + ss=0., sy=sy, + steady_state={0: True}, + transient={1: True}) + + # chd files + chd = flopy.mf6.modflow.mfgwfchd.ModflowGwfchd(gwf, + maxbound=len(chd6), + stress_period_data=cd6, + save_flows=False) + + # wel files + wel = flopy.mf6.ModflowGwfwel(gwf, print_input=True, print_flows=True, + maxbound=len(ws1), + stress_period_data=wd6, + save_flows=False) + + # csub files + if interbed: + sswt6 = swt6 + ninterbeds = len(sswt6) + else: + sswt6 = None + ninterbeds = 0 + opth = '{}.csub.obs'.format(name) + csub = flopy.mf6.ModflowGwfcsub(gwf, + # interbed_stress_offset=True, + boundnames=True, + compression_indices=True, + ninterbeds=ninterbeds, + sgs=sgs, sgm=sgm, + beta=beta, + gammaw=gammaw, + cg_ske_cr=0., + cg_theta=theta, + packagedata=sswt6) + orecarray = {} + orecarray['csub_obs.csv'] = [('wc01', 'wcomp-csub-cell', (1, 5, 8)), + ('wc02', 'wcomp-csub-cell', (3, 6, 11))] + csub_obs_package = csub.obs.initialize(filename=opth, digits=10, + print_input=True, + continuous=orecarray) + + # output control + oc = flopy.mf6.ModflowGwfoc(gwf, + budget_filerecord='{}.cbc'.format(name), + head_filerecord='{}.hds'.format(name), + headprintrecord=[ + ('COLUMNS', 10, 'WIDTH', 15, + 'DIGITS', 6, 'GENERAL')], + saverecord=[('HEAD', 'ALL'), + ('BUDGET', 'ALL')], + printrecord=[('HEAD', 'LAST'), + ('BUDGET', 'ALL')]) + return sim + + +def eval_wcomp(sim): + print('evaluating compaction...') + + # MODFLOW 6 without interbeds water compressibility + fpth = os.path.join(sim.simpath, 'csub_obs.csv') + try: + tc = np.genfromtxt(fpth, names=True, delimiter=',') + except: + assert False, 'could not load data from "{}"'.format(fpth) + + # MODFLOW 6 with interbeds water compressibility + fpth = os.path.join(sim.simpath, cmppth, 'csub_obs.csv') + try: + tci = np.genfromtxt(fpth, names=True, delimiter=',') + except: + assert False, 'could not load data from "{}"'.format(fpth) + + diffmax = 0. + tagmax = None + for tag in tc.dtype.names[1:]: + diff = tc[tag] - tci[tag] + diffmaxt = np.abs(diff).max() + if diffmaxt > diffmax: + diffmax = diffmaxt + tagmax = tag + + msg = 'maximum absolute water compressibility difference ' + \ + '({}) in tag: {}'.format(diffmax, tagmax) + + # write summary + fpth = os.path.join(sim.simpath, + '{}.wcomp.cmp.out'.format(os.path.basename(sim.name))) + f = open(fpth, 'w') + line = '{:>15s}'.format('TOTIM') + for tag in tc.dtype.names[1:]: + line += ' {:>15s}'.format('{}_SK'.format(tag)) + line += ' {:>15s}'.format('{}_SKIB'.format(tag)) + line += ' {:>15s}'.format('{}_DIFF'.format(tag)) + f.write(line + '\n') + for i in range(diff.shape[0]): + line = '{:15g}'.format(tc['time'][i]) + for tag in tc.dtype.names[1:]: + line += ' {:15g}'.format(tc[tag][i]) + line += ' {:15g}'.format(tci[tag][i]) + line += ' {:15g}'.format(tc[tag][i]-tci[tag][i]) + f.write(line + '\n') + f.close() + + if diffmax > dtol: + sim.success = False + msg += 'exceeds {}'.format(dtol) + assert diffmax < dtol, msg + else: + sim.success = True + print(' ' + msg) + + # compare budgets + cbc_compare(sim) + + return + + +# compare cbc and lst budgets +def cbc_compare(sim): + print('evaluating cbc and budget...') + # open cbc file + fpth = os.path.join(sim.simpath, + '{}.cbc'.format(os.path.basename(sim.name))) + cobj = flopy.utils.CellBudgetFile(fpth, precision='double') + + # build list of cbc data to retrieve + avail = cobj.get_unique_record_names() + cbc_bud = [] + bud_lst = [] + for t in avail: + if isinstance(t, bytes): + t = t.decode() + t = t.strip() + if paktest in t.lower(): + cbc_bud.append(t) + bud_lst.append('{}_IN'.format(t)) + bud_lst.append('{}_OUT'.format(t)) + + # get results from listing file + fpth = os.path.join(sim.simpath, + '{}.lst'.format(os.path.basename(sim.name))) + budl = flopy.utils.Mf6ListBudget(fpth) + names = list(bud_lst) + d0 = budl.get_budget(names=names)[0] + dtype = d0.dtype + nbud = d0.shape[0] + d = np.recarray(nbud, dtype=dtype) + for key in bud_lst: + d[key] = 0. + + # get data from cbc dile + kk = cobj.get_kstpkper() + times = cobj.get_times() + for idx, (k, t) in enumerate(zip(kk, times)): + for text in cbc_bud: + qin = 0. + qout = 0. + v = cobj.get_data(kstpkper=k, text=text)[0] + if isinstance(v, np.recarray): + vt = np.zeros(size3d, dtype=np.float) + for jdx, node in enumerate(v['node']): + vt[node - 1] += v['q'][jdx] + v = vt.reshape(shape3d) + for kk in range(v.shape[0]): + for ii in range(v.shape[1]): + for jj in range(v.shape[2]): + vv = v[kk, ii, jj] + if vv < 0.: + qout -= vv + else: + qin += vv + d['totim'][idx] = t + d['time_step'][idx] = k[0] + d['stress_period'] = k[1] + key = '{}_IN'.format(text) + d[key][idx] = qin + key = '{}_OUT'.format(text) + d[key][idx] = qout + + diff = np.zeros((nbud, len(bud_lst)), dtype=np.float) + for idx, key in enumerate(bud_lst): + diff[:, idx] = d0[key] - d[key] + diffmax = np.abs(diff).max() + msg = 'maximum absolute total-budget difference ({}) '.format(diffmax) + + # write summary + fpth = os.path.join(sim.simpath, + '{}.bud.cmp.out'.format(os.path.basename(sim.name))) + f = open(fpth, 'w') + for i in range(diff.shape[0]): + if i == 0: + line = '{:>10s}'.format('TIME') + for idx, key in enumerate(bud_lst): + line += '{:>25s}'.format(key + '_LST') + line += '{:>25s}'.format(key + '_CBC') + line += '{:>25s}'.format(key + '_DIF') + f.write(line + '\n') + line = '{:10g}'.format(d['totim'][i]) + for idx, key in enumerate(bud_lst): + line += '{:25g}'.format(d0[key][i]) + line += '{:25g}'.format(d[key][i]) + line += '{:25g}'.format(diff[i, idx]) + f.write(line + '\n') + f.close() + + if diffmax > budtol: + sim.success = False + msg += 'exceeds {}'.format(dtol) + assert diffmax < dtol, msg + else: + sim.success = True + print(' ' + msg) + + return + + +# - No need to change any code below +def build_models(): + for idx, dir in enumerate(exdirs): + sim, mc = get_model(idx, dir) + sim.write_simulation() + if mc is not None: + mc.write_simulation() + return + + +def test_mf6model(): + # determine if running on Travis + is_travis = 'TRAVIS' in os.environ + r_exe = None + if not is_travis: + if replace_exe is not None: + r_exe = replace_exe + + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + if is_travis and not travis[idx]: + continue + yield test.run_mf6, Simulation(dir, exe_dict=r_exe, + exfunc=eval_wcomp) + + return + + +def main(): + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for dir in exdirs: + sim = Simulation(dir, exe_dict=replace_exe, + exfunc=eval_wcomp) + test.run_mf6(sim) + + return + + +# main +if __name__ == "__main__": + # print message + print('standalone run of {}'.format(os.path.basename(__file__))) + + # run main routine + main() diff --git a/autotest/test_gwf_csub_wtgeo.py b/autotest/test_gwf_csub_wtgeo.py new file mode 100644 index 00000000000..30b3a972849 --- /dev/null +++ b/autotest/test_gwf_csub_wtgeo.py @@ -0,0 +1,748 @@ +import os +import numpy as np + +try: + import pymake +except: + msg = 'Error. Pymake package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install https://github.com/modflowpy/pymake/zipball/master' + raise Exception(msg) + +try: + import flopy +except: + msg = 'Error. FloPy package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install flopy' + raise Exception(msg) + +from framework import testing_framework +from simulation import Simulation + +ex = ['csub_wtgeoa', 'csub_wtgeob', + 'csub_wtgeoc', 'csub_wtgeod', + 'csub_wtgeoe', 'csub_wtgeof', + 'csub_wtgeog'] +exdirs = [] +for s in ex: + exdirs.append(os.path.join('temp', s)) +constantcv = [True for idx in range(len(exdirs))] + +cmppth = 'mfnwt' +compare = [True, True, True, True, False, False, False] +tops = [0., 0., 150., 0., 0., 150., 150.] +ump = [None, None, True, None, True, None, True] +iump = [0, 0, 1, 0, 1, 0, 1] +eslag = [True for idx in range(len(exdirs) - 2)] + 2 * [False] +headformulation = [True, False, False, True, True, False, False] +ndc = [None, None, None, 19, 19, 19, 19] +delay = [False, False, False, True, True, True, True] + +ddir = 'data' + +## run all examples on Travis +travis = [True for idx in range(len(exdirs))] + +# set replace_exe to None to use default executable +replace_exe = None + +htol = [None, None, None, 0.2, None, None, None] +dtol = 1e-3 +budtol = 1e-2 +paktest = 'csub' + +# static model data +# temporal discretization +nper = 31 +perlen = [1.] + [365.2500000 for i in range(nper - 1)] +nstp = [1] + [6 for i in range(nper - 1)] +tsmult = [1.0] + [1.3 for i in range(nper - 1)] +steady = [True] + [False for i in range(nper - 1)] +tdis_rc = [] +for idx in range(nper): + tdis_rc.append((perlen[idx], nstp[idx], tsmult[idx])) + +# spatial discretization data +nlay, nrow, ncol = 3, 10, 10 +shape3d = (nlay, nrow, ncol) +size3d = nlay * nrow * ncol +delr, delc = 1000., 2000. +botm = [-100, -150., -350.] +strt = 0. +hnoflo = 1e30 +hdry = -1e30 + +# calculate hk +hk1fact = 1. / 50. +hk1 = np.ones((nrow, ncol), dtype=np.float) * 0.5 * hk1fact +hk1[0, :] = 1000. * hk1fact +hk1[-1, :] = 1000. * hk1fact +hk1[:, 0] = 1000. * hk1fact +hk1[:, -1] = 1000. * hk1fact +hk = [20., hk1, 5.] + +# calculate vka +vka = [1e6, 7.5e-5, 1e6] + +# all cells are active and layer 1 is convertible +ib = 1 + +# solver options +nouter, ninner = 500, 300 +hclose, rclose, relax = 1e-9, 1e-6, 1. +newtonoptions = '' +imsla = 'BICGSTAB' + +# chd data +c = [] +c6 = [] +ccol = [3, 4, 5, 6] +for j in ccol: + c.append([0, nrow - 1, j, strt, strt]) + c6.append([(0, nrow - 1, j), strt]) +cd = {0: c} +cd6 = {0: c6} +maxchd = len(cd[0]) + +# pumping well data +wr = [0, 0, 0, 0, 1, 1, 2, 2, 3, 3] +wc = [0, 1, 8, 9, 0, 9, 0, 9, 0, 0] +wrp = [2, 2, 3, 3] +wcp = [5, 6, 5, 6] +wq = [-14000., -8000., -5000., -3000.] +d = [] +d6 = [] +for r, c, q in zip(wrp, wcp, wq): + d.append([2, r, c, q]) + d6.append([(2, r, c), q]) +wd = {1: d} +wd6 = {1: d6} +maxwel = len(wd[1]) + +# recharge data +q = 3000. / (delr * delc) +v = np.zeros((nrow, ncol), dtype=np.float) +for r, c in zip(wr, wc): + v[r, c] = q +rech = {0: v} + +# storage and compaction data +sgm = 1.7 +sgs = 2.0 +void = 0.82 +preconhead = -7. +theta = void / (1. + void) +sw = 4.65120000e-10 * 9806.65000000 * theta +sy = [0.1, 0., 0.] +ske = [6e-6, 3e-6, 6e-6] +skv = [6e-4, 3e-4, 6e-4] +cg_ske_cr = [ske[0], 0, ske[-1]] +kv = 1e-6 + +bdb = [45., 0, 90.] +facib = [0.6, 1., 0.6] +facsk = [0.4, 0., 0.4] +# facndb = [0.15, 1., 0.15] +# facdb = [0.45, 0., 0.45] + +dp = [[kv, ske[0], skv[0]]] +rnb = [7.635, 0., 17.718] +dhc = [preconhead for n in range(nlay)] +dstart = [strt for n in range(nlay)] +dz = [5.894, 0., 5.08] +nz = [1, 0, 1] + +# sub output data +ds15 = [0, 0, 0, 2052, 0, 0, 0, 0, 0, 0, 0, 0] +ds16 = [0, nper - 1, 0, nstp[-1] - 1, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1] + +# subwt output data +ds16swt = [0, 0, 0, 2053, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] +ds17swt = [0, nper - 1, 0, nstp[-1] - 1, 0, 0, 1, 1, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] + + +# calculate geostatic and effective stress +def calc_stress(sgm0, sgs0, h, bt): + geo = [] + for k in range(nlay): + top = bt[k] + bot = bt[k + 1] + ht = h + if ht > top: + gs = (top - bot) * sgs0 + elif ht < bot: + gs = (top - bot) * sgm0 + else: + gs = ((top - ht) * sgm0) + ((ht - bot) * sgs0) + geo.append(gs) + # calculate total geostatic stress at bottom of layer + for k in range(1, nlay): + geo[k] += geo[k - 1] + # calculate effective stress at the bottom of the layer + es = [] + for k in range(nlay): + es.append(geo[k] - (h - bt[k + 1])) + return geo, es + + +# variant SUB package problem 3 +def get_model(idx, dir): + name = ex[idx] + + # build MODFLOW 6 files + ws = dir + sim = flopy.mf6.MFSimulation(sim_name=name, version='mf6', + exe_name='mf6', + sim_ws=ws) + # create tdis package + tdis = flopy.mf6.ModflowTdis(sim, time_units='DAYS', + nper=nper, perioddata=tdis_rc) + + # create gwf model + top = tops[idx] + zthick = [top - botm[0], + botm[0] - botm[1], + botm[1] - botm[2]] + elevs = [top] + botm + + if top == 0: + laytyp = [0, 0, 0] + else: + laytyp = [1, 0, 0] + + # calculate sk, ndb, and db factors + # facndb = [0.15, 1., 0.15] + # facdb = [0.45, 0., 0.45] + # facsk = [0.4, 0., 0.4] + facdb = [] + facndb = [] + for k in range(nlay): + bt = zthick[k] + f = bdb[k] / bt + facdb.append(f) + bnd = bt * (facib[k] - f) + f = bnd / bt + facndb.append(f) + + # csub packagedata container counter + if headformulation[idx]: + head_based = True + sgmt = None + sgst = None + else: + head_based = None + sgmt = sgm + sgst = sgs + + # fill preconsolidation stress with preconsolidation head + # calculate preconsolidation stress, if necessary + pcs = [preconhead for k in range(nlay)] + gs, es = calc_stress(sgm, sgs, preconhead, elevs) + if not headformulation[idx]: + pcs = es + + # create no delay bed packagedata entries + sub6 = [] + ibcno = 0 + nndb = 0 + ln = [] + sfv = [] + sfe = [] + hc = [] + thickib0 = [] + cdelays = 'nodelay' + for k in range(nlay): + b = zthick[k] * facndb[k] + if b <= 0.: + continue + nndb += 1 + ln.append(k) + thickib0.append(b) + if headformulation[idx]: + sfv.append(skv[k] * b) + sfe.append(ske[k] * b) + hc.append(pcs[k]) + else: + sfv.append(skv[k]) + sfe.append(ske[k]) + for i in range(nrow): + for j in range(ncol): + # skip constant head cells + if k == 0 and i == nrow - 1 and j in ccol: + continue + # create nodelay entry + # no delay beds + d = [ibcno, (k, i, j), cdelays, pcs[k], + b, 1., skv[k], ske[k], theta, 999., -999.] + sub6.append(d) + ibcno += 1 + + if delay[idx]: + cdelays = 'delay' + else: + cdelays = 'nodelay' + ndb = 0 + nmz = 0 + ldn = [] + rnbsub = [] + nzsub = [] + dzsub = [] + dhcsub = [] + dstartsub = [] + for k in range(nlay): + b = zthick[k] * facdb[k] + if b <= 0.: + continue + if delay[idx]: + ndb += 1 + nmz = 1 + bb = dz[k] + rnbt = rnb[k] + rnbsub.append(rnbt) + dzsub.append(dz[k]) + dhcsub.append(dhc[k]) + dstartsub.append(dstart[k]) + hib = strt + nzsub.append(1) + ldn.append(k) + else: + bb = b + rnbt = 1 + hib = -999. + nndb += 1 + ln.append(k) + thickib0.append(b) + if headformulation[idx]: + sfv.append(skv[k] * b) + sfe.append(ske[k] * b) + hc.append(pcs[k]) + else: + sfv.append(skv[k]) + sfe.append(ske[k]) + for i in range(nrow): + for j in range(ncol): + # skip constant head cells + if k == 0 and i == nrow - 1 and j in ccol: + continue + # create nodelay entry + # no delay beds + d = [ibcno, (k, i, j), cdelays, pcs[k], + bb, rnbt, skv[k], ske[k], theta, kv, hib] + sub6.append(d) + ibcno += 1 + + + # add coarse-grained component + for k in range(nlay): + b = zthick[k] * facsk[k] + if b <= 0.: + continue + nndb += 1 + ln.append(k) + thickib0.append(b) + if headformulation[idx]: + sfv.append(ske[k] * b) + sfe.append(ske[k] * b) + hc.append(pcs[k]) + else: + sfv.append(ske[k]) + sfe.append(ske[k]) + + maxcsub = len(sub6) + + # water compressibility cannot be compared for cases where the material + # properties are adjusted since the porosity changes in mf6 + if iump[idx] == 0: + beta = 4.6512e-10 + wc = sw + else: + beta = 0. + wc = 0. + + gwf = flopy.mf6.ModflowGwf(sim, modelname=name, + newtonoptions=newtonoptions) + + # create iterative model solution and register the gwf model with it + ims = flopy.mf6.ModflowIms(sim, print_option='SUMMARY', + outer_hclose=hclose, + outer_maximum=nouter, + under_relaxation='NONE', + inner_maximum=ninner, + inner_hclose=hclose, rcloserecord=rclose, + linear_acceleration=imsla, + scaling_method='NONE', + reordering_method='NONE', + relaxation_factor=relax) + sim.register_ims_package(ims, [gwf.name]) + + dis = flopy.mf6.ModflowGwfdis(gwf, nlay=nlay, nrow=nrow, ncol=ncol, + delr=delr, delc=delc, + top=top, botm=botm, + filename='{}.dis'.format(name)) + + # initial conditions + ic = flopy.mf6.ModflowGwfic(gwf, strt=strt, + filename='{}.ic'.format(name)) + + # node property flow + npf = flopy.mf6.ModflowGwfnpf(gwf, save_flows=False, + # dev_modflowusg_upstream_weighted_saturation=True, + icelltype=laytyp, + k=hk, + k33=vka) + # storage + sto = flopy.mf6.ModflowGwfsto(gwf, save_flows=False, iconvert=laytyp, + ss=0., sy=sy, + storagecoefficient=True, + steady_state={0: True}, + transient={1: True}) + + # recharge + rch = flopy.mf6.ModflowGwfrcha(gwf, readasarrays=True, recharge=rech) + + # wel file + wel = flopy.mf6.ModflowGwfwel(gwf, print_input=True, print_flows=True, + maxbound=maxwel, + stress_period_data=wd6, + save_flows=False) + + # chd files + chd = flopy.mf6.modflow.mfgwfchd.ModflowGwfchd(gwf, + maxbound=maxchd, + stress_period_data=cd6, + save_flows=False) + # ibc files + opth = '{}.csub.obs'.format(name) + csub = flopy.mf6.ModflowGwfcsub(gwf, + specified_initial_interbed_state=True, + ndelaycells=ndc[idx], + head_based=head_based, + update_material_properties=ump[idx], + effective_stress_lag=eslag[idx], + save_flows=True, + ninterbeds=maxcsub, + sgm=sgmt, + sgs=sgst, + cg_theta=theta, + cg_ske_cr=cg_ske_cr, + beta=beta, + packagedata=sub6) + obspos = [(0, 4, 4), (1, 4, 4), (2, 4, 4)] + obstype = ['compaction-cell', 'gstress-cell', 'estress-cell', + 'ske-cell', 'sk-cell', 'csub-cell'] + obstag = ['tcomp', 'gs', 'es', 'ske', 'sk', 'csub'] + obsarr = [] + for iobs, cobs in enumerate(obstype): + for jobs, otup in enumerate(obspos): + otag = '{}{}'.format(obstag[iobs], jobs + 1) + obsarr.append((otag, cobs, otup)) + + orecarray = {} + orecarray['csub_obs.csv'] = obsarr + csub_obs_package = csub.obs.initialize(filename=opth, digits=10, + print_input=True, + continuous=orecarray) + + # output control + oc = flopy.mf6.ModflowGwfoc(gwf, + budget_filerecord='{}.cbc'.format(name), + head_filerecord='{}.hds'.format(name), + headprintrecord=[ + ('COLUMNS', 10, 'WIDTH', 15, + 'DIGITS', 6, 'GENERAL')], + saverecord=[('HEAD', 'ALL'), + ('BUDGET', 'ALL')], + printrecord=[('HEAD', 'LAST'), + ('BUDGET', 'ALL')]) + + # build MODFLOW-NWT files + if compare[idx]: + cpth = cmppth + ws = os.path.join(dir, cpth) + mc = flopy.modflow.Modflow(name, model_ws=ws, version=cpth) + dis = flopy.modflow.ModflowDis(mc, nlay=nlay, nrow=nrow, ncol=ncol, + nper=nper, perlen=perlen, nstp=nstp, + tsmult=tsmult, steady=steady, delr=delr, + delc=delc, top=top, botm=botm) + bas = flopy.modflow.ModflowBas(mc, ibound=ib, strt=strt, hnoflo=hnoflo, + stoper=0.01) + upw = flopy.modflow.ModflowUpw(mc, laytyp=laytyp, + hk=hk, vka=vka, + ss=wc, sy=sy, + hdry=hdry) + chd = flopy.modflow.ModflowChd(mc, stress_period_data=cd) + rch = flopy.modflow.ModflowRch(mc, rech=rech) + wel = flopy.modflow.ModflowWel(mc, stress_period_data=wd) + if headformulation[idx]: + sub = flopy.modflow.ModflowSub(mc, ipakcb=1001, + ndb=ndb, nndb=nndb, nmz=nmz, + nn=10, + ac2=1.0, + isuboc=1, ln=ln, ldn=ldn, + rnb=rnbsub, + dp=dp, dz=dzsub, nz=nzsub, + dhc=dhcsub, dstart=dstartsub, + hc=hc, sfe=sfe, sfv=sfv, + ids15=ds15, ids16=ds16) + else: + swt = flopy.modflow.ModflowSwt(mc, ipakcb=1001, + iswtoc=1, nsystm=len(sfe), + ithk=1, ivoid=iump[idx], + icrcc=1, + istpcs=0, lnwt=ln, + sse=sfe, ssv=sfv, + thick=thickib0, + void=void, + pcs=pcs, pcsoff=0., + sgm=sgm, sgs=sgs, + gl0=0., + ids16=ds16swt, ids17=ds17swt) + oc = flopy.modflow.ModflowOc(mc, stress_period_data=None, + save_every=1, + save_types=['save head', 'save budget', + 'print budget']) + fluxtol = (float(nlay * nrow * ncol) - 4.) * rclose + nwt = flopy.modflow.ModflowNwt(mc, + headtol=hclose, fluxtol=fluxtol, + maxiterout=nouter, linmeth=2, + maxitinner=ninner, + unitnumber=132, + options='SPECIFIED', + backflag=0, idroptol=0) + else: + mc = None + return sim, mc + + +def eval_comp(sim): + + if compare[sim.idxsim]: + print('evaluating compaction...') + # MODFLOW 6 total compaction results + fpth = os.path.join(sim.simpath, 'csub_obs.csv') + try: + tc = np.genfromtxt(fpth, names=True, delimiter=',') + except: + assert False, 'could not load data from "{}"'.format(fpth) + + # MODFLOW-2005 total compaction results + cpth = cmppth + fn2 = None + if headformulation[sim.idxsim]: + fn = '{}.total_comp.hds'.format(os.path.basename(sim.name)) + else: + fn = '{}.swt_total_comp.hds'.format(os.path.basename(sim.name)) + if delay[sim.idxsim]: + fn2 = '{}.total_comp.hds'.format(os.path.basename(sim.name)) + fpth = os.path.join(sim.simpath, cpth, fn) + try: + sobj = flopy.utils.HeadFile(fpth, text='LAYER COMPACTION') + tc0 = sobj.get_ts((2, 4, 4)) + except: + assert False, 'could not load data from "{}"'.format(fpth) + # add compaction from delay bed + if fn2 is not None: + fpth = os.path.join(sim.simpath, cpth, fn2) + try: + sobj = flopy.utils.HeadFile(fpth, text='LAYER COMPACTION') + v = sobj.get_ts((2, 4, 4)) + tc0[:, 1] += v[:, 1] + except: + assert False, 'could not load data from "{}"'.format(fpth) + + # calculate maximum absolute error + diff = tc['TCOMP3'] - tc0[:, 1] + diffmax = np.abs(diff).max() + msg = 'maximum absolute total-compaction difference ({}) '.format(diffmax) + + # write summary + fpth = os.path.join(sim.simpath, + '{}.comp.cmp.out'.format(os.path.basename(sim.name))) + f = open(fpth, 'w') + line = '{:>15s}'.format('TOTIM') + line += ' {:>15s}'.format('CSUB') + line += ' {:>15s}'.format('MF') + line += ' {:>15s}'.format('DIFF') + f.write(line + '\n') + for i in range(diff.shape[0]): + line = '{:15g}'.format(tc0[i, 0]) + line += ' {:15g}'.format(tc['TCOMP3'][i]) + line += ' {:15g}'.format(tc0[i, 1]) + line += ' {:15g}'.format(diff[i]) + f.write(line + '\n') + f.close() + + if diffmax > dtol: + sim.success = False + msg += 'exceeds {}'.format(dtol) + assert diffmax < dtol, msg + else: + sim.success = True + print(' ' + msg) + + # compare budgets + cbc_compare(sim) + + return + + +# compare cbc and lst budgets +def cbc_compare(sim): + print('evaluating cbc and budget...') + # open cbc file + fpth = os.path.join(sim.simpath, + '{}.cbc'.format(os.path.basename(sim.name))) + cobj = flopy.utils.CellBudgetFile(fpth, precision='double') + + # build list of cbc data to retrieve + avail = cobj.get_unique_record_names() + cbc_bud = [] + bud_lst = [] + for t in avail: + if isinstance(t, bytes): + t = t.decode() + t = t.strip() + if paktest in t.lower(): + cbc_bud.append(t) + bud_lst.append('{}_IN'.format(t)) + bud_lst.append('{}_OUT'.format(t)) + + # get results from listing file + fpth = os.path.join(sim.simpath, + '{}.lst'.format(os.path.basename(sim.name))) + budl = flopy.utils.Mf6ListBudget(fpth) + names = list(bud_lst) + d0 = budl.get_budget(names=names)[0] + dtype = d0.dtype + nbud = d0.shape[0] + d = np.recarray(nbud, dtype=dtype) + for key in bud_lst: + d[key] = 0. + + # get data from cbc dile + kk = cobj.get_kstpkper() + times = cobj.get_times() + for idx, (k, t) in enumerate(zip(kk, times)): + for text in cbc_bud: + qin = 0. + qout = 0. + v = cobj.get_data(kstpkper=k, text=text)[0] + if isinstance(v, np.recarray): + vt = np.zeros(size3d, dtype=np.float) + for jdx, node in enumerate(v['node']): + vt[node - 1] += v['q'][jdx] + v = vt.reshape(shape3d) + for kk in range(v.shape[0]): + for ii in range(v.shape[1]): + for jj in range(v.shape[2]): + vv = v[kk, ii, jj] + if vv < 0.: + qout -= vv + else: + qin += vv + d['totim'][idx] = t + d['time_step'][idx] = k[0] + d['stress_period'] = k[1] + key = '{}_IN'.format(text) + d[key][idx] = qin + key = '{}_OUT'.format(text) + d[key][idx] = qout + + diff = np.zeros((nbud, len(bud_lst)), dtype=np.float) + for idx, key in enumerate(bud_lst): + diff[:, idx] = d0[key] - d[key] + diffmax = np.abs(diff).max() + msg = 'maximum absolute total-budget difference ({}) '.format(diffmax) + + # write summary + fpth = os.path.join(sim.simpath, + '{}.bud.cmp.out'.format(os.path.basename(sim.name))) + f = open(fpth, 'w') + for i in range(diff.shape[0]): + if i == 0: + line = '{:>10s}'.format('TIME') + for idx, key in enumerate(bud_lst): + line += '{:>25s}'.format(key + '_LST') + line += '{:>25s}'.format(key + '_CBC') + line += '{:>25s}'.format(key + '_DIF') + f.write(line + '\n') + line = '{:10g}'.format(d['totim'][i]) + for idx, key in enumerate(bud_lst): + line += '{:25g}'.format(d0[key][i]) + line += '{:25g}'.format(d[key][i]) + line += '{:25g}'.format(diff[i, idx]) + f.write(line + '\n') + f.close() + + if diffmax > budtol: + sim.success = False + msg += 'exceeds {}'.format(dtol) + assert diffmax < dtol, msg + else: + sim.success = True + print(' ' + msg) + + return + + +# - No need to change any code below +def build_models(): + for idx, dir in enumerate(exdirs): + sim, mc = get_model(idx, dir) + sim.write_simulation() + if mc is not None: + mc.write_input() + return + + +def test_mf6model(): + # determine if running on Travis + is_travis = 'TRAVIS' in os.environ + r_exe = None + if not is_travis: + if replace_exe is not None: + r_exe = replace_exe + + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + if is_travis and not travis[idx]: + continue + yield test.run_mf6, Simulation(dir, exfunc=eval_comp, + exe_dict=r_exe, + htol=htol[idx], + idxsim=idx) + + return + + +def main(): + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + sim = Simulation(dir, exfunc=eval_comp, + exe_dict=replace_exe, htol=htol[idx], idxsim=idx) + test.run_mf6(sim) + + return + + +if __name__ == "__main__": + # print message + print('standalone run of {}'.format(os.path.basename(__file__))) + + # run main routine + main() diff --git a/autotest/test_gwf_csub_zdisp01.py b/autotest/test_gwf_csub_zdisp01.py new file mode 100644 index 00000000000..c3945449912 --- /dev/null +++ b/autotest/test_gwf_csub_zdisp01.py @@ -0,0 +1,554 @@ +import os +import numpy as np + +try: + import flopy +except: + msg = 'Error. FloPy package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install flopy' + raise Exception(msg) + +try: + import pymake +except: + msg = 'Error. Pymake package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install https://github.com/modflowpy/pymake/zipball/master' + raise Exception(msg) + +from framework import testing_framework +from simulation import Simulation + +ex = ['csub_zdisp01'] +exdirs = [] +for s in ex: + exdirs.append(os.path.join('temp', s)) + +cmppth = 'mfnwt' + +ddir = 'data' + +## run all examples on Travis +travis = [True for idx in range(len(exdirs))] + +# set replace_exe to None to use default executable +replace_exe = None + +htol = [None for idx in range(len(exdirs))] +dtol = 1e-3 +budtol = 1e-2 + +bud_lst = ['STO-SS_IN', 'STO-SS_OUT', + 'STO-SY_IN', 'STO-SY_OUT', + 'CSUB-CGELASTIC_IN', 'CSUB-CGELASTIC_OUT', + 'CSUB-ELASTIC_IN', 'CSUB-ELASTIC_OUT', + 'CSUB-INELASTIC_IN', 'CSUB-INELASTIC_OUT', + 'CSUB-WATERCOMP_IN', 'CSUB-WATERCOMP_OUT'] + +# static model data +# temporal discretization +nper = 31 +perlen = [1.] + [365.2500000 for i in range(nper - 1)] +nstp = [1] + [6 for i in range(nper - 1)] +tsmult = [1.0] + [1.3 for i in range(nper - 1)] +# tsmult = [1.0] + [1.0 for i in range(nper - 1)] +steady = [True] + [False for i in range(nper - 1)] +tdis_rc = [] +for idx in range(nper): + tdis_rc.append((perlen[idx], nstp[idx], tsmult[idx])) + +# spatial discretization data +nlay, nrow, ncol = 3, 20, 20 +shape3d = (nlay, nrow, ncol) +size3d = nlay * nrow * ncol +delr, delc = 1000., 2000. +top = 0. +botm = [-100, -150., -350.] +zthick = [top - botm[0], + botm[0] - botm[1], + botm[1] - botm[2]] +strt = 0. +hnoflo = 1e30 +hdry = -1e30 + +# create idomain and ibound +idomain = np.ones((nlay, nrow, ncol), dtype=np.int32) +idomain[0, 10:, :] = 0 +idomain[1, 0:5, :] = 0 +idomain[1, 15:, :] = 0 +idomain[2, 0:10, :] = 0 +iex = np.zeros((nlay, nrow, ncol), dtype=np.int32) +iex[idomain == 0] = 1 + +# calculate hk +hk1fact = 1. / 50. +hk1 = 0.5 * hk1fact +# hk1[0, :] = 1000. * hk1fact +# hk1[-1, :] = 1000. * hk1fact +# hk1[:, 0] = 1000. * hk1fact +# hk1[:, -1] = 1000. * hk1fact +hk = [20., hk1, 5.] + +# calculate vka +vka = [1e6, 7.5e-5, 1e6] + +# layer 1 is convertible +laytyp = [1, 0, 0] + +# solver options +nouter, ninner = 500, 300 +hclose, rclose, relax = 1e-9, 1e-6, 1. +newtonoptions = '' +imsla = 'BICGSTAB' + +# chd data +c = [] +c6 = [] +ccol = [j for j in range(ncol)] +for j in ccol: + c.append([0, 0, j, strt, strt]) + c6.append([(0, 0, j), strt]) +cd = {0: c} +cd6 = {0: c6} +maxchd = len(cd[0]) + +# drain data +dr = [] +dr6 = [] +drh = strt - 1. +drc = 10. +for j in ccol: + dr.append([2, nrow - 1, j, drh, drc]) + dr6.append([(2, nrow - 1, j), drh, drc]) +drd = {0: dr} +drd6 = {0: dr6} +maxdrd = len(drd[0]) + +# pumping well data +wrp = [12, 12, 13, 13] +wcp = [9, 10, 9, 10] +wq = [-14000., -8000., -5000., -3000.] +d = [] +d6 = [] +for r, c, q in zip(wrp, wcp, wq): + d.append([2, r, c, q]) + d6.append([(2, r, c), q]) +wd = {1: d} +wd6 = {1: d6} +maxwel = len(wd[1]) +maxwel = len(wd[1]) + +# storage and compaction data +# ske = [6e-4, 3e-4, 6e-4] +# ss = [3e-6, 0., 3e-6] +ss = [0., 0., 0.] +void = 0.82 +theta = void / (1. + void) + +# static ibc and sub data +sgm = 0. +sgs = 0. +omega = 1.0 + +# no delay bed data +nndb = 3 +lnd = [0, 1, 2] +hc = -7. +thicknd0 = [15., 50., 30.] +ccnd0 = [6e-4, 3e-4, 6e-4] +crnd0 = [6e-6, 3e-6, 6e-6] +sfv = [] +sfe = [] +for k in range(nlay): + sfv.append(ccnd0[k] * thicknd0[k]) + sfe.append(crnd0[k] * thicknd0[k]) + +# ibc packagedata container counter +sub6 = [] +ibcno = 0 + +# create no delay bed packagedata entries +if nndb > 0: + cdelays = 'nodelay' + for kdx, k in enumerate(lnd): + for i in range(nrow): + for j in range(ncol): + # skip constant head cells + if idomain[k, i, j] == 0: + continue + tag = '{:02d}_{:02d}_{:02d}'.format(k + 1, i + 1, j + 1) + # create nodelay entry + # no delay beds + b = thicknd0[kdx] + d = [ibcno, (k, i, j), cdelays, hc, + b, 1., ccnd0[kdx], crnd0[kdx], theta, + 999., -999., tag] + sub6.append(d) + ibcno += 1 + +# create delay bed packagedata entries and coarse-grained materia storage +ske_scaled = [] +# create S for aquifer and no-delay beds +for k in range(nlay): + sst = (zthick[k] - thicknd0[k]) * ss[k] / zthick[k] + ske_scaled.append(sst) + +maxcsub = len(sub6) + +# sub output data +ds15 = [0, 0, 0, 2052, 0, 0, 0, 2053, 0, 0, 0, 0] +ds16 = [0, nper - 1, 0, nstp[-1] - 1, 0, 0, 1, 1, 0, 0, 1, 1, 0, 0, 0, 0, 1] + + +# variant SUB package problem 3 +def get_model(idx, dir): + name = ex[idx] + + # build MODFLOW 6 files + ws = dir + sim = flopy.mf6.MFSimulation(sim_name=name, version='mf6', + exe_name='mf6', + sim_ws=ws) + # create tdis package + tdis = flopy.mf6.ModflowTdis(sim, time_units='DAYS', + nper=nper, perioddata=tdis_rc) + + # create gwf model + zthick = [top - botm[0], + botm[0] - botm[1], + botm[1] - botm[2]] + elevs = [top] + botm + + gwf = flopy.mf6.ModflowGwf(sim, modelname=name, + newtonoptions=newtonoptions, + save_flows=True) + + # create iterative model solution and register the gwf model with it + ims = flopy.mf6.ModflowIms(sim, print_option='SUMMARY', + outer_hclose=hclose, + outer_maximum=nouter, + under_relaxation='NONE', + inner_maximum=ninner, + inner_hclose=hclose, rcloserecord=rclose, + linear_acceleration=imsla, + scaling_method='NONE', + reordering_method='NONE', + relaxation_factor=relax) + sim.register_ims_package(ims, [gwf.name]) + + dis = flopy.mf6.ModflowGwfdis(gwf, nlay=nlay, nrow=nrow, ncol=ncol, + delr=delr, delc=delc, + top=top, botm=botm, + idomain=idomain, + filename='{}.dis'.format(name)) + + # initial conditions + ic = flopy.mf6.ModflowGwfic(gwf, strt=strt, + filename='{}.ic'.format(name)) + + # node property flow + npf = flopy.mf6.ModflowGwfnpf(gwf, save_flows=False, + icelltype=laytyp, + k=hk, + k33=vka) + # storage + sto = flopy.mf6.ModflowGwfsto(gwf, save_flows=False, iconvert=laytyp, + ss=0, sy=0, + storagecoefficient=None, + steady_state={0: True}, + transient={1: True}) + + # csub files + opth = '{}.csub.obs'.format(name) + ibcsv = '{}.ib.strain.csv'.format(name) + skcsv = '{}.sk.strain.csv'.format(name) + copth = '{}.compaction.bin'.format(name) + zopth = '{}.zdisplacement.bin'.format(name) + csub = flopy.mf6.ModflowGwfcsub(gwf, + boundnames=True, + head_based=True, + specified_initial_interbed_state=True, + effective_stress_lag=True, + save_flows=True, + strainib_filerecord=ibcsv, + straincg_filerecord=skcsv, + compaction_filerecord=copth, + zdisplacement_filerecord=zopth, + ninterbeds=maxcsub, + beta=0., cg_ske_cr=ss, + packagedata=sub6) + orecarray = {} + tag = '{:02d}_{:02d}_{:02d}'.format(3, wrp[0] + 1, wcp[0] + 1) + oloc = (2, wrp[0], wcp[0]) + orecarray['csub_obs.csv'] = [('tcomp3', 'interbed-compaction', tag), + ('sk-tcomp3', 'coarse-compaction', oloc), + ('ibi-tcomp3', 'inelastic-compaction', tag), + ('ibe-tcomp3', 'elastic-compaction', tag)] + csub_obs_package = csub.obs.initialize(filename=opth, digits=10, + print_input=True, + continuous=orecarray) + + # drain + drn = flopy.mf6.ModflowGwfdrn(gwf, maxbound=maxdrd, + stress_period_data=drd6) + + # wel file + wel = flopy.mf6.ModflowGwfwel(gwf, print_input=True, print_flows=True, + maxbound=maxwel, + stress_period_data=wd6) + + # chd files + chd = flopy.mf6.modflow.mfgwfchd.ModflowGwfchd(gwf, + maxbound=maxchd, + stress_period_data=cd6, + save_flows=False) + + # output control + oc = flopy.mf6.ModflowGwfoc(gwf, + budget_filerecord='{}.cbc'.format(name), + head_filerecord='{}.hds'.format(name), + headprintrecord=[ + ('COLUMNS', 10, 'WIDTH', 15, + 'DIGITS', 6, 'GENERAL')], + saverecord=[('HEAD', 'ALL'), + ('BUDGET', 'ALL')], + printrecord=[('HEAD', 'LAST'), + ('BUDGET', 'ALL')]) + + # build MODFLOW-NWT files + cpth = cmppth + ws = os.path.join(dir, cpth) + mc = flopy.modflow.Modflow(name, model_ws=ws, version=cpth) + dis = flopy.modflow.ModflowDis(mc, nlay=nlay, nrow=nrow, ncol=ncol, + nper=nper, perlen=perlen, nstp=nstp, + tsmult=tsmult, steady=steady, delr=delr, + delc=delc, top=top, botm=botm) + bas = flopy.modflow.ModflowBas(mc, ibound=idomain, strt=strt, + hnoflo=hnoflo, + stoper=0.01) + upw = flopy.modflow.ModflowUpw(mc, laytyp=laytyp, ipakcb=1001, + hk=hk, vka=vka, + ss=ske_scaled, sy=0., + hdry=hdry) + sub = flopy.modflow.ModflowSub(mc, ndb=0, nndb=nndb, + isuboc=1, ln=lnd, + hc=hc, sfe=sfe, sfv=sfv, + ids15=ds15, ids16=ds16) + chd = flopy.modflow.ModflowChd(mc, stress_period_data=cd) + drn = flopy.modflow.ModflowDrn(mc, stress_period_data=drd) + wel = flopy.modflow.ModflowWel(mc, stress_period_data=wd) + oc = flopy.modflow.ModflowOc(mc, stress_period_data=None, + save_every=1, + save_types=['print head', 'save head', + 'save budget']) + fluxtol = (float(nlay * nrow * ncol) - 4.) * rclose + nwt = flopy.modflow.ModflowNwt(mc, + headtol=hclose, fluxtol=fluxtol, + maxiterout=nouter, linmeth=2, + maxitinner=ninner, + unitnumber=132, + options='SPECIFIED', + backflag=0, idroptol=0) + return sim, mc + + +def build_models(): + for idx, dir in enumerate(exdirs): + sim, mc = get_model(idx, dir) + sim.write_simulation() + mc.write_input() + return + + +def eval_zdisplacement(sim): + print('evaluating z-displacement...') + + # MODFLOW 6 total compaction results + fpth = os.path.join(sim.simpath, 'csub_obs.csv') + try: + tc = np.genfromtxt(fpth, names=True, delimiter=',') + except: + assert False, 'could not load data from "{}"'.format(fpth) + + # MODFLOW-2005 total compaction results + fn = '{}.total_comp.hds'.format(os.path.basename(sim.name)) + fpth = os.path.join(sim.simpath, 'mfnwt', fn) + try: + sobj = flopy.utils.HeadFile(fpth, text='LAYER COMPACTION') + tc0 = sobj.get_ts((2, wrp[0], wcp[0])) + except: + assert False, 'could not load data from "{}"'.format(fpth) + + # calculate maximum absolute error + diff = tc['TCOMP3'] - tc0[:, 1] + diffmax = np.abs(diff).max() + msg = 'maximum absolute total-compaction difference ({}) '.format(diffmax) + + if diffmax > dtol: + sim.success = False + msg += 'exceeds {}'.format(dtol) + assert diffmax < dtol, msg + else: + sim.success = True + print(' ' + msg) + + # get results from listing file + fpth = os.path.join(sim.simpath, + '{}.lst'.format(os.path.basename(sim.name))) + budl = flopy.utils.Mf6ListBudget(fpth) + names = list(bud_lst) + d0 = budl.get_budget(names=names)[0] + dtype = d0.dtype + nbud = d0.shape[0] + + # get results from cbc file + cbc_bud = ['STO-SS', 'STO-SY', + 'CSUB-CGELASTIC', 'CSUB-ELASTIC', + 'CSUB-INELASTIC', 'CSUB-WATERCOMP'] + d = np.recarray(nbud, dtype=dtype) + for key in bud_lst: + d[key] = 0. + fpth = os.path.join(sim.simpath, + '{}.cbc'.format(os.path.basename(sim.name))) + cobj = flopy.utils.CellBudgetFile(fpth, precision='double') + kk = cobj.get_kstpkper() + times = cobj.get_times() + for idx, (k, t) in enumerate(zip(kk, times)): + for text in cbc_bud: + qin = 0. + qout = 0. + v = cobj.get_data(kstpkper=k, text=text)[0] + if isinstance(v, np.recarray): + vt = np.zeros(size3d, dtype=np.float) + for jdx, node in enumerate(v['node']): + vt[node - 1] += v['q'][jdx] + v = vt.reshape(shape3d) + for kk in range(v.shape[0]): + for ii in range(v.shape[1]): + for jj in range(v.shape[2]): + vv = v[kk, ii, jj] + if vv < 0.: + qout -= vv + else: + qin += vv + d['totim'][idx] = t + d['time_step'][idx] = k[0] + d['stress_period'] = k[1] + key = '{}_IN'.format(text) + d[key][idx] = qin + key = '{}_OUT'.format(text) + d[key][idx] = qout + + diff = np.zeros((nbud, len(bud_lst)), dtype=np.float) + for idx, key in enumerate(bud_lst): + diff[:, idx] = d0[key] - d[key] + diffmax = np.abs(diff).max() + msg = 'maximum absolute total-budget difference ({}) '.format(diffmax) + + # write summary + fpth = os.path.join(sim.simpath, + '{}.bud.cmp.out'.format(os.path.basename(sim.name))) + f = open(fpth, 'w') + for i in range(diff.shape[0]): + if i == 0: + line = '{:>10s}'.format('TIME') + for idx, key in enumerate(bud_lst): + line += '{:>25s}'.format(key + '_LST') + line += '{:>25s}'.format(key + '_CBC') + line += '{:>25s}'.format(key + '_DIF') + f.write(line + '\n') + line = '{:10g}'.format(d['totim'][i]) + for idx, key in enumerate(bud_lst): + line += '{:25g}'.format(d0[key][i]) + line += '{:25g}'.format(d[key][i]) + line += '{:25g}'.format(diff[i, idx]) + f.write(line + '\n') + f.close() + + if diffmax > budtol: + sim.success = False + msg += 'exceeds {}'.format(dtol) + assert diffmax < dtol, msg + else: + sim.success = True + print(' ' + msg) + + # compare z-displacement data + fpth1 = os.path.join(sim.simpath, + '{}.zdisplacement.bin'.format( + os.path.basename(sim.name))) + fpth2 = os.path.join(sim.simpath, cmppth, 'csub_zdisp01.vert_disp.hds') + text1 = 'CSUB-ZDISPLACE' + text2 = 'Z DISPLACEMENT' + fout = os.path.join(sim.simpath, + '{}.z-displacement.bin.out'.format( + os.path.basename(sim.name))) + success_tst = pymake.compare_heads(None, None, + text=text1, text2=text2, + outfile=fout, + files1=fpth1, + files2=fpth2, + difftol=True, + verbose=True, + exarr=iex) + msg = 'z-displacement comparison success = {}'.format(success_tst) + if success_tst: + sim.success = True + print(msg) + else: + sim.success = False + assert success_tst, msg + + return + + +# - No need to change any code below +def test_mf6model(): + # determine if running on Travis + is_travis = 'TRAVIS' in os.environ + r_exe = None + if not is_travis: + if replace_exe is not None: + r_exe = replace_exe + + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + if is_travis and not travis[idx]: + continue + yield test.run_mf6, Simulation(dir, exfunc=eval_zdisplacement, + exe_dict=r_exe, + htol=htol[idx], + idxsim=idx) + + return + + +def main(): + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + sim = Simulation(dir, exfunc=eval_zdisplacement, + exe_dict=replace_exe, htol=htol[idx], idxsim=idx) + test.run_mf6(sim) + + return + + +if __name__ == "__main__": + # print message + print('standalone run of {}'.format(os.path.basename(__file__))) + + # run main routine + main() diff --git a/autotest/test_gwf_disu01.py b/autotest/test_gwf_disu01.py new file mode 100644 index 00000000000..489e8402a84 --- /dev/null +++ b/autotest/test_gwf_disu01.py @@ -0,0 +1,140 @@ +""" +MODFLOW 6 Autotest +Test to make sure that disu is working correctly + +""" + +import os +import shutil +import subprocess +import numpy as np +from nose.tools import raises + +try: + import flopy +except: + msg = 'Error. FloPy package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install flopy' + raise Exception(msg) + +import targets + +mf6_exe = os.path.abspath(targets.target_dict['mf6']) +testname = 'gwf_disu01' +testdir = os.path.join('temp', testname) +if not os.path.isdir(testdir): + os.mkdir(testdir) +everything_was_successful = True + + +def run_mf6(argv, ws): + buff = [] + proc = subprocess.Popen(argv, + stdout=subprocess.PIPE, + stderr=subprocess.PIPE, + cwd=ws) + result, error = proc.communicate() + if result is not None: + c = result.decode('utf-8') + c = c.rstrip('\r\n') + print('{}'.format(c)) + buff.append(c) + + return proc.returncode, buff + + +def test_disu_simple(): + from disu_util import get_disu_kwargs + name = 'disu01a' + ws = os.path.join(testdir, name) + nlay = 3 + nrow = 3 + ncol = 3 + delr = 10. * np.ones(ncol) + delc = 10. * np.ones(nrow) + top = 0 + botm = [-10, -20, -30] + disukwargs = get_disu_kwargs(nlay, nrow, ncol, delr, delc, top, botm) + sim = flopy.mf6.MFSimulation(sim_name=name, version='mf6', + exe_name=mf6_exe, sim_ws=ws) + tdis = flopy.mf6.ModflowTdis(sim) + gwf = flopy.mf6.ModflowGwf(sim, modelname=name) + ims = flopy.mf6.ModflowIms(sim, print_option='SUMMARY') + disu = flopy.mf6.ModflowGwfdisu(gwf, **disukwargs) + ic = flopy.mf6.ModflowGwfic(gwf, strt=0.) + npf = flopy.mf6.ModflowGwfnpf(gwf) + spd = {0:[[(0, ), 1.], [(nrow * ncol - 1, ), 0.]]} + chd = flopy.mf6.modflow.mfgwfchd.ModflowGwfchd(gwf, stress_period_data=spd) + sim.write_simulation() + sim.run_simulation() + return + + +def test_disu_idomain_simple(): + from disu_util import get_disu_kwargs + name = 'disu01b' + ws = os.path.join(testdir, name) + nlay = 3 + nrow = 3 + ncol = 3 + delr = 10. * np.ones(ncol) + delc = 10. * np.ones(nrow) + top = 0 + botm = [-10, -20, -30] + idomain = np.ones(nlay*nrow*ncol, dtype=np.int) + idomain[1] = 0 + disukwargs = get_disu_kwargs(nlay, nrow, ncol, delr, delc, top, botm) + disukwargs['idomain'] = idomain + sim = flopy.mf6.MFSimulation(sim_name=name, version='mf6', + exe_name=mf6_exe, sim_ws=ws) + tdis = flopy.mf6.ModflowTdis(sim) + gwf = flopy.mf6.ModflowGwf(sim, modelname=name, save_flows=True) + ims = flopy.mf6.ModflowIms(sim, print_option='SUMMARY') + disu = flopy.mf6.ModflowGwfdisu(gwf, **disukwargs) + ic = flopy.mf6.ModflowGwfic(gwf, strt=0.) + npf = flopy.mf6.ModflowGwfnpf(gwf) + spd = {0:[[(0, ), 1.], [(nrow * ncol - 1, ), 0.]]} + chd = flopy.mf6.modflow.ModflowGwfchd(gwf, stress_period_data=spd) + oc = flopy.mf6.modflow.ModflowGwfoc(gwf, + budget_filerecord='{}.bud'.format(name), + head_filerecord='{}.hds'.format(name), + saverecord=[('HEAD', 'LAST'), + ('BUDGET', 'LAST')],) + sim.write_simulation() + sim.run_simulation() + + # check binary grid file + fname = os.path.join(ws, name + '.disu.grb') + grbobj = flopy.utils.MfGrdFile(fname) + nodes = grbobj._datadict['NODES'] + ia = grbobj._datadict['IA'] + ja = grbobj._datadict['JA'] + assert nodes == disukwargs['nodes'] + assert np.array_equal(ia[0: 4], np.array([1, 4, 4, 7])) + assert np.array_equal(ja[:6], np.array([ 1, 4, 10, 3, 6, 12])) + assert ia[-1] == 127 + assert ia.shape[0] == 28, 'ia should have size of 28' + assert ja.shape[0] == 126, 'ja should have size of 126' + + # load head array and ensure nodata value in second cell + fname = os.path.join(ws, name + '.hds') + hdsobj = flopy.utils.HeadFile(fname) + head = hdsobj.get_alldata().flatten() + assert head[1] == 1.e30 + + # load flowja to make sure it is the right size + fname = os.path.join(ws, name + '.bud') + budobj = flopy.utils.CellBudgetFile(fname, precision='double') + flowja = budobj.get_data(text='FLOW-JA-FACE')[0].flatten() + assert flowja.shape[0] == 126 + + return + + +if __name__ == "__main__": + # print message + print('standalone run of {}'.format(os.path.basename(__file__))) + + test_disu_simple() + test_disu_idomain_simple() diff --git a/autotest/test_gwf_errors.py b/autotest/test_gwf_errors.py new file mode 100644 index 00000000000..7e22a6e94e8 --- /dev/null +++ b/autotest/test_gwf_errors.py @@ -0,0 +1,226 @@ +""" +MODFLOW 6 Autotest +Test to make sure that mf6 is failing with the correct error messages. This +test script is set up to be extensible so that simple models can be created +very easily and tested with different options to succeed or fail correctly. + +""" + +import os +import shutil +import subprocess +import numpy as np +from nose.tools import raises + +try: + import flopy +except: + msg = 'Error. FloPy package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install flopy' + raise Exception(msg) + +import targets + +mf6_exe = os.path.abspath(targets.target_dict['mf6']) +testname = 'gwf_errors' +testdir = os.path.join('temp', testname) +if not os.path.isdir(testdir): + os.mkdir(testdir) +everything_was_successful = True + +def run_mf6(argv, ws): + buff = [] + proc = subprocess.Popen(argv, + stdout=subprocess.PIPE, + stderr=subprocess.PIPE, + cwd=ws) + result, error = proc.communicate() + if result is not None: + c = result.decode('utf-8') + c = c.rstrip('\r\n') + print('{}'.format(c)) + buff.append(c) + + return proc.returncode, buff + + +def run_mf6_error(ws, err_str_list): + returncode, buff = run_mf6([mf6_exe], ws) + msg = 'mf terminated with error' + if returncode != 0: + if not isinstance(err_str_list, list): + err_str_list = list(err_str_list) + for err_str in err_str_list: + err = any(err_str in s for s in buff) + if err: + raise RuntimeError(msg) + else: + msg += ' but did not print correct error message.' + msg += ' Correct message should have been "{}"'.format(err_str) + raise ValueError(msg) + return + + +def get_minimal_gwf_simulation(ws, name='test', + simkwargs=None, + simnamefilekwargs=None, + tdiskwargs=None, + gwfkwargs=None, + imskwargs=None, + diskwargs=None, + disukwargs=None, + ickwargs=None, + npfkwargs=None, + chdkwargs=None): + if simkwargs is None: + simkwargs = {} + if tdiskwargs is None: + tdiskwargs = {} + if gwfkwargs is None: + gwfkwargs = {} + gwfkwargs['modelname'] = name + if imskwargs is None: + imskwargs = {'print_option': 'SUMMARY', } + if diskwargs is None and disukwargs is None: + diskwargs = {} + diskwargs['nlay'] = 5 + diskwargs['nrow'] = 5 + diskwargs['ncol'] = 5 + diskwargs['top'] = 0 + diskwargs['botm'] = [-1, -2, -3, -4, -5] + if ickwargs is None: + ickwargs = {} + if npfkwargs is None: + npfkwargs = {} + if chdkwargs is None: + chdkwargs = {} + nl = diskwargs['nlay'] + nr = diskwargs['nrow'] + nc = diskwargs['ncol'] + chdkwargs['stress_period_data'] = {0:[[(0, 0, 0), 0], + [(0, nr - 1, nc - 1), 1]]} + sim = flopy.mf6.MFSimulation(sim_name=name, version='mf6', + exe_name=mf6_exe, + sim_ws=ws, **simkwargs) + if simnamefilekwargs is not None: + for k in simnamefilekwargs: + sim.name_file.__setattr__(k, simnamefilekwargs[k]) + tdis = flopy.mf6.ModflowTdis(sim, **tdiskwargs) + gwf = flopy.mf6.ModflowGwf(sim, **gwfkwargs) + ims = flopy.mf6.ModflowIms(sim, **imskwargs) + if diskwargs is not None: + dis = flopy.mf6.ModflowGwfdis(gwf, **diskwargs) + elif disukwargs is not None: + disu = flopy.mf6.ModflowGwfdisu(gwf, **disukwargs) + ic = flopy.mf6.ModflowGwfic(gwf, **ickwargs) + npf = flopy.mf6.ModflowGwfnpf(gwf, **npfkwargs) + chd = flopy.mf6.modflow.mfgwfchd.ModflowGwfchd(gwf, **chdkwargs) + return sim + + +def test_simple_model_success(): + # test a simple model to make sure it runs and terminates correctly + ws = os.path.join(testdir, 'sim0') + sim = get_minimal_gwf_simulation(ws) + sim.write_simulation() + returncode, buff = run_mf6([mf6_exe], ws) + assert returncode == 0, 'mf6 failed for simple model.' + + final_message = 'Normal termination of simulation.' + failure_message = 'mf6 did not terminate with "{}"'.format(final_message) + assert final_message in buff[-1], failure_message + return + + +@raises(RuntimeError) +def test_raises_error(): + # verify that the @raises decorator is working properly + msg = 'Raising runtime error' + raise RuntimeError(msg) + return + + +@raises(RuntimeError) +def test_empty_folder(): + # make sure mf6 fails when there is no simulation name file + err_str = 'mf6: mfsim.nam is not present in working directory.' + run_mf6_error(testdir, err_str) + return + + +@raises(RuntimeError) +def test_sim_errors(): + # verify that the correct number of errors are reported + ws = os.path.join(testdir, 'sim1') + chdkwargs = {} + chdkwargs['stress_period_data'] = {0: [[(0, 0, 0), 0.] for i in range(10)]} + sim = get_minimal_gwf_simulation(ws, + chdkwargs=chdkwargs) + sim.write_simulation() + err_str = ['11 errors detected.', + 'ERROR OCCURRED WHILE READING FILE:', + 'test.chd', + 'Stopping due to error(s)'] + run_mf6_error(ws, err_str) + return + + +@raises(RuntimeError) +def test_sim_maxerrors(): + # verify that the maxerrors keyword gives the correct error output + ws = os.path.join(testdir, 'sim2') + simnamefilekwargs = {} + simnamefilekwargs['maxerrors'] = 5 + chdkwargs = {} + chdkwargs['stress_period_data'] = {0: [[(0, 0, 0), 0.] for i in range(10)]} + sim = get_minimal_gwf_simulation(ws, + simnamefilekwargs=simnamefilekwargs, + chdkwargs=chdkwargs) + sim.write_simulation() + err_str = ['5 errors detected.', + '6 additional errors detected but not printed.', + 'Stopping due to error(s)'] + run_mf6_error(ws, err_str) + return + + +@raises(RuntimeError) +def test_disu_errors(): + from disu_util import get_disu_kwargs + ws = os.path.join(testdir, 'sim3') + disukwargs = get_disu_kwargs(3, 3, 3, np.ones(3), np.ones(3), + 0, [-1, -2, -3]) + top = disukwargs['top'] + bot = disukwargs['bot'] + top[9] = 2. + bot[9] = 1. + sim = get_minimal_gwf_simulation(ws, + disukwargs=disukwargs, + chdkwargs={'stress_period_data': [[]]}) + sim.write_simulation() + err_str = ['Top elevation ( 2.00000 ) for cell 10 is above bottom elevation (', + '-1.00000 ) for cell 1. Based on node numbering rules cell 10 must be', + 'below cell 1.', + '3 errors detected.', + 'Stopping due to error(s)'] + run_mf6_error(ws, err_str) + return + + +def test_clean_sim(): + shutil.rmtree(testdir) + return + + +if __name__ == "__main__": + # print message + print('standalone run of {}'.format(os.path.basename(__file__))) + + test_raises_error() + test_empty_folder() + test_simple_model_success() + test_sim_errors() + test_sim_maxerrors() + test_disu_errors() + diff --git a/autotest/test_gwf_evt01.py b/autotest/test_gwf_evt01.py new file mode 100644 index 00000000000..9d8918ad452 --- /dev/null +++ b/autotest/test_gwf_evt01.py @@ -0,0 +1,228 @@ +import os +import sys +import numpy as np + +try: + import pymake +except: + msg = 'Error. Pymake package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install https://github.com/modflowpy/pymake/zipball/master' + raise Exception(msg) + +try: + import flopy +except: + msg = 'Error. FloPy package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install flopy' + raise Exception(msg) + +from framework import testing_framework +from simulation import Simulation + +ex = ['evt01'] +exdirs = [] +for s in ex: + exdirs.append(os.path.join('temp', s)) + + +def get_model(idx, dir): + + nlay, nrow, ncol = 1, 1, 3 + chdheads = list(np.linspace(1, 100)) + nper = len(chdheads) + perlen = nper * [1.] + nstp = nper * [1] + tsmult = nper * [1.] + + delr = delc = 1. + strt = chdheads[0] + + nouter, ninner = 100, 300 + hclose, rclose, relax = 1e-9, 1e-3, 0.97 + + tdis_rc = [] + for i in range(nper): + tdis_rc.append((perlen[i], nstp[i], tsmult[i])) + + name = ex[idx] + + # build MODFLOW 6 files + ws = dir + sim = flopy.mf6.MFSimulation(sim_name=name, version='mf6', + exe_name='mf6', + sim_ws=ws) + # create tdis package + tdis = flopy.mf6.ModflowTdis(sim, time_units='DAYS', + nper=nper, perioddata=tdis_rc) + + # create gwf model + gwf = flopy.mf6.ModflowGwf(sim, modelname=name, save_flows=True) + + # create iterative model solution and register the gwf model with it + ims = flopy.mf6.ModflowIms(sim, print_option='SUMMARY', + outer_hclose=hclose, + outer_maximum=nouter, + under_relaxation='DBD', + inner_maximum=ninner, + inner_hclose=hclose, rcloserecord=rclose, + linear_acceleration='BICGSTAB', + scaling_method='NONE', + reordering_method='NONE', + relaxation_factor=relax) + sim.register_ims_package(ims, [gwf.name]) + + dis = flopy.mf6.ModflowGwfdis(gwf, nlay=nlay, nrow=nrow, ncol=ncol, + delr=delr, delc=delc, + top=100., botm=0.) + + # initial conditions + ic = flopy.mf6.ModflowGwfic(gwf, strt=strt) + + # node property flow + npf = flopy.mf6.ModflowGwfnpf(gwf, save_flows=True, + icelltype=1, + k=1.0) + + # chd files + chdspd = {} + for kper, chdval in enumerate(chdheads): + chdspd[kper] = [[(0, 0, 0), chdval], [(0, 0, ncol - 1), chdval]] + chd = flopy.mf6.ModflowGwfchd(gwf, stress_period_data=chdspd) + + nseg = 4 + surf_rate_specified = True + evtspd = [[(0, 0, 1), 95., 0.001, 90., 0.25, 0.5, 0.75, 1., 0., 1., 0.1]] + + #nseg = 4 + #surf_rate_specified = False + #evtspd = [((0, 0, 1), 95., 0.001, 90., 0.25, 0.5, 0.75, 1., 0., 1.)] + + #nseg = 1 + #surf_rate_specified = False + #evtspd = [[(0, 0, 1), 95., 0.001, 90.]] + + evt = flopy.mf6.ModflowGwfevt(gwf, print_flows=True, + surf_rate_specified=surf_rate_specified, + maxbound=1, nseg=nseg, + stress_period_data=evtspd) + + # output control + oc = flopy.mf6.ModflowGwfoc(gwf, + budget_filerecord='{}.cbc'.format(name), + head_filerecord='{}.hds'.format(name), + headprintrecord=[ + ('COLUMNS', 10, 'WIDTH', 15, + 'DIGITS', 6, 'GENERAL')], + saverecord=[('HEAD', 'ALL'), + ('BUDGET', 'ALL')], + printrecord=[('HEAD', 'ALL'), + ('BUDGET', 'ALL')], + filename='{}.oc'.format(name)) + + return sim + + +def build_models(): + for idx, dir in enumerate(exdirs): + sim = get_model(idx, dir) + sim.write_simulation() + return + + +def etfunc(h, qmax, surf, exdp, petm, pxdp, petm0=1.0): + nseg = len(petm) + 1 + d = surf - h + if h >= surf: + hcof = 0. + rhs = qmax * petm0 + elif d >= exdp: + hcof = 0. + rhs = 0. + else: + if nseg > 1: + pxdp1 = 0.0 + petm1 = petm0 + for iseg in range(nseg): + if iseg < nseg - 1: + pxdp2 = pxdp[iseg] + petm2 = petm[iseg] + else: + pxdp2 = 1.0 + petm2 = 0. + if d <= pxdp2 * exdp: + break + pxdp1 = pxdp2 + petm1 = petm2 + hcof = - (petm1 - petm2) * qmax / ((pxdp2 - pxdp1) * exdp) + rhs = hcof * (surf - pxdp1 * exdp) + petm1 * qmax + else: + hcof = -qmax / exdp + rhs = qmax - qmax * surf / exdp + q = h * hcof - rhs + return q, hcof, rhs + + +def eval_model(sim): + print('evaluating model...') + + fpth = os.path.join(sim.simpath, 'evt01.cbc') + bobj = flopy.utils.CellBudgetFile(fpth, precision='double') + records = bobj.get_data(text='evt') + + fpth = os.path.join(sim.simpath, 'evt01.hds') + hobj = flopy.utils.HeadFile(fpth, precision='double') + heads = hobj.get_alldata() + + for kper, r in enumerate(records): + node, node2, sim_evt_rate = r[0] + + h = heads[kper, 0, 0, 1] + + cal_evt_rate, hcof, rhs = etfunc(h, 0.001, 95., 90, + [1., 0., 1.], [.25, .5, .75], + petm0=0.1) + + msg = '{} {} {} {}'.format(kper, h, sim_evt_rate, cal_evt_rate) + assert np.allclose(sim_evt_rate, cal_evt_rate), msg + + return + + +# - No need to change any code below +def test_mf6model(): + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + yield test.run_mf6, Simulation(dir, exfunc=eval_model, idxsim=idx) + + return + + +def main(): + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + sim = Simulation(dir, exfunc=eval_model, idxsim=idx) + test.run_mf6(sim) + + return + + +if __name__ == "__main__": + # print message + print('standalone run of {}'.format(os.path.basename(__file__))) + + # run main routine + main() diff --git a/autotest/test_gwf_libmf6_rch02.py b/autotest/test_gwf_libmf6_rch02.py new file mode 100644 index 00000000000..3eedcf114a2 --- /dev/null +++ b/autotest/test_gwf_libmf6_rch02.py @@ -0,0 +1,258 @@ +""" +MODFLOW 6 Autotest +Test to make sure that recharge is passed to the highest active layer and +verify that recharge is in the highest active layer by looking at the +individual budget terms. For this test, there are two layers and five +columns. The top layer is dry except for the middle cell. Recharge is +applied to the top layer. In the test a, IRCH is not specified. In test b +IRCH is specified as 1, and in test c IRCH is specified as [2, 2, 1, 2, 2] +""" + +import os +import io +import sys +import numpy as np +from amipy import AmiWrapper + +try: + import pymake +except: + msg = 'Error. Pymake package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install https://github.com/modflowpy/pymake/zipball/master' + raise Exception(msg) + +try: + import flopy +except: + msg = 'Error. FloPy package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install flopy' + raise Exception(msg) + +from framework import testing_framework +from simulation import Simulation, bmi_return + +ex = ['libgwf_rch02'] +exdirs = [] +for s in ex: + exdirs.append(os.path.join('temp', s)) + +# average recharge rate +avg_rch = 0.001 + +# calculate recharge rates +dx = 1/20 +rad = np.arange(0, 1 + dx, dx) * 2. * np.pi +f = np.sin(rad) +rch_rates = avg_rch + f * avg_rch + +# temporal discretization +nper = rch_rates.shape[0] +tdis_rc = [] +for i in range(nper): + tdis_rc.append((1., 1, 1)) + +# model spatial dimensions +nlay, nrow, ncol = 1, 1, 100 + +# cell spacing +delr = 50. +delc = 1. +area = delr * delc + +# top of the aquifer +top = 25. + +# bottom of the aquifer +botm = 0. + +# hydraulic conductivity +hk = 50. + +# boundary heads +h1 = 20. +h2 = 11. + +# build chd stress period data +chd_spd = {0: [[(0, 0, 0), h1], + [(0, 0, ncol-1), h2]]} + +# build recharge spd +rch_spd = {} +for n in range(nper): + rch_spd[n] = rch_rates[n] + +# solver data +nouter, ninner = 100, 300 +hclose, rclose, relax = 1e-9, 1e-3, 0.97 + +def build_model(ws, name, rech): + sim = flopy.mf6.MFSimulation(sim_name=name, version='mf6', + exe_name='mf6', + sim_ws=ws, memory_print_option='all') + # create tdis package + tdis = flopy.mf6.ModflowTdis(sim, time_units='DAYS', + nper=nper, perioddata=tdis_rc) + + # create iterative model solution and register the gwf model with it + ims = flopy.mf6.ModflowIms(sim, print_option='SUMMARY', + outer_hclose=hclose, + outer_maximum=nouter, + under_relaxation='DBD', + inner_maximum=ninner, + inner_hclose=hclose, rcloserecord=rclose, + linear_acceleration='BICGSTAB', + relaxation_factor=relax) + + # create gwf model + gwf = flopy.mf6.ModflowGwf(sim, modelname=name, save_flows=True) + + dis = flopy.mf6.ModflowGwfdis(gwf, nlay=nlay, nrow=nrow, ncol=ncol, + delr=delr, delc=delc, + top=top, botm=botm) + + # initial conditions + ic = flopy.mf6.ModflowGwfic(gwf, strt=top) + + # node property flow + npf = flopy.mf6.ModflowGwfnpf(gwf, save_flows=True, + icelltype=1, + k=hk) + + # chd file + chd = flopy.mf6.ModflowGwfchd(gwf, stress_period_data=chd_spd) + + # recharge file + rch = flopy.mf6.ModflowGwfrcha(gwf, recharge=rech) + + # output control + oc = flopy.mf6.ModflowGwfoc(gwf, + head_filerecord='{}.hds'.format(name), + headprintrecord=[ + ('COLUMNS', 10, 'WIDTH', 15, + 'DIGITS', 6, 'GENERAL')], + saverecord=[('HEAD', 'ALL')], + printrecord=[('HEAD', 'ALL'), + ('BUDGET', 'ALL')]) + return sim + +def get_model(idx, dir): + + # build MODFLOW 6 files + ws = dir + name = ex[idx] + sim = build_model(ws, name, rech=rch_spd) + + # build comparison model + ws = os.path.join(dir, 'libmf6') + mc = build_model(ws, name, rech=avg_rch) + + return sim, mc + + +def build_models(): + for idx, dir in enumerate(exdirs): + sim, mc = get_model(idx, dir) + sim.write_simulation() + if mc is not None: + mc.write_simulation() + return + +def bmifunc(exe, idx, model_ws=None): + + success = False + + name = ex[idx].upper() + init_wd = os.path.abspath(os.getcwd()) + if model_ws is not None: + os.chdir(model_ws) + + mf6_config_file = os.path.join(model_ws, 'mfsim.nam') + mf6 = AmiWrapper(exe) + + # initialize the model + try: + mf6.initialize(mf6_config_file) + except: + return bmi_return(success, model_ws) + + # time loop + start_time = mf6.get_start_time() + current_time = mf6.get_current_time() + end_time = mf6.get_end_time() + simulation_length = end_time - current_time + + # get recharge array + cdata = "{} RCHA/BOUND".format(name) + recharge = mf6.get_value_ptr(cdata) + trch = np.zeros((ncol), dtype=np.float64) + + # model time loop + idx = 0 + while current_time < end_time: + # update recharge + trch[:] = rch_spd[idx] * area + recharge[:, 0] = trch[:] + + # run timestep + try: + mf6.update() + except: + return bmi_return(success, model_ws) + + # update time + current_time = mf6.get_current_time() + + # increment counter + idx += 1 + + # cleanup + try: + mf6.finalize() + success = True + except: + return bmi_return(success, model_ws) + + if model_ws is not None: + os.chdir(init_wd) + + # cleanup and return + return bmi_return(success, model_ws) + +# - No need to change any code below +def test_mf6model(): + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + yield test.run_mf6, Simulation(dir, idxsim=idx, bmifunc=bmifunc) + + return + + +def main(): + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + sim = Simulation(dir, idxsim=idx, bmifunc=bmifunc) + test.run_mf6(sim) + + return + + +if __name__ == "__main__": + # print message + print('standalone run of {}'.format(os.path.basename(__file__))) + + # run main routine + main() diff --git a/autotest/test_gwf_maw01.py b/autotest/test_gwf_maw01.py index 5176ba9df4a..5c4696f93ac 100644 --- a/autotest/test_gwf_maw01.py +++ b/autotest/test_gwf_maw01.py @@ -1,5 +1,4 @@ import os -import sys import numpy as np try: @@ -22,7 +21,7 @@ from simulation import Simulation ex = ['maw01', 'maw01nwt', 'maw01nwtur'] -newtonoptions = [None, [''], ['UNDER_RELAXATION']] +newtonoptions = [None, [''], ['NEWTON', 'UNDER_RELAXATION']] exdirs = [] for s in ex: exdirs.append(os.path.join('temp', s)) @@ -36,10 +35,8 @@ def get_model(idx, dir): perlen = [1., 1., 1.] nstp = [1, 1, 1] tsmult = [1., 1., 1.] - steady = [True, True, True] lenx = 300. delr = delc = lenx / float(nrow) - botm = [0.] strt = 100. hnoflo = 1e30 hdry = -1e30 @@ -86,25 +83,25 @@ def get_model(idx, dir): delr=delr, delc=delc, top=100., botm=0., idomain=1, - fname='{}.dis'.format(name)) + filename='{}.dis'.format(name)) # initial conditions ic = flopy.mf6.ModflowGwfic(gwf, strt=strt, - fname='{}.ic'.format(name)) + filename='{}.ic'.format(name)) # node property flow npf = flopy.mf6.ModflowGwfnpf(gwf, save_flows=True, icelltype=1, k=hk, k33=hk, - fname='{}.npf'.format(name)) + filename='{}.npf'.format(name)) # storage sto = flopy.mf6.ModflowGwfsto(gwf, save_flows=True, iconvert=1, ss=0., sy=0.1, steady_state={0: True}, # transient={1: False}, - fname='{}.sto'.format(name)) + filename='{}.sto'.format(name)) # chd files chdlist0 = [] @@ -119,7 +116,7 @@ def get_model(idx, dir): chd = flopy.mf6.ModflowGwfchd(gwf, stress_period_data=chdspdict, save_flows=False, - fname='{}.chd'.format(name)) + filename='{}.chd'.format(name)) # wel files #wel = flopy.mf6.ModflowGwfwel(gwf, print_input=True, print_flows=True, @@ -132,20 +129,15 @@ def get_model(idx, dir): wellrecarray = [[0, 0.1, wellbottom, 100., 'THIEM', 1]] wellconnectionsrecarray = [[0, 0, (0, 0, 1), 100., wellbottom, 1., 0.1]] wellperiodrecarray = [[0, 'rate', 0.]] - maw = flopy.mf6.ModflowGwfmaw(gwf, fname='{}.maw'.format(name), + mawo_dict = {} + mawo_dict['maw_obs.csv'] = [('mh1', 'head', 1)] + maw = flopy.mf6.ModflowGwfmaw(gwf, filename='{}.maw'.format(name), print_input=True, print_head=True, print_flows=True, save_flows=True, - obs_filerecord=opth, + observations=mawo_dict, packagedata=wellrecarray, connectiondata=wellconnectionsrecarray, perioddata=wellperiodrecarray) - mawo_dict = {} - mawo_dict['maw_obs.csv'] = [('mh1', 'head', 1)] - maw_obs = flopy.mf6.ModflowUtlobs(gwf, - fname=opth, - parent_file=maw, digits=20, - print_input=True, - continuous=mawo_dict) # output control oc = flopy.mf6.ModflowGwfoc(gwf, @@ -157,7 +149,7 @@ def get_model(idx, dir): saverecord=[('HEAD', 'ALL')], printrecord=[('HEAD', 'ALL'), ('BUDGET', 'ALL')], - fname='{}.oc'.format(name)) + filename='{}.oc'.format(name)) return sim diff --git a/autotest/test_gwf_maw02.py b/autotest/test_gwf_maw02.py index 7d164b68a58..a4174ec0721 100644 --- a/autotest/test_gwf_maw02.py +++ b/autotest/test_gwf_maw02.py @@ -36,10 +36,10 @@ shape3d = (nlay, nrow, ncol) size3d = nlay * nrow * ncol nper = 5 -perlen = [1. for n in range(nper)] -nstp = [1 for n in range(nper)] -tsmult = [1. for n in range(nper)] -steady = [True for n in range(nper)] +perlen = nper * [1.] +nstp = nper * [1] +tsmult = nper * [1.] +steady = nper * [True] lenx = 300. delr = delc = lenx / float(nrow) botm = [0.] @@ -92,25 +92,25 @@ def get_model(idx, dir): delr=delr, delc=delc, top=100., botm=0., idomain=1, - fname='{}.dis'.format(name)) + filename='{}.dis'.format(name)) # initial conditions ic = flopy.mf6.ModflowGwfic(gwf, strt=strt, - fname='{}.ic'.format(name)) + filename='{}.ic'.format(name)) # node property flow npf = flopy.mf6.ModflowGwfnpf(gwf, save_flows=True, icelltype=1, k=hk, k33=hk, - fname='{}.npf'.format(name)) + filename='{}.npf'.format(name)) # storage sto = flopy.mf6.ModflowGwfsto(gwf, save_flows=True, iconvert=1, ss=0., sy=0.1, steady_state={0: True}, # transient={1: False}, - fname='{}.sto'.format(name)) + filename='{}.sto'.format(name)) # chd files chdlist0 = [] @@ -125,7 +125,7 @@ def get_model(idx, dir): chd = flopy.mf6.ModflowGwfchd(gwf, stress_period_data=chdspdict, save_flows=False, - fname='{}.chd'.format(name)) + filename='{}.chd'.format(name)) # MAW opth = '{}.maw.obs'.format(name) @@ -140,21 +140,16 @@ def get_model(idx, dir): [1, 'rate', -130.], [1, 'status', 'active']], 3: [[0, 'status', 'inactive']], 4: [[0, 'status', 'active']]} - maw = flopy.mf6.ModflowGwfmaw(gwf, fname='{}.maw'.format(name), + mawo_dict = {} + mawo_dict['maw_obs.csv'] = [('mh1', 'head', 1)] + maw = flopy.mf6.ModflowGwfmaw(gwf, filename='{}.maw'.format(name), budget_filerecord='{}.maw.cbc'.format(name), print_input=True, print_head=True, print_flows=True, save_flows=True, - obs_filerecord=opth, + observations=mawo_dict, packagedata=wellrecarray, connectiondata=wellconnectionsrecarray, perioddata=wellperiodrecarray) - mawo_dict = {} - mawo_dict['maw_obs.csv'] = [('mh1', 'head', 1)] - maw_obs = flopy.mf6.ModflowUtlobs(gwf, - fname=opth, - parent_file=maw, digits=20, - print_input=True, - continuous=mawo_dict) # output control oc = flopy.mf6.ModflowGwfoc(gwf, @@ -167,7 +162,7 @@ def get_model(idx, dir): ('BUDGET', 'ALL')], printrecord=[('HEAD', 'ALL'), ('BUDGET', 'ALL')], - fname='{}.oc'.format(name)) + filename='{}.oc'.format(name)) return sim diff --git a/autotest/test_gwf_maw03.py b/autotest/test_gwf_maw03.py new file mode 100644 index 00000000000..5279517f294 --- /dev/null +++ b/autotest/test_gwf_maw03.py @@ -0,0 +1,241 @@ +""" +MODFLOW 6 Autotest +Test the MAW HEAD_LIMIT and RATE_SCALING options for injection wells. These +options were not originally supported in MODFLOW 6. They were added for +version 6.0.4. + +""" + +import os +import sys +import numpy as np + +try: + import pymake +except: + msg = 'Error. Pymake package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install https://github.com/modflowpy/pymake/zipball/master' + raise Exception(msg) + +try: + import flopy +except: + msg = 'Error. FloPy package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install flopy' + raise Exception(msg) + +from framework import testing_framework +from simulation import Simulation + +ex = ['maw03a', 'maw03b', 'maw03c'] +exdirs = [] +for s in ex: + exdirs.append(os.path.join('temp', s)) + +# maw settings for runs a, b, and c +mawsetting_a = [(0, 'rate', 2000.), ] +mawsetting_b = [(0, 'rate', 2000.), (0, 'head_limit', 0.4)] +mawsetting_c = [(0, 'rate', 2000.), (0, 'rate_scaling', 0.0, 1.0)] +mawsettings = [mawsetting_a, mawsetting_b, mawsetting_c] + +def get_model(idx, dir): + + nlay, nrow, ncol = 1, 101, 101 + nper = 1 + perlen = [1000.] + nstp = [50] + tsmult = [1.2] + delr = delc = 142. + top = 0. + botm = [-1000.] + strt = 0. + hk = 10. + + nouter, ninner = 100, 100 + hclose, rclose, relax = 1e-6, 1e-6, 1. + + tdis_rc = [] + for i in range(nper): + tdis_rc.append((perlen[i], nstp[i], tsmult[i])) + + name = ex[idx] + + # build MODFLOW 6 files + ws = dir + sim = flopy.mf6.MFSimulation(sim_name=name, sim_ws=ws) + + # create tdis package + tdis = flopy.mf6.ModflowTdis(sim, time_units='DAYS', + nper=nper, perioddata=tdis_rc) + + # create gwf model + gwf = flopy.mf6.MFModel(sim, model_type='gwf6', modelname=name, + model_nam_file='{}.nam'.format(name)) + + # create iterative model solution and register the gwf model with it + ims = flopy.mf6.ModflowIms(sim, print_option='SUMMARY', + outer_hclose=hclose, + outer_maximum=nouter, + under_relaxation='NONE', + inner_maximum=ninner, + inner_hclose=hclose, rcloserecord=rclose, + linear_acceleration='CG', + scaling_method='NONE', + reordering_method='NONE', + relaxation_factor=relax) + sim.register_ims_package(ims, [gwf.name]) + + dis = flopy.mf6.ModflowGwfdis(gwf, nlay=nlay, nrow=nrow, ncol=ncol, + delr=delr, delc=delc, + top=top, botm=botm, + idomain=1, + filename='{}.dis'.format(name)) + + # initial conditions + ic = flopy.mf6.ModflowGwfic(gwf, strt=strt, + filename='{}.ic'.format(name)) + + # node property flow + npf = flopy.mf6.ModflowGwfnpf(gwf, save_flows=True, + icelltype=1, + k=hk, + k33=hk, + filename='{}.npf'.format(name)) + + # storage + sto = flopy.mf6.ModflowGwfsto(gwf, save_flows=True, + iconvert=0, + ss=1.e-5, sy=0.1, + steady_state={0: False}, + transient={0: True}, + filename='{}.sto'.format(name)) + + # MAW + opth = '{}.maw.obs'.format(name) + wellbottom = -1000 + wellrecarray = [[0, 0.15, wellbottom, 0., 'THIEM', 1]] + wellconnectionsrecarray = [[0, 0, (0, 50, 50), 0., wellbottom, 0., 0.0]] + wellperiodrecarray = mawsettings[idx] + mawo_dict = {} + mawo_dict['{}.maw.obs.csv'.format(name)] = [('m1head', 'head', (0,)), + ('m1rate', 'rate', (0,))] #is this index one-based? Not if in a tuple + maw = flopy.mf6.ModflowGwfmaw(gwf, filename='{}.maw'.format(name), + print_input=True, print_head=True, + print_flows=True, save_flows=True, + observations=mawo_dict, + packagedata=wellrecarray, + connectiondata=wellconnectionsrecarray, + perioddata=wellperiodrecarray) + + # output control + oc = flopy.mf6.ModflowGwfoc(gwf, + budget_filerecord='{}.cbc'.format(name), + head_filerecord='{}.hds'.format(name), + headprintrecord=[ + ('COLUMNS', ncol, 'WIDTH', 15, + 'DIGITS', 6, 'GENERAL')], + saverecord=[('HEAD', 'ALL')], + printrecord=[('HEAD', 'ALL'), + ('BUDGET', 'ALL')], + filename='{}.oc'.format(name)) + + # head observations + obs_data0 = [('head_well_cell', 'HEAD', (0, 0, 0))] + obs_recarray = {'{}.obs.csv'.format(name): obs_data0} + obs = flopy.mf6.ModflowUtlobs(gwf, pname='head_obs', + filename='{}.obs'.format(name), + digits=15, print_input=True, + continuous=obs_recarray) + + + return sim + + +def build_models(): + for idx, dir in enumerate(exdirs): + sim = get_model(idx, dir) + sim.write_simulation() + return + + +def eval_maw(sim): + print('evaluating MAW heads...') + + # MODFLOW 6 maw results + idx = sim.idxsim + name = ex[idx] + fpth = os.path.join(sim.simpath, '{}.maw.obs.csv'.format(name)) + try: + tc = np.genfromtxt(fpth, names=True, delimiter=',') + except: + assert False, 'could not load data from "{}"'.format(fpth) + + + if idx == 0: + + # M1RATE should be 2000. + msg = 'The injection rate should be 2000. for all times' + assert tc['M1RATE'].min() == tc['M1RATE'].max() == 2000, msg + + elif idx == 1: + + # M1RATE should have a minimum value less than 200 and + # M1HEAD should not exceed 0.400001 + msg = ('Injection rate should fall below 200 and the head should not' + 'exceed 0.4') + assert tc['M1RATE'].min() < 200., msg + assert tc['M1HEAD'].max() < 0.400001, msg + + elif idx == 2: + + # M1RATE should have a minimum value less than 800 + # M1HEAD should not exceed 1.0. + msg = ('Min injection rate should be less than 800 and well ' + 'head should not exceed 1.0') + assert tc['M1RATE'].min() < 800. and tc['M1HEAD'].max() < 1., msg + + else: + + assert False, 'Test error. idx {} not being tested.'.format(idx) + + return + + +# - No need to change any code below +def test_mf6model(): + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + yield test.run_mf6, Simulation(dir, exfunc=eval_maw, idxsim=idx) + + return + + +def main(): + # initialize testing framework + test = testing_framework() + + # build the models + build_models() + + # run the test models + for idx, dir in enumerate(exdirs): + sim = Simulation(dir, exfunc=eval_maw, idxsim=idx) + test.run_mf6(sim) + + return + + +if __name__ == "__main__": + # print message + print('standalone run of {}'.format(os.path.basename(__file__))) + + # run main routine + main() diff --git a/autotest/test_gwf_maw04.py b/autotest/test_gwf_maw04.py new file mode 100644 index 00000000000..9e08b0a1ca7 --- /dev/null +++ b/autotest/test_gwf_maw04.py @@ -0,0 +1,263 @@ +import os +import sys +import numpy as np + +try: + import pymake +except: + msg = 'Error. Pymake package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install https://github.com/modflowpy/pymake/zipball/master' + raise Exception(msg) + +try: + import flopy +except: + msg = 'Error. FloPy package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install flopy' + raise Exception(msg) + +from framework import testing_framework +from simulation import Simulation + +ex = ['maw_iss305a', 'maw_iss305b', 'maw_iss305c', 'maw_iss305d', + 'maw_iss305e', 'maw_iss305f'] +exdirs = [] +for s in ex: + exdirs.append(os.path.join('temp', s)) +ddir = 'data' +cmppth = 'mf2005' + +paktest = 'maw' + +require_failure = [True for i in range(len(exdirs))] +require_failure[0] = False + +# set travis to True when version 1.13.0 is released +travis = [True for n in ex] + +# set replace_exe to None to use default executable +replace_exe = None + +# temporal discretization +nper = 2 +perlen = [0., 365.] +nstp = [1, 25] +tsmult = [1., 1.1] +steady = [True, False] + +# spatial discretization +nlay, nrow, ncol = 2, 101, 101 +shape3d = (nlay, nrow, ncol) +size3d = nlay * nrow * ncol + +xlen = 1000. +common_ratio = 1.01 +nhalf = int(0.5 * ncol) + 1 +first_term = 0.5 * xlen / ((1 - common_ratio**nhalf) / (1 - common_ratio)) +delr = np.zeros((ncol), dtype=np.float) +for n in range(nhalf): + if n == 0: + v = first_term + else: + v = first_term * common_ratio**n + delr[nhalf + n - 1] = v +delr[:nhalf-1] = delr[-1:nhalf-1:-1] + +# add error to edge cells +err = xlen - delr.sum() +delr[0] += 0.5 * err +delr[-1] += 0.5 * err + +top = 0. +botm = [-175, -350.] +strt = 0. + +# hydraulic data +hk = 1. +ss = 1e-5 +confined = 0 + +chd_spd = [] +chd5_spd = [] +for i in range(nrow): + if i == 0 or i == ncol - 1: + for j in range(ncol): + chd_spd.append([(0, i, j), strt]) + chd5_spd.append([0, i, j, strt, strt]) + else: + chd_spd.append([(0, i, 0), strt]) + chd_spd.append([(0, i, ncol-1), strt]) + chd5_spd.append([0, i, 0, strt, strt]) + chd5_spd.append([0, i, ncol-1, strt, strt]) + +# maw data +radius0 = np.sqrt(delr[nhalf] * delr[nhalf] / (8. * np.pi)) +radius = 0.25 +sradius0 = radius + 0.1 +wellq = -100. +skin_mult = [.1, 10., 1., 0., -1., 100.] +condeqn = ['CUMULATIVE', 'SKIN', 'SKIN', 'SKIN', 'SPECIFIED', 'CUMULATIVE'] +sradius = [sradius0, sradius0, sradius0, sradius0, sradius0, radius0*1.5] + +tdis_rc = [] +for idx in range(nper): + tdis_rc.append((perlen[idx], nstp[idx], tsmult[idx])) + +hclose, rclose = 1e-9, 1e-6 + +def get_model(idx, dir): + name = ex[idx] + ws = dir + + # build MODFLOW 6 files + sim = flopy.mf6.MFSimulation(sim_name=name, version='mf6', + exe_name='mf6', + sim_ws=ws) + # create tdis package + tdis = flopy.mf6.ModflowTdis(sim, time_units='DAYS', nper=nper, + perioddata=tdis_rc) + + # create iterative model solution + ims = flopy.mf6.ModflowIms(sim, inner_hclose=hclose, rcloserecord=rclose, + outer_hclose=hclose) + + # create gwf model + gwf = flopy.mf6.ModflowGwf(sim, modelname=name, save_flows=True) + + # discretization + dis = flopy.mf6.ModflowGwfdis(gwf, nlay=nlay, nrow=nrow, ncol=ncol, + delr=delr, delc=delr, + top=top, botm=botm) + # initial conditions + ic = flopy.mf6.ModflowGwfic(gwf, strt=strt) + + # node property flow + npf = flopy.mf6.ModflowGwfnpf(gwf, save_flows=False, + icelltype=confined, + k=hk) + # storage + sto = flopy.mf6.ModflowGwfsto(gwf, save_flows=False, + iconvert=confined, + ss=ss, + steady_state={0: True}, + transient={1: True}) + # constant head + chd = flopy.mf6.ModflowGwfchd(gwf, + stress_period_data=chd_spd, + save_flows=False) + # multi-aquifer well + hks = hk * skin_mult[idx] + mpd = [[0, radius, botm[-1], strt, condeqn[idx], 2]] + mcd = [[0, 0, (0, nhalf, nhalf), top, botm[0], hks, sradius[idx]], + [0, 1, (1, nhalf, nhalf), botm[0], botm[1], hks, sradius[idx]]] + perioddata = {1: [[0, 'RATE', wellq]]} + maw = flopy.mf6.ModflowGwfmaw(gwf, print_input=True, + no_well_storage=True, + packagedata=mpd, + connectiondata=mcd, + perioddata=perioddata) + # output control + oc = flopy.mf6.ModflowGwfoc(gwf, + budget_filerecord='{}.cbc'.format(name), + head_filerecord='{}.hds'.format(name), + saverecord=[('HEAD', 'ALL'), + ('BUDGET', 'ALL')]) + # build MODFLOW-2005 files + if require_failure[idx]: + mc = None + else: + ws = os.path.join(dir, cmppth) + mc = flopy.modflow.Modflow(name, model_ws=ws, version=cmppth) + dis = flopy.modflow.ModflowDis(mc, nlay=nlay, nrow=nrow, ncol=ncol, + nper=nper, perlen=perlen, nstp=nstp, + tsmult=tsmult, steady=steady, delr=delr, + delc=delr, top=top, botm=botm) + bas = flopy.modflow.ModflowBas(mc, strt=strt) + lpf = flopy.modflow.ModflowLpf(mc, laytyp=confined, + hk=hk, vka=hk, + ss=ss, sy=0) + chd = flopy.modflow.ModflowChd(mc, stress_period_data=chd5_spd) + # mnw2 + # empty mnw2 file to create recarrays + mnw2 = flopy.modflow.ModflowMnw2(mc) + node_data = mnw2.get_empty_node_data(2) + node_data['ztop'] = np.array([top, botm[0]]) + node_data['zbotm'] = np.array([botm[0], botm[1]]) + node_data['i'] = np.array([nhalf, nhalf]) + node_data['j'] = np.array([nhalf, nhalf]) + node_data['wellid'] = np.array(['well1', 'well1']) + node_data['losstype'] = np.array(['skin', 'skin']) + node_data['rw'] = np.array([radius, radius]) + node_data['rskin'] = np.array([sradius[idx], sradius[idx]]) + node_data['kskin'] = np.array([hks, hks]) + dtype = [('wellid', np.unicode_, 20), ('qdes', ' budtol or diffzbmax> budtol: + if diffmax > budtol or diffzbmax > budtol: sim.success = False msg += '\n...exceeds {}'.format(budtol) assert diffmax < budtol and diffzbmax < budtol, msg diff --git a/autotest/test_mf6_tmp_simulations.py b/autotest/test_mf6_tmp_simulations.py new file mode 100644 index 00000000000..0c38285c33e --- /dev/null +++ b/autotest/test_mf6_tmp_simulations.py @@ -0,0 +1,175 @@ +import os +import sys + +try: + import pymake +except: + msg = 'Error. Pymake package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install https://github.com/modflowpy/pymake/zipball/master' + raise Exception(msg) + +try: + import flopy +except: + msg = 'Error. FloPy package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install flopy' + raise Exception(msg) + +from simulation import Simulation + +exdir = os.path.join('..', 'tmp_simulations') +testpaths = os.path.join('..', exdir) + + +def get_mf6_models(): + """ + Get a list of test models + """ + # tuple of example files to exclude + exclude = ('test006_03models', + 'test018_NAC', + 'test051_uzf1d_a') + + exclude_travis = ('test006_gwf3_transport', + 'test006_Gwf1-Lnf1') + + # build list of directories with valid example files + exclude = list(exclude + exclude_travis) + dirs = [d for d in os.listdir(exdir) + if 'test' in d and d not in exclude] + # sort in numerical order for case sensitive os + dirs = sorted(dirs, key=lambda v: (v.upper(), v[0].islower())) + + + # determine if only a selection of models should be run + select_dirs = None + select_packages = None + for idx, arg in enumerate(sys.argv): + if arg.lower() == '--sim': + if len(sys.argv) > idx + 1: + select_dirs = sys.argv[idx + 1:] + break + elif arg.lower() == '--pak': + if len(sys.argv) > idx + 1: + select_packages = sys.argv[idx + 1:] + select_packages = [item.upper() for item in select_packages] + break + + # determine if the selection of model is in the test models to evaluate + if select_dirs is not None: + found_dirs = [] + for d in select_dirs: + if d in dirs: + found_dirs.append(d) + dirs = found_dirs + if len(dirs) < 1: + msg = 'Selected models not available in test' + print(msg) + + # determine if the specified package(s) is in the test models to evaluate + if select_packages is not None: + found_dirs = [] + for d in dirs: + pth = os.path.join(exdir, d) + namefiles = pymake.get_namefiles(pth) + ftypes = [] + for namefile in namefiles: + ftype = pymake.autotest.get_mf6_ftypes(namefile, + select_packages) + if ftype not in ftypes: + ftypes += ftype + if len(ftypes) > 0: + ftypes = [item.upper() for item in ftypes] + for pak in select_packages: + if pak in ftypes: + found_dirs.append(d) + break + dirs = found_dirs + if len(dirs) < 1: + msg = 'Selected packages not available [' + for pak in select_packages: + msg += ' {}'.format(pak) + msg += ']' + print(msg) + + + return dirs + + +def run_mf6(sim): + """ + Run the MODFLOW 6 simulation and compare to existing head file or + appropriate MODFLOW-2005, MODFLOW-NWT, MODFLOW-USG, or MODFLOW-LGR run. + + """ + print(os.getcwd()) + src = os.path.join(exdir, sim.name) + dst = os.path.join('temp', sim.name) + sim.setup(src, dst) + sim.run() + sim.compare() + sim.teardown() + + +def test_mf6model(): + # determine if test directory exists + dirtest = dir_avail() + if not dirtest: + return + + # get a list of test models to run + dirs = get_mf6_models() + + # run the test models + for dir in dirs: + yield run_mf6, Simulation(dir) + + return + + +def dir_avail(): + avail = os.path.isdir(exdir) + if not avail: + print('"{}" does not exist'.format(exdir)) + print('no need to run {}'.format(os.path.basename(__file__))) + return avail + + +def main(): + # write message + tnam = os.path.splitext(os.path.basename(__file__))[0] + msg = 'Running {} test'.format(tnam) + print(msg) + + # determine if test directory exists + dirtest = dir_avail() + if not dirtest: + return + + # get a list of test models to run + dirs = get_mf6_models() + + # run the test models + for dir in dirs: + sim = Simulation(dir) + run_mf6(sim) + + return + + +if __name__ == "__main__": + + print('standalone run of {}'.format(os.path.basename(__file__))) + + delFiles = True + for idx, arg in enumerate(sys.argv): + if arg.lower() == '--keep': + if len(sys.argv) > idx + 1: + delFiles = False + break + + # run main routine + main() + diff --git a/autotest/test_z01_nightly_build_examples.py b/autotest/test_z01_nightly_build_examples.py index ac7a3b45176..de9a70280bd 100644 --- a/autotest/test_z01_nightly_build_examples.py +++ b/autotest/test_z01_nightly_build_examples.py @@ -20,8 +20,19 @@ from simulation import Simulation -exdir = os.path.join('..', '..', 'modflow6-examples', 'mf6') +# find path to modflow6-examples or modflow6-examples.git directory +home = os.path.expanduser('~') +fdir = 'modflow6-examples' +exdir = None +for root, dirs, files in os.walk(home): + for d in dirs: + if d.startswith(fdir): + exdir = os.path.join(root, d, 'mf6') + break + if exdir is not None: + break testpaths = os.path.join('..', exdir) +assert os.path.isdir(testpaths) def get_branch(): @@ -58,17 +69,21 @@ def get_mf6_models(): print('On branch {}'.format(branch)) # tuple of example files to exclude - exclude = ('test006_03models', - 'test018_NAC', - 'test051_uzf1d_a') + exclude = (None,) - exclude_travis = ('test006_gwf3_transport', - 'test022_MNW2_Fig28', - 'test007_751x751_confined', - 'test006_Gwf1-Lnf1') + # update exclude + if is_travis: + exclude_travis = ('test022_MNW2_Fig28', + 'test007_751x751_confined') + exclude = exclude + exclude_travis + exclude = list(exclude) + + # write a summary of the files to exclude + print('list of tests to exclude:') + for idx, ex in enumerate(exclude): + print(' {}: {}'.format(idx + 1, ex)) # build list of directories with valid example files - exclude = list(exclude + exclude_travis) dirs = [d for d in os.listdir(exdir) if 'test' in d and d not in exclude] @@ -175,7 +190,9 @@ def test_mf6model(): def dir_avail(): - avail = os.path.isdir(exdir) + avail = False + if exdir is not None: + avail = os.path.isdir(exdir) if not avail: print('"{}" does not exist'.format(exdir)) print('no need to run {}'.format(os.path.basename(__file__))) diff --git a/autotest/test_z02_nightly_build_mf5to6.py b/autotest/test_z02_nightly_build_mf5to6.py index 86ef777d236..f5325a01474 100644 --- a/autotest/test_z02_nightly_build_mf5to6.py +++ b/autotest/test_z02_nightly_build_mf5to6.py @@ -24,8 +24,19 @@ from targets import target_dict as target_dict -exdir = os.path.join('..', '..', 'modflow6-examples', 'mf5to6') +# find path to modflow6-examples or modflow6-examples.git directory +home = os.path.expanduser('~') +fdir = 'modflow6-examples' +exdir = None +for root, dirs, files in os.walk(home): + for d in dirs: + if d.startswith(fdir): + exdir = os.path.join(root, d, 'mf5to6') + break + if exdir is not None: + break testpaths = os.path.join('..', exdir) +assert os.path.isdir(testpaths) sfmt = '{:25s} - {}' @@ -45,9 +56,15 @@ def get_mf5to6_models(): 'testTwrip', 'test028_sfr_simple') + # write a summary of the files to exclude + print('list of tests to exclude:') + for idx, ex in enumerate(exclude): + print(' {}: {}'.format(idx + 1, ex)) + # build list of directories with valid example files dirs = [d for d in os.listdir(exdir) if 'test' in d and d not in exclude] + # sort in numerical order for case sensitive os dirs = sorted(dirs, key=lambda v: (v.upper(), v[0].islower())) @@ -108,7 +125,6 @@ def get_mf5to6_models(): msg += ']' print(msg) - return dirs @@ -245,7 +261,9 @@ def test_model(): def dir_avail(): - avail = os.path.isdir(exdir) + avail = False + if exdir is not None: + avail = os.path.isdir(exdir) if not avail: print('"{}" does not exist'.format(exdir)) print('no need to run {}'.format(os.path.basename(__file__))) diff --git a/autotest/test_z03_nightly_build_largeexamples.py b/autotest/test_z03_nightly_build_largeexamples.py index 9f82031c5f9..171ad0cbdc7 100644 --- a/autotest/test_z03_nightly_build_largeexamples.py +++ b/autotest/test_z03_nightly_build_largeexamples.py @@ -20,27 +20,52 @@ from simulation import Simulation -exdir = os.path.join('..', '..', 'modflow6-largetests') -testpaths = os.path.join('..', exdir) +# find path to modflow6-largetests directory +home = os.path.expanduser('~') +fdir = 'modflow6-largetests' +exdir = None +for root, dirs, files in os.walk(home): + for d in dirs: + if d == fdir or d == fdir + '.git': + exdir = os.path.join(root, d) + break + if exdir is not None: + break +if exdir is not None: + testpaths = os.path.join('..', exdir) +else: + testpaths = None def get_mf6_models(): """ Get a list of test models """ - # tuple of example files to exclude - exclude = ('test006_03models', - 'test018_NAC', - 'test051_uzf1d_a') + # determine if running on travis + is_travis = 'TRAVIS' in os.environ + # tuple of example files to exclude + exclude = (None,) - # build list of directories with valid example files + # update exclude + if is_travis: + exclude_travis = (None, ) + exclude = exclude + exclude_travis exclude = list(exclude) - dirs = [d for d in os.listdir(exdir) - if 'test' in d and d not in exclude] - # sort in numerical order for case sensitive os - dirs = sorted(dirs, key=lambda v: (v.upper(), v[0].islower())) + # write a summary of the files to exclude + print('list of tests to exclude:') + for idx, ex in enumerate(exclude): + print(' {}: {}'.format(idx + 1, ex)) + + # build list of directories with valid example files + if exdir is not None: + dirs = [d for d in os.listdir(exdir) + if 'test' in d and d not in exclude] + # sort in numerical order for case sensitive os + dirs = sorted(dirs, key=lambda v: (v.upper(), v[0].islower())) + else: + dirs = [] # determine if only a selection of models should be run select_dirs = None @@ -93,7 +118,6 @@ def get_mf6_models(): msg += ']' print(msg) - return dirs @@ -117,7 +141,7 @@ def test_mf6model(): dirtest = dir_avail() if not dirtest: return - + # get a list of test models to run dirs = get_mf6_models() @@ -129,7 +153,9 @@ def test_mf6model(): def dir_avail(): - avail = os.path.isdir(exdir) + avail = False + if exdir is not None: + avail = os.path.isdir(exdir) if not avail: print('"{}" does not exist'.format(exdir)) print('no need to run {}'.format(os.path.basename(__file__))) @@ -137,6 +163,7 @@ def dir_avail(): avail = False return avail + def main(): # write message tnam = os.path.splitext(os.path.basename(__file__))[0] @@ -172,4 +199,3 @@ def main(): # run main routine main() - diff --git a/autotest/update_flopy.py b/autotest/update_flopy.py index 54d7faca84f..95b6037fab3 100644 --- a/autotest/update_flopy.py +++ b/autotest/update_flopy.py @@ -20,17 +20,17 @@ def cwd(path): os.chdir(oldpwd) -# def test_delete_mf6(): -# pth = os.path.join(flopypth, 'mf6', 'modflow') -# files = [entry for entry in os.listdir(pth) if os.path.isfile(os.path.join(pth, entry))] -# delete_files(files, pth) +def test_delete_mf6(): + pth = os.path.join(flopypth, 'mf6', 'modflow') + files = [entry for entry in os.listdir(pth) if os.path.isfile(os.path.join(pth, entry))] + delete_files(files, pth, exclude='mfsimulation.py') def test_delete_dfn(): pth = os.path.join(flopypth, 'mf6', 'data', 'dfn') files = [entry for entry in os.listdir(pth) if os.path.isfile(os.path.join(pth, entry))] - delete_files(files, pth) + delete_files(files, pth, exclude='flopy.dfn') def test_copy_dfn(): @@ -139,8 +139,8 @@ def main(): msg = 'Running {} test'.format(tnam) print(msg) - # print('deleting existing MODFLOW 6 FloPy files') - # test_delete_mf6() + print('deleting existing MODFLOW 6 FloPy files') + test_delete_mf6() print('deleting existing MODFLOW 6 dfn files') test_delete_dfn() print('copying MODFLOW 6 repo dfn files') diff --git a/code.json b/code.json index 9ade0c07621..122a8a5a066 100755 --- a/code.json +++ b/code.json @@ -1,38 +1,38 @@ [ { - "status": "Release Candidate", - "downloadURL": "https://code.usgs.gov/usgs/modflow/modflow6/archive/master.zip", - "repositoryURL": "https://code.usgs.gov/usgs/modflow/modflow6.git", - "disclaimerURL": "https://code.usgs.gov/usgs/modflow/modflow6/blob/master/DISCLAIMER.md", + "status": "Release Candidate", + "languages": [ + "Fortran2008" + ], + "repositoryURL": "https://code.usgs.gov/usgs/modflow/modflow6.git", + "disclaimerURL": "https://code.usgs.gov/usgs/modflow/modflow6/blob/master/DISCLAIMER.md", "tags": [ - "MODFLOW", + "MODFLOW", "groundwater model" - ], - "description": "MODFLOW is the USGS's modular hydrologic model. MODFLOW is considered an international standard for simulating and predicting groundwater conditions and groundwater/surface-water interactions.", + ], + "vcs": "git", + "name": "modflow6", + "downloadURL": "https://code.usgs.gov/usgs/modflow/modflow6/archive/master.zip", "contact": { - "name": "Christian D. Langevin", + "name": "Christian D. Langevin", "email": "langevin@usgs.gov" - }, - "languages": [ - "Fortran2008" - ], - "vcs": "git", - "laborHours": -1, - "version": "6.0.3.8", + }, + "laborHours": -1, + "version": "6.1.1", "date": { - "metadataLastUpdated": "2018-09-06" - }, - "organization": "U.S. Geological Survey", + "metadataLastUpdated": "2019-12-12" + }, + "organization": "U.S. Geological Survey", "permissions": { "licenses": [ { - "URL": "https://code.usgs.gov/usgs/modflow/modflow6/blob/master/LICENSE.md", + "URL": "https://code.usgs.gov/usgs/modflow/modflow6/blob/master/LICENSE.md", "name": "Public Domain, CC0-1.0" } - ], + ], "usageType": "openSource" - }, - "homepageURL": "https://code.usgs.gov/usgs/modflow/modflow6/", - "name": "modflow6" + }, + "homepageURL": "https://code.usgs.gov/usgs/modflow/modflow6/", + "description": "MODFLOW is the USGS's modular hydrologic model. MODFLOW is considered an international standard for simulating and predicting groundwater conditions and groundwater/surface-water interactions." } -] \ No newline at end of file +] diff --git a/pre-commit.py b/distribution/make-release.py similarity index 62% rename from pre-commit.py rename to distribution/make-release.py index 8e9ec41bcb5..0d57e26c3f1 100644 --- a/pre-commit.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 hook_files import paths, files - -prod = 'MODFLOW 6' - -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_version_str(v0, v1, v2, v3): - version_type = ('{}'.format(v0), - '{}'.format(v1), - '{}'.format(v2), - '{}'.format(v3)) - 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 get_disclaimer(branch): - if 'release' in branch.lower() or 'master' in branch.lower(): - disclaimer = approved - else: - disclaimer = preliminary - return disclaimer - - -def get_disclaimerfmt(branch): - if 'release' in branch.lower() or 'master' in branch.lower(): - disclaimer = approvedfmt - else: - disclaimer = preliminaryfmt - return disclaimer - - -def update_version(): - try: - vmajor = 0 - vminor = 0 - vmicro = 0 - vbuild = 0 - - # read version.txt into memory - pth = files[0] - with open(pth, 'r') as file: - lines = [line.rstrip() for line in file] - - 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]) - elif 'build =' in line: - vbuild = int(t[2]) - - v0 = get_version_str(vmajor, vminor, vmicro, vbuild) - - # get latest build number - tag = get_tag(vmajor, vminor, vmicro) - print('determining version build from {}'.format(tag)) - try: - b = subprocess.Popen(("git", "describe", "--match", tag), - stdout=subprocess.PIPE).communicate()[0] - vbuild = int(b.decode().strip().split('-')[1]) + 1 - # assume if tag does not exist that it has not been added - except: - vbuild = 0 - - v1 = get_version_str(vmajor, vminor, vmicro, vbuild) - - # get current build number - b = subprocess.Popen(("git", "describe", "--match", "build"), - stdout=subprocess.PIPE).communicate()[0] - vcommit = int(b.decode().strip().split('-')[1]) + 2 - - print('Updating version:') - print(' ', v0, '->', v1) - - # write new version file - now = datetime.datetime.now() - f = open(pth, 'w') - for line in lines: - if 'version file automatically' in line: - line = '# {} version file automatically '.format(prod) + \ - 'created using...{}'.format(os.path.basename(__file__)) - elif 'created on...' in line: - line = '# created on...' + \ - '{}'.format(now.strftime('%B %d, %Y %H:%M:%S')) - elif 'major =' in line: - line = 'major = {}'.format(vmajor) - elif 'minor =' in line: - line = 'minor = {}'.format(vminor) - elif 'micro =' in line: - line = 'micro = {}'.format(vmicro) - elif 'build =' in line: - line = 'build = {}'.format(vbuild) - elif 'commit =' in line: - line = 'commit = {}'.format(vcommit) - f.write('{}\n'.format(line)) - f.close() - print('Succesfully updated {}'.format(files[0])) - - # update latex version file - if vbuild == 0: - version = get_tag(vmajor, vminor, vmicro) - else: - version = get_version_str(vmajor, vminor, vmicro, vbuild) - 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: - print('There was a problem updating the version file') - sys.exit(1) - - # update version.f90 - update_mf6_version(vmajor, vminor, vmicro, vbuild) - - # update README.md with new version information - update_readme_markdown(vmajor, vminor, vmicro, vbuild) - - -def add_updated_files(): - cargs = ['git', 'add'] - for (p, f) in zip(paths, files): - if p == '.': - fpth = f - else: - fpth = os.path.join(p, f) - cargs.append(fpth) - try: - # add modified version file - print('Adding updated files to repo') - b = subprocess.Popen(cargs, - stdout=subprocess.PIPE).communicate()[0] - except: - print('Could not add updated files') - sys.exit(1) - -def get_branch(): - try: - # determine current buildstat branch - b = subprocess.Popen(("git", "status"), - stdout=subprocess.PIPE, - stderr=subprocess.STDOUT).communicate()[0] - if isinstance(b, bytes): - b = b.decode('utf-8') - - # determine current buildstat branch - for line in b.splitlines(): - if 'On branch' in line: - branch = line.replace('On branch ', '').rstrip() - except: - branch = None - - return branch - - -def update_mf6_version(vmajor, vminor, vmicro, vbuild): - branch = get_branch() - if branch is None: - print('Cannot update MODFLOW 6 version - could not determine current branch') - return - - # create version - version = get_tag(vmajor, vminor, vmicro) - idevelopmode = 0 - if 'release' not in branch.lower() and 'master' not in branch.lower(): - version = '{}.{}'.format(version, vbuild) - idevelopmode = 1 - - # develop date text - now = datetime.datetime.now() - sdate = now.strftime('%m/%d/%Y') - - # create disclaimer text - disclaimerfmt = get_disclaimerfmt(branch) - - # 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, vbuild): - - branch = get_branch() - if branch is None: - print('Cannot update README.md - could not determine current branch') - return - - # create version - version = get_tag(vmajor, vminor, vmicro) - - # create disclaimer text - disclaimer = get_disclaimer(branch) - - # read README.md into memory - with open(files[2], 'r') as file: - lines = [line.rstrip() for line in file] - - # rewrite README.md - terminate = False - f = open(files[2], 'w') - for line in lines: - if '### Version ' in line: - line = '### Version {}'.format(version) - if vbuild > 0: - line += ' {} — build {}'.format(branch, vbuild) - 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: - now = datetime.datetime.now() - sb = '' - if vbuild > 0: - sb = ' — {}'.format(branch) - 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 - f = open(files[3], 'w') - f.write(disclaimer) - f.close() - - # load and modify json file - jsonFile = open(files[4], 'r') # Open the JSON file for reading - data = json.load(jsonFile) # Read the JSON into the buffer - jsonFile.close() # Close the JSON file - - # modify the json file data - now = datetime.datetime.now() - 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 + '.{}'.format(vbuild) - data[0]['status'] = 'Release Candidate' - - # rewrite the json file - with open(files[4], 'w') as f: - json.dump(data, f, indent=4) - - return - - -if __name__ == "__main__": - update_version() - add_updated_files() +#!/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/distribution/mkdist.py b/distribution/mkdist.py index 95f04c3aa94..8e3b7c82993 100644 --- a/distribution/mkdist.py +++ b/distribution/mkdist.py @@ -5,11 +5,14 @@ To make a distribution: 1. Create a release branch - 2. Run the pre-commit.py script, which will create the proper dist name - 3. Run this script - 4. Post the distribution zip file - 5. Merge the release changes into the master branch - 6. Tag the master branch with the correct version + 2. Update version.txt with the correct minor and micro numbers + 3. Run the pre-commit.py script, which will create the proper dist name + 4. Run this mkdist.py script + 5. Post the distribution zip file + 6. Commit the release changes, but no need to push + 7. Merge the release changes into the master branch + 8. Tag the master branch with the correct version + 9. Merge master into develop """ @@ -540,14 +543,20 @@ def update_latex_releaseinfo(): cmd = ['python', 'mk_example_items.py'] buff, ierr = run_command(cmd, pth) + msg = '\nERROR {}: could not run {} on {}'.format(ierr, cmd[0], + cmd[1]) assert ierr == 0, buff + msg cmd = ['python', 'mk_example_table.py'] buff, ierr = run_command(cmd, pth) + msg = '\nERROR {}: could not run {} on {}'.format(ierr, cmd[0], + cmd[1]) assert ierr == 0, buff + msg cmd = ['python', 'mk_folder_struct.py'] buff, ierr = run_command(cmd, pth) + msg = '\nERROR {}: could not run {} on {}'.format(ierr, cmd[0], + cmd[1]) assert ierr == 0, buff + msg for f in files: @@ -571,8 +580,11 @@ def update_latex_releaseinfo(): # Copy the Visual Studio solution and project files flist = [ - # os.path.join('..', 'msvs', 'mf6.sln'), + os.path.join('..', 'msvs', 'mf6.sln'), os.path.join('..', 'msvs', 'mf6.vfproj'), + os.path.join('..', 'msvs', 'mf6core.vfproj'), + os.path.join('..', 'msvs', 'mf6bmi.sln'), + os.path.join('..', 'msvs', 'mf6bmi.vfproj'), ] print('Copying msvs files') for d in flist: @@ -670,6 +682,10 @@ def update_latex_releaseinfo(): ['test019_VilhelmsenLGR', 'vilhelmsen-lgr'], ['test046_periodic_bc', 'periodicbc'], + ['test061_csub_jacob', 'csub-jacob'], + ['test062_csub_sub01', 'csub-sub01'], + ['test063_csub_holly', 'csub-holly'], + ['test064_csub_subwt01', 'csub-subwt01'], ] # Create a runall.bat file in examples @@ -750,9 +766,11 @@ def update_latex_releaseinfo(): print('Downloading published reports for inclusion in distribution') for url in ['https://pubs.usgs.gov/tm/06/a57/tm6a57.pdf', 'https://pubs.usgs.gov/tm/06/a55/tm6a55.pdf', - 'https://pubs.usgs.gov/tm/06/a56/tm6a56.pdf']: + 'https://pubs.usgs.gov/tm/06/a56/tm6a56.pdf', + 'https://github.com/MODFLOW-USGS/modflow6-examples/releases/download/6.1.0/csubexamples.pdf', + ]: print(' downloading {}'.format(url)) - download_and_unzip(url, pth=fd['doc'], delete_zip=False) + download_and_unzip(url, pth=fd['doc'], delete_zip=False, verify=False) print('\n') # Prior to zipping, enforce os line endings on all text files diff --git a/doc/Common/gwf-csubobs.tex b/doc/Common/gwf-csubobs.tex new file mode 100644 index 00000000000..8d718c45a8f --- /dev/null +++ b/doc/Common/gwf-csubobs.tex @@ -0,0 +1,44 @@ +CSUB & csub & icsubno or boundname & -- & Flow between the groundwater system and a interbed or group of interbeds. \\ +CSUB & inelastic-csub & icsubno or boundname & -- & Flow between the groundwater system and a interbed or group of interbeds from inelastic compaction. \\ +CSUB & elastic-csub & icsubno or boundname & -- & Flow between the groundwater system and a interbed or group of interbeds from elastic compaction. \\ +CSUB & coarse-csub & cellid & -- & Flow between the groundwater system and coarse-grained materials in a GWF cell. \\ +CSUB & csub-cell & cellid & -- & Flow between the groundwater system for all interbeds and coarse-grained materials in a GWF cell. \\ +CSUB & wcomp-csub-cell & cellid & -- & Flow between the groundwater system for all interbeds and coarse-grained materials in a GWF cell from water compressibility. \\ + +CSUB & sk & icsubno or boundname & -- & Convertible interbed storativity in a interbed or group of interbeds. Convertible interbed storativity is inelastic interbed storativity if the current effective stress is greater than the preconsolidation stress. The NODATA value is reported for steady-state stress periods. \\ +CSUB & ske & icsubno or boundname & -- & Elastic interbed storativity in a interbed or group of interbeds. The NODATA value is reported for steady-state stress periods. \\ +CSUB & sk-cell & cellid & -- & Convertible interbed and coarse-grained material storativity in a GWF cell. Convertible interbed storativity is inelastic interbed storativity if the current effective stress is greater than the preconsolidation stress. The NODATA value is reported for steady-state stress periods. \\ +CSUB & ske-cell & cellid & -- & Elastic interbed and coarse-grained material storativity in a GWF cell. The NODATA value is reported for steady-state stress periods. \\ + +CSUB & estress-cell & cellid & -- & effective stress in a GWF cell. \\ +CSUB & gstress-cell & cellid & -- & geostatic stress in a GWF cell. \\ + +CSUB & interbed-compaction & icsubno or boundname & -- & interbed compaction in a interbed or group of interbeds. \\ +CSUB & inelastic-compaction & icsubno or boundname & -- & inelastic interbed compaction in a interbed or group of interbeds. \\ +CSUB & elastic-compaction & icsubno or boundname & -- & elastic interbed compaction a interbed or group of interbeds. \\ +CSUB & coarse-compaction & cellid & -- & elastic compaction in coarse-grained materials in a GWF cell. \\ +CSUB & inelastic-compaction-cell & cellid & -- & inelastic compaction in all interbeds in a GWF cell. \\ +CSUB & elastic-compaction-cell & cellid & -- & elastic compaction in coarse-grained materials and all interbeds in a GWF cell. \\ +CSUB & compaction-cell & cellid & -- & total compaction in coarse-grained materials and all interbeds in a GWF cell. \\ + +CSUB & thickness & icsubno or boundname & -- & thickness of a interbed or group of interbeds. \\ +CSUB & coarse-thickness & cellid & -- & thickness of coarse-grained materials in a GWF cell. \\ +CSUB & thickness-cell & cellid & -- & total thickness of coarse-grained materials and all interbeds in a GWF cell. \\ + +CSUB & theta & icsubno & -- & porosity of a interbed . \\ +CSUB & coarse-theta & cellid & -- & porosity of coarse-grained materials in a GWF cell. \\ +CSUB & theta-cell & cellid & -- & thickness-weighted porosity of coarse-grained materials and all interbeds in a GWF cell. \\ + +CSUB & delay-flowtop & icsubno & -- & Flow between the groundwater system and a delay interbed across the top of the interbed. \\ +CSUB & delay-flowbot & icsubno & -- & Flow between the groundwater system and a delay interbed across the bottom of the interbed. \\ + +CSUB & delay-head & icsubno & idcellno & head in interbed delay cell idcellno (1 $<=$ idcellno $<=$ NDELAYCELLS). The NODATA value is reported for steady-state stress periods. \\ +CSUB & delay-gstress & icsubno & idcellno & geostatic stress in interbed delay cell idcellno (1 $<=$ idcellno $<=$ NDELAYCELLS). The NODATA value is reported for steady-state stress periods. \\ +CSUB & delay-estress & icsubno & idcellno & effective stress in interbed delay cell idcellno (1 $<=$ idcellno $<=$ NDELAYCELLS). The NODATA value is reported for steady-state stress periods. \\ +CSUB & delay-preconstress & icsubno & idcellno & preconsolidation stress in interbed delay cell idcellno (1 $<=$ idcellno $<=$ NDELAYCELLS). The NODATA value is reported for steady-state stress periods. \\ +CSUB & delay-compaction & icsubno & idcellno & compaction in interbed delay cell idcellno (1 $<=$ idcellno $<=$ NDELAYCELLS). \\ +CSUB & delay-thickness & icsubno & idcellno & thickness of interbed delay cell idcellno (1 $<=$ idcellno $<=$ NDELAYCELLS). \\ +CSUB & delay-theta & icsubno & idcellno & porosity of interbed delay cell idcellno (1 $<=$ idcellno $<=$ NDELAYCELLS). \\ + +CSUB & preconstress-cell & cellid & -- & preconsolidation stress in a GWF cell containing at least one interbed. The NODATA value is reported for steady-state stress periods. + diff --git a/doc/ConverterGuide/converter_mf5to6.tex b/doc/ConverterGuide/converter_mf5to6.tex index 6324c320156..6de246160d0 100644 --- a/doc/ConverterGuide/converter_mf5to6.tex +++ b/doc/ConverterGuide/converter_mf5to6.tex @@ -286,6 +286,19 @@ \normalsize \end{table} + +% ------------------------------------------------- +\section{History} +This section describes changes introduced into the MODFLOW 6 converter with each official release. These changes may substantially affect users. + +\begin{itemize} +\item +\currentmodflowversion +\begin{itemize} + \item Fixed an issue in the conversion of MNW2 wells into the MODFLOW 6 format. The converter did not produce correct results when multiple MNW wells were present and when the wells spanned multiple model layers. +\end{itemize} +\end{itemize} + \REFSECTION %\SECTION{References Cited} \bibliography{../MODFLOW6References} diff --git a/doc/MODFLOW6References.bib b/doc/MODFLOW6References.bib index 308dab21694..be955b5d86f 100644 --- a/doc/MODFLOW6References.bib +++ b/doc/MODFLOW6References.bib @@ -1,14 +1,30 @@ %% This BibTeX bibliography file was created using BibDesk. -%% http://bibdesk.sourceforge.net/ +%% https://bibdesk.sourceforge.io/ - -%% Created for Hughes, Joseph D. at 2017-07-28 12:42:51 -0400 +%% Created for Hughes, Joseph D. at 2020-03-24 13:53:56 -0400 %% Saved with string encoding Unicode (UTF-8) +@article{PECKHAM20133, + Abstract = {Development of scientific modeling software increasingly requires the coupling of multiple, independently developed models. Component-based software engineering enables the integration of plug-and-play components, but significant additional challenges must be addressed in any specific domain in order to produce a usable development and simulation environment that also encourages contributions and adoption by entire communities. In this paper we describe the challenges in creating a coupling environment for Earth-surface process modeling and the innovative approach that we have developed to address them within the Community Surface Dynamics Modeling System.}, + Author = {Scott D. Peckham and Eric W.H. Hutton and Boyana Norris}, + Date-Added = {2020-03-24 13:28:50 -0400}, + Date-Modified = {2020-03-24 13:53:55 -0400}, + Doi = {https://doi.org/10.1016/j.cageo.2012.04.002}, + Issn = {0098-3004}, + Journal = {Computers \& Geosciences}, + Keywords = {Component software, CCA, CSDMS, Modeling, Code generation}, + Pages = {3 - 12}, + Title = {A component-based approach to integrated modeling in the geosciences: The design of {CSDMS}}, + Urldate = {March 24, 2020}, + Volume = {53}, + Year = {2013}, + Bdsk-Url-1 = {http://www.sciencedirect.com/science/article/pii/S0098300412001252}, + Bdsk-Url-2 = {https://doi.org/10.1016/j.cageo.2012.04.002}} + @article{colbeck1972, Author = {Colbeck, S C}, Date-Modified = {2017-05-15 22:36:06 +0000}, diff --git a/doc/ReleaseNotes/ReleaseNotes.bbl b/doc/ReleaseNotes/ReleaseNotes.bbl new file mode 100644 index 00000000000..e69de29bb2d diff --git a/doc/ReleaseNotes/ReleaseNotes.tex b/doc/ReleaseNotes/ReleaseNotes.tex index be7b3571282..80d12d73b82 100644 --- a/doc/ReleaseNotes/ReleaseNotes.tex +++ b/doc/ReleaseNotes/ReleaseNotes.tex @@ -115,35 +115,111 @@ \section{History} This section describes changes introduced into MODFLOW 6 with each release. These changes may substantially affect users. \begin{itemize} +\item Version mf6.1.1--Release Candidate -\item \currentmodflowversion +\underline{NEW FUNCTIONALITY} +\begin{itemize} +\item Added silent command line switch (-s or --silent) that sends all output to the screen (\texttt{STDOUT}) to a file (``mfsim.stdout''). +\item Added a new option, called SAVE\_SATURATION to the Node Property Flow Package. When invoked, cell saturation is written to the binary budget file. The cell saturation can be used by post-processors to determine how much of the cell is saturated without having to know the value for ICELLTYPE or the value for head. If a cell is marked as confined (ICELLTYPE=0) then saturation is always one. If ICELLTYPE is one, then saturation ranges between zero and one. +\end{itemize} + +\underline{BASIC FUNCTIONALITY} +\begin{itemize} +\item Corrected an error in how the discretization package (for regular MODFLOW grids) calculates the distance between two cells when one or both of the cells are unconfined. The error in the code would have only affected XT3D simulations with a regular grid, unconfined conditions, and specification of ANGLE2 in the NPF Package. +\item Corrected an error in the use of the AUXMULTNAME option for boundary packages when time series are used. +\end{itemize} + +\underline{STRESS PACKAGES} +\begin{itemize} + \item Fixed a bug in binary budget file header for CSUB Package budget data written using IMETH=6 (CSUB-ELASTIC and CSUB-INELASTIC) . + \item Added information on the CSUB Package budget terms and compaction data written the the Input/Output document in the `Description of Groundwater Flow (GWF) Model Binary Output Files' section. + \item Refactored the SFR Package to remove use of RectangularChGeometry objects and added required functionality as private methods in the SFR module. + \item Prior to this release, the calculated flows between a standard stress package (WEL, DRN, RIV, GHB, RCH, and EVT) and the connected model cell were based on the RHS and HCOF terms from the previous iteration. This was not consistent with previous MODFLOW versions. These packages were modified so that the flows are recalculated using the final converged head solution. As a result of this change, simulated groundwater flows for these packages may be slightly different (compared to previous releases) if the package HCOF and RHS values depend on the simulated groundwater head. +\end{itemize} + +\underline{ADVANCED STRESS PACKAGES} +\begin{itemize} +\item The code for saving the budget terms for the advanced packages was refactored to use common routines. These changes should have no affect on simulation results. +\item The LAK Package would accept negative user-input values for RAINFALL, EVAPORATION, RUNOFF, INFLOW, and WITHDRAWAL even though the user guide mentioned that negative values are not allowed for these flow terms. Error checks were added to ensure these values are specified as positive. +\item Added a storage term to the SFR Package binary output file. This term is always zero with the present implementation. An auxiliary variable, called VOLUME, is also written with the storage budget term. This term contains the calculated water volume in the reach. +\item Added additional error trapping in the MAW Package to catch divide by zero errors when calculating the saturated conductance for wells using the SKIN CONDEQN in connections where the cell transmissivity (the product of geometric mean of the horizontal hydraulic conductivity and cell thickness) and well transmissivity (the product of HK\_SKIN and screen thickness) is equal to one. Also add error trapping for well connections using the 1) SKIN CONDEQN where the contrast between the cell and well transmissivities are less than one and 2) SKIN and MEAN CONDEQN where the calculated connection saturated conductance is less than zero. +\item For the Lake Package, the outlet number was written as ID1 and ID2 for the TO-MVR record in the binary budget file. This has been changed so that the lake number of the connected outlet is written to ID1 and ID2. This change was implemented so that lake budgets can be calculated using the information in the lake budget file. +\item The Lake, Streamflow Routing, and Multi-Aquifer Well Packages were modified to save the user-specified stage or head to the binary output file for lakes, reaches, or wells that are specified as being CONSTANT. Prior to this change, a no-flow value was written to the package binary output files for constant stage lakes and streams and constant head multi-aquifer wells. The no-flow value is still written for those lakes, streams, or wells that are specified by the user as being inactive. This change should make it easier to post-process the results from these packages. +\end{itemize} + +\underline{SOLUTION} + +\item Version mf6.1.0 + +\underline{NEW FUNCTIONALITY} +\begin{itemize} + \item Added the Skeletal Storage, Compaction, and Subsidence (CSUB) Package. The one-dimensional effective-stress based compaction theory implemented in the CSUB Package is documented in Leake and Galloway (2007). The numerical approach used for delay interbeds in the CSUB package is documented in Hoffmann and others (2003) and uses the same one-dimensional effective-stress based compaction theory as coarse-grained and fine-grained no-delay interbed sediments. A number of example problems that use the CSUB Package are documented in the ``MODFLOW 6 CSUB Package Example Problems'' pdf document included in this and subsequent releases. +\end{itemize} + +\underline{BASIC FUNCTIONALITY} +\begin{itemize} +\item Added an error check to the DISU Package that ensures that an underlying cell has a top elevation that is less than or equal to the bottom of an overlying cell. An underlying cell is one in which the IHC value for the connection is zero and the connecting node number is greater than the cell node number. +\item Added restricted IDOMAIN support for DISU grids. Users can specify an optional IDOMAIN in the DISU Package input file. IDOMAIN values must be zero or one. Vertical pass-through cells (specified with an IDOMAIN value of -1 in the DIS or DISV Package input files) are not supported for DISU. +\item NPF Package will now write a message to the GWF Model list file to indicate when the SAVE\_SPECIFIC\_DISCHARGE option is invoked. +\item Added two new options to the NPF Package. The K22OVERK option allows the user to enter the anisotropy ratio for K22. If activated, the K22 values entered by the user in the NPF input file will be multiplied by the K values entered in the NPF input file. The K33OVERK option allows the user to enter the anisotropy ratio for K33. If activated, the K33 values entered by the user in the NPF input file will be multiplied by the K values entered in the NPF input file. With this K33OVERK option, for example, the user can specify a value of 0.1 for K33 and have all K33 values be one tenth of the values specified for K. The program will terminate with an error if these options are invoked, but arrays for K22 and/or K33 are not provided in the NPF input file. +\item Added new MAXERRORS option to mfsim.nam. If specified, the maximum number of errors stored and printed will be limited to this number. This can prevent a situation where memory will run out when there are an excessive number of errors. +\item Refactored many parts of the code to remove unused variables, conform to stricter FORTRAN standard checks, and allow for new development efforts to be included in the code base. +\end{itemize} + +\underline{STRESS PACKAGES} +\begin{itemize} +\item There was an error in the calculation of the segmented evapotranspiration rate for the case where the rate did not decrease with depth. There was another error in which PETM0 was being used as the evapotranspiration rate at the surface instead of the proportion of the evapotranspiration rate at the surface. +\end{itemize} + +\underline{ADVANCED STRESS PACKAGES} +\begin{itemize} +\item Corrected the way auxiliary variables are handled for the advanced packages. In some cases, values for auxiliary variables were not being correctly written to the GWF Model budget file or to the advanced package budget file. A consistent approach for updating and saving auxiliary variables was implemented for the MAW, SFR, LAK, and UZF Packages. +\item The user guide was updated to include a missing laksetting that was omitted from the PERIOD block. The laksetting description now includes an INFLOW option; a description for INFLOW is also now included. +\item The LAK package was incorrectly making an error check against NOUTLETS instead of NLAKES. +\item For the advanced stress packages, values assigned to the auxiliary variables were not written correctly to the GWF Model budget file, but the values were correct in the advanced package budget file. Program was modified so that auxiliary variables are correctly written to the GWF Model budget file. +\item Corrected several error messages issued by the SFR Package that were not formatted correctly. +\item Fixed a bug in which the lake stage stable would sometimes result in touching numbers. This only occurred for negative lake stages. +\item The UZF Package was built on the UZFKinematicType, which used an array of structures. A large array like this, can cause memory problems. The UZFKinematicType was replaced with a new UzfCellGroupType, which is a structure of arrays and is much more memory efficient. The underlying UZF algorithm did not change. +\end{itemize} + +\underline{SOLUTION} +\begin{itemize} +\item Add ALL and FIRST options to optional NO\_PTC optional keyword in OPTIONS block. If NO\_PTC option is FIRST, PTC is disabled for the first stress period but is applied in all subsequent steady-state stress periods. If NO\_PTC option is ALL, PTC is disabled for all steady-state stress periods. If the NO\_PTC options is not defined, PTC is disabled for all steady-state stress periods (this is consistent with the behaviour of the NO\_PTC option in previous versions). +\end{itemize} + +\item Version mf6.0.4--Feb. 27, 2019 \underline{BASIC FUNCTIONALITY} \begin{itemize} \item Addressed issue with pointing contiguous pointer vectors/arrays to non-contiguous pointer vectors/arrays that caused code compilation failure with gfortran-8. A consequence of addressing this issue is that all pointer vectors/arrays that are allocated or pointed to using the memory manager must be defined to be contiguous. -\item - -\item - +\item Corrected a problem with the reading of grid data from a binary file, in which the program was reading a binary header for each row of data. +\item Added a new error check for very small time steps. If the value of the starting time is equal to the ending time (starting time plus the time step length), then the time step is too small to be differentiated by the program based on the precision of floating point numbers. The program will terminate with an error in this case. The program will also terminate if the storage package with a transient stress period has a time step length of zero. +\item The observation package was modified to use non-advancing output instead of fixed length strings when writing ascii output. The previous use of fixed length strings resulted in truncation of ascii observation output when the product of user-specified \texttt{digits} + 7 and the number of observations exceeded 5000. +\item Corrected an error in the GWF-GWF Exchange module that caused the specific discharge values in the child model to be calculated incorrectly. The calculation was incorrect because the face normal for the child model was pointing toward the center of the cell instead of outward. +\item Minor refactoring to improve code clarity. \end{itemize} \underline{STRESS PACKAGES} \begin{itemize} -\item - -\item - -\item - +\item Minor refactoring to improve code clarity. \end{itemize} \underline{ADVANCED STRESS PACKAGES} \begin{itemize} -\item - -\item - -\item - +\item Modified the Multi-Aquifer Well (MAW) Package so that the HEAD\_LIMIT and RATE\_SCALING options work for injection wells. Prior to this change, these options only worked for extraction wells. These options can be used to reduce or even shut off well injection as the head in the well rises above user-specified levels. +\item Added stage and residual convergence checks to the SFR package to make sure that stage and upstream flow changes between successive outer iterations are less than OUTER\_HCLOSE and OUTER\_RCLOSEBND, respectively. This addition is expected to be useful for steady-state simulations with complicated networks and simple reaches. +\item Modified the final convergence check for the LAK package to use OUTER\_HCLOSE when evaluating lake stage changes between successive outer iterations. +\item Modified the final convergence check for the UZF package to use OUTER\_RCLOSEBND when evaluating rejected infiltration, groundwater recharge, and groundwater seepage changes between successive outer iterations. +\item Minor refactoring to improve code clarity. \end{itemize} \underline{SOLUTION} \begin{itemize} -\item - -\item - -\item - +\item Modified pseudo-transient continuation (PTC) approach to use PTC for steady-state stress period for models using the Newton-Raphson formulation for problems with and without the storage (STO) package. Previously, PTC was only used with problems that did not include the STO package (this was not the intended behavior of PTC). +\item Added NO\_PTC option to disable PTC for problems where PTC degrades/prevents model convergence. Option only applies to steady-state stress periods for models using the Newton-Raphson formulation. For many problems, PTC can significantly improve convergence behavior for steady-state simulations, and for this reason it is active by default. In some cases, however, PTC can worsen the convergence behavior, especially when the initial conditions are similar to the solution. When the initial conditions are similar to, or exactly the same as, the solution and convergence is slow, then this NO\_PTC option should be used to deactivate PTC. This NO\_PTC option should also be used in order to compare convergence behavior with other MODFLOW versions, as PTC is only available in MODFLOW 6. +\item Small improvements to PTC to reduce the initial PTCDEL value loaded on the diagonal. This reduces the number of iterations required to achieve convergence for steady-state stress periods for most problems. +\item Added OUTER\_RCLOSEBND variable that is used when performing final convergence checks on model packages that solve a separate equation not solved by the IMS linear solver. This value represents the maximum allowable residual at any single model package element between successive outer iterations. An example of a model package that would use OUTER\_RCLOSEBND to evaluate convergence is the SFR package which solves a continuity equation for each reach. +\item Minor refactoring to improve code clarity. \end{itemize} \item Version mf6.0.3--Aug. 9, 2018 @@ -298,7 +374,7 @@ \section{History} \item Added functionality to pass SFR leakage to the aquifer to the highest active layer. \item Converted SFR Manning's to a time-varying, time series aware variable. \item Updated LAK package so that conductance calculations correctly account for THICKSTRT in the NPF package for layers that use THICKSTRT (and are confined). Also updated EMBEDDEDH and EMBEDDEDV so that the conductance for these connection types are constant for confined layers. -\item Converted UZF stress-period data to time series aware data. +\item Converted UZF stress period data to time series aware data. \item Added time-series aware AUXILIARY variables to UZF package. \item Implemented AUXMULTNAME in options block for UZF package (AUXILIARY variables have to be specified). AUXMULTNAME is applied to the GWF cell area and is used to simulated more than one UZF cell per GWF cell. This could be used to simulate different land use classifications (i.e., agricultural and natural land use types) in the same GWF cell. \end{itemize} @@ -360,7 +436,7 @@ \section{Distribution File} It is recommended that no user files are kept in the \modflowversion~directory structure. If you do plan to put your own files in the \modflowversion~directory structure, do so only by creating additional subdirectories. % ------------------------------------------------- -\section{Installation and Executation} +\section{Installation and Execution} There is no installation of MODFLOW 6 other than the requirement that \modflowversion.zip must be unzipped into a location where it can be accessed. To make the executable versions of MODFLOW 6 accessible from any directory, the directory containing the executables should be included in the PATH environment variable. Also, if a prior release of MODFLOW 6 is installed on your system, the directory containing the executables for the prior release should be removed from the PATH environment variable. @@ -373,7 +449,7 @@ \section{Installation and Executation} \section{Compiling MODFLOW 6} MODFLOW 6 has been compiled using Intel Visual Fortran and gfortran on the Windows and Mac/OS operating systems. Because the program uses relatively new Fortran capabilities, newer versions of the compilers may be required for successful compilation. For example, to use gfortran to compile MODFLOW 6, gfortran version 4.9 or newer must be used. If you have gfortran installed on your computer, you can tell which version it is by entering ``\verb|gfortran --version|'' at a terminal window. -This distribution contains the Microsoft Visual Studio project files for compiling MODFLOW 6 on Windows using the Intel Fortran Compiler. The files have been used successfully with Visual Studio 2017 and Intel(R) Visual Fortran Compiler 18.0.1.156. +This distribution contains the Microsoft Visual Studio project files for compiling MODFLOW 6 on Windows using the Intel Fortran Compiler. The files have been used successfully with Visual Studio 2017 and Intel(R) Visual Fortran Compiler 2019.2.190. This distribution also comes with a makefile for compiling MODFLOW 6 with gfortran. The makefile is contained in the \texttt{make} folder. @@ -436,23 +512,27 @@ \section{Disclaimer and Notices} \section{References Cited} \begin{itemize} -\item Keating, E., and Zyvoloski, G. 2009. A stable and efficient numerical algorithm for unconfined aquifer analysis. Ground Water, 47: 569--579. doi:10.1111/j.1745-6584.2009.00555.x +\item Hoffmann, J{\"o}rn, Leake, S.A., Galloway, D.L., and Wilson, A.M., 2003, MODFLOW-2000 Ground-Water Model--User Guide to the Subsidence and Aquifer-System Compaction (SUB) Package: U.S. Geological Survey Open-File Report 03–233, 44 p., \url{https://pubs.usgs.gov/of/2003/ofr03-233/} + +\item Keating, E., and Zyvoloski, G. 2009. A stable and efficient numerical algorithm for unconfined aquifer analysis. Ground Water, 47: 569--579. \href{https://doi.org/10.1111/j.1745-6584.2009.00555.x}{doi:10.1111/j.1745-6584.2009.00555.x} + +\item Laattoe, T., Post, V. E.A. and Werner, A. D. 2014, Spatial periodic boundary condition for MODFLOW. Groundwater, v. 52: 606--612. \href{https://doi.org/10.1111/gwat.12086}{doi:10.1111/gwat.12086} -\item Laattoe, T., Post, V. E.A. and Werner, A. D. 2014, Spatial periodic boundary condition for MODFLOW. Groundwater, v. 52: 606--612. doi:10.1111/gwat.12086 +\item Leake, S.A., and Galloway, D.L., 2007, MODFLOW Ground-water model--User guide to the Subsidence and Aquifer-System Compaction Package (SUB-WT) for Water-Table Aquifers: U.S. Geological Survey Techniques and Methods, book 6, chap. A23, 42 p., \url{https://pubs.er.usgs.gov/publication/tm6A23}. -\item Merritt, M.L., and Konikow, L.F. 2000, Documentation of a computer program to simulate lake-aquifer interaction using the MODFLOW ground-water flow model and the MOC3D solute-transport model. U.S. Geological Survey Water-Resources Investigations Report 00--4167, 146 p. https://pubs.er.usgs.gov/publication/wri004167. +\item Merritt, M.L., and Konikow, L.F. 2000, Documentation of a computer program to simulate lake-aquifer interaction using the MODFLOW ground-water flow model and the MOC3D solute-transport model. U.S. Geological Survey Water-Resources Investigations Report 00--4167, 146 p. \url{https://pubs.er.usgs.gov/publication/wri004167}. -\item Neville, C.J., and M.J. Tonkin. 2004. Modeling multiaquifer wells with MODFLOW. Ground Water, 42: 910--919. doi:10.1111/j.1745-6584.2004.t01-9-.x +\item Neville, C.J., and M.J. Tonkin. 2004. Modeling multiaquifer wells with MODFLOW. Ground Water, 42: 910--919. \href{https://doi.org/10.1111/j.1745-6584.2004.t01-9-.x}{doi:10.1111/j.1745-6584.2004.t01-9-.x} -\item Panday, Sorab, Langevin, C.D., Niswonger, R.G., Ibaraki, Motomu, and Hughes, J.D. 2013, MODFLOW-USG version 1: An unstructured grid version of MODFLOW for simulating groundwater flow and tightly coupled processes using a control volume finite-difference formulation. U.S. Geological Survey Techniques and Methods, book 6, chap. A45, 66 p., https://pubs.usgs.gov/tm/06/a45. +\item Panday, Sorab, Langevin, C.D., Niswonger, R.G., Ibaraki, Motomu, and Hughes, J.D. 2013, MODFLOW-USG version 1: An unstructured grid version of MODFLOW for simulating groundwater flow and tightly coupled processes using a control volume finite-difference formulation. U.S. Geological Survey Techniques and Methods, book 6, chap. A45, 66 p., \url{https://pubs.usgs.gov/tm/06/a45}. -\item Prudic, D.E. 1989, Documentation of a computer program to simulate stream-aquifer relations using a modular, finite-difference, ground-water flow model. U.S. Geological Survey Open-File Report 88--729, 113 p. https://pubs.er.usgs.gov/publication/ofr88729. +\item Prudic, D.E. 1989, Documentation of a computer program to simulate stream-aquifer relations using a modular, finite-difference, ground-water flow model. U.S. Geological Survey Open-File Report 88--729, 113 p. \url{https://pubs.er.usgs.gov/publication/ofr88729}. -\item Reilly, T.E., O.L. Franke, and Bennett, G.D. 1989. Bias in groundwater samples caused by wellbore flow. Journal of Hydraulic Engineering 115, no. 2: 270--276. https://doi.org/10.1061/(ASCE)0733-9429(1989)115:2(270) +\item Reilly, T.E., O.L. Franke, and Bennett, G.D. 1989. Bias in groundwater samples caused by wellbore flow. Journal of Hydraulic Engineering 115, no. 2: 270--276. \url{https://doi.org/10.1061/(ASCE)0733-9429(1989)115:2(270)} -\item Vilhelmsen, T.N., Christensen, S., and Mehl, S.W., 2012, Evaluation of MODFLOW-LGR in connection with a synthetic regional-scale model. Ground Water, 50: 118--132. doi:10.1111/j.1745-6584.2011.00826.x +\item Vilhelmsen, T.N., Christensen, S., and Mehl, S.W., 2012, Evaluation of MODFLOW-LGR in connection with a synthetic regional-scale model. Ground Water, 50: 118--132. \href{https://doi.org/10.1111/j.1745-6584.2011.00826.x}{doi:10.1111/j.1745-6584.2011.00826.x} -\item Zaidel, J. 2013, Discontinuous Steady-State Analytical Solutions of the Boussinesq Equation and Their Numerical Representation by MODFLOW. Groundwater, 51: 952--959. doi:10.1111/gwat.12019 +\item Zaidel, J. 2013, Discontinuous Steady-State Analytical Solutions of the Boussinesq Equation and Their Numerical Representation by MODFLOW. Groundwater, 51: 952--959. \href{https://doi.org/10.1111/gwat.12019}{doi:10.1111/gwat.12019} \end{itemize} @@ -461,4 +541,4 @@ \section{References Cited} \clearpage \pagestyle{backofreport} \makebackcover -\end{document} \ No newline at end of file +\end{document} diff --git a/doc/ReleaseNotes/example_items.tex b/doc/ReleaseNotes/example_items.tex index 0892ab49d85..b0095b50b79 100644 --- a/doc/ReleaseNotes/example_items.tex +++ b/doc/ReleaseNotes/example_items.tex @@ -35,4 +35,9 @@ \item ex30-vilhelmsen-gf---This is the Globally Fine (GF) model described in Vilhelmsen et al. (2012). \item ex31-vilhelmsen-lgr---This is the Local Grid Refinement (LGR) model described in Vilhelmsen et al. (2012). \item ex32-periodicbc---Periodic boundary condition problem is based on Laattoe and others (2014). A MODFLOW 6 GWF-GWF Exchange is used to connect the left column with the right column. +\item ex33-csub-jacob---This is the Jacob (1939) train problem simulates elastic compaction of aquifer materials in response to the loading of an aquifer by + +\item ex34-csub-sub01---This is the Problem 1 from the Subsidence Package for MODFLOW-2000 documentation (Hoffman and others, 2003), which is described in the MODFLOW 6 CSUB Package Example Problems document released with MODFLOW 6 (version 6.1.0 or higher). This simulates the drainage of a thick interbed caused by a step decrease in hydraulic head in the aquifer in MODFLOW 6. The thick interbed is simulated using a delay-bed interbed and the default effective-stress formulation is used to simulate thick interbed compaction. +\item ex35-csub-holly---This is the one-dimensional MODFLOW 6 extensometer model based on the model developed by Sneed (2008) to simulate aquitard drainage, compaction and, land subsidence at the Holly site, located at the Edwards Air Force base, in response to effective stress changes caused by groundwater pumpage in the Antelope Valley in southern California. This problem is described in the MODFLOW 6 CSUB Package Example Problems document released with MODFLOW 6 (version 6.1.0 or higher). The model simulates compaction in a combination of no-delay and delay interbeds and the default effective-stress formulation is used to simulate interbed compaction. +\item ex36-csub-subwt01---This is the one-dimensional compaction in a three-dimensional flow field problem that is described in the MODFLOW 6 CSUB Package Example Problems document released with MODFLOW 6 (version 6.1.0 or higher). This problem is based on the problem presented in the SUB-WT package for MODFLOW-2005 report (Leake and Galloway, 2007) and represents groundwater development in a hypothetical aquifer that includes some features typical of basin-fill aquifers in an arid or semi-arid environment. The problem of Leake and Galloway (2007) was modified to include compaction of coarse-grained aquifer materials and water compressibility. The model simulates compaction in no-delay interbeds and the default effective-stress formulation is used to simulate interbed compaction. \end{itemize} diff --git a/doc/ReleaseNotes/example_table.tex b/doc/ReleaseNotes/example_table.tex index 10a779b0b73..d4ecd552e51 100644 --- a/doc/ReleaseNotes/example_table.tex +++ b/doc/ReleaseNotes/example_table.tex @@ -81,6 +81,14 @@ \hline ex32-periodicbc & 1 & \parbox[t]{3cm}{ pbc.nam \\}& \parbox[t]{3cm}{ (190, 1, 100) \\}& \parbox[t]{4cm}{ CHD \\}\\ \hline +ex33-csub-jacob & 2 & \parbox[t]{3cm}{ fig4\_base.nam \\}& \parbox[t]{3cm}{ (3, 1, 35) \\}& \parbox[t]{4cm}{ none \\}\\ +\hline +ex34-csub-sub01 & 1 & \parbox[t]{3cm}{ sub01es.nam \\}& \parbox[t]{3cm}{ (1, 1, 3) \\}& \parbox[t]{4cm}{ CHD \\}\\ +\hline +ex35-csub-holly & 353 & \parbox[t]{3cm}{ holly.nam \\}& \parbox[t]{3cm}{ (14, 1, 1) \\}& \parbox[t]{4cm}{ chd \\}\\ +\hline +ex36-csub-subwt01 & 3 & \parbox[t]{3cm}{ csub\_subwt02b.nam \\}& \parbox[t]{3cm}{ (4, 20, 15) \\}& \parbox[t]{4cm}{ CHD WEL RCH \\}\\ +\hline \hline \end{longtable} \label{table:examples} diff --git a/doc/ReleaseNotes/folder_struct.tex b/doc/ReleaseNotes/folder_struct.tex index 86510eda043..492b914f5a7 100644 --- a/doc/ReleaseNotes/folder_struct.tex +++ b/doc/ReleaseNotes/folder_struct.tex @@ -1,5 +1,5 @@ \begin{verbatim} -mf6.0.3/ +mf6.1.0/ bin/ doc/ examples/ @@ -35,6 +35,10 @@ ex30-vilhelmsen-gf/ ex31-vilhelmsen-lgr/ ex32-periodicbc/ + ex33-csub-jacob/ + ex34-csub-sub01/ + ex35-csub-holly/ + ex36-csub-subwt01/ make/ msvs/ src/ diff --git a/doc/mf6bmi/bibliography.tex b/doc/mf6bmi/bibliography.tex new file mode 100644 index 00000000000..0a554896627 --- /dev/null +++ b/doc/mf6bmi/bibliography.tex @@ -0,0 +1,2 @@ +\bibliography{../MODFLOW6References} +\bibliographystyle{../usgs.bst} diff --git a/doc/mf6bmi/body.tex b/doc/mf6bmi/body.tex new file mode 100644 index 00000000000..bed42a60e3b --- /dev/null +++ b/doc/mf6bmi/body.tex @@ -0,0 +1,34 @@ +%Introduction +\SECTION{Introduction} +\input{introduction.tex} + +%Instructions for running a simulation +\SECTION{Compiling \mf as a dynamic linked library or shared object} +% add \input{} to the file describing how to compile the *.dll or *.so + +%Instructions for running a simulation +\SECTION{Running a \mf Simulation with python} +% add \input{} to the file describing how to run mf6 from python + +% General form of input instructions +\SECTION{Coupling \mf to another Basic Model Interface compliant code} +\input{coupling.tex} + +\newpage +\ifx\usgsdirector\undefined +\addcontentsline{toc}{section}{\hspace{1.5em}\bibname} +\else +\inreferences +\REFSECTION +\fi +\input{bibliography.tex} + +\newpage +\inappendix +\SECTION{Appendix A. \mf Basic Model Interface Function Calls} +% add \input{} to the file with the function calls + +\newpage +\inappendix +\SECTION{Appendix B. Additional \mf python examples} +% add \input{} to the file with additional python examples diff --git a/doc/mf6bmi/coupling.tex b/doc/mf6bmi/coupling.tex new file mode 100644 index 00000000000..7f55f6e9118 --- /dev/null +++ b/doc/mf6bmi/coupling.tex @@ -0,0 +1,11 @@ +Intro text. + + +\subsection{Coupling to another model using python} + Text.... + + + +\subsection{Coupling to another model using compiled code with a compiled wrapper} + Text.... + \ No newline at end of file diff --git a/doc/mf6bmi/introduction.tex b/doc/mf6bmi/introduction.tex new file mode 100644 index 00000000000..dfd4f9f281b --- /dev/null +++ b/doc/mf6bmi/introduction.tex @@ -0,0 +1,3 @@ +The Initialize, Run, Finalize model and the Basic Model Interface (BMI) developed by the Community Surface Dynamics Modeling System group \citep{PECKHAM20133} has been implemented in \mf. + +Add a more introduction text. \ No newline at end of file diff --git a/doc/mf6bmi/mf6bmi.stdsty.bbl b/doc/mf6bmi/mf6bmi.stdsty.bbl new file mode 100644 index 00000000000..2c518ec89d3 --- /dev/null +++ b/doc/mf6bmi/mf6bmi.stdsty.bbl @@ -0,0 +1,14 @@ +\begin{thebibliography}{1} +\providecommand{\natexlab}[1]{#1} +\expandafter\ifx\csname urlstyle\endcsname\relax + \providecommand{\doi}[1]{doi:\discretionary{}{}{}#1}\else + \providecommand{\doi}{doi:\discretionary{}{}{}\begingroup + \urlstyle{rm}\Url}\fi + +\bibitem[{Peckham and others(2013)Peckham, Hutton, and Norris}]{PECKHAM20133} +Peckham, S.D., Hutton, E.W., and Norris, Boyana, 2013, A component-based + approach to integrated modeling in the geosciences: The design of {CSDMS}: + Computers \& Geosciences, v.~53, p.~3 -- 12, accessed March 24, 2020, at + \url{https://doi.org/https://doi.org/10.1016/j.cageo.2012.04.002}. + +\end{thebibliography} diff --git a/doc/mf6bmi/mf6bmi.stdsty.tex b/doc/mf6bmi/mf6bmi.stdsty.tex new file mode 100644 index 00000000000..be999461b5f --- /dev/null +++ b/doc/mf6bmi/mf6bmi.stdsty.tex @@ -0,0 +1,165 @@ +\documentclass[11pt,twoside,twocolumn]{book} + +\RequirePackage[left=1in, + right=.767in, + top=1in, + bottom=1in, + headheight=14bp, + headsep=9bp, + columnsep=0.24in, + footskip=14bp, + heightrounded]{geometry} + +\usepackage{amsmath} +\usepackage{algorithm} +\usepackage{algpseudocode} +\usepackage{bm} +\usepackage{calc} +\usepackage{natbib} +\usepackage{graphicx} +\usepackage{longtable} +\usepackage{caption} +\usepackage[]{titletoc} + +%Do not allow a page break to result in a line appearing by itself +% https://tex.stackexchange.com/questions/4152/how-do-i-prevent-widow-orphan-lines +\usepackage[all]{nowidow} + +\makeindex +\usepackage{setspace} +% uncomment to make double space +%\doublespacing +\usepackage{etoolbox} +\usepackage{verbatim} + +% set up the listings package for highlighting block definitions and input files +\usepackage{listings} +\usepackage{xcolor} +\lstset{ + basicstyle=\footnotesize\ttfamily\color{black}, + numbers=none, + columns=flexible, + backgroundcolor=\color{yellow!10}, +% frame=tlbr, + moredelim=**[is][\color{red}]{@}{@}, +} +\lstdefinestyle{blockdefinition}{ + moredelim=**[is][\color{blue}]{@}{@}, +} +%usage: \lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwf-chd-dimensions.dat} +\lstdefinestyle{inputfile}{ + morecomment=[l]\#, + backgroundcolor=\color{gray!10}, +} +%usage: \lstinputlisting[style=modeloutput]{file.dat} +\lstdefinestyle{modeloutput}{ + backgroundcolor=\color{blue!20}, +} + +\usepackage[hidelinks]{hyperref} +\hypersetup{ + pdftitle={Basic Model Interface for MODFLOW 6}, + pdfauthor={MODFLOW 6 Development Team}, + pdfsubject={numerical simulation groundwater flow}, + pdfkeywords={groundwater, MODFLOW, simulation, basic model interface, CSDMS}, + pdflang={en-US}, + bookmarksnumbered=true, + bookmarksopen=true, + bookmarksopenlevel=1, + colorlinks=true, + allcolors={blue}, + pdfstartview=Fit, + pdfpagemode=UseOutlines, + pdfpagelayout=TwoPageRight +} + +\graphicspath{{./Figures/}} +\input{../version.tex} + +\title{Basic Model Interface for MODFLOW 6} +\author{MODFLOW 6 Development Team} +\date{\currentmodflowversion} + +\newcommand{\mli}[1]{\mathit{#1}} + +\urlstyle{rm} + +\newcommand{\programname}{MODFLOW 6} +\newcommand{\mf}{MODFLOW~6~} +\newcommand{\mfdot}{MODFLOW~6.~} +\newcommand{\mfcomma}{MODFLOW~6,~} +\newcommand{\mfpar}{(MODFLOW~6)~} +\usepackage{placeins} +\usepackage{float} +\floatstyle{plain} +\newfloat{exampleinput}{H}{exi} +\floatname{exampleinput}{} + +\newcommand{\inreferences}{% +\renewcommand{\theequation}{R--\arabic{equation}}% +\setcounter{equation}{0}% +\renewcommand{\thefigure}{R--\arabic{figure}}% +\setcounter{figure}{0}% +\renewcommand{\thetable}{R--\arabic{table}}% +\setcounter{table}{0}% +\renewcommand{\thepage}{R--\arabic{page}}% +\setcounter{page}{1}% +} + +\newcounter{appendixno} +\setcounter{appendixno}{0} +\newcommand{\inappendix}{% +\addtocounter{appendixno}{1}% +\renewcommand{\theequation}{\Alph{appendixno}--\arabic{equation}}% +\setcounter{equation}{0}% +\renewcommand{\thefigure}{\Alph{appendixno}--\arabic{figure}}% +\setcounter{figure}{0}% +\renewcommand{\thetable}{\Alph{appendixno}--\arabic{table}}% +\setcounter{table}{0}% +\renewcommand{\thepage}{\Alph{appendixno}--\arabic{page}}% +\setcounter{page}{1}% +} + +\renewcommand{\thesection}{} +\renewcommand{\thesubsection}{} +\newcommand{\SECTION}{\section} +\newcommand{\REFSECTION}{\section} + +\makeatletter +\renewcommand*\l@section{\@dottedtocline{1}{0em}{1.5em}} +\renewcommand\section{\@startsection {section}{1}{-1em}% + {-3.5ex \@plus -1ex \@minus -.2ex}% + {2.3ex \@plus.2ex}% + {\normalfont\Large\bfseries}} +\def\sectionmark#1{% + \markright {\MakeUppercase{#1}}} +\makeatother + +\makeatletter +\patchcmd{\@verbatim} + {\verbatim@font} + {\verbatim@font\footnotesize} + {}{} +\makeatother + +\renewcommand\bibname{References Cited} + +\begin{document} +%\makefrontcover + +%\makefrontmatter + +\onecolumn +\hbadness=10000 +\setlength{\parindent}{1.5pc} + +\maketitle + +\tableofcontents +\listoffigures +\listoftables + +\newpage +\input{./body.tex} + +\end{document} \ No newline at end of file diff --git a/doc/mf6io/gwf/binaryoutput.tex b/doc/mf6io/gwf/binaryoutput.tex index 5afb8845506..7845d6bf947 100644 --- a/doc/mf6io/gwf/binaryoutput.tex +++ b/doc/mf6io/gwf/binaryoutput.tex @@ -6,7 +6,7 @@ \newpage \subsection{Binary Grid File} -\mf~ writes a binary grid file that can be used for post processing model results. The file name is assigned automatically by the program by adding ``.grb'' to the end of the discretization input file name. The structure of the binary grid file depends on the type of discretization package that is used. The following subsections summarize the binary grid file for the different grid types. The red text in is not written to the binary grid file. +\mf~writes a binary grid file that can be used for post processing model results. The file structure was designed to be self-documenting so that it can evolve if necessary. The file name is assigned automatically by the program by adding ``.grb'' to the end of the discretization input file name. The structure of the binary grid file depends on the type of discretization package that is used. The following subsections summarize the binary grid file for the different grid types. The red text is not written to the binary grid file, but is shown here to explain the file content. \newpage \subsubsection{DIS Grids} @@ -137,7 +137,7 @@ \subsubsection{DISV Grids} \newpage \subsubsection{DISU Grids} -The binary grid file for DISU grids may contain information on the vertices and which vertices comprise a cell, but this depends on whether or not the user provided the information in the DISU Package. This information is not required unless the XT3D option is used. If provided, the x, y coordinates for each vertex are stored in the VERTICES array. The list of vertices that comprise all of the cells is stored in the JAVERT array. The list of vertices for any cell can be found using the IAVERT array. Pseudocode for looping through cells in the grid is listed above in the section on the binary grid file for the DISV Package. As for the DISV binary grid file, the list of vertices is ``closed'' for each cell in that the first listed vertex is equal to the last listed vertex. +The binary grid file for DISU grids may contain information on the vertices and which vertices comprise a cell, but this depends on whether or not the user provided the information in the DISU Package. This information is not required unless the XT3D or SAVE\_SPECIFIC\_DISCHARGE options are specified in the NPF Package. If provided, the x, y coordinates for each vertex are stored in the VERTICES array. The list of vertices that comprise all of the cells is stored in the JAVERT array. The list of vertices for any cell can be found using the IAVERT array. Pseudocode for looping through cells in the grid is listed above in the section on the binary grid file for the DISV Package. As for the DISV binary grid file, the list of vertices is ``closed'' for each cell in that the first listed vertex is equal to the last listed vertex. \vspace{5mm} \noindent Header 1: \texttt{`GRID DISU'} {\color{red} \footnotesize{CHARACTER(LEN=50)}} \\ @@ -358,7 +358,7 @@ \subsubsection{Variations for Discretization Types} \subsubsection{Budget File Contents} -The type of information that is written to the budget file for a GWF Model depends on the packages used for the model and whether or not the save flags are set. Table \ref{table:gwfbud} contains a list of the types of information that may be contained in a GWF Model budget file. In all cases, the flows in table \ref{table:gwfbud} are flows to or a from a GWF Model cell. As described in the next section, intercell flows are written as FLOW-JA-FACE using IMETH=1. If the model has an active Storage Package, then STORAGE-SS and STORAGE-SY are written to the budget file using IMETH=1. +The type of information that is written to the budget file for a GWF Model depends on the packages used for the model and whether or not the save flags are set. Table \ref{table:gwfbud} contains a list of the types of information that may be contained in a GWF Model budget file. In all cases, the flows in table \ref{table:gwfbud} are flows to or a from a GWF Model cell. As described in the next section, intercell flows are written as FLOW-JA-FACE using IMETH=1. If the model has an active Storage Package, then STORAGE-SS and STORAGE-SY are written to the budget file using IMETH=1. If the model has an active Skeletal Storage, Compaction, and Subsidence Package, then CSUB-CGELASTIC and CSUB-WATERCOMP are written to the budget file using IMETH=1. The remaining flow terms in table \ref{table:gwfbud} are all written using IMETH=6. When IMETH=6 is used, the records contain additional text descriptors and two identifying numbers. For all records in the GWF Model budget file, TXT1ID1 is the name of the GWF Model and TXT2ID1 is also the name of the GWF Model. These text identifiers describe what is contained in ID1. For the GWF Model budget file, ID1 is the cell or node number in the GWF Model grid. The second set of text identifiers refer to the information in ID2. Unless noted otherwise in the description in table \ref{table:gwfbud}, TXT1ID2 is the name of the GWF Model, TXT2ID2 is the name of the package, and ID2 is the bound number in the package; for example, this is the first constant head cell, second constant head cell, and so forth. @@ -374,6 +374,10 @@ \subsubsection{Budget File Contents} \texttt{FLOW-JA-FACE} & 1 & intercell flow; array of size(NJA) \\ \texttt{STO-SS} & 1 & confined storage; array of size (NCELLS) \\ \texttt{STO-SY} & 1 & unconfined storage; array of size (NCELLS) \\ +\texttt{CSUB-CGELASTIC} & 1 & coarse-grained elastic storage from CSUB Package; array of size (NCELLS) \\ +\texttt{CSUB-WATERCOMP} & 1 & water compressibility from CSUB Package; array of size (NCELLS) \\ +\texttt{CSUB-ELASTIC} & 6 & interbed elastic storage from CSUB package; list of size(NINTERBEDS) \\ +\texttt{CSUB-INELASTIC} & 6 & interbed inelastic storage from CSUB package; list of size(NINTERBEDS) \\ \texttt{CHD} & 6 & constant head flow\\ \texttt{WEL} & 6 & well flow \\ \texttt{WEL-TO-MVR} & 6 & well flow that is routed to Mover Package \\ @@ -393,7 +397,8 @@ \subsubsection{Budget File Contents} \texttt{UZF-GWD} & 6 & groundwater discharge to land surface from UZF Package \\ \texttt{UZF-GWD-TO-MVR} & 6 & groundwater discharge to land surface from UZF Package that is routed to Mover Package\\ \texttt{FLOW-JA-FACE} & 6 & flow to or from a cell in another GWF Model; TXT1ID1 is the name of the GWF Model described by this budget file, TXT2ID1 is the name of the GWF-GWF Exchange, TXT1ID2 is the name of the connected GWF Model, TXT2ID2 is the name of the GWF-GWF Exchange, and ID2 is the cell or node number of the cell in the connected model \\ -\texttt{DATA-SPDIS} & 6 & specific discharge at the cell center. The x, y, and z components are stored in auxiliary variables called ``qx'', ``qy'', and ``qz'', respectively. The flow value written for each cell is zero. The ``DATA'' prefix on the text identifier can be used by post-processors to recognize that the record does not contain a cell flow budget term. +\texttt{DATA-SPDIS} & 6 & specific discharge at the cell center. The x, y, and z components are stored in auxiliary variables called ``qx'', ``qy'', and ``qz'', respectively. The flow value written for each cell is zero. The ``DATA'' prefix on the text identifier can be used by post-processors to recognize that the record does not contain a cell flow budget term. \\ +\texttt{DATA-SAT} & 6 & cell saturation. The cell saturation is stored in an auxiliary variable called ``sat''. The flow value written for each cell is zero. The ``DATA'' prefix on the text identifier can be used by post-processors to recognize that the record does not contain a cell flow budget term. The cell saturation can be used by post-processors to determine how much of the cell is saturated without having to know the value for ICELLTYPE or the value for head. If a cell is marked as confined (ICELLTYPE=0) then saturation is always one. If ICELLTYPE is one, then saturation ranges between zero and one. For Newton GWF simulations, saturation is zero if the head is below the cell bottom. \label{table:gwfbud} \end{longtable} @@ -420,6 +425,29 @@ \subsubsection{Intercell Flows} \end{verbatim} \newpage +\subsubsection{CSUB Package} + +\vspace{5mm} +For each stress period, time step, and compaction data type that is saved to the CSUB Package binary output files as \texttt{IMETH=1} budget file type. The compaction data that are written to the CSUB Package binary files are summarized in Tables~\ref{table:binarycsub}. + +\begin{longtable}{p{3.5cm} p{2cm} p{9cm}} + \caption{Data written to the CSUB Package compaction binary output files} + \tabularnewline + \hline + \textbf{Flow Type (TEXT)} & \textbf{Method Code (IMETH)} & \textbf{Description} \\ + \hline + \endhead + \hline + \endfoot + \texttt{CSUB-COMPACTION} & 1 & total compaction for cell; array of size (NCELLS) \\ + \texttt{CSUB-INELASTIC} & 1 & inelastic compaction for cell; array of size (NCELLS) \\ + \texttt{CSUB-ELASTIC} & 1 & elastic compaction for cell; array of size (NCELLS) \\ + \texttt{CSUB-INTERBED} & 1 & interbed compaction for cell; array of size (NCELLS) \\ + \texttt{CSUB-COARSE} & 1 & coarse-grained compaction for cell; array of size (NCELLS) \\ + \texttt{CSUB-ZDISPLACE} & 1 & z-displacement for cell; z-displacement of the upper most model cells represents subsidance at land-surface; array of size (NCELLS) \\ + \label{table:binarycsub} +\end{longtable} + \subsubsection{LAK, MAW, SFR, and UZF Packages} \vspace{5mm} @@ -456,7 +484,7 @@ \subsubsection{LAK, MAW, SFR, and UZF Packages} \texttt{CONSTANT} & 6 & 1 / \texttt{nlakes} & Calculated flow to maintain constant stage for lake. The lake number is written to (\texttt{ID1}) and (\texttt{ID2}). \\ \texttt{EXT-OUTFLOW} & 6 & 1 / \texttt{nlakes} & Calculated outflow to external boundaries (is nonzero for lakes with outlets not connected to another lake). The lake number is written to (\texttt{ID1}) and (\texttt{ID2}). \\ \texttt{FROM-MVR} & 6 & 1 / \texttt{nlakes} & Calculated flow to lake from the MVR Package. Only saved if MVR Package is used in the LAK Package. The lake number is written to (\texttt{ID1}) and (\texttt{ID2}). \\ -\texttt{TO-MVR} & 6 & 1 / \texttt{noutlets} & Calculated flow from a lake outlet to the MVR Package. Only saved if MVR Package is used in the LAK Package. The lake outlet number is written to (\texttt{ID1}) and (\texttt{ID2}). \\ +\texttt{TO-MVR} & 6 & 1 / \texttt{noutlets} & Calculated flow from a lake outlet to the MVR Package. Only saved if MVR Package is used in the LAK Package. The lake number \texttt{LAKEIN} for the connected outlet is written to (\texttt{ID1}) and (\texttt{ID2}). \\ \texttt{AUXILIARY} & 6 & \texttt{naux}+1 / \texttt{nlakes} & Auxiliary variables, if specified in the LAK Package, are saved to this flow term. The first entry of the \texttt{DATA2D} column has a value of zero. The lake number is written to (\texttt{ID1}) and (\texttt{ID2}). \label{table:binarylak} \end{longtable} @@ -520,6 +548,7 @@ \subsubsection{LAK, MAW, SFR, and UZF Packages} \texttt{RAIN} & 6 & 1 / \texttt{maxbound} & Specified rainfall on reach. The reach number is written to (\texttt{ID1}) and (\texttt{ID2}). \\ \texttt{EVAPORATION} & 6 & 1 / \texttt{maxbound} & Calculated evaporation from reach. The reach number is written to (\texttt{ID1}) and (\texttt{ID2}). \\ \texttt{EXT-OUTFLOW} & 6 & 1 / \texttt{maxbound} & Calculated outflow to external boundaries (is nonzero for reaches with no downstream connections). The reach number is written to (\texttt{ID1}) and (\texttt{ID2}). \\ +\texttt{STORAGE} & 6 & 2 / \texttt{maxbound} & Calculated storage changes for each reach. This value is always zero for the present implementation. The water volume in the reach (\texttt{VOLUME}) is saved as an auxiliary data item for this flow term. The reach number is written to (\texttt{ID1}) and (\texttt{ID2}). \\ \texttt{FROM-MVR} & 6 & 1 / \texttt{maxbound} & Calculated flow to reach from the MVR Package. Only saved if MVR Package is used in the SFR Package. The reach number is written to (\texttt{ID1}) and (\texttt{ID2}). \\ \texttt{TO-MVR} & 6 & 1 / \texttt{maxbound} & Calculated flow from reach to the MVR Package. Only saved if MVR Package is used in the SFR Package. The reach number is written to (\texttt{ID1}) and (\texttt{ID2}). \\ \texttt{AUXILIARY} & 6 & \texttt{naux}+1 / \texttt{maxbound} & Auxiliary variables, if specified in the SFR Package, are saved to this flow term. The first entry of the \texttt{DATA2D} column has a value of zero. The reach number is written to (\texttt{ID1}) and (\texttt{ID2}). @@ -580,7 +609,7 @@ \subsection{Observation Output File} \begin{description} \itemsep0pt \parskip0pt \parsep0pt \item \texttt{TYPE} (bytes 1--4 of Record 1) is ``cont `` --- ``cont'' indicates the file contains continuous observations ; -\item \texttt{PRECISION} (bytes 6--11 of Record 1) is either ``single'' or ``double'' --- ``single'' indicates that floating-point values are written in single precision (4 bytes), and ``double'' indicates double precision (8 bytes); +\item \texttt{PRECISION} (bytes 6--11 of Record 1) will always be ``double'' to indicate that floating-point values are written in double precision (8 bytes); \item \texttt{LENOBSNAME} (bytes 12--15 of Record 1) is an integer indicating the number of characters used to store each observation name in following records (in the initial release of MODFLOW~6, LENOBSNAME equals 40); \item \texttt{NOBS} (4-byte integer) is the number of observations recorded in the file; \item \texttt{OBSNAME} (LENOBSNAME bytes) is an observation name; diff --git a/doc/mf6io/gwf/csub.tex b/doc/mf6io/gwf/csub.tex new file mode 100644 index 00000000000..2ee747994a8 --- /dev/null +++ b/doc/mf6io/gwf/csub.tex @@ -0,0 +1,60 @@ +Input to the Skeletal Storage, Compaction, and Subsidence (CSUB) Package is read from the file that has type ``CSUB6'' in the Name File. If the CSUB Package is not included for a model, then storage changes resulting from compaction will not be calculated. Only one CSUB Package can be specified for a GWF model. Only the first and last stress period can be specified to be STEADY-STATE in the STO Package when the CSUB Package is being used in the GWF model. Also the specific storage (SS) must be specified to be zero in the STO Package for every cell. + +\vspace{5mm} +\subsubsection{Structure of Blocks} + +\vspace{5mm} +\noindent \textit{FOR EACH SIMULATION} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwf-csub-options.dat} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwf-csub-dimensions.dat} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwf-csub-griddata.dat} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwf-csub-packagedata.dat} +\vspace{5mm} +\noindent \textit{FOR ANY STRESS PERIOD} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwf-csub-period.dat} +\packageperioddescription + +\vspace{5mm} +\subsubsection{Explanation of Variables} +\begin{description} +\input{./mf6ivar/tex/gwf-csub-desc.tex} +\end{description} + +\vspace{5mm} +\subsubsection{Example Input File} +\lstinputlisting[style=inputfile]{./mf6ivar/examples/gwf-csub-example.dat} + + +\vspace{5mm} +\subsubsection{Available observation types} +Subsidence Package observations include all of the terms that contribute to the continuity equation for each GWF cell. The data required for each CSUB Package observation type is defined in table~\ref{table:gwf-csubobstype}. Negative and positive values for \texttt{CSUB} observations represent a loss from and gain to the GWF model, respectively. + + +\begin{longtable}{p{2cm} p{2.75cm} p{2cm} p{1.25cm} p{7cm}} +\caption{Available CSUB Package observation types} \tabularnewline + +\hline +\hline +\textbf{Stress Package} & \textbf{Observation type} & \textbf{ID} & \textbf{ID2} & \textbf{Description} \\ +\hline +\endfirsthead + +\captionsetup{textformat=simple} +\caption*{\textbf{Table \arabic{table}.}{\quad}Available CSUB Package observation types.---Continued} \\ + +\hline +\hline +\textbf{Stress Package} & \textbf{Observation type} & \textbf{ID} & \textbf{ID2} & \textbf{Description} \\ +\hline +\endhead + +\hline +\endfoot + +\input{../Common/gwf-csubobs.tex} +\label{table:gwf-csubobstype} +\end{longtable} + +\vspace{5mm} +\subsubsection{Example Observation Input File} +\lstinputlisting[style=inputfile]{./mf6ivar/examples/gwf-csub-example-obs.dat} diff --git a/doc/mf6io/gwf/disu.tex b/doc/mf6io/gwf/disu.tex index 7c814e27542..10b2612bed3 100644 --- a/doc/mf6io/gwf/disu.tex +++ b/doc/mf6io/gwf/disu.tex @@ -4,6 +4,8 @@ The DISU Package does not support the concept of layers, which is different from the DISU implementation in MODFLOW-USG. In \mf~all grid input and output for models that use the DISU Package is entered or written as a one-dimensional array of size nodes. +The DISU VERTICES and CELL2D blocks are not required for all simulations. These blocks are required if the XT3D or the SAVE\_SPECIFIC\_DISCHARGE options are specified in the NPF Package. In general, it is recommended to include the VERTICES and CELL2D blocks. + \vspace{5mm} \subsubsection{Structure of Blocks} \lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwf-disu-options.dat} diff --git a/doc/mf6io/gwf/gwf.tex b/doc/mf6io/gwf/gwf.tex index 18cc2640c63..63a105b419e 100644 --- a/doc/mf6io/gwf/gwf.tex +++ b/doc/mf6io/gwf/gwf.tex @@ -62,7 +62,7 @@ \subsection{Structured Discretization (DIS) Input File} \input{gwf/dis} \newpage -\subsection{Discretization with Vertices (DISV) Input File} +\subsection{Discretization by Vertices (DISV) Input File} \input{gwf/disv} \newpage @@ -97,6 +97,10 @@ \subsection{Horizontal Flow Barrier (HFB) Package} \subsection{Storage (STO) Package} \input{gwf/sto} +\newpage +\subsection{Skeletal Storage, Compaction, and Subsidence (CSUB) Package} +\input{gwf/csub} + \newpage \subsection{Constant-Head (CHD) Package} \input{gwf/chd} diff --git a/doc/mf6io/gwf/info_existing_users.tex b/doc/mf6io/gwf/info_existing_users.tex index 71f6c71e7c1..1c1a8c1c6c7 100644 --- a/doc/mf6io/gwf/info_existing_users.tex +++ b/doc/mf6io/gwf/info_existing_users.tex @@ -47,16 +47,13 @@ \item The GWF Model described in this report does not support the following list of packages and capabilities. Support for some of these capabilities may be added in future \mf versions. \begin{itemize} - \item Interbed Storage Package \citep{leake1991documentation}, - \item Subsidence Package \citep{hoffmann2003modflow}, - \item Subsidence and Aquifer-System Compaction Package for Water-Table Aquifers \citep{leake2007modflow}, \item Drain with Return Flow Package \citep{modflowdrtpack} \item Reservoir Package \citep{fenske1996documentation}, \item Seawater Intrusion Package \citep{bakker2013documentation}, \item Surface-Water Routing Process \citep{hughes2012documentation}, \item Connected Linear Network Process \citep{modflowusg}, \item Parameter Value File \citep{modflow2005}, and - \item Link to the MT3DMS Contaminant Transport Model \citep{zheng2001modflow}. + \item Link to the MT3DMS Contaminant Transport Model \citep{zheng2001modflow}. However, MT3D-USGS can read the head and budget files created by MODFLOW 6, but only if the GWF Model uses the DIS Package. MT3D-USGS will not work with GWF output if the DISV or DISU Packages are used. \end{itemize} \end{enumerate} diff --git a/doc/mf6io/gwf/namefile.tex b/doc/mf6io/gwf/namefile.tex index 85cac60edb4..32c03718936 100644 --- a/doc/mf6io/gwf/namefile.tex +++ b/doc/mf6io/gwf/namefile.tex @@ -29,6 +29,7 @@ \subsubsection{Explanation of Variables} OC6 & Output Control Option \\ NPF6 & Node Property Flow Package \\ STO6 & Storage Package \\ +CSUB6 & Compaction and Subsidence Package \\ HFB6 & Horizontal Flow Barrier Package\\ CHD6 & Time-Variant Specified Head Option & * \\ WEL6 & Well Package & * \\ diff --git a/doc/mf6io/gwf/tsi.tex b/doc/mf6io/gwf/tsi.tex index 8645caedb45..f2aaa4c05e7 100644 --- a/doc/mf6io/gwf/tsi.tex +++ b/doc/mf6io/gwf/tsi.tex @@ -249,9 +249,9 @@ \subsubsection{Using Time-Array Series in a Package} END OPTIONS \end{lstlisting} -A time-array series is linked to an array in one or more stress-period blocks used to define package input. To indicate that an array is to be controlled by a time-array series, the array property word is followed by the keyword TIMEARRAYSERIES and the time-array series name. When the TIMEARRAYSERIES keyword is found (and the array to be populated supports time-array series), the array reader is not invoked. Consequently, the array-control record and any associated input are omitted. The syntax to define the link is: +A time-array series is linked to an array in one or more stress period blocks used to define package input. To indicate that an array is to be controlled by a time-array series, the array property word is followed by the keyword TIMEARRAYSERIES and the time-array series name. When the TIMEARRAYSERIES keyword is found (and the array to be populated supports time-array series), the array reader is not invoked. Consequently, the array-control record and any associated input are omitted. The syntax to define the link is: -% Syntax for stress-period block +% Syntax for stress period block \begin{lstlisting}[style=blockdefinition] BEGIN PERIOD kper property-name TIMEARRAYSERIES time-array-series-name diff --git a/doc/mf6io/ims_table.tex b/doc/mf6io/ims_table.tex index 3963ca7b6f6..d64d92b3a10 100644 --- a/doc/mf6io/ims_table.tex +++ b/doc/mf6io/ims_table.tex @@ -4,6 +4,7 @@ Nonlinear Variable & default/\texttt{simple} & \texttt{moderate} & \texttt{complex} \\ \hline \texttt{OUTER\_HCLOSE} & 0.001 & 0.01 & 0.1 \\ +\texttt{OUTER\_RCLOSEBND} & 0.1 & 0.1 & 0.1 \\ \texttt{OUTER\_MAXIMUM} & 25 & 50 & 100 \\ \texttt{UNDER\_RELAXATION} & \texttt{NONE} & \texttt{DBD} & \texttt{DBD} \\ \texttt{UNDER\_RELAXATION\_THETA} & 0.0 & 0.9 & 0.8 \\ diff --git a/doc/mf6io/mf6io.bbl b/doc/mf6io/mf6io.bbl index 96443ad589f..301374a24d6 100644 --- a/doc/mf6io/mf6io.bbl +++ b/doc/mf6io/mf6io.bbl @@ -1,4 +1,4 @@ -\begin{thebibliography}{29} +\begin{thebibliography}{26} \providecommand{\natexlab}[1]{#1} \expandafter\ifx\csname urlstyle\endcsname\relax \providecommand{\doi}[1]{doi:\discretionary{}{}{}#1}\else @@ -78,14 +78,6 @@ Hill, M.C., Banta, E.R., Harbaugh, A.W., and Anderman, E.R., 2000, three post-processing programs: {U.S. Geological Survey Open-File Report 00--184, 210 p.} -\bibitem[{Hoffmann and others(2003)Hoffmann, Leake, Galloway, and - Wilson}]{hoffmann2003modflow} -Hoffmann, J{\"o}rn, Leake, S.A., Galloway, D.L., and Wilson, A.M., 2003, - MODFLOW-2000 Ground-Water Model---User Guide to the Subsidence and - Aquifer-System Compaction (SUB) Package: {U.S. Geological Survey Open-File - Report 03--233, 44 p.}, accessed June 27, 2017, at - \url{https://pubs.usgs.gov/of/2003/ofr03-233/}. - \bibitem[{Hsieh and Freckleton(1993)}]{hsieh1993hfb} Hsieh, P.A., and Freckleton, J.R., 1993, Documentation of a computer program to simulate horizontal-flow barriers using the U.S. Geological Survey's modular @@ -123,13 +115,6 @@ Langevin, C.D., Hughes, J.D., Provost, A.M., Banta, E.R., Niswonger, R.G., and Model: {U.S. Geological Survey Techniques and Methods, book 6, chap. A55, 197 p.}, accessed August 4, 2017, at \url{https://doi.org/10.3133/tm6A55}. -\bibitem[{Leake and Galloway(2007)}]{leake2007modflow} -Leake, S.A., and Galloway, D.L., 2007, MODFLOW Ground-water model---User guide - to the Subsidence and Aquifer-System Compaction Package (SUB-WT) for - Water-Table Aquifers: {U.S. Geological Survey Techniques and Methods, book 6, - chap. A23, 42 p.}, accessed June 27, 2017, at - \url{https://pubs.er.usgs.gov/publication/tm6A23}. - \bibitem[{Leake and Lilly(1997)}]{leake1997documentation} Leake, S.A., and Lilly, M.R., 1997, Documentation of computer program (FHB1) for assignment of transient specified-flow and specified-head boundaries in @@ -137,13 +122,6 @@ Leake, S.A., and Lilly, M.R., 1997, Documentation of computer program (FHB1) (MODFLOW): {U.S. Geological Survey Open-File Report 97--571, 50 p.}, accessed June 27, 2017, at \url{https://pubs.er.usgs.gov/publication/ofr97571}. -\bibitem[{Leake and Prudic(1991)}]{leake1991documentation} -Leake, S.A., and Prudic, D.E., 1991, Documentation of a computer program to - simulate aquifer-system compaction using the modular finite-difference - ground-water flow model: {U.S. Geological Survey Techniques of - Water-Resources Investigations, book 6, chap. A2, 68 p.}, accessed June 27, - 2017, at \url{https://pubs.er.usgs.gov/publication/twri06A2}. - \bibitem[{Maddock and others(2012)Maddock, Baird, Hanson, Schmid, and Ajami}]{modflowripetpack} Maddock, Thomas, III, Baird, K.J., Hanson, R.T., Schmid, Wolfgang, and Ajami, diff --git a/doc/mf6io/mf6ivar/dfn/exg-gwfgwf.dfn b/doc/mf6io/mf6ivar/dfn/exg-gwfgwf.dfn index 24036e68cae..8f280b93604 100644 --- a/doc/mf6io/mf6ivar/dfn/exg-gwfgwf.dfn +++ b/doc/mf6io/mf6ivar/dfn/exg-gwfgwf.dfn @@ -7,7 +7,7 @@ shape (naux) reader urword optional true longname keyword to specify aux variables -description an array of auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided. Most auxiliary variables will not be used by the GWF-GWF Exchange, but they will be available for use by other parts of the program. If an auxiliary variable with the name ``ANGLDEGX'' is found, then this information will be used as the angle (provided in degrees) between the connection face normal and the x axis. Additional information on ``ANGLDEGX'' is provided in the description of the DISU Package. If an auxiliary variable with the name ``CDIST'' is found, then this information will be used as the straight-line connection distance between the two cell centers. CDIST is required if specific discharge is calculated for either of the groundwater models. +description an array of auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided. Most auxiliary variables will not be used by the GWF-GWF Exchange, but they will be available for use by other parts of the program. If an auxiliary variable with the name ``ANGLDEGX'' is found, then this information will be used as the angle (provided in degrees) between the connection face normal and the x axis, where a value of zero indicates that a normal vector points directly along the positive x axis. The connection face normal is a normal vector on the cell face shared between the cell in model 1 and the cell in model 2 pointing away from the model 1 cell. Additional information on ``ANGLDEGX'' is provided in the description of the DISU Package. If an auxiliary variable with the name ``CDIST'' is found, then this information will be used as the straight-line connection distance, including the vertical component, between the two cell centers. Both ANGLDEGX and CDIST are required if specific discharge is calculated for either of the groundwater models. block options name print_input diff --git a/doc/mf6io/mf6ivar/dfn/gwf-chd.dfn b/doc/mf6io/mf6ivar/dfn/gwf-chd.dfn index d0a4b55f957..1a432ee3991 100644 --- a/doc/mf6io/mf6ivar/dfn/gwf-chd.dfn +++ b/doc/mf6io/mf6ivar/dfn/gwf-chd.dfn @@ -180,7 +180,7 @@ in_record true reader urword time_series true longname head value assigned to constant head -description is the head at the boundary. +description is the head at the boundary. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. block period name aux diff --git a/doc/mf6io/mf6ivar/dfn/gwf-csub.dfn b/doc/mf6io/mf6ivar/dfn/gwf-csub.dfn new file mode 100644 index 00000000000..d4f126410fa --- /dev/null +++ b/doc/mf6io/mf6ivar/dfn/gwf-csub.dfn @@ -0,0 +1,749 @@ +# --------------------- gwf csub options --------------------- + +block options +name boundnames +type keyword +shape +reader urword +optional true +longname +description REPLACE boundnames {'{#1}': 'CSUB'} + +block options +name print_input +type keyword +reader urword +optional true +longname print input to listing file +description REPLACE print_input {'{#1}': 'CSUB'} + +block options +name save_flows +type keyword +reader urword +optional true +longname keyword to save CSUB flows +description keyword to indicate that cell-by-cell flow terms will be written to the file specified with ``BUDGET SAVE FILE'' in Output Control. + +# csub options +block options +name gammaw +type double precision +reader urword +optional true +longname unit weight of water +description unit weight of water. For freshwater, GAMMAW is 9806.65 Newtons/cubic meters or 62.48 lb/cubic foot in SI and English units, respectively. By default, GAMMAW is 9806.65 Newtons/cubic meters. +default_value 9806.65 + +block options +name beta +type double precision +reader urword +optional true +longname compressibility of water +description compressibility of water. Typical values of BETA are 4.6512e-10 1/Pa or 2.2270e-8 lb/square foot in SI and English units, respectively. By default, BETA is 4.6512e-10 1/Pa. +default_value 4.6512e-10 + +block options +name head_based +type keyword +reader urword +optional true +longname keyword to indicate the head-based formulation will be used +description keyword to indicate the head-based formulation will be used to simulate coarse-grained aquifer materials and no-delay and delay interbeds. Specifying HEAD\_BASED also specifies the INITIAL\_PRECONSOLIDATION\_HEAD option. + +block options +name initial_preconsolidation_head +type keyword +reader urword +optional true +longname keyword to indicate that preconsolidation heads will be specified +description keyword to indicate that preconsolidation heads will be specified for no-delay and delay interbeds in the PACKAGEDATA block. If the SPECIFIED\_INITIAL\_INTERBED\_STATE option is specified in the OPTIONS block, user-specified preconsolidation heads in the PACKAGEDATA block are absolute values. Otherwise, user-specified preconsolidation heads in the PACKAGEDATA block are relative to steady-state or initial heads. + +block options +name ndelaycells +type integer +reader urword +optional true +longname number of interbed cell nodes +description number of nodes used to discretize delay interbeds. If not specified, then a default value of 19 is assigned. + +block options +name compression_indices +type keyword +reader urword +optional true +longname keyword to indicate CR and CC are read instead of SSE and SSV +description keyword to indicate that the recompression (CR) and compression (CC) indices are specified instead of the elastic specific storage (SSE) and inelastic specific storage (SSV) coefficients. If not specified, then elastic specific storage (SSE) and inelastic specific storage (SSV) coefficients must be specified. + +block options +name update_material_properties +type keyword +reader urword +optional true +longname keyword to indicate material properties can change during the simulations +description keyword to indicate that the thickness and void ratio of coarse-grained and interbed sediments (delay and no-delay) will vary during the simulation. If not specified, the thickness and void ratio of coarse-grained and interbed sediments will not vary during the simulation. + +block options +name cell_fraction +type keyword +reader urword +optional true +longname keyword to indicate cell fraction interbed thickness +description keyword to indicate that the thickness of interbeds will be specified in terms of the fraction of cell thickness. If not specified, interbed thicknness must be specified. + +block options +name specified_initial_interbed_state +type keyword +reader urword +optional true +longname keyword to indicate that absolute initial states will be specified +description keyword to indicate that absolute preconsolidation stresses (heads) and delay bed heads will be specified for interbeds defined in the PACKAGEDATA block. The SPECIFIED\_INITIAL\_INTERBED\_STATE option is equivalent to specifying the SPECIFIED\_INITIAL\_PRECONSOLITATION\_STRESS and SPECIFIED\_INITIAL\_DELAY\_HEAD. If SPECIFIED\_INITIAL\_INTERBED\_STATE is not specified then preconsolidation stress (head) and delay bed head values specified in the PACKAGEDATA block are relative to simulated values of the first stress period if steady-state or initial stresses and GWF heads if the first stress period is transient. + +block options +name specified_initial_preconsolidation_stress +type keyword +reader urword +optional true +longname keyword to indicate that absolute initial preconsolidation stresses (head) will be specified +description keyword to indicate that absolute preconsolidation stresses (heads) will be specified for interbeds defined in the PACKAGEDATA block. If SPECIFIED\_INITIAL\_PRECONSOLITATION\_STRESS and SPECIFIED\_INITIAL\_INTERBED\_STATE are not specified then preconsolidation stress (head) values specified in the PACKAGEDATA block are relative to simulated values if the first stress period is steady-state or initial stresses (heads) if the first stress period is transient. + +block options +name specified_initial_delay_head +type keyword +reader urword +optional true +longname keyword to indicate that absolute initial delay bed heads will be specified +description keyword to indicate that absolute initial delay bed head will be specified for interbeds defined in the PACKAGEDATA block. If SPECIFIED\_INITIAL\_DELAY\_HEAD and SPECIFIED\_INITIAL\_INTERBED\_STATE are not specified then delay bed head values specified in the PACKAGEDATA block are relative to simulated values if the first stress period is steady-state or initial GWF heads if the first stress period is transient. + +block options +name effective_stress_lag +type keyword +reader urword +optional true +longname keyword to indicate that specific storage will be calculate using the effective stress from the previous time step +description keyword to indicate the effective stress from the previous time step will be used to calculate specific storage values. This option can 1) help with convergence in models with thin cells and water table elevations close to land surface; 2) is identical to the approach used in the SUBWT package for MODFLOW-2005; and 3) is only used if the effective-stress formulation is being used. By default, current effective stress values are used to calculate specific storage values. + + +# csub csv strain output +block options +name strainib_filerecord +type record strain_csv_interbed fileout interbedstrain_filename +shape +reader urword +tagged true +optional true +longname +description + +block options +name strain_csv_interbed +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname budget keyword +description keyword to specify the record that corresponds to final interbed strain output. + +block options +name fileout +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname file keyword +description keyword to specify that an output filename is expected next. + +block options +name interbedstrain_filename +type string +shape +in_record true +reader urword +tagged false +optional false +longname file keyword +description name of the comma-separated-values output file to write final interbed strain information. + +block options +name straincg_filerecord +type record strain_csv_coarse fileout coarsestrain_filename +shape +reader urword +tagged true +optional true +longname +description + +block options +name strain_csv_coarse +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname budget keyword +description keyword to specify the record that corresponds to final coarse-grained material strain output. + +block options +name coarsestrain_filename +type string +shape +in_record true +reader urword +tagged false +optional false +longname file keyword +description name of the comma-separated-values output file to write final coarse-grained material strain information. + +# binary compaction output +block options +name compaction_filerecord +type record compaction fileout compaction_filename +shape +reader urword +tagged true +optional true +longname +description + +block options +name compaction +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname compaction keyword +description keyword to specify that record corresponds to the compaction. + +block options +name fileout +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname file keyword +description keyword to specify that an output filename is expected next. + +block options +name compaction_filename +type string +shape +in_record true +reader urword +tagged false +optional false +longname file keyword +description name of the binary output file to write compaction information. + +block options +name compaction_elastic_filerecord +type record compaction_elastic fileout elastic_compaction_filename +shape +reader urword +tagged true +optional true +longname +description + +block options +name compaction_elastic +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname elastic interbed compaction keyword +description keyword to specify that record corresponds to the elastic interbed compaction binary file. + +block options +name elastic_compaction_filename +type string +shape +in_record true +reader urword +tagged false +optional false +longname file keyword +description name of the binary output file to write elastic interbed compaction information. + +block options +name compaction_inelastic_filerecord +type record compaction_inelastic fileout inelastic_compaction_filename +shape +reader urword +tagged true +optional true +longname +description + +block options +name compaction_inelastic +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname inelastic interbed compaction keyword +description keyword to specify that record corresponds to the inelastic interbed compaction binary file. + +block options +name inelastic_compaction_filename +type string +shape +in_record true +reader urword +tagged false +optional false +longname file keyword +description name of the binary output file to write inelastic interbed compaction information. + +block options +name compaction_interbed_filerecord +type record compaction_interbed fileout interbed_compaction_filename +shape +reader urword +tagged true +optional true +longname +description + +block options +name compaction_interbed +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname interbed compaction keyword +description keyword to specify that record corresponds to the interbed compaction binary file. + +block options +name interbed_compaction_filename +type string +shape +in_record true +reader urword +tagged false +optional false +longname file keyword +description name of the binary output file to write interbed compaction information. + +block options +name compaction_coarse_filerecord +type record compaction_coarse fileout coarse_compaction_filename +shape +reader urword +tagged true +optional true +longname +description + +block options +name compaction_coarse +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname coarse compaction keyword +description keyword to specify that record corresponds to the elastic coarse-grained material compaction binary file. + +block options +name coarse_compaction_filename +type string +shape +in_record true +reader urword +tagged false +optional false +longname file keyword +description name of the binary output file to write elastic coarse-grained material compaction information. + +block options +name zdisplacement_filerecord +type record zdisplacement fileout zdisplacement_filename +shape +reader urword +tagged true +optional true +longname +description + +block options +name zdisplacement +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname budget keyword +description keyword to specify that record corresponds to the z-displacement binary file. + +block options +name zdisplacement_filename +type string +shape +in_record true +reader urword +tagged false +optional false +longname file keyword +description name of the binary output file to write z-displacement information. + +block options +name package_convergence_filerecord +type record package_convergence fileout package_convergence_filename +shape +reader urword +tagged true +optional true +longname +description + +block options +name package_convergence +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname package_convergence keyword +description keyword to specify that record corresponds to the package convergence comma spaced values file. + +block options +name package_convergence_filename +type string +shape +in_record true +reader urword +tagged false +optional false +longname file keyword +description name of the comma spaced values output file to write package convergence information. + +block options +name ts_filerecord +type record ts6 filein ts6_filename +shape +reader urword +tagged true +optional true +longname +description + +block options +name ts6 +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname head keyword +description keyword to specify that record corresponds to a time-series file. + +block options +name filein +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname file keyword +description keyword to specify that an input filename is expected next. + +block options +name ts6_filename +type string +in_record true +reader urword +optional false +tagged false +longname file name of time series information +description REPLACE timeseriesfile {} + +block options +name obs_filerecord +type record obs6 filein obs6_filename +shape +reader urword +tagged true +optional true +longname +description + +block options +name obs6 +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname obs keyword +description keyword to specify that record corresponds to an observations file. + +block options +name obs6_filename +type string +in_record true +tagged false +reader urword +optional false +longname obs6 input filename +description REPLACE obs6_filename {'{#1}': 'CSUB'} + +# --------------------- gwf csub dimensions --------------------- + +block dimensions +name ninterbeds +type integer +reader urword +optional false +longname number of CSUB interbed systems +description is the number of CSUB interbed systems. More than 1 CSUB interbed systems can be assigned to a GWF cell; however, only 1 GWF cell can be assigned to a single CSUB interbed system. + +block dimensions +name maxsig0 +type integer +reader urword +optional true +longname maximum number of stress offset cells +description is the maximum number of cells that can have a specified stress offset. More than 1 stress offset can be assigned to a GWF cell. By default, MAXSIG0 is 0. + + +# --------------------- gwf csub griddata --------------------- + +block griddata +name cg_ske_cr +type double precision +shape (nodes) +valid +reader readarray +longname elastic coarse specific storage +description is the initial elastic coarse-grained material specific storage or recompression index. The recompression index is specified if COMPRESSION\_INDICES is specified in the OPTIONS block. Specified or calculated elastic coarse-grained material specific storage values are not adjusted from initial values if HEAD\_BASED is specified in the OPTIONS block. +default_value 1e-5 + +block griddata +name cg_theta +type double precision +shape (nodes) +valid +reader readarray +longname initial coarse-grained material porosity +description is the initial porosity of coarse-grained materials. +default_value 0.2 + +block griddata +name sgm +type double precision +shape (nodes) +valid +reader readarray +optional true +longname specific gravity of moist sediments +description is the specific gravity of moist or unsaturated sediments. If not specified, then a default value of 1.7 is assigned. + +block griddata +name sgs +type double precision +shape (nodes) +valid +reader readarray +optional true +longname specific gravity of saturated sediments +description is the specific gravity of saturated sediments. If not specified, then a default value of 2.0 is assigned. + +# --------------------- gwf csub packagedata --------------------- + +block packagedata +name packagedata +type recarray icsubno cellid cdelay pcs0 thick_frac rnb ssv_cc sse_cr theta kv h0 boundname +shape (ninterbeds) +reader urword +longname +description + +block packagedata +name icsubno +type integer +shape +tagged false +in_record true +reader urword +longname CSUB id number for this entry +description integer value that defines the CSUB interbed number associated with the specified PACKAGEDATA data on the line. CSUBNO must be greater than zero and less than or equal to NINTERBEDS. CSUB information must be specified for every CSUB cell or the program will terminate with an error. The program will also terminate with an error if information for a CSUB interbed number is specified more than once. +numeric_index true + +block packagedata +name cellid +type integer +shape (ncelldim) +tagged false +in_record true +reader urword +longname cell identifier +description REPLACE cellid {} + +block packagedata +name cdelay +type string +shape +tagged false +in_record true +reader urword +longname delay type +description character string that defines the subsidence delay type for the interbed. Possible subsidence package CDELAY strings include: NODELAY--character keyword to indicate that delay will not be simulated in the interbed. DELAY--character keyword to indicate that delay will be simulated in the interbed. + +block packagedata +name pcs0 +type double precision +shape +tagged false +in_record true +reader urword +longname initial stress +description is the initial offset from the calculated initial effective stress or initial preconsolidation stress in the interbed, in units of height of a column of water. PCS0 is the initial preconsolidation stress if SPECIFIED\_INITIAL\_INTERBED\_STATE or SPECIFIED\_INITIAL\_PRECONSOLIDATION\_STRESS are specified in the OPTIONS block. If HEAD\_BASED is specified in the OPTIONS block, PCS0 is the initial offset from the calculated initial head or initial preconsolidation head in the CSUB interbed and the initial preconsolidation stress is calculated from the calculated initial effective stress or calculated initial geostatic stress, respectively. + +block packagedata +name thick_frac +type double precision +shape +tagged false +in_record true +reader urword +longname interbed thickness or cell fraction +description is the interbed thickness or cell fraction of the interbed. Interbed thickness is specified as a fraction of the cell thickness if CELL\_FRACTION is specified in the OPTIONS block. + +block packagedata +name rnb +type double precision +shape +tagged false +in_record true +reader urword +longname delay interbed material factor +description is the interbed material factor equivalent number of interbeds in the interbed system represented by the interbed. RNB must be greater than or equal to 1 if CDELAY is DELAY. Otherwise, RNB can be any value. + +block packagedata +name ssv_cc +type double precision +shape +tagged false +in_record true +reader urword +longname initial interbed inelastic specific storage +description is the initial inelastic specific storage or compression index of the interbed. The compression index is specified if COMPRESSION\_INDICES is specified in the OPTIONS block. Specified or calculated interbed inelastic specific storage values are not adjusted from initial values if HEAD\_BASED is specified in the OPTIONS block. + +block packagedata +name sse_cr +type double precision +shape +tagged false +in_record true +reader urword +longname initial interbed elastic specific storage +description is the initial elastic coarse-grained material specific storage or recompression index of the interbed. The recompression index is specified if COMPRESSION\_INDICES is specified in the OPTIONS block. Specified or calculated interbed elastic specific storage values are not adjusted from initial values if HEAD\_BASED is specified in the OPTIONS block. + +block packagedata +name theta +type double precision +shape +tagged false +in_record true +reader urword +longname initial interbed porosity +description is the initial porosity of the interbed. +default_value 0.2 + +block packagedata +name kv +type double precision +shape +tagged false +in_record true +reader urword +longname delay interbed vertical hydraulic conductivity +description is the vertical hydraulic conductivity of the delay interbed. KV must be greater than 0 if CDELAY is DELAY. Otherwise, KV can be any value. + +block packagedata +name h0 +type double precision +shape +tagged false +in_record true +reader urword +longname initial delay interbed head +description is the initial offset from the head in cell cellid or the initial head in the delay interbed. H0 is the initial head in the delay bed if SPECIFIED\_INITIAL\_INTERBED\_STATE or SPECIFIED\_INITIAL\_DELAY\_HEAD are specified in the OPTIONS block. H0 can be any value if CDELAY is NODELAY. + +block packagedata +name boundname +type string +shape +tagged false +in_record true +reader urword +optional true +longname well name +description REPLACE boundname {'{#1}': 'CSUB'} + +# --------------------- gwf csub period --------------------- + +block period +name iper +type integer +block_variable True +in_record true +tagged false +shape +valid +reader urword +optional false +longname stress period number +description REPLACE iper {} + +block period +name stress_period_data +type recarray cellid sig0 +shape (maxsig0) +reader urword +longname +description + +block period +name cellid +type integer +shape (ncelldim) +tagged false +in_record true +reader urword +longname cell identifier +description REPLACE cellid {} + +block period +name sig0 +type double precision +shape +tagged false +in_record true +reader urword +time_series true +longname well stress offset +description is the stress offset for the cell. SIG0 is added to the calculated geostatic stress for the cell. SIG0 is specified only if MAXSIG0 is specified to be greater than 0 in the DIMENSIONS block. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. diff --git a/doc/mf6io/mf6ivar/dfn/gwf-dis.dfn b/doc/mf6io/mf6ivar/dfn/gwf-dis.dfn index d7ca2a675c8..2b71d836c4d 100644 --- a/doc/mf6io/mf6ivar/dfn/gwf-dis.dfn +++ b/doc/mf6io/mf6ivar/dfn/gwf-dis.dfn @@ -78,7 +78,7 @@ type double precision shape (ncol) reader readarray longname spacing along a row -description is the is the column spacing in the row direction. +description is the column spacing in the row direction. default_value 1.0 block griddata @@ -87,7 +87,7 @@ type double precision shape (nrow) reader readarray longname spacing along a column -description is the is the row spacing in the column direction. +description is the row spacing in the column direction. default_value 1.0 block griddata diff --git a/doc/mf6io/mf6ivar/dfn/gwf-disu.dfn b/doc/mf6io/mf6ivar/dfn/gwf-disu.dfn index 9cc7ae47e71..a4e45ceb8ac 100644 --- a/doc/mf6io/mf6ivar/dfn/gwf-disu.dfn +++ b/doc/mf6io/mf6ivar/dfn/gwf-disu.dfn @@ -64,7 +64,7 @@ type integer reader urword optional true longname number of vertices -description is the total number of (x, y) vertex pairs used to define the plan-view shape of each cell in the model grid. If NVERT is not specified or is specified as zero, then the VERTICES and CELL2D blocks below are not read. +description is the total number of (x, y) vertex pairs used to define the plan-view shape of each cell in the model grid. If NVERT is not specified or is specified as zero, then the VERTICES and CELL2D blocks below are not read. NVERT and the accompanying VERTICES and CELL2D blocks should be specified for most simulations. If the XT3D or SAVE\_SPECIFIC\_DISCHARGE options are specified in the NPF Package, then this information is required. # --------------------- gwf disu griddata --------------------- @@ -92,6 +92,15 @@ reader readarray longname cell surface area description is the cell surface area (in plan view). +block griddata +name idomain +type integer +shape (nodes) +reader readarray +layered false +optional true +longname idomain existence array +description is an optional array that characterizes the existence status of a cell. If the IDOMAIN array is not specified, then all model cells exist within the solution. If the IDOMAIN value for a cell is 0, the cell does not exist in the simulation. Input and output values will be read and written for the cell, but internal to the program, the cell is excluded from the solution. If the IDOMAIN value for a cell is 1, the cell exists in the simulation. IDOMAIN values of -1 cannot be specified for the DISU Package. # --------------------- gwf disu connectiondata --------------------- @@ -111,6 +120,7 @@ reader readarray longname grid connectivity description is a list of cell number (n) followed by its connecting cell numbers (m) for each of the m cells connected to cell n. The number of values to provide for cell n is IAC(n). This list is sequentially provided for the first to the last cell. The first value in the list must be cell n itself, and the remaining cells must be listed in an increasing order (sorted from lowest number to highest). Note that the cell and its connections are only supplied for the GWF cells and their connections to the other GWF cells. Also note that the JA list input may be divided such that every node and its connectivity list can be on a separate line for ease in readability of the file. To further ease readability of the file, the node number of the cell whose connectivity is subsequently listed, may be expressed as a negative number, the sign of which is subsequently converted to positive by the code. numeric_index true +jagged_array iac block connectiondata name ihc @@ -119,6 +129,7 @@ shape (nja) reader readarray longname connection type description is an index array indicating the direction between node n and all of its m connections. If IHC = 0 then cell n and cell m are connected in the vertical direction. Cell n overlies cell m if the cell number for n is less than m; cell m overlies cell n if the cell number for m is less than n. If IHC = 1 then cell n and cell m are connected in the horizontal direction. If IHC = 2 then cell n and cell m are connected in the horizontal direction, and the connection is vertically staggered. A vertically staggered connection is one in which a cell is horizontally connected to more than one cell in a horizontal connection. +jagged_array iac block connectiondata name cl12 @@ -127,6 +138,7 @@ shape (nja) reader readarray longname connection lengths description is the array containing connection lengths between the center of cell n and the shared face with each adjacent m cell. +jagged_array iac block connectiondata name hwva @@ -135,6 +147,7 @@ shape (nja) reader readarray longname connection lengths description is a symmetric array of size NJA. For horizontal connections, entries in HWVA are the horizontal width perpendicular to flow. For vertical connections, entries in HWVA are the vertical area for flow. Thus, values in the HWVA array contain dimensions of both length and area. Entries in the HWVA array have a one-to-one correspondence with the connections specified in the JA array. Likewise, there is a one-to-one correspondence between entries in the HWVA array and entries in the IHC array, which specifies the connection type (horizontal or vertical). Entries in the HWVA array must be symmetric; the program will terminate with an error if the value for HWVA for an n to m connection does not equal the value for HWVA for the corresponding n to m connection. +jagged_array iac block connectiondata name angldegx @@ -143,7 +156,8 @@ optional true shape (nja) reader readarray longname angle of face normal to connection -description is the angle (in degrees) between the horizontal x-axis and the outward normal to the face between a cell and its connecting cells (see figure 8 in the MODFLOW-USG documentation). The angle varies between zero and 360.0 degrees. ANGLDEGX is only needed if horizontal anisotropy is specified in the NPF Package or if the XT3D option is used in the NPF Package. ANGLDEGX does not need to be specified if horizontal anisotropy or the XT3D option is not used. ANGLDEGX is of size NJA; values specified for vertical connections and for the diagonal position are not used. Note that ANGLDEGX is read in degrees, which is different from MODFLOW-USG, which reads a similar variable (ANGLEX) in radians. +description is the angle (in degrees) between the horizontal x-axis and the outward normal to the face between a cell and its connecting cells. The angle varies between zero and 360.0 degrees, where zero degrees points in the positive x-axis direction, and 90 degrees points in the positive y-axis direction. ANGLDEGX is only needed if horizontal anisotropy is specified in the NPF Package, if the XT3D option is used in the NPF Package, or if the SAVE\_SPECIFIC\_DISCHARGE option is specifed in the NPF Package. ANGLDEGX does not need to be specified if these conditions are not met. ANGLDEGX is of size NJA; values specified for vertical connections and for the diagonal position are not used. Note that ANGLDEGX is read in degrees, which is different from MODFLOW-USG, which reads a similar variable (ANGLEX) in radians. +jagged_array iac # --------------------- gwf disu vertices --------------------- diff --git a/doc/mf6io/mf6ivar/dfn/gwf-disv.dfn b/doc/mf6io/mf6ivar/dfn/gwf-disv.dfn index 5842d684323..a602a81f508 100644 --- a/doc/mf6io/mf6ivar/dfn/gwf-disv.dfn +++ b/doc/mf6io/mf6ivar/dfn/gwf-disv.dfn @@ -71,7 +71,7 @@ description is the total number of (x, y) vertex pairs used to characterize the block griddata name top type double precision -shape (1, ncpl) +shape (ncpl) reader readarray longname model top elevation description is the top elevation for each cell in the top model layer. diff --git a/doc/mf6io/mf6ivar/dfn/gwf-evt.dfn b/doc/mf6io/mf6ivar/dfn/gwf-evt.dfn index fecad119022..720dd8ed0ae 100644 --- a/doc/mf6io/mf6ivar/dfn/gwf-evt.dfn +++ b/doc/mf6io/mf6ivar/dfn/gwf-evt.dfn @@ -140,8 +140,8 @@ name surf_rate_specified type keyword reader urword optional true -longname specify evapotranspiration rate at ET surface -description indicates that the evapotranspiration rate at the ET surface will be specified as PETM0 in list input. +longname specify proportion of evapotranspiration rate at ET surface +description indicates that the proportion of the evapotranspiration rate at the ET surface will be specified as PETM0 in list input. # --------------------- gwf evt dimensions --------------------- @@ -203,7 +203,7 @@ in_record true reader urword time_series true longname ET surface -description is the elevation of the ET surface ($L$). A time-series name may be specified. +description is the elevation of the ET surface ($L$). If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. block period name rate @@ -214,7 +214,7 @@ in_record true reader urword time_series true longname maximum ET rate -description is the maximum ET flux rate ($LT^{-1}$). A time-series name may be specified. +description is the maximum ET flux rate ($LT^{-1}$). If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. block period name depth @@ -225,7 +225,7 @@ in_record true reader urword time_series true longname ET extinction depth -description is the ET extinction depth ($L$). A time-series name may be specified. +description is the ET extinction depth ($L$). If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. block period name pxdp @@ -236,7 +236,7 @@ in_record true reader urword time_series true longname proportion of ET extinction depth -description is the proportion of the ET extinction depth at the bottom of a segment (dimensionless). A time-series name may be specified. +description is the proportion of the ET extinction depth at the bottom of a segment (dimensionless). If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. block period name petm @@ -247,7 +247,7 @@ in_record true reader urword time_series true longname proportion of maximum ET rate -description is the proportion of the maximum ET flux rate at the bottom of a segment (dimensionless). A time-series name may be specified. +description is the proportion of the maximum ET flux rate at the bottom of a segment (dimensionless). If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. block period name petm0 @@ -259,7 +259,7 @@ reader urword optional true time_series true longname proportion of maximum ET rate at ET surface -description is the proportion of the maximum ET flux rate that will apply when head is at or above the ET surface (dimensionless). PETM0 is read only when the SURF\_RATE\_SPECIFIED option is used. A time-series name may be specified. +description is the proportion of the maximum ET flux rate that will apply when head is at or above the ET surface (dimensionless). PETM0 is read only when the SURF\_RATE\_SPECIFIED option is used. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. block period name aux diff --git a/doc/mf6io/mf6ivar/dfn/gwf-lak.dfn b/doc/mf6io/mf6ivar/dfn/gwf-lak.dfn index db5f68b9bce..209baf110fe 100644 --- a/doc/mf6io/mf6ivar/dfn/gwf-lak.dfn +++ b/doc/mf6io/mf6ivar/dfn/gwf-lak.dfn @@ -127,6 +127,38 @@ optional false longname file keyword description name of the binary output file to write budget information. +block options +name package_convergence_filerecord +type record package_convergence fileout package_convergence_filename +shape +reader urword +tagged true +optional true +longname +description + +block options +name package_convergence +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname package_convergence keyword +description keyword to specify that record corresponds to the package convergence comma spaced values file. + +block options +name package_convergence_filename +type string +shape +in_record true +reader urword +tagged false +optional false +longname file keyword +description name of the comma spaced values output file to write package convergence information. + block options name ts_filerecord type record ts6 filein ts6_filename @@ -333,7 +365,7 @@ description REPLACE boundname {'{#1}': 'lake'} block connectiondata name connectiondata type recarray lakeno iconn cellid claktype bedleak belev telev connlen connwidth -shape (sum(nlakecon)) +shape (sum(nlakeconn)) reader urword longname description @@ -378,7 +410,7 @@ tagged false in_record true reader urword longname lake connection type -description character string that defines the lake-GWF connection type for the lake connection. Possible lake-GWF connection type strings include: VERTICAL--character keyword to indicate the lake-GWF connection is vertical and connection conductance calculations use the hydraulic conductivity corresponding to the $K_{33}$ tensor component defined for CELLID in the NPF package. HORIZONTAL--character keyword to indicate the lake-GWF connection is horizontal and connection conductance calculations use the hydraulic conductivity corresponding to the $K_{11}$ tensor component defined for CELLID in the NPF package. EMBEDDEDH--character keyword to indicate the lake-GWF connection is embedded in a single cell and connection conductance calculations use the hydraulic conductivity corresponding to the $K_{11}$ tensor component defined for CELLID in the NPF package. EMBEDDEDV--character keyword to indicate the lake-GWF connection is embedded in a single cell and connection conductance calculations use the hydraulic conductivity corresponding to the $K_{33}$ tensor component defined for CELLID in the NPF package. Embedded lakes can only be connected to a single cell (NLAKCONN = 1) and there must be a lake table associated with each embedded lake. +description character string that defines the lake-GWF connection type for the lake connection. Possible lake-GWF connection type strings include: VERTICAL--character keyword to indicate the lake-GWF connection is vertical and connection conductance calculations use the hydraulic conductivity corresponding to the $K_{33}$ tensor component defined for CELLID in the NPF package. HORIZONTAL--character keyword to indicate the lake-GWF connection is horizontal and connection conductance calculations use the hydraulic conductivity corresponding to the $K_{11}$ tensor component defined for CELLID in the NPF package. EMBEDDEDH--character keyword to indicate the lake-GWF connection is embedded in a single cell and connection conductance calculations use the hydraulic conductivity corresponding to the $K_{11}$ tensor component defined for CELLID in the NPF package. EMBEDDEDV--character keyword to indicate the lake-GWF connection is embedded in a single cell and connection conductance calculations use the hydraulic conductivity corresponding to the $K_{33}$ tensor component defined for CELLID in the NPF package. Embedded lakes can only be connected to a single cell (NLAKECONN = 1) and there must be a lake table associated with each embedded lake. block connectiondata name bedleak @@ -483,7 +515,7 @@ reader urword optional false tagged false longname table file name -description character string that defines the path and filename for the file containing lake table data for the lake connection. The CTABNAME file includes the number of entries in the file and the relation between stage, surface area, and volume for each entry in the file. Lake table files for EMBEDDEDH and EMBEDDEDV lake-GWF connections also include lake-GWF exchange area data for each entry in the file. Input instructions for the CTABNAME file is included at the LAK package lake table file input instructions section. +description character string that defines the path and filename for the file containing lake table data for the lake connection. The CTABNAME file includes the number of entries in the file and the relation between stage, volume, and surface area for each entry in the file. Lake table files for EMBEDDEDH and EMBEDDEDV lake-GWF connections also include lake-GWF exchange area data for each entry in the file. Input instructions for the CTABNAME file is included at the LAK package lake table file input instructions section. @@ -601,33 +633,33 @@ longname stress period number description REPLACE iper {} block period -name lakeperioddata -type recarray lakeno laksetting +name perioddata +type recarray number laksetting shape reader urword longname description block period -name lakeno +name number type integer shape tagged false in_record true reader urword -longname lake number for this entry -description integer value that defines the lake number associated with the specified PERIOD data on the line. LAKENO must be greater than zero and less than or equal to NLAKES. +longname lake or outlet number for this entry +description integer value that defines the lake or outlet number associated with the specified PERIOD data on the line. NUMBER must be greater than zero and less than or equal to NLAKES for a lake number and less than or equal to NOUTLETS for an outlet number. numeric_index true block period name laksetting -type keystring status stage rainfall evaporation runoff withdrawal auxiliaryrecord +type keystring status stage rainfall evaporation runoff inflow withdrawal rate invert width slope rough auxiliaryrecord shape tagged false in_record true reader urword longname -description line of information that is parsed into a keyword and values. Keyword values that can be used to start the LAKSETTING string include: STATUS, STAGE, RAINFALL, EVAPORATION, RUNOFFON, WITHDRAWAL, and AUXILIARY. +description line of information that is parsed into a keyword and values. Keyword values that can be used to start the LAKSETTING string include both keywords for lake settings and keywords for outlet settings. Keywords for lake settings include: STATUS, STAGE, RAINFALL, EVAPORATION, RUNOFF, INFLOW, WITHDRAWAL, and AUXILIARY. Keywords for outlet settings include RATE, INVERT, WIDTH, SLOPE, and ROUGH. block period name status @@ -684,84 +716,26 @@ longname runoff rate description real or character value that defines the runoff rate $(L^3 T^{-1})$ for the lake. Value must be greater than or equal to zero. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. block period -name withdrawal +name inflow type string shape tagged true in_record true reader urword time_series true -longname maximum withdrawal rate -description real or character value that defines the maximum withdrawal rate $(L^3 T^{-1})$ for the lake. Value must be greater than or equal to zero. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. +longname inflow rate +description real or character value that defines the volumetric inflow rate $(L^3 T^{-1})$ for the lake. Value must be greater than or equal to zero. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. By default, inflow rates are zero for each lake. block period -name auxiliaryrecord -type record auxiliary auxname auxval -shape -tagged -in_record true -reader urword -longname -description - -block period -name auxiliary -type keyword -shape -in_record true -reader urword -longname -description keyword for specifying auxiliary variable. - -block period -name auxname +name withdrawal type string shape -tagged false -in_record true -reader urword -longname -description name for the auxiliary variable to be assigned AUXVAL. AUXNAME must match one of the auxiliary variable names defined in the OPTIONS block. If AUXNAME does not match one of the auxiliary variable names defined in the OPTIONS block the data are ignored. - -block period -name auxval -type double precision -shape -tagged false +tagged true in_record true reader urword time_series true -longname auxiliary variable value -description value for the auxiliary variable. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. - -block period -name outletperioddata -type recarray outletno outletsetting -shape -reader urword -longname -description - -block period -name outletno -type integer -shape -tagged false -in_record true -reader urword -longname outlet number for this entry -description integer value that defines the outlet number associated with the specified PERIOD data on the line. OUTLETNO must be greater than zero and less than or equal to NOUTLETS. -numeric_index true - -block period -name outletsetting -type keystring rate invert width slope rough -shape -tagged false -in_record true -reader urword -longname -description line of information that is parsed into a keyword and values. Keyword values that can be used to start the OUTLETSETTING string include: RATE, INVERT, WIDTH, SLOPE, and ROUGH. +longname maximum withdrawal rate +description real or character value that defines the maximum withdrawal rate $(L^3 T^{-1})$ for the lake. Value must be greater than or equal to zero. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. block period name rate @@ -793,8 +767,8 @@ tagged true in_record true reader urword time_series true -longname outlet width -description real or character value that defines the width of the lake outlet. A specified WIDTH value is only used for active lakes if COUTTYPE for lake outlet OUTLETNO is not SPECIFIED. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. +longname roughness coefficient +description real value that defines the roughness coefficient for the lake outlet. Any value can be specified if COUTTYPE is not MANNING. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. block period name width @@ -817,3 +791,43 @@ reader urword time_series true longname bed slope description real or character value that defines the bed slope for the lake outlet. A specified SLOPE value is only used for active lakes if COUTTYPE for lake outlet OUTLETNO is MANNING. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. + +block period +name auxiliaryrecord +type record auxiliary auxname auxval +shape +tagged +in_record true +reader urword +longname +description + +block period +name auxiliary +type keyword +shape +in_record true +reader urword +longname +description keyword for specifying auxiliary variable. + +block period +name auxname +type string +shape +tagged false +in_record true +reader urword +longname +description name for the auxiliary variable to be assigned AUXVAL. AUXNAME must match one of the auxiliary variable names defined in the OPTIONS block. If AUXNAME does not match one of the auxiliary variable names defined in the OPTIONS block the data are ignored. + +block period +name auxval +type double precision +shape +tagged false +in_record true +reader urword +time_series true +longname auxiliary variable value +description value for the auxiliary variable. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. diff --git a/doc/mf6io/mf6ivar/dfn/gwf-maw.dfn b/doc/mf6io/mf6ivar/dfn/gwf-maw.dfn index 00c3032c875..b83a6dd3f2e 100644 --- a/doc/mf6io/mf6ivar/dfn/gwf-maw.dfn +++ b/doc/mf6io/mf6ivar/dfn/gwf-maw.dfn @@ -314,7 +314,7 @@ tagged false in_record true reader urword longname conductance equation -description character string that defines the conductance equation that is used to calculate the saturated conductance for the multi-aquifer well. Possible multi-aquifer well CONDEQN strings include: SPECIFIED--character keyword to indicate the multi-aquifer well saturated conductance will be specified. THIEM--character keyword to indicate the multi-aquifer well saturated conductance will be calculated using the Thiem equation, which considers the cell top and bottom, aquifer hydraulic conductivity, and effective cell and well radius. SKIN--character keyword to indicate that the multi-aquifer well saturated conductance will be calculated using the cell top and bottom, aquifer and screen hydraulic conductivity, and well and skin radius. CUMULATIVE--character keyword to indicate that the multi-aquifer well saturated conductance will be calculated using a combination of the Thiem and SKIN equations. MEAN--character keyword to indicate the multi-aquifer well saturated conductance will be calculated using the aquifer and screen top and bottom, aquifer and screen hydraulic conductivity, and well and skin radius. +description character string that defines the conductance equation that is used to calculate the saturated conductance for the multi-aquifer well. Possible multi-aquifer well CONDEQN strings include: SPECIFIED--character keyword to indicate the multi-aquifer well saturated conductance will be specified. THIEM--character keyword to indicate the multi-aquifer well saturated conductance will be calculated using the Thiem equation, which considers the cell top and bottom, aquifer hydraulic conductivity, and effective cell and well radius. SKIN--character keyword to indicate that the multi-aquifer well saturated conductance will be calculated using the cell top and bottom, aquifer and screen hydraulic conductivity, and well and skin radius. CUMULATIVE--character keyword to indicate that the multi-aquifer well saturated conductance will be calculated using a combination of the Thiem and SKIN equations. MEAN--character keyword to indicate the multi-aquifer well saturated conductance will be calculated using the aquifer and screen top and bottom, aquifer and screen hydraulic conductivity, and well and skin radius. The CUMULATIVE conductance equation is identical to the SKIN LOSSTYPE in the Multi-Node Well (MNW2) package for MODFLOW-2005. The program will terminate with an error condition if CONDEQN is SKIN or CUMULATIVE and the calculated saturated conductance is less than zero; if an error condition occurs, it is suggested that the THEIM or MEAN conductance equations be used for these multi-aquifer wells. block packagedata name ngwfnodes @@ -419,7 +419,7 @@ tagged false in_record true reader urword longname skin data -description value that defines the skin (filter pack) hydraulic conductivity (if CONDEQN for the multi-aquifer well is SKIN, CUMULATIVE, or MEAN) or conductance (if CONDEQN for the multi-aquifer well is SPECIFIED) for each GWF node connected to the multi-aquifer well (NGWFNODES). HK\_SKIN can be any value if CONDEQN is THIEM. +description value that defines the skin (filter pack) hydraulic conductivity (if CONDEQN for the multi-aquifer well is SKIN, CUMULATIVE, or MEAN) or conductance (if CONDEQN for the multi-aquifer well is SPECIFIED) for each GWF node connected to the multi-aquifer well (NGWFNODES). If CONDEQN is SPECIFIED, HK\_SKIN must be greater than or equal to zero. HK\_SKIN can be any value if CONDEQN is THIEM. Otherwise, HK\_SKIN must be greater than zero. If CONDEQN is SKIN, the contrast between the cell transmissivity (the product of geometric mean horizontal hydraulic conductivity and the cell thickness) and the well transmissivity (the product of HK\_SKIN and the screen thicknesses) must be greater than one in node CELLID or the program will terminate with an error condition; if an error condition occurs, it is suggested that the HK\_SKIN be reduced to a value less than K11 and K22 in node CELLID or the THEIM or MEAN conductance equations be used for these multi-aquifer wells. block connectiondata name radius_skin @@ -565,7 +565,7 @@ tagged true in_record true reader urword longname head limit -description is the limiting water level (head) in the well, which is the minimum of the well RATE or the well inflow rate from the aquifer. HEAD\_LIMIT is only applied to discharging wells (RATE $<$ 0). HEAD\_LIMIT can be deactivated by specifying the text string `OFF'. The HEAD\_LIMIT option is based on the HEAD\_LIMIT functionality available in the MNW2~\citep{konikow2009} package for MODFLOW-2005. The HEAD\_LIMIT option has been included to facilitate backward compatibility with previous versions of MODFLOW but use of the RATE\_SCALING option instead of the HEAD\_LIMIT option is recommended. By default, HEAD\_LIMIT is `OFF'. +description is the limiting water level (head) in the well, which is the minimum of the well RATE or the well inflow rate from the aquifer. HEAD\_LIMIT can be applied to extraction wells (RATE $<$ 0) or injection wells (RATE $>$ 0). HEAD\_LIMIT can be deactivated by specifying the text string `OFF'. The HEAD\_LIMIT option is based on the HEAD\_LIMIT functionality available in the MNW2~\citep{konikow2009} package for MODFLOW-2005. The HEAD\_LIMIT option has been included to facilitate backward compatibility with previous versions of MODFLOW but use of the RATE\_SCALING option instead of the HEAD\_LIMIT option is recommended. By default, HEAD\_LIMIT is `OFF'. block period name shutoffrecord @@ -584,7 +584,7 @@ shape in_record true reader urword longname shut off well -description keyword for activating well shut off capability. Subsequent values define the minimum and maximum pumping rate that a well must exceed to shutoff or reactivate a well, respectively, during a stress period. SHUT\_OFF is only applied to discharging wells (RATE$<0$) and if HEAD\_LIMIT is specified (not set to `OFF'). If HEAD\_LIMIT is specified, SHUT\_OFF can be deactivated by specifying a minimum value equal to zero. The SHUT\_OFF option is based on the SHUT\_OFF functionality available in the MNW2~\citep{konikow2009} package for MODFLOW-2005. The SHUT\_OFF option has been included to facilitate backward compatibility with previous versions of MODFLOW but use of the RATE\_SCALING option instead of the SHUT\_OFF option is recommended. By default, SHUT\_OFF is not used. +description keyword for activating well shut off capability. Subsequent values define the minimum and maximum pumping rate that a well must exceed to shutoff or reactivate a well, respectively, during a stress period. SHUT\_OFF is only applied to injection wells (RATE$<0$) and if HEAD\_LIMIT is specified (not set to `OFF'). If HEAD\_LIMIT is specified, SHUT\_OFF can be deactivated by specifying a minimum value equal to zero. The SHUT\_OFF option is based on the SHUT\_OFF functionality available in the MNW2~\citep{konikow2009} package for MODFLOW-2005. The SHUT\_OFF option has been included to facilitate backward compatibility with previous versions of MODFLOW but use of the RATE\_SCALING option instead of the SHUT\_OFF option is recommended. By default, SHUT\_OFF is not used. block period name minrate @@ -623,7 +623,7 @@ shape in_record true reader urword longname rate scaling -description activate rate scaling. If RATE\_SCALING is specified, both PUMP\_ELEVATION and SCALING\_LENGTH must be specified. RATE\_SCALING cannot be used with HEAD\_LIMIT. +description activate rate scaling. If RATE\_SCALING is specified, both PUMP\_ELEVATION and SCALING\_LENGTH must be specified. RATE\_SCALING cannot be used with HEAD\_LIMIT. RATE\_SCALING can be used for extraction or injection wells. For extraction wells, the extraction rate will start to decrease once the head in the well lowers to a level equal to the pump elevation plus the scaling length. If the head in the well drops below the pump elevation, then the extraction rate is calculated to be zero. For an injection well, the injection rate will begin to decrease once the head in the well rises above the specified pump elevation. If the head in the well rises above the pump elevation plus the scaling length, then the injection rate will be set to zero. block period name pump_elevation @@ -633,7 +633,7 @@ tagged false in_record true reader urword longname pump elevation -description is the elevation of the multi-aquifer well pump (PUMP\_ELEVATION). PUMP\_ELEVATION cannot be less than the bottom elevation (BOTTOM) of the multi-aquifer well. By default, PUMP\_ELEVATION is set equal to the bottom of the largest GWF node number connected to a MAW well. +description is the elevation of the multi-aquifer well pump (PUMP\_ELEVATION). PUMP\_ELEVATION should not be less than the bottom elevation (BOTTOM) of the multi-aquifer well. block period name scaling_length @@ -643,7 +643,7 @@ tagged false in_record true reader urword longname -description height above the pump elevation (SCALING\_LENGTH) below which the pumping rate is reduced. The default value for SCALING\_LENGTH is the well radius. +description height above the pump elevation (SCALING\_LENGTH). If the simulated well head is below this elevation (pump elevation plus the scaling length), then the pumping rate is reduced. block period name auxiliaryrecord diff --git a/doc/mf6io/mf6ivar/dfn/gwf-npf.dfn b/doc/mf6io/mf6ivar/dfn/gwf-npf.dfn index 4df35fcfef8..900a975f2d9 100644 --- a/doc/mf6io/mf6ivar/dfn/gwf-npf.dfn +++ b/doc/mf6io/mf6ivar/dfn/gwf-npf.dfn @@ -6,7 +6,7 @@ type keyword reader urword optional true longname keyword to save NPF flows -description keyword to indicate that cell-by-cell flow terms will be written to the file specified with ``BUDGET SAVE FILE'' in Output Control. +description keyword to indicate that budget flow terms will be written to the file specified with ``BUDGET SAVE FILE'' in Output Control. block options name alternative_cell_averaging @@ -77,7 +77,7 @@ description activates model rewetting. Rewetting is off by default. block options name wetfct -type double +type double precision in_record true reader urword optional false @@ -133,7 +133,31 @@ type keyword reader urword optional true longname keyword to save specific discharge -description keyword to indicate that x, y, and z components of specific discharge will be calculated at cell centers and written to the cell-by-cell flow file, which is specified with ``BUDGET SAVE FILE'' in Output Control. +description keyword to indicate that x, y, and z components of specific discharge will be calculated at cell centers and written to the budget file, which is specified with ``BUDGET SAVE FILE'' in Output Control. If this option is activated, then additional information may be required in the discretization packages and the GWF Exchange package (if GWF models are coupled). Specifically, ANGLDEGX must be specified in the CONNECTIONDATA block of the DISU Package; ANGLDEGX must also be specified for the GWF Exchange as an auxiliary variable. + +block options +name save_saturation +type keyword +reader urword +optional true +longname keyword to save saturation +description keyword to indicate that cell saturation will be written to the budget file, which is specified with ``BUDGET SAVE FILE'' in Output Control. Saturation will be saved to the budget file as an auxiliary variable saved with the DATA-SAT text label. Saturation is a cell variable that ranges from zero to one and can be used by post processing programs to determine how much of a cell volume is saturated. If ICELLTYPE is 0, then saturation is always one. + +block options +name k22overk +type keyword +reader urword +optional true +longname keyword to indicate that specified K22 is a ratio +description keyword to indicate that specified K22 is a ratio of K22 divided by K. If this option is specified, then the K22 array entered in the NPF Package will be multiplied by K after being read. + +block options +name k33overk +type keyword +reader urword +optional true +longname keyword to indicate that specified K33 is a ratio +description keyword to indicate that specified K33 is a ratio of K33 divided by K. If this option is specified, then the K33 array entered in the NPF Package will be multiplied by K after being read. block options name vkd_filerecord @@ -214,7 +238,7 @@ reader readarray layered true optional true longname hydraulic conductivity of second ellipsoid axis -description is the hydraulic conductivity of the second ellipsoid axis; for an unrotated case this is the hydraulic conductivity in the y direction. If K22 is not included in the GRIDDATA block, then K22 is set equal to K. For a regular MODFLOW grid (DIS Package is used) in which no rotation angles are specified, K22 is the hydraulic conductivity along columns in the y direction. For an unstructured DISU grid, the user must assign principal x and y axes and provide the angle for each cell face relative to the assigned x direction. All included cells (IDOMAIN $>$ 0) must have a K22 value greater than zero. +description is the hydraulic conductivity of the second ellipsoid axis (or the ratio of K22/K if the K22OVERK option is specified); for an unrotated case this is the hydraulic conductivity in the y direction. If K22 is not included in the GRIDDATA block, then K22 is set equal to K. For a regular MODFLOW grid (DIS Package is used) in which no rotation angles are specified, K22 is the hydraulic conductivity along columns in the y direction. For an unstructured DISU grid, the user must assign principal x and y axes and provide the angle for each cell face relative to the assigned x direction. All included cells (IDOMAIN $>$ 0) must have a K22 value greater than zero. block griddata name k33 @@ -225,7 +249,7 @@ reader readarray layered true optional true longname hydraulic conductivity of third ellipsoid axis (L/T) -description is the hydraulic conductivity of the third ellipsoid axis; for an unrotated case, this is the vertical hydraulic conductivity. When anisotropy is applied, K33 corresponds to the K33 tensor component. All included cells (IDOMAIN $>$ 0) must have a K33 value greater than zero. +description is the hydraulic conductivity of the third ellipsoid axis (or the ratio of K33/K if the K33OVERK option is specified); for an unrotated case, this is the vertical hydraulic conductivity. When anisotropy is applied, K33 corresponds to the K33 tensor component. All included cells (IDOMAIN $>$ 0) must have a K33 value greater than zero. block griddata name angle1 diff --git a/doc/mf6io/mf6ivar/dfn/gwf-rch.dfn b/doc/mf6io/mf6ivar/dfn/gwf-rch.dfn index 957041bb1a2..19fd93e2a54 100644 --- a/doc/mf6io/mf6ivar/dfn/gwf-rch.dfn +++ b/doc/mf6io/mf6ivar/dfn/gwf-rch.dfn @@ -188,7 +188,7 @@ in_record true reader urword time_series true longname recharge rate -description is the recharge flux rate ($LT^{-1}$). This rate is multiplied inside the program by the surface area of the cell to calculate the volumetric recharge rate. A time-series name may be specified. +description is the recharge flux rate ($LT^{-1}$). This rate is multiplied inside the program by the surface area of the cell to calculate the volumetric recharge rate. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. block period name aux diff --git a/doc/mf6io/mf6ivar/dfn/gwf-sfr.dfn b/doc/mf6io/mf6ivar/dfn/gwf-sfr.dfn index 1b6d9767395..ad0adea71bb 100644 --- a/doc/mf6io/mf6ivar/dfn/gwf-sfr.dfn +++ b/doc/mf6io/mf6ivar/dfn/gwf-sfr.dfn @@ -127,6 +127,38 @@ optional false longname file keyword description name of the binary output file to write budget information. +block options +name package_convergence_filerecord +type record package_convergence fileout package_convergence_filename +shape +reader urword +tagged true +optional true +longname +description + +block options +name package_convergence +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname package_convergence keyword +description keyword to specify that record corresponds to the package convergence comma spaced values file. + +block options +name package_convergence_filename +type string +shape +in_record true +reader urword +tagged false +optional false +longname file keyword +description name of the comma spaced values output file to write package convergence information. + block options name ts_filerecord type record ts6 filein ts6_filename @@ -213,11 +245,11 @@ description REPLACE mover {'{#1}': 'SFR'} block options name maximum_iterations -type double precision +type integer reader urword optional true longname SFR Newton-Raphson iterations -description value that defines an maximum number of Streamflow Routing Newton-Raphson iterations allowed for a reach. By default, MAXSFRIT is equal to 100. +description value that defines the maximum number of Streamflow Routing Newton-Raphson iterations allowed for a reach. By default, MAXSFRIT is equal to 100. block options name maximum_depth_change @@ -487,7 +519,7 @@ tagged false in_record true reader urword longname iprior code -description character string value that defines the the prioritization system for the diversion, such as when insufficient water is available to meet all diversion stipulations, and is used in conjunction with the value of FLOW value specified in the STRESS\_PERIOD\_DATA section. Available diversion options include: (1) CPRIOR = `FRACTION', then the amount of the diversion is computed as a fraction of the streamflow leaving reach RNO ($Q_{DS}$); in this case, 0.0 $\le$ DIVFLOW $\le$ 1.0. (2) CPRIOR = `EXCESS', a diversion is made only if $Q_{DS}$ for reach RNO exceeds the value of DIVFLOW. If this occurs, then the quantity of water diverted is the excess flow ($Q_{DS} -$ DIVFLOW) and $Q_{DS}$ from reach RNO is set equal to DIVFLOW. This represents a flood-control type of diversion, as described by Danskin and Hanson (2002). (3) CPRIOR = `THRESHOLD', then if $Q_{DS}$ in reach RNO is less than the specified diversion flow (DIVFLOW), no water is diverted from reach RNO. If $Q_{DS}$ in reach RNO is greater than or equal to (DIVFLOW), (DIVFLOW) is diverted and $Q_{DS}$ is set to the remainder ($Q_{DS} -$ DIVFLOW)). This approach assumes that once flow in the stream is sufficiently low, diversions from the stream cease, and is the `priority' algorithm that originally was programmed into the STR1 Package (Prudic, 1989). (4) CPRIOR = `UPTO' -- if $Q_{DS}$ in reach RNO is greater than or equal to the specified diversion flow (DIVFLOW), $Q_{DS}$ is reduced by DIVFLOW. If $Q_{DS}$ in reach RNO is less than (DIVFLOW), DIVFLOW is set to $Q_{DS}$ and there will be no flow available for reaches connected to downstream end of reach RNO. +description character string value that defines the the prioritization system for the diversion, such as when insufficient water is available to meet all diversion stipulations, and is used in conjunction with the value of FLOW value specified in the STRESS\_PERIOD\_DATA section. Available diversion options include: (1) CPRIOR = `FRACTION', then the amount of the diversion is computed as a fraction of the streamflow leaving reach RNO ($Q_{DS}$); in this case, 0.0 $\le$ DIVFLOW $\le$ 1.0. (2) CPRIOR = `EXCESS', a diversion is made only if $Q_{DS}$ for reach RNO exceeds the value of DIVFLOW. If this occurs, then the quantity of water diverted is the excess flow ($Q_{DS} -$ DIVFLOW) and $Q_{DS}$ from reach RNO is set equal to DIVFLOW. This represents a flood-control type of diversion, as described by Danskin and Hanson (2002). (3) CPRIOR = `THRESHOLD', then if $Q_{DS}$ in reach RNO is less than the specified diversion flow (DIVFLOW), no water is diverted from reach RNO. If $Q_{DS}$ in reach RNO is greater than or equal to (DIVFLOW), (DIVFLOW) is diverted and $Q_{DS}$ is set to the remainder ($Q_{DS} -$ DIVFLOW)). This approach assumes that once flow in the stream is sufficiently low, diversions from the stream cease, and is the `priority' algorithm that originally was programmed into the STR1 Package (Prudic, 1989). (4) CPRIOR = `UPTO' -- if $Q_{DS}$ in reach RNO is greater than or equal to the specified diversion flow (DIVFLOW), $Q_{DS}$ is reduced by DIVFLOW. If $Q_{DS}$ in reach RNO is less than (DIVFLOW), DIVFLOW is set to $Q_{DS}$ and there will be no flow available for reaches connected to downstream end of reach RNO. # --------------------- gwf sfr period --------------------- @@ -542,7 +574,7 @@ tagged true in_record true reader urword longname well status -description keyword option to define stream reach status. STATUS can be ACTIVE, INACTIVE, or SIMPLE. The SIMPLE STATUS option simulates streamflow using a user-specified stage for a reach or a stage set to the top of the reach (depth = 0). In cases where the simulated leakage calculated using the specified stage exceeds the sum of inflows to the reach, the stage is set to the top of the reach and leakage is set equal to the sum of inflows. Upstream factions should be changed using the UPSTREAM\_FRACTION SFRSETTING if the status for one or more reaches is changed to ACTIVE or INACTIVE. For example, if one of two downstream connections for a reach is inactivated, the upstream fraction for the active and inactive downstream reach should be changed to 1.0 and 0.0, respectively, to ensure that the active reach receives all of the downstream outflow from the upstream reach. By default, STATUS is ACTIVE. +description keyword option to define stream reach status. STATUS can be ACTIVE, INACTIVE, or SIMPLE. The SIMPLE STATUS option simulates streamflow using a user-specified stage for a reach or a stage set to the top of the reach (depth = 0). In cases where the simulated leakage calculated using the specified stage exceeds the sum of inflows to the reach, the stage is set to the top of the reach and leakage is set equal to the sum of inflows. Upstream fractions should be changed using the UPSTREAM\_FRACTION SFRSETTING if the status for one or more reaches is changed to ACTIVE or INACTIVE. For example, if one of two downstream connections for a reach is inactivated, the upstream fraction for the active and inactive downstream reach should be changed to 1.0 and 0.0, respectively, to ensure that the active reach receives all of the downstream outflow from the upstream reach. By default, STATUS is ACTIVE. block period name manning @@ -612,7 +644,7 @@ description real or character value that defines the volumetric rate of diffuse block period name diversionrecord -type record diversion idv divrate +type record diversion idv divflow shape tagged in_record true @@ -641,14 +673,14 @@ description diversion number. numeric_index true block period -name divrate +name divflow type double precision shape tagged false in_record true reader urword time_series true -longname volumetric diversion rate +longname volumetric diversion flow rate description real or character value that defines the volumetric diversion (DIVFLOW) rate for the streamflow routing reach. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. block period diff --git a/doc/mf6io/mf6ivar/dfn/gwf-sto.dfn b/doc/mf6io/mf6ivar/dfn/gwf-sto.dfn index 6e74dfa1735..6239b02d736 100644 --- a/doc/mf6io/mf6ivar/dfn/gwf-sto.dfn +++ b/doc/mf6io/mf6ivar/dfn/gwf-sto.dfn @@ -39,7 +39,7 @@ reader readarray layered true optional false longname specific storage -description is specific storage (or the storage coefficient if STORAGECOEFFICIENT is specified as an option). Specific storage values must be greater than or equal to 0. +description is specific storage (or the storage coefficient if STORAGECOEFFICIENT is specified as an option). Specific storage values must be greater than or equal to 0. If the CSUB Package is included in the GWF model, specific storage must be zero for every cell. default_value 1.e-5 block griddata @@ -78,7 +78,7 @@ valid reader urword optional true longname steady state indicator -description keyword to indicate that stress-period IPER is steady-state. Steady-state conditions will apply until the TRANSIENT keyword is specified in a subsequent BEGIN PERIOD block. +description keyword to indicate that stress period IPER is steady-state. Steady-state conditions will apply until the TRANSIENT keyword is specified in a subsequent BEGIN PERIOD block. If the CSUB Package is included in the GWF model, only the first and last stress period can be steady-state. block period name transient @@ -88,5 +88,5 @@ valid reader urword optional true longname transient indicator -description keyword to indicate that stress-period IPER is transient. Transient conditions will apply until the STEADY-STATE keyword is specified in a subsequent BEGIN PERIOD block. +description keyword to indicate that stress period IPER is transient. Transient conditions will apply until the STEADY-STATE keyword is specified in a subsequent BEGIN PERIOD block. diff --git a/doc/mf6io/mf6ivar/dfn/gwf-uzf.dfn b/doc/mf6io/mf6ivar/dfn/gwf-uzf.dfn index e0dea5bdfad..d62f058f722 100644 --- a/doc/mf6io/mf6ivar/dfn/gwf-uzf.dfn +++ b/doc/mf6io/mf6ivar/dfn/gwf-uzf.dfn @@ -95,6 +95,38 @@ optional false longname file keyword description name of the binary output file to write budget information. +block options +name package_convergence_filerecord +type record package_convergence fileout package_convergence_filename +shape +reader urword +tagged true +optional true +longname +description + +block options +name package_convergence +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname package_convergence keyword +description keyword to specify that record corresponds to the package convergence comma spaced values file. + +block options +name package_convergence_filename +type string +shape +in_record true +reader urword +tagged false +optional false +longname file keyword +description name of the comma spaced values output file to write package convergence information. + block options name ts_filerecord type record ts6 filein ts6_filename @@ -186,7 +218,7 @@ tagged true reader urword optional true longname -description keyword specifying that ET in the unsaturated (UZF) and saturated zones (GWF) will be simulated. ET can be simulated in the UZF cell and not the GWF cell by emitting keywords LINEAR\_GWET and SQUARE\_GWET. +description keyword specifying that ET in the unsaturated (UZF) and saturated zones (GWF) will be simulated. ET can be simulated in the UZF cell and not the GWF cell by omitting keywords LINEAR\_GWET and SQUARE\_GWET. block options name linear_gwet @@ -242,7 +274,7 @@ type integer reader urword optional false longname number of UZF cells -description is the number of UZF cells. More than 1 UZF cell can be assigned to a GWF cell; however, only 1 GWF cell can be assigned to a single UZF cell. If the MULTILAYER option is used then UZF cells can be assigned to GWF cells below (in deeper layers than) the upper most active GWF cells. +description is the number of UZF cells. More than one UZF cell can be assigned to a GWF cell; however, only one GWF cell can be assigned to a single UZF cell. If more than one UZF cell is assigned to a GWF cell, then an auxiliary variable should be used to reduce the surface area of the UZF cell with the AUXMULTNAME option. block dimensions name ntrailwaves @@ -250,7 +282,7 @@ type integer reader urword optional false longname number of trailing waves -description is the number of trailing waves. NTRAILWAVES has a default value of 7 and can be increased to lower mass balance error in the unsaturated zone. +description is the number of trailing waves. A recommended value of 7 can be used for NTRAILWAVES. This value can be increased to lower mass balance error in the unsaturated zone. block dimensions name nwavesets @@ -258,7 +290,7 @@ type integer reader urword optional false longname number of wave sets -description is the number of UZF cells specified. NWAVSETS has a default value of 40 and can be increased if more waves are required to resolve variations in water content within the unsaturated zone. +description is the number of wave sets. A recommended value of 40 can be used for NWAVESETS. This value can be increased if more waves are required to resolve variations in water content within the unsaturated zone. # --------------------- gwf uzf packagedata --------------------- @@ -310,7 +342,7 @@ tagged false in_record true reader urword longname vertical connection flag -description integer value set to specify underlying UZF cell that receives water flowing to bottom of cell. If unsaturated zone flow reaches water table before the cell bottom then water is added to GWF cell instead of flowing to underlying UZF cell. A value of 0 indicates the UZF cell is not connected to an underlying UZF cell. +description integer value set to specify underlying UZF cell that receives water flowing to bottom of cell. If unsaturated zone flow reaches the water table before the cell bottom, then water is added to the GWF cell instead of flowing to the underlying UZF cell. A value of 0 indicates the UZF cell is not connected to an underlying UZF cell. numeric_index true block packagedata diff --git a/doc/mf6io/mf6ivar/dfn/sim-nam.dfn b/doc/mf6io/mf6ivar/dfn/sim-nam.dfn index f20a8bf1698..ac9be58e7bb 100644 --- a/doc/mf6io/mf6ivar/dfn/sim-nam.dfn +++ b/doc/mf6io/mf6ivar/dfn/sim-nam.dfn @@ -24,6 +24,13 @@ optional true longname memory print option description is a flag that controls printing of detailed memory manager usage to the end of the simulation list file. NONE means do not print detailed information. SUMMARY means print only the total memory for each simulation component. ALL means print information for each variable stored in the memory manager. NONE is default if MEMORY\_PRINT\_OPTION is not specified. +block options +name maxerrors +type integer +reader urword +optional true +longname maximum number of errors +description maximum number of errors that will be stored and printed. # --------------------- sim nam timing --------------------- @@ -156,7 +163,7 @@ description is the list of solution types and models in the solution. block solutiongroup name slntype type string -valid_values ims6 +valid ims6 in_record true tagged false reader urword diff --git a/doc/mf6io/mf6ivar/dfn/sln-ims.dfn b/doc/mf6io/mf6ivar/dfn/sln-ims.dfn index fea4af2fd8e..b903c08e24c 100644 --- a/doc/mf6io/mf6ivar/dfn/sln-ims.dfn +++ b/doc/mf6io/mf6ivar/dfn/sln-ims.dfn @@ -60,6 +60,34 @@ optional false longname file keyword description name of the ascii comma separated values output file to write solver convergence information. If PRINT\_OPTION is NONE or SUMMARY, comma separated values output includes maximum head change convergence information at the end of each outer iteration for each time step. If PRINT\_OPTION is ALL, comma separated values output includes maximum head change and maximum residual convergence information for the solution and each model (if the solution includes more than one model) and linear acceleration information for each inner iteration. +block options +name no_ptcrecord +type record no_ptc no_ptc_option +reader urword +optional true +longname no_ptc record +description + +block options +name no_ptc +type keyword +in_record true +reader urword +optional false +tagged true +longname no pseudo-transient continuation +description is a flag that is used to disable pseudo-transient continuation (PTC). Option only applies to steady-state stress periods for models using the Newton-Raphson formulation. For many problems, PTC can significantly improve convergence behavior for steady-state simulations, and for this reason it is active by default. In some cases, however, PTC can worsen the convergence behavior, especially when the initial conditions are similar to the solution. When the initial conditions are similar to, or exactly the same as, the solution and convergence is slow, then the NO\_PTC FIRST option should be used to deactivate PTC for the first stress period. The NO\_PTC ALL option should also be used in order to compare convergence behavior with other MODFLOW versions, as PTC is only available in MODFLOW 6. + +block options +name no_ptc_option +type string +in_record true +reader urword +optional true +tagged false +longname no pseudo-transient continuation option +description is an optional keyword that is used to define options for disabling pseudo-transient continuation (PTC). FIRST is an optional keyword to disable PTC for the first stress period, if steady-state and one or more model is using the Newton-Raphson formulation. ALL is an optional keyword to disable PTC for all steady-state stress periods for models using the Newton-Raphson formulation. If NO\_PTC\_OPTION is not specified, the NO\_PTC ALL option is used. + # --------------------- sln ims nonlinear --------------------- @@ -190,7 +218,7 @@ description real value that defines the flow residual tolerance for convergence block linear name rclose_option -type string +type string tagged false in_record true reader urword diff --git a/doc/mf6io/mf6ivar/dfn/utl-lak-tab.dfn b/doc/mf6io/mf6ivar/dfn/utl-lak-tab.dfn index b7e26ae1178..a771ea0509c 100644 --- a/doc/mf6io/mf6ivar/dfn/utl-lak-tab.dfn +++ b/doc/mf6io/mf6ivar/dfn/utl-lak-tab.dfn @@ -14,7 +14,7 @@ type integer reader urword optional false longname number of table columns -description integer value specifying the number of colums in the lake table. There must be NCOL columns of data in the TABLE block. For lakes with HORIZONTAL and/or VERTICAL CTYPE connections, NCOL must be equal to 3. For lakes with EMBEDDEDH or EMBEDDEDV CTYPE connections, NCOL must be equal to 4. +description integer value specifying the number of columns in the lake table. There must be NCOL columns of data in the TABLE block. For lakes with HORIZONTAL and/or VERTICAL CTYPE connections, NCOL must be equal to 3. For lakes with EMBEDDEDH or EMBEDDEDV CTYPE connections, NCOL must be equal to 4. # --------------------- gwf laktab table --------------------- diff --git a/doc/mf6io/mf6ivar/dfn/utl-obs.dfn b/doc/mf6io/mf6ivar/dfn/utl-obs.dfn index cde7c7a6696..d7c27845ac0 100644 --- a/doc/mf6io/mf6ivar/dfn/utl-obs.dfn +++ b/doc/mf6io/mf6ivar/dfn/utl-obs.dfn @@ -1,14 +1,5 @@ # --------------------- gwf obs options --------------------- -block options -name precision -type double precision -shape -reader urword -optional true -longname -description Keyword and precision specifier for output of binary data, which can be either SINGLE or DOUBLE. The default is DOUBLE. When simulated values are written to a file specified as file type DATA(BINARY) in the Name File, the precision specifier controls whether the data (including simulated values and, for continuous observations, time values) are written as single- or double-precision. - block options name digits type integer @@ -33,7 +24,7 @@ name output type record fileout obs_output_file_name binary shape block_variable true -in_record = false +in_record false reader urword optional false longname 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 $0 means saturated thickness varies with computed head when head is below the cell top; $<$0 means saturated thickness varies with computed head unless the THICKSTRT option is in effect. When THICKSTRT is in effect, a negative value of icelltype indicates that saturated thickness will be computed as STRT-BOT and held constant. | | GWF | NPF | GRIDDATA | K | DOUBLE PRECISION (NODES) | is the hydraulic conductivity. For the common case in which the user would like to specify the horizontal hydraulic conductivity and the vertical hydraulic conductivity, then K should be assigned as the horizontal hydraulic conductivity, K33 should be assigned as the vertical hydraulic conductivity, and texttt{K22} and the three rotation angles should not be specified. When more sophisticated anisotropy is required, then K corresponds to the K11 hydraulic conductivity axis. All included cells (IDOMAIN $>$ 0) must have a K value greater than zero. | -| GWF | NPF | GRIDDATA | K22 | DOUBLE PRECISION (NODES) | is the hydraulic conductivity of the second ellipsoid axis; for an unrotated case this is the hydraulic conductivity in the y direction. If K22 is not included in the GRIDDATA block, then K22 is set equal to K. For a regular MODFLOW grid (DIS Package is used) in which no rotation angles are specified, K22 is the hydraulic conductivity along columns in the y direction. For an unstructured DISU grid, the user must assign principal x and y axes and provide the angle for each cell face relative to the assigned x direction. All included cells (IDOMAIN $>$ 0) must have a K22 value greater than zero. | -| GWF | NPF | GRIDDATA | K33 | DOUBLE PRECISION (NODES) | is the hydraulic conductivity of the third ellipsoid axis; for an unrotated case, this is the vertical hydraulic conductivity. When anisotropy is applied, K33 corresponds to the K33 tensor component. All included cells (IDOMAIN $>$ 0) must have a K33 value greater than zero. | +| GWF | NPF | GRIDDATA | K22 | DOUBLE PRECISION (NODES) | is the hydraulic conductivity of the second ellipsoid axis (or the ratio of K22/K if the K22OVERK option is specified); for an unrotated case this is the hydraulic conductivity in the y direction. If K22 is not included in the GRIDDATA block, then K22 is set equal to K. For a regular MODFLOW grid (DIS Package is used) in which no rotation angles are specified, K22 is the hydraulic conductivity along columns in the y direction. For an unstructured DISU grid, the user must assign principal x and y axes and provide the angle for each cell face relative to the assigned x direction. All included cells (IDOMAIN $>$ 0) must have a K22 value greater than zero. | +| GWF | NPF | GRIDDATA | K33 | DOUBLE PRECISION (NODES) | is the hydraulic conductivity of the third ellipsoid axis (or the ratio of K33/K if the K33OVERK option is specified); for an unrotated case, this is the vertical hydraulic conductivity. When anisotropy is applied, K33 corresponds to the K33 tensor component. All included cells (IDOMAIN $>$ 0) must have a K33 value greater than zero. | | GWF | NPF | GRIDDATA | ANGLE1 | DOUBLE PRECISION (NODES) | is a rotation angle of the hydraulic conductivity tensor in degrees. The angle represents the first of three sequential rotations of the hydraulic conductivity ellipsoid. With the K11, K22, and K33 axes of the ellipsoid initially aligned with the x, y, and z coordinate axes, respectively, ANGLE1 rotates the ellipsoid about its K33 axis (within the x - y plane). A positive value represents counter-clockwise rotation when viewed from any point on the positive K33 axis, looking toward the center of the ellipsoid. A value of zero indicates that the K11 axis lies within the x - z plane. If ANGLE1 is not specified, default values of zero are assigned to ANGLE1, ANGLE2, and ANGLE3, in which case the K11, K22, and K33 axes are aligned with the x, y, and z axes, respectively. | | GWF | NPF | GRIDDATA | ANGLE2 | DOUBLE PRECISION (NODES) | is a rotation angle of the hydraulic conductivity tensor in degrees. The angle represents the second of three sequential rotations of the hydraulic conductivity ellipsoid. Following the rotation by ANGLE1 described above, ANGLE2 rotates the ellipsoid about its K22 axis (out of the x - y plane). An array can be specified for ANGLE2 only if ANGLE1 is also specified. A positive value of ANGLE2 represents clockwise rotation when viewed from any point on the positive K22 axis, looking toward the center of the ellipsoid. A value of zero indicates that the K11 axis lies within the x - y plane. If ANGLE2 is not specified, default values of zero are assigned to ANGLE2 and ANGLE3; connections that are not user-designated as vertical are assumed to be strictly horizontal (that is, to have no z component to their orientation); and connection lengths are based on horizontal distances. | | GWF | NPF | GRIDDATA | ANGLE3 | DOUBLE PRECISION (NODES) | is a rotation angle of the hydraulic conductivity tensor in degrees. The angle represents the third of three sequential rotations of the hydraulic conductivity ellipsoid. Following the rotations by ANGLE1 and ANGLE2 described above, ANGLE3 rotates the ellipsoid about its K11 axis. An array can be specified for ANGLE3 only if ANGLE1 and ANGLE2 are also specified. An array must be specified for ANGLE3 if ANGLE2 is specified. A positive value of ANGLE3 represents clockwise rotation when viewed from any point on the positive K11 axis, looking toward the center of the ellipsoid. A value of zero indicates that the K22 axis lies within the x - y plane. | @@ -174,11 +181,71 @@ | GWF | STO | OPTIONS | SAVE_FLOWS | KEYWORD | keyword to indicate that cell-by-cell flow terms will be written to the file specified with ``BUDGET SAVE FILE'' in Output Control. | | GWF | STO | OPTIONS | STORAGECOEFFICIENT | KEYWORD | keyword to indicate that the SS array is read as storage coefficient rather than specific storage. | | GWF | STO | GRIDDATA | ICONVERT | INTEGER (NODES) | is a flag for each cell that specifies whether or not a cell is convertible for the storage calculation. 0 indicates confined storage is used. $>$0 indicates confined storage is used when head is above cell top and a mixed formulation of unconfined and confined storage is used when head is below cell top. | -| GWF | STO | GRIDDATA | SS | DOUBLE PRECISION (NODES) | is specific storage (or the storage coefficient if STORAGECOEFFICIENT is specified as an option). Specific storage values must be greater than or equal to 0. | +| GWF | STO | GRIDDATA | SS | DOUBLE PRECISION (NODES) | is specific storage (or the storage coefficient if STORAGECOEFFICIENT is specified as an option). Specific storage values must be greater than or equal to 0. If the CSUB Package is included in the GWF model, specific storage must be zero for every cell. | | GWF | STO | GRIDDATA | SY | DOUBLE PRECISION (NODES) | is specific yield. Specific yield values must be greater than or equal to 0. Specific yield does not have to be specified if there are no convertible cells (ICONVERT=0 in every cell). | | GWF | STO | PERIOD | IPER | INTEGER | integer value specifying the starting stress period number for which the data specified in the PERIOD block apply. IPER must be less than or equal to NPER in the TDIS Package and greater than zero. The IPER value assigned to a stress period block must be greater than the IPER value assigned for the previous PERIOD block. The information specified in the PERIOD block will continue to apply for all subsequent stress periods, unless the program encounters another PERIOD block. | -| GWF | STO | PERIOD | STEADY-STATE | KEYWORD | keyword to indicate that stress-period IPER is steady-state. Steady-state conditions will apply until the TRANSIENT keyword is specified in a subsequent BEGIN PERIOD block. | -| GWF | STO | PERIOD | TRANSIENT | KEYWORD | keyword to indicate that stress-period IPER is transient. Transient conditions will apply until the STEADY-STATE keyword is specified in a subsequent BEGIN PERIOD block. | +| GWF | STO | PERIOD | STEADY-STATE | KEYWORD | keyword to indicate that stress period IPER is steady-state. Steady-state conditions will apply until the TRANSIENT keyword is specified in a subsequent BEGIN PERIOD block. If the CSUB Package is included in the GWF model, only the first and last stress period can be steady-state. | +| GWF | STO | PERIOD | TRANSIENT | KEYWORD | keyword to indicate that stress period IPER is transient. Transient conditions will apply until the STEADY-STATE keyword is specified in a subsequent BEGIN PERIOD block. | +| GWF | CSUB | OPTIONS | BOUNDNAMES | KEYWORD | keyword to indicate that boundary names may be provided with the list of CSUB cells. | +| GWF | CSUB | OPTIONS | PRINT_INPUT | KEYWORD | keyword to indicate that the list of CSUB information will be written to the listing file immediately after it is read. | +| GWF | CSUB | OPTIONS | SAVE_FLOWS | KEYWORD | keyword to indicate that cell-by-cell flow terms will be written to the file specified with ``BUDGET SAVE FILE'' in Output Control. | +| GWF | CSUB | OPTIONS | GAMMAW | DOUBLE PRECISION | unit weight of water. For freshwater, GAMMAW is 9806.65 Newtons/cubic meters or 62.48 lb/cubic foot in SI and English units, respectively. By default, GAMMAW is 9806.65 Newtons/cubic meters. | +| GWF | CSUB | OPTIONS | BETA | DOUBLE PRECISION | compressibility of water. Typical values of BETA are 4.6512e-10 1/Pa or 2.2270e-8 lb/square foot in SI and English units, respectively. By default, BETA is 4.6512e-10 1/Pa. | +| GWF | CSUB | OPTIONS | HEAD_BASED | KEYWORD | keyword to indicate the head-based formulation will be used to simulate coarse-grained aquifer materials and no-delay and delay interbeds. Specifying HEAD\_BASED also specifies the INITIAL\_PRECONSOLIDATION\_HEAD option. | +| GWF | CSUB | OPTIONS | INITIAL_PRECONSOLIDATION_HEAD | KEYWORD | keyword to indicate that preconsolidation heads will be specified for no-delay and delay interbeds in the PACKAGEDATA block. If the SPECIFIED\_INITIAL\_INTERBED\_STATE option is specified in the OPTIONS block, user-specified preconsolidation heads in the PACKAGEDATA block are absolute values. Otherwise, user-specified preconsolidation heads in the PACKAGEDATA block are relative to steady-state or initial heads. | +| GWF | CSUB | OPTIONS | NDELAYCELLS | INTEGER | number of nodes used to discretize delay interbeds. If not specified, then a default value of 19 is assigned. | +| GWF | CSUB | OPTIONS | COMPRESSION_INDICES | KEYWORD | keyword to indicate that the recompression (CR) and compression (CC) indices are specified instead of the elastic specific storage (SSE) and inelastic specific storage (SSV) coefficients. If not specified, then elastic specific storage (SSE) and inelastic specific storage (SSV) coefficients must be specified. | +| GWF | CSUB | OPTIONS | UPDATE_MATERIAL_PROPERTIES | KEYWORD | keyword to indicate that the thickness and void ratio of coarse-grained and interbed sediments (delay and no-delay) will vary during the simulation. If not specified, the thickness and void ratio of coarse-grained and interbed sediments will not vary during the simulation. | +| GWF | CSUB | OPTIONS | CELL_FRACTION | KEYWORD | keyword to indicate that the thickness of interbeds will be specified in terms of the fraction of cell thickness. If not specified, interbed thicknness must be specified. | +| GWF | CSUB | OPTIONS | SPECIFIED_INITIAL_INTERBED_STATE | KEYWORD | keyword to indicate that absolute preconsolidation stresses (heads) and delay bed heads will be specified for interbeds defined in the PACKAGEDATA block. The SPECIFIED\_INITIAL\_INTERBED\_STATE option is equivalent to specifying the SPECIFIED\_INITIAL\_PRECONSOLITATION\_STRESS and SPECIFIED\_INITIAL\_DELAY\_HEAD. If SPECIFIED\_INITIAL\_INTERBED\_STATE is not specified then preconsolidation stress (head) and delay bed head values specified in the PACKAGEDATA block are relative to simulated values of the first stress period if steady-state or initial stresses and GWF heads if the first stress period is transient. | +| GWF | CSUB | OPTIONS | SPECIFIED_INITIAL_PRECONSOLIDATION_STRESS | KEYWORD | keyword to indicate that absolute preconsolidation stresses (heads) will be specified for interbeds defined in the PACKAGEDATA block. If SPECIFIED\_INITIAL\_PRECONSOLITATION\_STRESS and SPECIFIED\_INITIAL\_INTERBED\_STATE are not specified then preconsolidation stress (head) values specified in the PACKAGEDATA block are relative to simulated values if the first stress period is steady-state or initial stresses (heads) if the first stress period is transient. | +| GWF | CSUB | OPTIONS | SPECIFIED_INITIAL_DELAY_HEAD | KEYWORD | keyword to indicate that absolute initial delay bed head will be specified for interbeds defined in the PACKAGEDATA block. If SPECIFIED\_INITIAL\_DELAY\_HEAD and SPECIFIED\_INITIAL\_INTERBED\_STATE are not specified then delay bed head values specified in the PACKAGEDATA block are relative to simulated values if the first stress period is steady-state or initial GWF heads if the first stress period is transient. | +| GWF | CSUB | OPTIONS | EFFECTIVE_STRESS_LAG | KEYWORD | keyword to indicate the effective stress from the previous time step will be used to calculate specific storage values. This option can 1) help with convergence in models with thin cells and water table elevations close to land surface; 2) is identical to the approach used in the SUBWT package for MODFLOW-2005; and 3) is only used if the effective-stress formulation is being used. By default, current effective stress values are used to calculate specific storage values. | +| GWF | CSUB | OPTIONS | STRAIN_CSV_INTERBED | KEYWORD | keyword to specify the record that corresponds to final interbed strain output. | +| GWF | CSUB | OPTIONS | FILEOUT | KEYWORD | keyword to specify that an output filename is expected next. | +| GWF | CSUB | OPTIONS | INTERBEDSTRAIN_FILENAME | STRING | name of the comma-separated-values output file to write final interbed strain information. | +| GWF | CSUB | OPTIONS | STRAIN_CSV_COARSE | KEYWORD | keyword to specify the record that corresponds to final coarse-grained material strain output. | +| GWF | CSUB | OPTIONS | COARSESTRAIN_FILENAME | STRING | name of the comma-separated-values output file to write final coarse-grained material strain information. | +| GWF | CSUB | OPTIONS | COMPACTION | KEYWORD | keyword to specify that record corresponds to the compaction. | +| GWF | CSUB | OPTIONS | COMPACTION_FILENAME | STRING | name of the binary output file to write compaction information. | +| GWF | CSUB | OPTIONS | COMPACTION_ELASTIC | KEYWORD | keyword to specify that record corresponds to the elastic interbed compaction binary file. | +| GWF | CSUB | OPTIONS | ELASTIC_COMPACTION_FILENAME | STRING | name of the binary output file to write elastic interbed compaction information. | +| GWF | CSUB | OPTIONS | COMPACTION_INELASTIC | KEYWORD | keyword to specify that record corresponds to the inelastic interbed compaction binary file. | +| GWF | CSUB | OPTIONS | INELASTIC_COMPACTION_FILENAME | STRING | name of the binary output file to write inelastic interbed compaction information. | +| GWF | CSUB | OPTIONS | COMPACTION_INTERBED | KEYWORD | keyword to specify that record corresponds to the interbed compaction binary file. | +| GWF | CSUB | OPTIONS | INTERBED_COMPACTION_FILENAME | STRING | name of the binary output file to write interbed compaction information. | +| GWF | CSUB | OPTIONS | COMPACTION_COARSE | KEYWORD | keyword to specify that record corresponds to the elastic coarse-grained material compaction binary file. | +| GWF | CSUB | OPTIONS | COARSE_COMPACTION_FILENAME | STRING | name of the binary output file to write elastic coarse-grained material compaction information. | +| GWF | CSUB | OPTIONS | ZDISPLACEMENT | KEYWORD | keyword to specify that record corresponds to the z-displacement binary file. | +| GWF | CSUB | OPTIONS | ZDISPLACEMENT_FILENAME | STRING | name of the binary output file to write z-displacement information. | +| GWF | CSUB | OPTIONS | PACKAGE_CONVERGENCE | KEYWORD | keyword to specify that record corresponds to the package convergence comma spaced values file. | +| GWF | CSUB | OPTIONS | PACKAGE_CONVERGENCE_FILENAME | STRING | name of the comma spaced values output file to write package convergence information. | +| GWF | CSUB | OPTIONS | TS6 | KEYWORD | keyword to specify that record corresponds to a time-series file. | +| GWF | CSUB | OPTIONS | FILEIN | KEYWORD | keyword to specify that an input filename is expected next. | +| GWF | CSUB | OPTIONS | TS6_FILENAME | STRING | defines a time-series file defining time series that can be used to assign time-varying values. See the ``Time-Variable Input'' section for instructions on using the time-series capability. | +| GWF | CSUB | OPTIONS | OBS6 | KEYWORD | keyword to specify that record corresponds to an observations file. | +| GWF | CSUB | OPTIONS | OBS6_FILENAME | STRING | name of input file to define observations for the CSUB package. See the ``Observation utility'' section for instructions for preparing observation input files. Table \ref{table:obstype} lists observation type(s) supported by the CSUB package. | +| GWF | CSUB | DIMENSIONS | NINTERBEDS | INTEGER | is the number of CSUB interbed systems. More than 1 CSUB interbed systems can be assigned to a GWF cell; however, only 1 GWF cell can be assigned to a single CSUB interbed system. | +| GWF | CSUB | DIMENSIONS | MAXSIG0 | INTEGER | is the maximum number of cells that can have a specified stress offset. More than 1 stress offset can be assigned to a GWF cell. By default, MAXSIG0 is 0. | +| GWF | CSUB | GRIDDATA | CG_SKE_CR | DOUBLE PRECISION (NODES) | is the initial elastic coarse-grained material specific storage or recompression index. The recompression index is specified if COMPRESSION\_INDICES is specified in the OPTIONS block. Specified or calculated elastic coarse-grained material specific storage values are not adjusted from initial values if HEAD\_BASED is specified in the OPTIONS block. | +| GWF | CSUB | GRIDDATA | CG_THETA | DOUBLE PRECISION (NODES) | is the initial porosity of coarse-grained materials. | +| GWF | CSUB | GRIDDATA | SGM | DOUBLE PRECISION (NODES) | is the specific gravity of moist or unsaturated sediments. If not specified, then a default value of 1.7 is assigned. | +| GWF | CSUB | GRIDDATA | SGS | DOUBLE PRECISION (NODES) | is the specific gravity of saturated sediments. If not specified, then a default value of 2.0 is assigned. | +| GWF | CSUB | PACKAGEDATA | ICSUBNO | INTEGER | integer value that defines the CSUB interbed number associated with the specified PACKAGEDATA data on the line. CSUBNO must be greater than zero and less than or equal to NINTERBEDS. CSUB information must be specified for every CSUB cell or the program will terminate with an error. The program will also terminate with an error if information for a CSUB interbed number is specified more than once. | +| GWF | CSUB | PACKAGEDATA | CELLID | INTEGER (NCELLDIM) | is the cell identifier, and depends on the type of grid that is used for the simulation. For a structured grid that uses the DIS input file, CELLID is the layer, row, and column. For a grid that uses the DISV input file, CELLID is the layer and CELL2D number. If the model uses the unstructured discretization (DISU) input file, CELLID is the node number for the cell. | +| GWF | CSUB | PACKAGEDATA | CDELAY | STRING | character string that defines the subsidence delay type for the interbed. Possible subsidence package CDELAY strings include: NODELAY--character keyword to indicate that delay will not be simulated in the interbed. DELAY--character keyword to indicate that delay will be simulated in the interbed. | +| GWF | CSUB | PACKAGEDATA | PCS0 | DOUBLE PRECISION | is the initial offset from the calculated initial effective stress or initial preconsolidation stress in the interbed, in units of height of a column of water. PCS0 is the initial preconsolidation stress if SPECIFIED\_INITIAL\_INTERBED\_STATE or SPECIFIED\_INITIAL\_PRECONSOLIDATION\_STRESS are specified in the OPTIONS block. If HEAD\_BASED is specified in the OPTIONS block, PCS0 is the initial offset from the calculated initial head or initial preconsolidation head in the CSUB interbed and the initial preconsolidation stress is calculated from the calculated initial effective stress or calculated initial geostatic stress, respectively. | +| GWF | CSUB | PACKAGEDATA | THICK_FRAC | DOUBLE PRECISION | is the interbed thickness or cell fraction of the interbed. Interbed thickness is specified as a fraction of the cell thickness if CELL\_FRACTION is specified in the OPTIONS block. | +| GWF | CSUB | PACKAGEDATA | RNB | DOUBLE PRECISION | is the interbed material factor equivalent number of interbeds in the interbed system represented by the interbed. RNB must be greater than or equal to 1 if CDELAY is DELAY. Otherwise, RNB can be any value. | +| GWF | CSUB | PACKAGEDATA | SSV_CC | DOUBLE PRECISION | is the initial inelastic specific storage or compression index of the interbed. The compression index is specified if COMPRESSION\_INDICES is specified in the OPTIONS block. Specified or calculated interbed inelastic specific storage values are not adjusted from initial values if HEAD\_BASED is specified in the OPTIONS block. | +| GWF | CSUB | PACKAGEDATA | SSE_CR | DOUBLE PRECISION | is the initial elastic coarse-grained material specific storage or recompression index of the interbed. The recompression index is specified if COMPRESSION\_INDICES is specified in the OPTIONS block. Specified or calculated interbed elastic specific storage values are not adjusted from initial values if HEAD\_BASED is specified in the OPTIONS block. | +| GWF | CSUB | PACKAGEDATA | THETA | DOUBLE PRECISION | is the initial porosity of the interbed. | +| GWF | CSUB | PACKAGEDATA | KV | DOUBLE PRECISION | is the vertical hydraulic conductivity of the delay interbed. KV must be greater than 0 if CDELAY is DELAY. Otherwise, KV can be any value. | +| GWF | CSUB | PACKAGEDATA | H0 | DOUBLE PRECISION | is the initial offset from the head in cell cellid or the initial head in the delay interbed. H0 is the initial head in the delay bed if SPECIFIED\_INITIAL\_INTERBED\_STATE or SPECIFIED\_INITIAL\_DELAY\_HEAD are specified in the OPTIONS block. H0 can be any value if CDELAY is NODELAY. | +| GWF | CSUB | PACKAGEDATA | BOUNDNAME | STRING | name of the CSUB cell. BOUNDNAME is an ASCII character variable that can contain as many as 40 characters. If BOUNDNAME contains spaces in it, then the entire name must be enclosed within single quotes. | +| GWF | CSUB | PERIOD | IPER | INTEGER | integer value specifying the starting stress period number for which the data specified in the PERIOD block apply. IPER must be less than or equal to NPER in the TDIS Package and greater than zero. The IPER value assigned to a stress period block must be greater than the IPER value assigned for the previous PERIOD block. The information specified in the PERIOD block will continue to apply for all subsequent stress periods, unless the program encounters another PERIOD block. | +| GWF | CSUB | PERIOD | CELLID | INTEGER (NCELLDIM) | is the cell identifier, and depends on the type of grid that is used for the simulation. For a structured grid that uses the DIS input file, CELLID is the layer, row, and column. For a grid that uses the DISV input file, CELLID is the layer and CELL2D number. If the model uses the unstructured discretization (DISU) input file, CELLID is the node number for the cell. | +| GWF | CSUB | PERIOD | SIG0 | DOUBLE PRECISION | is the stress offset for the cell. SIG0 is added to the calculated geostatic stress for the cell. SIG0 is specified only if MAXSIG0 is specified to be greater than 0 in the DIMENSIONS block. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWF | HFB | OPTIONS | PRINT_INPUT | KEYWORD | keyword to indicate that the list of horizontal flow barriers will be written to the listing file immediately after it is read. | | GWF | HFB | DIMENSIONS | MAXHFB | INTEGER | integer value specifying the maximum number of horizontal flow barriers that will be entered in this input file. The value of MAXHFB is used to allocate memory for the horizontal flow barriers. | | GWF | HFB | PERIOD | IPER | INTEGER | integer value specifying the starting stress period number for which the data specified in the PERIOD block apply. IPER must be less than or equal to NPER in the TDIS Package and greater than zero. The IPER value assigned to a stress period block must be greater than the IPER value assigned for the previous PERIOD block. The information specified in the PERIOD block will continue to apply for all subsequent stress periods, unless the program encounters another PERIOD block. | @@ -199,7 +266,7 @@ | GWF | CHD | DIMENSIONS | MAXBOUND | INTEGER | integer value specifying the maximum number of constant-head cells that will be specified for use during any stress period. | | GWF | CHD | PERIOD | IPER | INTEGER | integer value specifying the starting stress period number for which the data specified in the PERIOD block apply. IPER must be less than or equal to NPER in the TDIS Package and greater than zero. The IPER value assigned to a stress period block must be greater than the IPER value assigned for the previous PERIOD block. The information specified in the PERIOD block will continue to apply for all subsequent stress periods, unless the program encounters another PERIOD block. | | GWF | CHD | PERIOD | CELLID | INTEGER (NCELLDIM) | is the cell identifier, and depends on the type of grid that is used for the simulation. For a structured grid that uses the DIS input file, CELLID is the layer, row, and column. For a grid that uses the DISV input file, CELLID is the layer and CELL2D number. If the model uses the unstructured discretization (DISU) input file, CELLID is the node number for the cell. | -| GWF | CHD | PERIOD | HEAD | DOUBLE PRECISION | is the head at the boundary. | +| GWF | CHD | PERIOD | HEAD | DOUBLE PRECISION | is the head at the boundary. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWF | CHD | PERIOD | AUX | DOUBLE PRECISION (NAUX) | represents the values of the auxiliary variables for each constant head. The values of auxiliary variables must be present for each constant head. The values must be specified in the order of the auxiliary variables specified in the OPTIONS block. If the package supports time series and the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWF | CHD | PERIOD | BOUNDNAME | STRING | name of the constant head boundary cell. BOUNDNAME is an ASCII character variable that can contain as many as 40 characters. If BOUNDNAME contains spaces in it, then the entire name must be enclosed within single quotes. | | GWF | WEL | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | @@ -294,7 +361,7 @@ | GWF | RCH | DIMENSIONS | MAXBOUND | INTEGER | integer value specifying the maximum number of recharge cells cells that will be specified for use during any stress period. | | GWF | RCH | PERIOD | IPER | INTEGER | integer value specifying the starting stress period number for which the data specified in the PERIOD block apply. IPER must be less than or equal to NPER in the TDIS Package and greater than zero. The IPER value assigned to a stress period block must be greater than the IPER value assigned for the previous PERIOD block. The information specified in the PERIOD block will continue to apply for all subsequent stress periods, unless the program encounters another PERIOD block. | | GWF | RCH | PERIOD | CELLID | INTEGER (NCELLDIM) | is the cell identifier, and depends on the type of grid that is used for the simulation. For a structured grid that uses the DIS input file, CELLID is the layer, row, and column. For a grid that uses the DISV input file, CELLID is the layer and CELL2D number. If the model uses the unstructured discretization (DISU) input file, CELLID is the node number for the cell. | -| GWF | RCH | PERIOD | RECHARGE | DOUBLE PRECISION | is the recharge flux rate ($LT^{-1}$). This rate is multiplied inside the program by the surface area of the cell to calculate the volumetric recharge rate. A time-series name may be specified. | +| GWF | RCH | PERIOD | RECHARGE | DOUBLE PRECISION | is the recharge flux rate ($LT^{-1}$). This rate is multiplied inside the program by the surface area of the cell to calculate the volumetric recharge rate. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWF | RCH | PERIOD | AUX | DOUBLE PRECISION (NAUX) | represents the values of the auxiliary variables for each recharge. The values of auxiliary variables must be present for each recharge. The values must be specified in the order of the auxiliary variables specified in the OPTIONS block. If the package supports time series and the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWF | RCH | PERIOD | BOUNDNAME | STRING | name of the recharge cell. BOUNDNAME is an ASCII character variable that can contain as many as 40 characters. If BOUNDNAME contains spaces in it, then the entire name must be enclosed within single quotes. | | GWF | RCHA | OPTIONS | READASARRAYS | KEYWORD | indicates that array-based input will be used for the Recharge Package. This keyword must be specified to use array-based input. | @@ -325,17 +392,17 @@ | GWF | EVT | OPTIONS | TS6_FILENAME | STRING | defines a time-series file defining time series that can be used to assign time-varying values. See the ``Time-Variable Input'' section for instructions on using the time-series capability. | | GWF | EVT | OPTIONS | OBS6 | KEYWORD | keyword to specify that record corresponds to an observations file. | | GWF | EVT | OPTIONS | OBS6_FILENAME | STRING | name of input file to define observations for the Evapotranspiration package. See the ``Observation utility'' section for instructions for preparing observation input files. Table \ref{table:obstype} lists observation type(s) supported by the Evapotranspiration package. | -| GWF | EVT | OPTIONS | SURF_RATE_SPECIFIED | KEYWORD | indicates that the evapotranspiration rate at the ET surface will be specified as PETM0 in list input. | +| GWF | EVT | OPTIONS | SURF_RATE_SPECIFIED | KEYWORD | indicates that the proportion of the evapotranspiration rate at the ET surface will be specified as PETM0 in list input. | | GWF | EVT | DIMENSIONS | MAXBOUND | INTEGER | integer value specifying the maximum number of evapotranspiration cells cells that will be specified for use during any stress period. | | GWF | EVT | DIMENSIONS | NSEG | INTEGER | number of ET segments. Default is one. When NSEG is greater than 1, PXDP and PETM arrays must be specified NSEG - 1 times each, in order from the uppermost segment down. PXDP defines the extinction-depth proportion at the bottom of a segment. PETM defines the proportion of the maximum ET flux rate at the bottom of a segment. | | GWF | EVT | PERIOD | IPER | INTEGER | integer value specifying the starting stress period number for which the data specified in the PERIOD block apply. IPER must be less than or equal to NPER in the TDIS Package and greater than zero. The IPER value assigned to a stress period block must be greater than the IPER value assigned for the previous PERIOD block. The information specified in the PERIOD block will continue to apply for all subsequent stress periods, unless the program encounters another PERIOD block. | | GWF | EVT | PERIOD | CELLID | INTEGER (NCELLDIM) | is the cell identifier, and depends on the type of grid that is used for the simulation. For a structured grid that uses the DIS input file, CELLID is the layer, row, and column. For a grid that uses the DISV input file, CELLID is the layer and CELL2D number. If the model uses the unstructured discretization (DISU) input file, CELLID is the node number for the cell. | -| GWF | EVT | PERIOD | SURFACE | DOUBLE PRECISION | is the elevation of the ET surface ($L$). A time-series name may be specified. | -| GWF | EVT | PERIOD | RATE | DOUBLE PRECISION | is the maximum ET flux rate ($LT^{-1}$). A time-series name may be specified. | -| GWF | EVT | PERIOD | DEPTH | DOUBLE PRECISION | is the ET extinction depth ($L$). A time-series name may be specified. | -| GWF | EVT | PERIOD | PXDP | DOUBLE PRECISION (NSEG-1) | is the proportion of the ET extinction depth at the bottom of a segment (dimensionless). A time-series name may be specified. | -| GWF | EVT | PERIOD | PETM | DOUBLE PRECISION (NSEG-1) | is the proportion of the maximum ET flux rate at the bottom of a segment (dimensionless). A time-series name may be specified. | -| GWF | EVT | PERIOD | PETM0 | DOUBLE PRECISION | is the proportion of the maximum ET flux rate that will apply when head is at or above the ET surface (dimensionless). PETM0 is read only when the SURF\_RATE\_SPECIFIED option is used. A time-series name may be specified. | +| GWF | EVT | PERIOD | SURFACE | DOUBLE PRECISION | is the elevation of the ET surface ($L$). If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | +| GWF | EVT | PERIOD | RATE | DOUBLE PRECISION | is the maximum ET flux rate ($LT^{-1}$). If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | +| GWF | EVT | PERIOD | DEPTH | DOUBLE PRECISION | is the ET extinction depth ($L$). If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | +| GWF | EVT | PERIOD | PXDP | DOUBLE PRECISION (NSEG-1) | is the proportion of the ET extinction depth at the bottom of a segment (dimensionless). If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | +| GWF | EVT | PERIOD | PETM | DOUBLE PRECISION (NSEG-1) | is the proportion of the maximum ET flux rate at the bottom of a segment (dimensionless). If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | +| GWF | EVT | PERIOD | PETM0 | DOUBLE PRECISION | is the proportion of the maximum ET flux rate that will apply when head is at or above the ET surface (dimensionless). PETM0 is read only when the SURF\_RATE\_SPECIFIED option is used. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWF | EVT | PERIOD | AUX | DOUBLE PRECISION (NAUX) | represents the values of the auxiliary variables for each evapotranspiration. The values of auxiliary variables must be present for each evapotranspiration. The values must be specified in the order of the auxiliary variables specified in the OPTIONS block. If the package supports time series and the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWF | EVT | PERIOD | BOUNDNAME | STRING | name of the evapotranspiration cell. BOUNDNAME is an ASCII character variable that can contain as many as 40 characters. If BOUNDNAME contains spaces in it, then the entire name must be enclosed within single quotes. | | GWF | EVTA | OPTIONS | READASARRAYS | KEYWORD | indicates that array-based input will be used for the Evapotranspiration Package. This keyword must be specified to use array-based input. | @@ -382,7 +449,7 @@ | GWF | MAW | PACKAGEDATA | RADIUS | DOUBLE PRECISION | radius for the multi-aquifer well. | | GWF | MAW | PACKAGEDATA | BOTTOM | DOUBLE PRECISION | bottom elevation of the multi-aquifer well. The well bottom is reset to the cell bottom in the lowermost GWF cell connection in cases where the specified well bottom is above the bottom of this GWF cell. | | GWF | MAW | PACKAGEDATA | STRT | DOUBLE PRECISION | starting head for the multi-aquifer well. | -| GWF | MAW | PACKAGEDATA | CONDEQN | STRING | character string that defines the conductance equation that is used to calculate the saturated conductance for the multi-aquifer well. Possible multi-aquifer well CONDEQN strings include: SPECIFIED--character keyword to indicate the multi-aquifer well saturated conductance will be specified. THIEM--character keyword to indicate the multi-aquifer well saturated conductance will be calculated using the Thiem equation, which considers the cell top and bottom, aquifer hydraulic conductivity, and effective cell and well radius. SKIN--character keyword to indicate that the multi-aquifer well saturated conductance will be calculated using the cell top and bottom, aquifer and screen hydraulic conductivity, and well and skin radius. CUMULATIVE--character keyword to indicate that the multi-aquifer well saturated conductance will be calculated using a combination of the Thiem and SKIN equations. MEAN--character keyword to indicate the multi-aquifer well saturated conductance will be calculated using the aquifer and screen top and bottom, aquifer and screen hydraulic conductivity, and well and skin radius. | +| GWF | MAW | PACKAGEDATA | CONDEQN | STRING | character string that defines the conductance equation that is used to calculate the saturated conductance for the multi-aquifer well. Possible multi-aquifer well CONDEQN strings include: SPECIFIED--character keyword to indicate the multi-aquifer well saturated conductance will be specified. THIEM--character keyword to indicate the multi-aquifer well saturated conductance will be calculated using the Thiem equation, which considers the cell top and bottom, aquifer hydraulic conductivity, and effective cell and well radius. SKIN--character keyword to indicate that the multi-aquifer well saturated conductance will be calculated using the cell top and bottom, aquifer and screen hydraulic conductivity, and well and skin radius. CUMULATIVE--character keyword to indicate that the multi-aquifer well saturated conductance will be calculated using a combination of the Thiem and SKIN equations. MEAN--character keyword to indicate the multi-aquifer well saturated conductance will be calculated using the aquifer and screen top and bottom, aquifer and screen hydraulic conductivity, and well and skin radius. The CUMULATIVE conductance equation is identical to the SKIN LOSSTYPE in the Multi-Node Well (MNW2) package for MODFLOW-2005. The program will terminate with an error condition if CONDEQN is SKIN or CUMULATIVE and the calculated saturated conductance is less than zero; if an error condition occurs, it is suggested that the THEIM or MEAN conductance equations be used for these multi-aquifer wells. | | GWF | MAW | PACKAGEDATA | NGWFNODES | INTEGER | integer value that defines the number of GWF nodes connected to this (WELLNO) multi-aquifer well. NGWFNODES must be greater than zero. | | GWF | MAW | PACKAGEDATA | AUX | DOUBLE PRECISION (NAUX) | represents the values of the auxiliary variables for each multi-aquifer well. The values of auxiliary variables must be present for each multi-aquifer well. The values must be specified in the order of the auxiliary variables specified in the OPTIONS block. If the package supports time series and the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWF | MAW | PACKAGEDATA | BOUNDNAME | STRING | name of the multi-aquifer well cell. BOUNDNAME is an ASCII character variable that can contain as many as 40 characters. If BOUNDNAME contains spaces in it, then the entire name must be enclosed within single quotes. | @@ -391,7 +458,7 @@ | GWF | MAW | CONNECTIONDATA | CELLID | INTEGER (NCELLDIM) | is the cell identifier, and depends on the type of grid that is used for the simulation. For a structured grid that uses the DIS input file, CELLID is the layer, row, and column. For a grid that uses the DISV input file, CELLID is the layer and CELL2D number. If the model uses the unstructured discretization (DISU) input file, CELLID is the node number for the cell. One or more screened intervals can be connected to the same CELLID if CONDEQN for a well is MEAN. The program will terminate with an error if MAW wells using SPECIFIED, THIEM, SKIN, or CUMULATIVE conductance equations have more than one connection to the same CELLID. | | GWF | MAW | CONNECTIONDATA | SCRN_TOP | DOUBLE PRECISION | value that defines the top elevation of the screen for the multi-aquifer well connection. If the specified SCRN\_TOP is greater than the top of the GWF cell it is set equal to the top of the cell. SCRN\_TOP can be any value if CONDEQN is SPECIFIED, THIEM, SKIN, or COMPOSITE and SCRN\_TOP is set to the top of the cell. | | GWF | MAW | CONNECTIONDATA | SCRN_BOT | DOUBLE PRECISION | value that defines the bottom elevation of the screen for the multi-aquifer well connection. If the specified SCRN\_BOT is less than the bottom of the GWF cell it is set equal to the bottom of the cell. SCRN\_BOT can be any value if CONDEQN is SPECIFIED, THIEM, SKIN, or COMPOSITE and SCRN\_BOT is set to the bottom of the cell. | -| GWF | MAW | CONNECTIONDATA | HK_SKIN | DOUBLE PRECISION | value that defines the skin (filter pack) hydraulic conductivity (if CONDEQN for the multi-aquifer well is SKIN, CUMULATIVE, or MEAN) or conductance (if CONDEQN for the multi-aquifer well is SPECIFIED) for each GWF node connected to the multi-aquifer well (NGWFNODES). HK\_SKIN can be any value if CONDEQN is THIEM. | +| GWF | MAW | CONNECTIONDATA | HK_SKIN | DOUBLE PRECISION | value that defines the skin (filter pack) hydraulic conductivity (if CONDEQN for the multi-aquifer well is SKIN, CUMULATIVE, or MEAN) or conductance (if CONDEQN for the multi-aquifer well is SPECIFIED) for each GWF node connected to the multi-aquifer well (NGWFNODES). If CONDEQN is SPECIFIED, HK\_SKIN must be greater than or equal to zero. HK\_SKIN can be any value if CONDEQN is THIEM. Otherwise, HK\_SKIN must be greater than zero. If CONDEQN is SKIN, the contrast between the cell transmissivity (the product of geometric mean horizontal hydraulic conductivity and the cell thickness) and the well transmissivity (the product of HK\_SKIN and the screen thicknesses) must be greater than one in node CELLID or the program will terminate with an error condition; if an error condition occurs, it is suggested that the HK\_SKIN be reduced to a value less than K11 and K22 in node CELLID or the THEIM or MEAN conductance equations be used for these multi-aquifer wells. | | GWF | MAW | CONNECTIONDATA | RADIUS_SKIN | DOUBLE PRECISION | real value that defines the skin radius (filter pack radius) for the multi-aquifer well. RADIUS\_SKIN can be any value if CONDEQN is SPECIFIED or THIEM. Otherwise, RADIUS\_SKIN must be greater than RADIUS for the multi-aquifer well. | | GWF | MAW | PERIOD | IPER | INTEGER | integer value specifying the starting stress period number for which the data specified in the PERIOD block apply. IPER must be less than or equal to NPER in the TDIS Package and greater than zero. The IPER value assigned to a stress period block must be greater than the IPER value assigned for the previous PERIOD block. The information specified in the PERIOD block will continue to apply for all subsequent stress periods, unless the program encounters another PERIOD block. | | GWF | MAW | PERIOD | WELLNO | INTEGER | integer value that defines the well number associated with the specified PERIOD data on the line. WELLNO must be greater than zero and less than or equal to NMAWWELLS. | @@ -403,13 +470,13 @@ | GWF | MAW | PERIOD | FWRLEN | DOUBLE PRECISION | length used to reduce the conductance of the flowing well. When the head in the well drops below the well top plus the reduction length, then the conductance is reduced. This reduction length can be used to improve the stability of simulations with flowing wells so that there is not an abrupt change in flowing well rates. | | GWF | MAW | PERIOD | RATE | DOUBLE PRECISION | is the volumetric pumping rate for the multi-aquifer well. A positive value indicates recharge and a negative value indicates discharge (pumping). RATE only applies to active (IBOUND $>$ 0) multi-aquifer wells. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. By default, the RATE for each multi-aquifer well is zero. | | GWF | MAW | PERIOD | WELL_HEAD | DOUBLE PRECISION | is the head in the multi-aquifer well. WELL\_HEAD is only applied to constant head (STATUS is CONSTANT) and inactive (STATUS is INACTIVE) multi-aquifer wells. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | -| GWF | MAW | PERIOD | HEAD_LIMIT | STRING | is the limiting water level (head) in the well, which is the minimum of the well RATE or the well inflow rate from the aquifer. HEAD\_LIMIT is only applied to discharging wells (RATE $<$ 0). HEAD\_LIMIT can be deactivated by specifying the text string `OFF'. The HEAD\_LIMIT option is based on the HEAD\_LIMIT functionality available in the MNW2~\citep{konikow2009} package for MODFLOW-2005. The HEAD\_LIMIT option has been included to facilitate backward compatibility with previous versions of MODFLOW but use of the RATE\_SCALING option instead of the HEAD\_LIMIT option is recommended. By default, HEAD\_LIMIT is `OFF'. | -| GWF | MAW | PERIOD | SHUT_OFF | KEYWORD | keyword for activating well shut off capability. Subsequent values define the minimum and maximum pumping rate that a well must exceed to shutoff or reactivate a well, respectively, during a stress period. SHUT\_OFF is only applied to discharging wells (RATE$<0$) and if HEAD\_LIMIT is specified (not set to `OFF'). If HEAD\_LIMIT is specified, SHUT\_OFF can be deactivated by specifying a minimum value equal to zero. The SHUT\_OFF option is based on the SHUT\_OFF functionality available in the MNW2~\citep{konikow2009} package for MODFLOW-2005. The SHUT\_OFF option has been included to facilitate backward compatibility with previous versions of MODFLOW but use of the RATE\_SCALING option instead of the SHUT\_OFF option is recommended. By default, SHUT\_OFF is not used. | +| GWF | MAW | PERIOD | HEAD_LIMIT | STRING | is the limiting water level (head) in the well, which is the minimum of the well RATE or the well inflow rate from the aquifer. HEAD\_LIMIT can be applied to extraction wells (RATE $<$ 0) or injection wells (RATE $>$ 0). HEAD\_LIMIT can be deactivated by specifying the text string `OFF'. The HEAD\_LIMIT option is based on the HEAD\_LIMIT functionality available in the MNW2~\citep{konikow2009} package for MODFLOW-2005. The HEAD\_LIMIT option has been included to facilitate backward compatibility with previous versions of MODFLOW but use of the RATE\_SCALING option instead of the HEAD\_LIMIT option is recommended. By default, HEAD\_LIMIT is `OFF'. | +| GWF | MAW | PERIOD | SHUT_OFF | KEYWORD | keyword for activating well shut off capability. Subsequent values define the minimum and maximum pumping rate that a well must exceed to shutoff or reactivate a well, respectively, during a stress period. SHUT\_OFF is only applied to injection wells (RATE$<0$) and if HEAD\_LIMIT is specified (not set to `OFF'). If HEAD\_LIMIT is specified, SHUT\_OFF can be deactivated by specifying a minimum value equal to zero. The SHUT\_OFF option is based on the SHUT\_OFF functionality available in the MNW2~\citep{konikow2009} package for MODFLOW-2005. The SHUT\_OFF option has been included to facilitate backward compatibility with previous versions of MODFLOW but use of the RATE\_SCALING option instead of the SHUT\_OFF option is recommended. By default, SHUT\_OFF is not used. | | GWF | MAW | PERIOD | MINRATE | DOUBLE PRECISION | is the minimum rate that a well must exceed to shutoff a well during a stress period. The well will shut down during a time step if the flow rate to the well from the aquifer is less than MINRATE. If a well is shut down during a time step, reactivation of the well cannot occur until the next time step to reduce oscillations. MINRATE must be less than maxrate. | | GWF | MAW | PERIOD | MAXRATE | DOUBLE PRECISION | is the maximum rate that a well must exceed to reactivate a well during a stress period. The well will reactivate during a timestep if the well was shutdown during the previous time step and the flow rate to the well from the aquifer exceeds maxrate. Reactivation of the well cannot occur until the next time step if a well is shutdown to reduce oscillations. maxrate must be greater than MINRATE. | -| GWF | MAW | PERIOD | RATE_SCALING | KEYWORD | activate rate scaling. If RATE\_SCALING is specified, both PUMP\_ELEVATION and SCALING\_LENGTH must be specified. RATE\_SCALING cannot be used with HEAD\_LIMIT. | -| GWF | MAW | PERIOD | PUMP_ELEVATION | DOUBLE PRECISION | is the elevation of the multi-aquifer well pump (PUMP\_ELEVATION). PUMP\_ELEVATION cannot be less than the bottom elevation (BOTTOM) of the multi-aquifer well. By default, PUMP\_ELEVATION is set equal to the bottom of the largest GWF node number connected to a MAW well. | -| GWF | MAW | PERIOD | SCALING_LENGTH | DOUBLE PRECISION | height above the pump elevation (SCALING\_LENGTH) below which the pumping rate is reduced. The default value for SCALING\_LENGTH is the well radius. | +| GWF | MAW | PERIOD | RATE_SCALING | KEYWORD | activate rate scaling. If RATE\_SCALING is specified, both PUMP\_ELEVATION and SCALING\_LENGTH must be specified. RATE\_SCALING cannot be used with HEAD\_LIMIT. RATE\_SCALING can be used for extraction or injection wells. For extraction wells, the extraction rate will start to decrease once the head in the well lowers to a level equal to the pump elevation plus the scaling length. If the head in the well drops below the pump elevation, then the extraction rate is calculated to be zero. For an injection well, the injection rate will begin to decrease once the head in the well rises above the specified pump elevation. If the head in the well rises above the pump elevation plus the scaling length, then the injection rate will be set to zero. | +| GWF | MAW | PERIOD | PUMP_ELEVATION | DOUBLE PRECISION | is the elevation of the multi-aquifer well pump (PUMP\_ELEVATION). PUMP\_ELEVATION should not be less than the bottom elevation (BOTTOM) of the multi-aquifer well. | +| GWF | MAW | PERIOD | SCALING_LENGTH | DOUBLE PRECISION | height above the pump elevation (SCALING\_LENGTH). If the simulated well head is below this elevation (pump elevation plus the scaling length), then the pumping rate is reduced. | | GWF | MAW | PERIOD | AUXILIARY | KEYWORD | keyword for specifying auxiliary variable. | | GWF | MAW | PERIOD | AUXNAME | STRING | name for the auxiliary variable to be assigned AUXVAL. AUXNAME must match one of the auxiliary variable names defined in the OPTIONS block. If AUXNAME does not match one of the auxiliary variable names defined in the OPTIONS block the data are ignored. | | GWF | MAW | PERIOD | AUXVAL | DOUBLE PRECISION | value for the auxiliary variable. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | @@ -424,13 +491,15 @@ | GWF | SFR | OPTIONS | BUDGET | KEYWORD | keyword to specify that record corresponds to the budget. | | GWF | SFR | OPTIONS | FILEOUT | KEYWORD | keyword to specify that an output filename is expected next. | | GWF | SFR | OPTIONS | BUDGETFILE | STRING | name of the binary output file to write budget information. | +| GWF | SFR | OPTIONS | PACKAGE_CONVERGENCE | KEYWORD | keyword to specify that record corresponds to the package convergence comma spaced values file. | +| GWF | SFR | OPTIONS | PACKAGE_CONVERGENCE_FILENAME | STRING | name of the comma spaced values output file to write package convergence information. | | GWF | SFR | OPTIONS | TS6 | KEYWORD | keyword to specify that record corresponds to a time-series file. | | GWF | SFR | OPTIONS | FILEIN | KEYWORD | keyword to specify that an input filename is expected next. | | GWF | SFR | OPTIONS | TS6_FILENAME | STRING | defines a time-series file defining time series that can be used to assign time-varying values. See the ``Time-Variable Input'' section for instructions on using the time-series capability. | | GWF | SFR | OPTIONS | OBS6 | KEYWORD | keyword to specify that record corresponds to an observations file. | | GWF | SFR | OPTIONS | OBS6_FILENAME | STRING | name of input file to define observations for the SFR package. See the ``Observation utility'' section for instructions for preparing observation input files. Table \ref{table:obstype} lists observation type(s) supported by the SFR package. | | GWF | SFR | OPTIONS | MOVER | KEYWORD | keyword to indicate that this instance of the SFR Package can be used with the Water Mover (MVR) Package. When the MOVER option is specified, additional memory is allocated within the package to store the available, provided, and received water. | -| GWF | SFR | OPTIONS | MAXIMUM_ITERATIONS | DOUBLE PRECISION | value that defines an maximum number of Streamflow Routing Newton-Raphson iterations allowed for a reach. By default, MAXSFRIT is equal to 100. | +| GWF | SFR | OPTIONS | MAXIMUM_ITERATIONS | INTEGER | value that defines the maximum number of Streamflow Routing Newton-Raphson iterations allowed for a reach. By default, MAXSFRIT is equal to 100. | | GWF | SFR | OPTIONS | MAXIMUM_DEPTH_CHANGE | DOUBLE PRECISION | value that defines the depth closure tolerance. By default, DMAXCHG is equal to $1 \times 10^{-5}$. | | GWF | SFR | OPTIONS | UNIT_CONVERSION | DOUBLE PRECISION | value (or conversion factor) that is used in calculating stream depth for stream reach. A constant of 1.486 is used for flow units of cubic feet per second, and a constant of 1.0 is used for units of cubic meters per second. The constant must be multiplied by 86,400 when using time units of days in the simulation. | | GWF | SFR | DIMENSIONS | NREACHES | INTEGER | integer value specifying the number of stream reaches. There must be NREACHES entries in the PACKAGEDATA block. | @@ -457,7 +526,7 @@ | GWF | SFR | PERIOD | IPER | INTEGER | integer value specifying the starting stress period number for which the data specified in the PERIOD block apply. IPER must be less than or equal to NPER in the TDIS Package and greater than zero. The IPER value assigned to a stress period block must be greater than the IPER value assigned for the previous PERIOD block. The information specified in the PERIOD block will continue to apply for all subsequent stress periods, unless the program encounters another PERIOD block. | | GWF | SFR | PERIOD | RNO | INTEGER | integer value that defines the reach number associated with the specified PERIOD data on the line. RNO must be greater than zero and less than or equal to NREACHES. | | GWF | SFR | PERIOD | SFRSETTING | KEYSTRING | line of information that is parsed into a keyword and values. Keyword values that can be used to start the SFRSETTING string include: STATUS, MANNING, STAGE, INFLOW, RAINFALL, EVAPORATION, RUNOFF, DIVERSION, UPSTREAM\_FRACTION, and AUXILIARY. | -| GWF | SFR | PERIOD | STATUS | STRING | keyword option to define stream reach status. STATUS can be ACTIVE, INACTIVE, or SIMPLE. The SIMPLE STATUS option simulates streamflow using a user-specified stage for a reach or a stage set to the top of the reach (depth = 0). In cases where the simulated leakage calculated using the specified stage exceeds the sum of inflows to the reach, the stage is set to the top of the reach and leakage is set equal to the sum of inflows. Upstream factions should be changed using the UPSTREAM\_FRACTION SFRSETTING if the status for one or more reaches is changed to ACTIVE or INACTIVE. For example, if one of two downstream connections for a reach is inactivated, the upstream fraction for the active and inactive downstream reach should be changed to 1.0 and 0.0, respectively, to ensure that the active reach receives all of the downstream outflow from the upstream reach. By default, STATUS is ACTIVE. | +| GWF | SFR | PERIOD | STATUS | STRING | keyword option to define stream reach status. STATUS can be ACTIVE, INACTIVE, or SIMPLE. The SIMPLE STATUS option simulates streamflow using a user-specified stage for a reach or a stage set to the top of the reach (depth = 0). In cases where the simulated leakage calculated using the specified stage exceeds the sum of inflows to the reach, the stage is set to the top of the reach and leakage is set equal to the sum of inflows. Upstream fractions should be changed using the UPSTREAM\_FRACTION SFRSETTING if the status for one or more reaches is changed to ACTIVE or INACTIVE. For example, if one of two downstream connections for a reach is inactivated, the upstream fraction for the active and inactive downstream reach should be changed to 1.0 and 0.0, respectively, to ensure that the active reach receives all of the downstream outflow from the upstream reach. By default, STATUS is ACTIVE. | | GWF | SFR | PERIOD | MANNING | STRING | real or character value that defines the Manning's roughness coefficient for the reach. MANNING must be greater than zero. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWF | SFR | PERIOD | STAGE | STRING | real or character value that defines the stage for the reach. The specified STAGE is only applied if the reach uses the simple routing option. If STAGE is not specified for reaches that use the simple routing option, the specified stage is set to the top of the reach. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWF | SFR | PERIOD | INFLOW | STRING | real or character value that defines the volumetric inflow rate for the streamflow routing reach. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. By default, inflow rates are zero for each reach. | @@ -466,7 +535,7 @@ | GWF | SFR | PERIOD | RUNOFF | STRING | real or character value that defines the volumetric rate of diffuse overland runoff that enters the streamflow routing reach. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. If the volumetric runoff rate for a reach is negative and exceeds inflows to the reach (upstream and specified inflows, and rainfall but excluding groundwater leakage into the reach) the volumetric runoff rate is limited to inflows to the reach and the volumetric evaporation rate for the reach is set to zero. By default, runoff rates are zero for each reach. | | GWF | SFR | PERIOD | DIVERSION | KEYWORD | keyword to indicate diversion record. | | GWF | SFR | PERIOD | IDV | INTEGER | diversion number. | -| GWF | SFR | PERIOD | DIVRATE | DOUBLE PRECISION | real or character value that defines the volumetric diversion (DIVFLOW) rate for the streamflow routing reach. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | +| GWF | SFR | PERIOD | DIVFLOW | DOUBLE PRECISION | real or character value that defines the volumetric diversion (DIVFLOW) rate for the streamflow routing reach. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWF | SFR | PERIOD | UPSTREAM_FRACTION | DOUBLE PRECISION | real value that defines the fraction of upstream flow (USTRF) from each upstream reach that is applied as upstream inflow to the reach. The sum of all USTRF values for all reaches connected to the same upstream reach must be equal to one. | | GWF | SFR | PERIOD | AUXILIARY | KEYWORD | keyword for specifying auxiliary variable. | | GWF | SFR | PERIOD | AUXNAME | STRING | name for the auxiliary variable to be assigned AUXVAL. AUXNAME must match one of the auxiliary variable names defined in the OPTIONS block. If AUXNAME does not match one of the auxiliary variable names defined in the OPTIONS block the data are ignored. | @@ -482,6 +551,8 @@ | GWF | LAK | OPTIONS | BUDGET | KEYWORD | keyword to specify that record corresponds to the budget. | | GWF | LAK | OPTIONS | FILEOUT | KEYWORD | keyword to specify that an output filename is expected next. | | GWF | LAK | OPTIONS | BUDGETFILE | STRING | name of the binary output file to write budget information. | +| GWF | LAK | OPTIONS | PACKAGE_CONVERGENCE | KEYWORD | keyword to specify that record corresponds to the package convergence comma spaced values file. | +| GWF | LAK | OPTIONS | PACKAGE_CONVERGENCE_FILENAME | STRING | name of the comma spaced values output file to write package convergence information. | | GWF | LAK | OPTIONS | TS6 | KEYWORD | keyword to specify that record corresponds to a time-series file. | | GWF | LAK | OPTIONS | FILEIN | KEYWORD | keyword to specify that an input filename is expected next. | | GWF | LAK | OPTIONS | TS6_FILENAME | STRING | defines a time-series file defining time series that can be used to assign time-varying values. See the ``Time-Variable Input'' section for instructions on using the time-series capability. | @@ -502,7 +573,7 @@ | GWF | LAK | CONNECTIONDATA | LAKENO | INTEGER | integer value that defines the lake number associated with the specified CONNECTIONDATA data on the line. LAKENO must be greater than zero and less than or equal to NLAKES. Lake connection information must be specified for every lake connection to the GWF model (NLAKECONN) or the program will terminate with an error. The program will also terminate with an error if connection information for a lake connection to the GWF model is specified more than once. | | GWF | LAK | CONNECTIONDATA | ICONN | INTEGER | integer value that defines the GWF connection number for this lake connection entry. ICONN must be greater than zero and less than or equal to NLAKECONN for lake LAKENO. | | GWF | LAK | CONNECTIONDATA | CELLID | INTEGER (NCELLDIM) | is the cell identifier, and depends on the type of grid that is used for the simulation. For a structured grid that uses the DIS input file, CELLID is the layer, row, and column. For a grid that uses the DISV input file, CELLID is the layer and CELL2D number. If the model uses the unstructured discretization (DISU) input file, CELLID is the node number for the cell. | -| GWF | LAK | CONNECTIONDATA | CLAKTYPE | STRING | character string that defines the lake-GWF connection type for the lake connection. Possible lake-GWF connection type strings include: VERTICAL--character keyword to indicate the lake-GWF connection is vertical and connection conductance calculations use the hydraulic conductivity corresponding to the $K_{33}$ tensor component defined for CELLID in the NPF package. HORIZONTAL--character keyword to indicate the lake-GWF connection is horizontal and connection conductance calculations use the hydraulic conductivity corresponding to the $K_{11}$ tensor component defined for CELLID in the NPF package. EMBEDDEDH--character keyword to indicate the lake-GWF connection is embedded in a single cell and connection conductance calculations use the hydraulic conductivity corresponding to the $K_{11}$ tensor component defined for CELLID in the NPF package. EMBEDDEDV--character keyword to indicate the lake-GWF connection is embedded in a single cell and connection conductance calculations use the hydraulic conductivity corresponding to the $K_{33}$ tensor component defined for CELLID in the NPF package. Embedded lakes can only be connected to a single cell (NLAKCONN = 1) and there must be a lake table associated with each embedded lake. | +| GWF | LAK | CONNECTIONDATA | CLAKTYPE | STRING | character string that defines the lake-GWF connection type for the lake connection. Possible lake-GWF connection type strings include: VERTICAL--character keyword to indicate the lake-GWF connection is vertical and connection conductance calculations use the hydraulic conductivity corresponding to the $K_{33}$ tensor component defined for CELLID in the NPF package. HORIZONTAL--character keyword to indicate the lake-GWF connection is horizontal and connection conductance calculations use the hydraulic conductivity corresponding to the $K_{11}$ tensor component defined for CELLID in the NPF package. EMBEDDEDH--character keyword to indicate the lake-GWF connection is embedded in a single cell and connection conductance calculations use the hydraulic conductivity corresponding to the $K_{11}$ tensor component defined for CELLID in the NPF package. EMBEDDEDV--character keyword to indicate the lake-GWF connection is embedded in a single cell and connection conductance calculations use the hydraulic conductivity corresponding to the $K_{33}$ tensor component defined for CELLID in the NPF package. Embedded lakes can only be connected to a single cell (NLAKECONN = 1) and there must be a lake table associated with each embedded lake. | | GWF | LAK | CONNECTIONDATA | BEDLEAK | DOUBLE PRECISION | character string or real value that defines the bed leakance for the lake-GWF connection. BEDLEAK must be greater than or equal to zero or specified to be NONE. If BEDLEAK is specified to be NONE, the lake-GWF connection conductance is solely a function of aquifer properties in the connected GWF cell and lakebed sediments are assumed to be absent. | | GWF | LAK | CONNECTIONDATA | BELEV | DOUBLE PRECISION | real value that defines the bottom elevation for a HORIZONTAL lake-GWF connection. Any value can be specified if CLAKTYPE is VERTICAL, EMBEDDEDH, or EMBEDDEDV. If CLAKTYPE is HORIZONTAL and BELEV is not equal to TELEV, BELEV must be greater than or equal to the bottom of the GWF cell CELLID. If BELEV is equal to TELEV, BELEV is reset to the bottom of the GWF cell CELLID. | | GWF | LAK | CONNECTIONDATA | TELEV | DOUBLE PRECISION | real value that defines the top elevation for a HORIZONTAL lake-GWF connection. Any value can be specified if CLAKTYPE is VERTICAL, EMBEDDEDH, or EMBEDDEDV. If CLAKTYPE is HORIZONTAL and TELEV is not equal to BELEV, TELEV must be less than or equal to the top of the GWF cell CELLID. If TELEV is equal to BELEV, TELEV is reset to the top of the GWF cell CELLID. | @@ -511,7 +582,7 @@ | GWF | LAK | TABLES | LAKENO | INTEGER | integer value that defines the lake number associated with the specified TABLES data on the line. LAKENO must be greater than zero and less than or equal to NLAKES. The program will terminate with an error if table information for a lake is specified more than once or the number of specified tables is less than NTABLES. | | GWF | LAK | TABLES | TAB6 | KEYWORD | keyword to specify that record corresponds to a table file. | | GWF | LAK | TABLES | FILEIN | KEYWORD | keyword to specify that an input filename is expected next. | -| GWF | LAK | TABLES | TAB6_FILENAME | STRING | character string that defines the path and filename for the file containing lake table data for the lake connection. The CTABNAME file includes the number of entries in the file and the relation between stage, surface area, and volume for each entry in the file. Lake table files for EMBEDDEDH and EMBEDDEDV lake-GWF connections also include lake-GWF exchange area data for each entry in the file. Input instructions for the CTABNAME file is included at the LAK package lake table file input instructions section. | +| GWF | LAK | TABLES | TAB6_FILENAME | STRING | character string that defines the path and filename for the file containing lake table data for the lake connection. The CTABNAME file includes the number of entries in the file and the relation between stage, volume, and surface area for each entry in the file. Lake table files for EMBEDDEDH and EMBEDDEDV lake-GWF connections also include lake-GWF exchange area data for each entry in the file. Input instructions for the CTABNAME file is included at the LAK package lake table file input instructions section. | | GWF | LAK | OUTLETS | OUTLETNO | INTEGER | integer value that defines the outlet number associated with the specified OUTLETS data on the line. OUTLETNO must be greater than zero and less than or equal to NOUTLETS. Outlet information must be specified for every outlet or the program will terminate with an error. The program will also terminate with an error if information for a outlet is specified more than once. | | GWF | LAK | OUTLETS | LAKEIN | INTEGER | integer value that defines the lake number that outlet is connected to. LAKEIN must be greater than zero and less than or equal to NLAKES. | | GWF | LAK | OUTLETS | LAKEOUT | INTEGER | integer value that defines the lake number that outlet discharge from lake outlet OUTLETNO is routed to. LAKEOUT must be greater than or equal to zero and less than or equal to NLAKES. If LAKEOUT is zero, outlet discharge from lake outlet OUTLETNO is discharged to an external boundary. | @@ -521,24 +592,23 @@ | GWF | LAK | OUTLETS | ROUGH | DOUBLE PRECISION | real value that defines the roughness coefficient for the lake outlet. Any value can be specified if COUTTYPE is not MANNING. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWF | LAK | OUTLETS | SLOPE | DOUBLE PRECISION | real value that defines the bed slope for the lake outlet. Any value can be specified if COUTTYPE is not MANNING. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWF | LAK | PERIOD | IPER | INTEGER | integer value specifying the starting stress period number for which the data specified in the PERIOD block apply. IPER must be less than or equal to NPER in the TDIS Package and greater than zero. The IPER value assigned to a stress period block must be greater than the IPER value assigned for the previous PERIOD block. The information specified in the PERIOD block will continue to apply for all subsequent stress periods, unless the program encounters another PERIOD block. | -| GWF | LAK | PERIOD | LAKENO | INTEGER | integer value that defines the lake number associated with the specified PERIOD data on the line. LAKENO must be greater than zero and less than or equal to NLAKES. | -| GWF | LAK | PERIOD | LAKSETTING | KEYSTRING | line of information that is parsed into a keyword and values. Keyword values that can be used to start the LAKSETTING string include: STATUS, STAGE, RAINFALL, EVAPORATION, RUNOFFON, WITHDRAWAL, and AUXILIARY. | +| GWF | LAK | PERIOD | NUMBER | INTEGER | integer value that defines the lake or outlet number associated with the specified PERIOD data on the line. NUMBER must be greater than zero and less than or equal to NLAKES for a lake number and less than or equal to NOUTLETS for an outlet number. | +| GWF | LAK | PERIOD | LAKSETTING | KEYSTRING | line of information that is parsed into a keyword and values. Keyword values that can be used to start the LAKSETTING string include both keywords for lake settings and keywords for outlet settings. Keywords for lake settings include: STATUS, STAGE, RAINFALL, EVAPORATION, RUNOFF, INFLOW, WITHDRAWAL, and AUXILIARY. Keywords for outlet settings include RATE, INVERT, WIDTH, SLOPE, and ROUGH. | | GWF | LAK | PERIOD | STATUS | STRING | keyword option to define lake status. STATUS can be ACTIVE, INACTIVE, or CONSTANT. By default, STATUS is ACTIVE. | | GWF | LAK | PERIOD | STAGE | STRING | real or character value that defines the stage for the lake. The specified STAGE is only applied if the lake is a constant stage lake. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWF | LAK | PERIOD | RAINFALL | STRING | real or character value that defines the rainfall rate $(LT^{-1})$ for the lake. Value must be greater than or equal to zero. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWF | LAK | PERIOD | EVAPORATION | STRING | real or character value that defines the maximum evaporation rate $(LT^{-1})$ for the lake. Value must be greater than or equal to zero. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWF | LAK | PERIOD | RUNOFF | STRING | real or character value that defines the runoff rate $(L^3 T^{-1})$ for the lake. Value must be greater than or equal to zero. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | +| GWF | LAK | PERIOD | INFLOW | STRING | real or character value that defines the volumetric inflow rate $(L^3 T^{-1})$ for the lake. Value must be greater than or equal to zero. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. By default, inflow rates are zero for each lake. | | GWF | LAK | PERIOD | WITHDRAWAL | STRING | real or character value that defines the maximum withdrawal rate $(L^3 T^{-1})$ for the lake. Value must be greater than or equal to zero. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | -| GWF | LAK | PERIOD | AUXILIARY | KEYWORD | keyword for specifying auxiliary variable. | -| GWF | LAK | PERIOD | AUXNAME | STRING | name for the auxiliary variable to be assigned AUXVAL. AUXNAME must match one of the auxiliary variable names defined in the OPTIONS block. If AUXNAME does not match one of the auxiliary variable names defined in the OPTIONS block the data are ignored. | -| GWF | LAK | PERIOD | AUXVAL | DOUBLE PRECISION | value for the auxiliary variable. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | -| GWF | LAK | PERIOD | OUTLETNO | INTEGER | integer value that defines the outlet number associated with the specified PERIOD data on the line. OUTLETNO must be greater than zero and less than or equal to NOUTLETS. | -| GWF | LAK | PERIOD | OUTLETSETTING | KEYSTRING | line of information that is parsed into a keyword and values. Keyword values that can be used to start the OUTLETSETTING string include: RATE, INVERT, WIDTH, SLOPE, and ROUGH. | | GWF | LAK | PERIOD | RATE | STRING | real or character value that defines the extraction rate for the lake outflow. A positive value indicates inflow and a negative value indicates outflow from the lake. RATE only applies to active (IBOUND $>$ 0) lakes. A specified RATE is only applied if COUTTYPE for the OUTLETNO is SPECIFIED. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. By default, the RATE for each SPECIFIED lake outlet is zero. | | GWF | LAK | PERIOD | INVERT | STRING | real or character value that defines the invert elevation for the lake outlet. A specified INVERT value is only used for active lakes if COUTTYPE for lake outlet OUTLETNO is not SPECIFIED. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | -| GWF | LAK | PERIOD | ROUGH | STRING | real or character value that defines the width of the lake outlet. A specified WIDTH value is only used for active lakes if COUTTYPE for lake outlet OUTLETNO is not SPECIFIED. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | +| GWF | LAK | PERIOD | ROUGH | STRING | real value that defines the roughness coefficient for the lake outlet. Any value can be specified if COUTTYPE is not MANNING. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWF | LAK | PERIOD | WIDTH | STRING | real or character value that defines the width of the lake outlet. A specified WIDTH value is only used for active lakes if COUTTYPE for lake outlet OUTLETNO is not SPECIFIED. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWF | LAK | PERIOD | SLOPE | STRING | real or character value that defines the bed slope for the lake outlet. A specified SLOPE value is only used for active lakes if COUTTYPE for lake outlet OUTLETNO is MANNING. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | +| GWF | LAK | PERIOD | AUXILIARY | KEYWORD | keyword for specifying auxiliary variable. | +| GWF | LAK | PERIOD | AUXNAME | STRING | name for the auxiliary variable to be assigned AUXVAL. AUXNAME must match one of the auxiliary variable names defined in the OPTIONS block. If AUXNAME does not match one of the auxiliary variable names defined in the OPTIONS block the data are ignored. | +| GWF | LAK | PERIOD | AUXVAL | DOUBLE PRECISION | value for the auxiliary variable. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWF | UZF | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | | GWF | UZF | OPTIONS | AUXMULTNAME | STRING | name of auxiliary variable to be used as multiplier of GWF cell area used by UZF cell. | | GWF | UZF | OPTIONS | BOUNDNAMES | KEYWORD | keyword to indicate that boundary names may be provided with the list of UZF cells. | @@ -548,25 +618,27 @@ | GWF | UZF | OPTIONS | BUDGET | KEYWORD | keyword to specify that record corresponds to the budget. | | GWF | UZF | OPTIONS | FILEOUT | KEYWORD | keyword to specify that an output filename is expected next. | | GWF | UZF | OPTIONS | BUDGETFILE | STRING | name of the binary output file to write budget information. | +| GWF | UZF | OPTIONS | PACKAGE_CONVERGENCE | KEYWORD | keyword to specify that record corresponds to the package convergence comma spaced values file. | +| GWF | UZF | OPTIONS | PACKAGE_CONVERGENCE_FILENAME | STRING | name of the comma spaced values output file to write package convergence information. | | GWF | UZF | OPTIONS | TS6 | KEYWORD | keyword to specify that record corresponds to a time-series file. | | GWF | UZF | OPTIONS | FILEIN | KEYWORD | keyword to specify that an input filename is expected next. | | GWF | UZF | OPTIONS | TS6_FILENAME | STRING | defines a time-series file defining time series that can be used to assign time-varying values. See the ``Time-Variable Input'' section for instructions on using the time-series capability. | | GWF | UZF | OPTIONS | OBS6 | KEYWORD | keyword to specify that record corresponds to an observations file. | | GWF | UZF | OPTIONS | OBS6_FILENAME | STRING | name of input file to define observations for the UZF package. See the ``Observation utility'' section for instructions for preparing observation input files. Table \ref{table:obstype} lists observation type(s) supported by the UZF package. | | GWF | UZF | OPTIONS | MOVER | KEYWORD | keyword to indicate that this instance of the UZF Package can be used with the Water Mover (MVR) Package. When the MOVER option is specified, additional memory is allocated within the package to store the available, provided, and received water. | -| GWF | UZF | OPTIONS | SIMULATE_ET | KEYWORD | keyword specifying that ET in the unsaturated (UZF) and saturated zones (GWF) will be simulated. ET can be simulated in the UZF cell and not the GWF cell by emitting keywords LINEAR\_GWET and SQUARE\_GWET. | +| GWF | UZF | OPTIONS | SIMULATE_ET | KEYWORD | keyword specifying that ET in the unsaturated (UZF) and saturated zones (GWF) will be simulated. ET can be simulated in the UZF cell and not the GWF cell by omitting keywords LINEAR\_GWET and SQUARE\_GWET. | | GWF | UZF | OPTIONS | LINEAR_GWET | KEYWORD | keyword specifying that groundwater ET will be simulated using the original ET formulation of MODFLOW-2005. | | GWF | UZF | OPTIONS | SQUARE_GWET | KEYWORD | keyword specifying that groundwater ET will be simulated by assuming a constant ET rate for groundwater levels between land surface (TOP) and land surface minus the ET extinction depth (TOP-EXTDP). Groundwater ET is smoothly reduced from the PET rate to zero over a nominal interval at TOP-EXTDP. | | GWF | UZF | OPTIONS | SIMULATE_GWSEEP | KEYWORD | keyword specifying that groundwater discharge (GWSEEP) to land surface will be simulated. Groundwater discharge is nonzero when groundwater head is greater than land surface. | | GWF | UZF | OPTIONS | UNSAT_ETWC | KEYWORD | keyword specifying that ET in the unsaturated zone will be simulated as a function of the specified PET rate while the water content (THETA) is greater than the ET extinction water content (EXTWC). | | GWF | UZF | OPTIONS | UNSAT_ETAE | KEYWORD | keyword specifying that ET in the unsaturated zone will be simulated simulated using a capillary pressure based formulation. Capillary pressure is calculated using the Brooks-Corey retention function. | -| GWF | UZF | DIMENSIONS | NUZFCELLS | INTEGER | is the number of UZF cells. More than 1 UZF cell can be assigned to a GWF cell; however, only 1 GWF cell can be assigned to a single UZF cell. If the MULTILAYER option is used then UZF cells can be assigned to GWF cells below (in deeper layers than) the upper most active GWF cells. | -| GWF | UZF | DIMENSIONS | NTRAILWAVES | INTEGER | is the number of trailing waves. NTRAILWAVES has a default value of 7 and can be increased to lower mass balance error in the unsaturated zone. | -| GWF | UZF | DIMENSIONS | NWAVESETS | INTEGER | is the number of UZF cells specified. NWAVSETS has a default value of 40 and can be increased if more waves are required to resolve variations in water content within the unsaturated zone. | +| GWF | UZF | DIMENSIONS | NUZFCELLS | INTEGER | is the number of UZF cells. More than one UZF cell can be assigned to a GWF cell; however, only one GWF cell can be assigned to a single UZF cell. If more than one UZF cell is assigned to a GWF cell, then an auxiliary variable should be used to reduce the surface area of the UZF cell with the AUXMULTNAME option. | +| GWF | UZF | DIMENSIONS | NTRAILWAVES | INTEGER | is the number of trailing waves. A recommended value of 7 can be used for NTRAILWAVES. This value can be increased to lower mass balance error in the unsaturated zone. | +| GWF | UZF | DIMENSIONS | NWAVESETS | INTEGER | is the number of wave sets. A recommended value of 40 can be used for NWAVESETS. This value can be increased if more waves are required to resolve variations in water content within the unsaturated zone. | | GWF | UZF | PACKAGEDATA | IUZNO | INTEGER | integer value that defines the UZF cell number associated with the specified PACKAGEDATA data on the line. IUZNO must be greater than zero and less than or equal to NUZFCELLS. UZF information must be specified for every UZF cell or the program will terminate with an error. The program will also terminate with an error if information for a UZF cell is specified more than once. | | GWF | UZF | PACKAGEDATA | CELLID | INTEGER (NCELLDIM) | is the cell identifier, and depends on the type of grid that is used for the simulation. For a structured grid that uses the DIS input file, CELLID is the layer, row, and column. For a grid that uses the DISV input file, CELLID is the layer and CELL2D number. If the model uses the unstructured discretization (DISU) input file, CELLID is the node number for the cell. | | GWF | UZF | PACKAGEDATA | LANDFLAG | INTEGER | integer value set to one for land surface cells indicating that boundary conditions can be applied and data can be specified in the PERIOD block. A value of 0 specifies a non-land surface cell. | -| GWF | UZF | PACKAGEDATA | IVERTCON | INTEGER | integer value set to specify underlying UZF cell that receives water flowing to bottom of cell. If unsaturated zone flow reaches water table before the cell bottom then water is added to GWF cell instead of flowing to underlying UZF cell. A value of 0 indicates the UZF cell is not connected to an underlying UZF cell. | +| GWF | UZF | PACKAGEDATA | IVERTCON | INTEGER | integer value set to specify underlying UZF cell that receives water flowing to bottom of cell. If unsaturated zone flow reaches the water table before the cell bottom, then water is added to the GWF cell instead of flowing to the underlying UZF cell. A value of 0 indicates the UZF cell is not connected to an underlying UZF cell. | | GWF | UZF | PACKAGEDATA | SURFDEP | DOUBLE PRECISION | is the surface depression depth of the UZF cell. | | GWF | UZF | PACKAGEDATA | VKS | DOUBLE PRECISION | is the vertical saturated hydraulic conductivity of the UZF cell. | | GWF | UZF | PACKAGEDATA | THTR | DOUBLE PRECISION | is the residual (irreducible) water content of the UZF cell. | @@ -633,12 +705,11 @@ | GWF | OC | PERIOD | FREQUENCY | INTEGER | save at the specified time step frequency. This keyword may be used in conjunction with other keywords to print or save results for multiple time steps. | | GWF | OC | PERIOD | STEPS | INTEGER ( + [MAXSIG0 ] +END DIMENSIONS diff --git a/doc/mf6io/mf6ivar/tex/gwf-csub-griddata.dat b/doc/mf6io/mf6ivar/tex/gwf-csub-griddata.dat new file mode 100644 index 00000000000..c68e38a5fe4 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwf-csub-griddata.dat @@ -0,0 +1,10 @@ +BEGIN GRIDDATA + CG_SKE_CR + -- READARRAY + CG_THETA + -- READARRAY + [SGM + -- READARRAY] + [SGS + -- READARRAY] +END GRIDDATA diff --git a/doc/mf6io/mf6ivar/tex/gwf-csub-options.dat b/doc/mf6io/mf6ivar/tex/gwf-csub-options.dat new file mode 100644 index 00000000000..10b1a5bd4af --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwf-csub-options.dat @@ -0,0 +1,28 @@ +BEGIN OPTIONS + [BOUNDNAMES] + [PRINT_INPUT] + [SAVE_FLOWS] + [GAMMAW ] + [BETA ] + [HEAD_BASED] + [INITIAL_PRECONSOLIDATION_HEAD] + [NDELAYCELLS ] + [COMPRESSION_INDICES] + [UPDATE_MATERIAL_PROPERTIES] + [CELL_FRACTION] + [SPECIFIED_INITIAL_INTERBED_STATE] + [SPECIFIED_INITIAL_PRECONSOLIDATION_STRESS] + [SPECIFIED_INITIAL_DELAY_HEAD] + [EFFECTIVE_STRESS_LAG] + [STRAIN_CSV_INTERBED FILEOUT ] + [STRAIN_CSV_COARSE FILEOUT ] + [COMPACTION FILEOUT ] + [COMPACTION_ELASTIC FILEOUT ] + [COMPACTION_INELASTIC FILEOUT ] + [COMPACTION_INTERBED FILEOUT ] + [COMPACTION_COARSE FILEOUT ] + [ZDISPLACEMENT FILEOUT ] + [PACKAGE_CONVERGENCE FILEOUT ] + [TS6 FILEIN ] + [OBS6 FILEIN ] +END OPTIONS diff --git a/doc/mf6io/mf6ivar/tex/gwf-csub-packagedata.dat b/doc/mf6io/mf6ivar/tex/gwf-csub-packagedata.dat new file mode 100644 index 00000000000..4a9f562d11c --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwf-csub-packagedata.dat @@ -0,0 +1,5 @@ +BEGIN PACKAGEDATA + [] + [] + ... +END PACKAGEDATA diff --git a/doc/mf6io/mf6ivar/tex/gwf-csub-period.dat b/doc/mf6io/mf6ivar/tex/gwf-csub-period.dat new file mode 100644 index 00000000000..03c41d7b0e8 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwf-csub-period.dat @@ -0,0 +1,5 @@ +BEGIN PERIOD + <@sig0@> + <@sig0@> + ... +END PERIOD diff --git a/doc/mf6io/mf6ivar/tex/gwf-dis-desc.tex b/doc/mf6io/mf6ivar/tex/gwf-dis-desc.tex index cb9667c6fe5..afef5a5fa76 100644 --- a/doc/mf6io/mf6ivar/tex/gwf-dis-desc.tex +++ b/doc/mf6io/mf6ivar/tex/gwf-dis-desc.tex @@ -27,9 +27,9 @@ \item \textbf{Block: GRIDDATA} \begin{description} -\item \texttt{delr}---is the is the column spacing in the row direction. +\item \texttt{delr}---is the column spacing in the row direction. -\item \texttt{delc}---is the is the row spacing in the column direction. +\item \texttt{delc}---is the row spacing in the column direction. \item \texttt{top}---is the top elevation for each cell in the top model layer. diff --git a/doc/mf6io/mf6ivar/tex/gwf-disu-desc.tex b/doc/mf6io/mf6ivar/tex/gwf-disu-desc.tex index 49f50aceb7e..cd36ee93cdc 100644 --- a/doc/mf6io/mf6ivar/tex/gwf-disu-desc.tex +++ b/doc/mf6io/mf6ivar/tex/gwf-disu-desc.tex @@ -21,7 +21,7 @@ \item \texttt{nja}---is the sum of the number of connections and NODES. When calculating the total number of connections, the connection between cell n and cell m is considered to be different from the connection between cell m and cell n. Thus, NJA is equal to the total number of connections, including n to m and m to n, and the total number of cells. -\item \texttt{nvert}---is the total number of (x, y) vertex pairs used to define the plan-view shape of each cell in the model grid. If NVERT is not specified or is specified as zero, then the VERTICES and CELL2D blocks below are not read. +\item \texttt{nvert}---is the total number of (x, y) vertex pairs used to define the plan-view shape of each cell in the model grid. If NVERT is not specified or is specified as zero, then the VERTICES and CELL2D blocks below are not read. NVERT and the accompanying VERTICES and CELL2D blocks should be specified for most simulations. If the XT3D or SAVE\_SPECIFIC\_DISCHARGE options are specified in the NPF Package, then this information is required. \end{description} \item \textbf{Block: GRIDDATA} @@ -33,6 +33,8 @@ \item \texttt{area}---is the cell surface area (in plan view). +\item \texttt{idomain}---is an optional array that characterizes the existence status of a cell. If the IDOMAIN array is not specified, then all model cells exist within the solution. If the IDOMAIN value for a cell is 0, the cell does not exist in the simulation. Input and output values will be read and written for the cell, but internal to the program, the cell is excluded from the solution. If the IDOMAIN value for a cell is 1, the cell exists in the simulation. IDOMAIN values of -1 cannot be specified for the DISU Package. + \end{description} \item \textbf{Block: CONNECTIONDATA} @@ -47,7 +49,7 @@ \item \texttt{hwva}---is a symmetric array of size NJA. For horizontal connections, entries in HWVA are the horizontal width perpendicular to flow. For vertical connections, entries in HWVA are the vertical area for flow. Thus, values in the HWVA array contain dimensions of both length and area. Entries in the HWVA array have a one-to-one correspondence with the connections specified in the JA array. Likewise, there is a one-to-one correspondence between entries in the HWVA array and entries in the IHC array, which specifies the connection type (horizontal or vertical). Entries in the HWVA array must be symmetric; the program will terminate with an error if the value for HWVA for an n to m connection does not equal the value for HWVA for the corresponding n to m connection. -\item \texttt{angldegx}---is the angle (in degrees) between the horizontal x-axis and the outward normal to the face between a cell and its connecting cells (see figure 8 in the MODFLOW-USG documentation). The angle varies between zero and 360.0 degrees. ANGLDEGX is only needed if horizontal anisotropy is specified in the NPF Package or if the XT3D option is used in the NPF Package. ANGLDEGX does not need to be specified if horizontal anisotropy or the XT3D option is not used. ANGLDEGX is of size NJA; values specified for vertical connections and for the diagonal position are not used. Note that ANGLDEGX is read in degrees, which is different from MODFLOW-USG, which reads a similar variable (ANGLEX) in radians. +\item \texttt{angldegx}---is the angle (in degrees) between the horizontal x-axis and the outward normal to the face between a cell and its connecting cells. The angle varies between zero and 360.0 degrees, where zero degrees points in the positive x-axis direction, and 90 degrees points in the positive y-axis direction. ANGLDEGX is only needed if horizontal anisotropy is specified in the NPF Package, if the XT3D option is used in the NPF Package, or if the SAVE\_SPECIFIC\_DISCHARGE option is specifed in the NPF Package. ANGLDEGX does not need to be specified if these conditions are not met. ANGLDEGX is of size NJA; values specified for vertical connections and for the diagonal position are not used. Note that ANGLDEGX is read in degrees, which is different from MODFLOW-USG, which reads a similar variable (ANGLEX) in radians. \end{description} \item \textbf{Block: VERTICES} diff --git a/doc/mf6io/mf6ivar/tex/gwf-disu-griddata.dat b/doc/mf6io/mf6ivar/tex/gwf-disu-griddata.dat index efff69211ad..2978f43b84e 100644 --- a/doc/mf6io/mf6ivar/tex/gwf-disu-griddata.dat +++ b/doc/mf6io/mf6ivar/tex/gwf-disu-griddata.dat @@ -5,4 +5,6 @@ BEGIN GRIDDATA -- READARRAY AREA -- READARRAY + [IDOMAIN + -- READARRAY] END GRIDDATA diff --git a/doc/mf6io/mf6ivar/tex/gwf-disv-griddata.dat b/doc/mf6io/mf6ivar/tex/gwf-disv-griddata.dat index 1eb376ac001..a9db9563a42 100644 --- a/doc/mf6io/mf6ivar/tex/gwf-disv-griddata.dat +++ b/doc/mf6io/mf6ivar/tex/gwf-disv-griddata.dat @@ -1,6 +1,6 @@ BEGIN GRIDDATA TOP - -- READARRAY + -- READARRAY BOTM [LAYERED] -- READARRAY [IDOMAIN [LAYERED] diff --git a/doc/mf6io/mf6ivar/tex/gwf-evt-desc.tex b/doc/mf6io/mf6ivar/tex/gwf-evt-desc.tex index c1e0338fc93..7bd90707ee2 100644 --- a/doc/mf6io/mf6ivar/tex/gwf-evt-desc.tex +++ b/doc/mf6io/mf6ivar/tex/gwf-evt-desc.tex @@ -27,7 +27,7 @@ \item \texttt{obs6\_filename}---name of input file to define observations for the Evapotranspiration package. See the ``Observation utility'' section for instructions for preparing observation input files. Table \ref{table:obstype} lists observation type(s) supported by the Evapotranspiration package. -\item \texttt{SURF\_RATE\_SPECIFIED}---indicates that the evapotranspiration rate at the ET surface will be specified as PETM0 in list input. +\item \texttt{SURF\_RATE\_SPECIFIED}---indicates that the proportion of the evapotranspiration rate at the ET surface will be specified as PETM0 in list input. \end{description} \item \textbf{Block: DIMENSIONS} @@ -45,17 +45,17 @@ \item \texttt{cellid}---is the cell identifier, and depends on the type of grid that is used for the simulation. For a structured grid that uses the DIS input file, CELLID is the layer, row, and column. For a grid that uses the DISV input file, CELLID is the layer and CELL2D number. If the model uses the unstructured discretization (DISU) input file, CELLID is the node number for the cell. -\item \textcolor{blue}{\texttt{surface}---is the elevation of the ET surface ($L$). A time-series name may be specified.} +\item \textcolor{blue}{\texttt{surface}---is the elevation of the ET surface ($L$). If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} -\item \textcolor{blue}{\texttt{rate}---is the maximum ET flux rate ($LT^{-1}$). A time-series name may be specified.} +\item \textcolor{blue}{\texttt{rate}---is the maximum ET flux rate ($LT^{-1}$). If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} -\item \textcolor{blue}{\texttt{depth}---is the ET extinction depth ($L$). A time-series name may be specified.} +\item \textcolor{blue}{\texttt{depth}---is the ET extinction depth ($L$). If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} -\item \textcolor{blue}{\texttt{pxdp}---is the proportion of the ET extinction depth at the bottom of a segment (dimensionless). A time-series name may be specified.} +\item \textcolor{blue}{\texttt{pxdp}---is the proportion of the ET extinction depth at the bottom of a segment (dimensionless). If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} -\item \textcolor{blue}{\texttt{petm}---is the proportion of the maximum ET flux rate at the bottom of a segment (dimensionless). A time-series name may be specified.} +\item \textcolor{blue}{\texttt{petm}---is the proportion of the maximum ET flux rate at the bottom of a segment (dimensionless). If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} -\item \textcolor{blue}{\texttt{petm0}---is the proportion of the maximum ET flux rate that will apply when head is at or above the ET surface (dimensionless). PETM0 is read only when the SURF\_RATE\_SPECIFIED option is used. A time-series name may be specified.} +\item \textcolor{blue}{\texttt{petm0}---is the proportion of the maximum ET flux rate that will apply when head is at or above the ET surface (dimensionless). PETM0 is read only when the SURF\_RATE\_SPECIFIED option is used. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} \item \textcolor{blue}{\texttt{aux}---represents the values of the auxiliary variables for each evapotranspiration. The values of auxiliary variables must be present for each evapotranspiration. The values must be specified in the order of the auxiliary variables specified in the OPTIONS block. If the package supports time series and the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} diff --git a/doc/mf6io/mf6ivar/tex/gwf-lak-desc.tex b/doc/mf6io/mf6ivar/tex/gwf-lak-desc.tex index bbc2c7435f7..f775d2c69a9 100644 --- a/doc/mf6io/mf6ivar/tex/gwf-lak-desc.tex +++ b/doc/mf6io/mf6ivar/tex/gwf-lak-desc.tex @@ -25,6 +25,10 @@ \item \texttt{budgetfile}---name of the binary output file to write budget information. +\item \texttt{PACKAGE\_CONVERGENCE}---keyword to specify that record corresponds to the package convergence comma spaced values file. + +\item \texttt{package\_convergence\_filename}---name of the comma spaced values output file to write package convergence information. + \item \texttt{TS6}---keyword to specify that record corresponds to a time-series file. \item \texttt{FILEIN}---keyword to specify that an input filename is expected next. @@ -77,7 +81,7 @@ \item \texttt{cellid}---is the cell identifier, and depends on the type of grid that is used for the simulation. For a structured grid that uses the DIS input file, CELLID is the layer, row, and column. For a grid that uses the DISV input file, CELLID is the layer and CELL2D number. If the model uses the unstructured discretization (DISU) input file, CELLID is the node number for the cell. -\item \texttt{claktype}---character string that defines the lake-GWF connection type for the lake connection. Possible lake-GWF connection type strings include: VERTICAL--character keyword to indicate the lake-GWF connection is vertical and connection conductance calculations use the hydraulic conductivity corresponding to the $K_{33}$ tensor component defined for CELLID in the NPF package. HORIZONTAL--character keyword to indicate the lake-GWF connection is horizontal and connection conductance calculations use the hydraulic conductivity corresponding to the $K_{11}$ tensor component defined for CELLID in the NPF package. EMBEDDEDH--character keyword to indicate the lake-GWF connection is embedded in a single cell and connection conductance calculations use the hydraulic conductivity corresponding to the $K_{11}$ tensor component defined for CELLID in the NPF package. EMBEDDEDV--character keyword to indicate the lake-GWF connection is embedded in a single cell and connection conductance calculations use the hydraulic conductivity corresponding to the $K_{33}$ tensor component defined for CELLID in the NPF package. Embedded lakes can only be connected to a single cell (NLAKCONN = 1) and there must be a lake table associated with each embedded lake. +\item \texttt{claktype}---character string that defines the lake-GWF connection type for the lake connection. Possible lake-GWF connection type strings include: VERTICAL--character keyword to indicate the lake-GWF connection is vertical and connection conductance calculations use the hydraulic conductivity corresponding to the $K_{33}$ tensor component defined for CELLID in the NPF package. HORIZONTAL--character keyword to indicate the lake-GWF connection is horizontal and connection conductance calculations use the hydraulic conductivity corresponding to the $K_{11}$ tensor component defined for CELLID in the NPF package. EMBEDDEDH--character keyword to indicate the lake-GWF connection is embedded in a single cell and connection conductance calculations use the hydraulic conductivity corresponding to the $K_{11}$ tensor component defined for CELLID in the NPF package. EMBEDDEDV--character keyword to indicate the lake-GWF connection is embedded in a single cell and connection conductance calculations use the hydraulic conductivity corresponding to the $K_{33}$ tensor component defined for CELLID in the NPF package. Embedded lakes can only be connected to a single cell (NLAKECONN = 1) and there must be a lake table associated with each embedded lake. \item \texttt{bedleak}---character string or real value that defines the bed leakance for the lake-GWF connection. BEDLEAK must be greater than or equal to zero or specified to be NONE. If BEDLEAK is specified to be NONE, the lake-GWF connection conductance is solely a function of aquifer properties in the connected GWF cell and lakebed sediments are assumed to be absent. @@ -99,7 +103,7 @@ \item \texttt{FILEIN}---keyword to specify that an input filename is expected next. -\item \texttt{tab6\_filename}---character string that defines the path and filename for the file containing lake table data for the lake connection. The CTABNAME file includes the number of entries in the file and the relation between stage, surface area, and volume for each entry in the file. Lake table files for EMBEDDEDH and EMBEDDEDV lake-GWF connections also include lake-GWF exchange area data for each entry in the file. Input instructions for the CTABNAME file is included at the LAK package lake table file input instructions section. +\item \texttt{tab6\_filename}---character string that defines the path and filename for the file containing lake table data for the lake connection. The CTABNAME file includes the number of entries in the file and the relation between stage, volume, and surface area for each entry in the file. Lake table files for EMBEDDEDH and EMBEDDEDV lake-GWF connections also include lake-GWF exchange area data for each entry in the file. Input instructions for the CTABNAME file is included at the LAK package lake table file input instructions section. \end{description} \item \textbf{Block: OUTLETS} @@ -127,9 +131,9 @@ \begin{description} \item \texttt{iper}---integer value specifying the starting stress period number for which the data specified in the PERIOD block apply. IPER must be less than or equal to NPER in the TDIS Package and greater than zero. The IPER value assigned to a stress period block must be greater than the IPER value assigned for the previous PERIOD block. The information specified in the PERIOD block will continue to apply for all subsequent stress periods, unless the program encounters another PERIOD block. -\item \texttt{lakeno}---integer value that defines the lake number associated with the specified PERIOD data on the line. LAKENO must be greater than zero and less than or equal to NLAKES. +\item \texttt{number}---integer value that defines the lake or outlet number associated with the specified PERIOD data on the line. NUMBER must be greater than zero and less than or equal to NLAKES for a lake number and less than or equal to NOUTLETS for an outlet number. -\item \texttt{laksetting}---line of information that is parsed into a keyword and values. Keyword values that can be used to start the LAKSETTING string include: STATUS, STAGE, RAINFALL, EVAPORATION, RUNOFFON, WITHDRAWAL, and AUXILIARY. +\item \texttt{laksetting}---line of information that is parsed into a keyword and values. Keyword values that can be used to start the LAKSETTING string include both keywords for lake settings and keywords for outlet settings. Keywords for lake settings include: STATUS, STAGE, RAINFALL, EVAPORATION, RUNOFF, INFLOW, WITHDRAWAL, and AUXILIARY. Keywords for outlet settings include RATE, INVERT, WIDTH, SLOPE, and ROUGH. \begin{lstlisting}[style=blockdefinition] STATUS @@ -137,7 +141,13 @@ RAINFALL <@rainfall@> EVAPORATION <@evaporation@> RUNOFF <@runoff@> +INFLOW <@inflow@> WITHDRAWAL <@withdrawal@> +RATE <@rate@> +INVERT <@invert@> +WIDTH <@width@> +SLOPE <@slope@> +ROUGH <@rough@> AUXILIARY <@auxval@> \end{lstlisting} @@ -151,35 +161,25 @@ \item \textcolor{blue}{\texttt{runoff}---real or character value that defines the runoff rate $(L^3 T^{-1})$ for the lake. Value must be greater than or equal to zero. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} -\item \textcolor{blue}{\texttt{withdrawal}---real or character value that defines the maximum withdrawal rate $(L^3 T^{-1})$ for the lake. Value must be greater than or equal to zero. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} - -\item \texttt{AUXILIARY}---keyword for specifying auxiliary variable. - -\item \texttt{auxname}---name for the auxiliary variable to be assigned AUXVAL. AUXNAME must match one of the auxiliary variable names defined in the OPTIONS block. If AUXNAME does not match one of the auxiliary variable names defined in the OPTIONS block the data are ignored. - -\item \textcolor{blue}{\texttt{auxval}---value for the auxiliary variable. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} - -\item \texttt{outletno}---integer value that defines the outlet number associated with the specified PERIOD data on the line. OUTLETNO must be greater than zero and less than or equal to NOUTLETS. - -\item \texttt{outletsetting}---line of information that is parsed into a keyword and values. Keyword values that can be used to start the OUTLETSETTING string include: RATE, INVERT, WIDTH, SLOPE, and ROUGH. +\item \textcolor{blue}{\texttt{inflow}---real or character value that defines the volumetric inflow rate $(L^3 T^{-1})$ for the lake. Value must be greater than or equal to zero. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. By default, inflow rates are zero for each lake.} -\begin{lstlisting}[style=blockdefinition] -RATE <@rate@> -INVERT <@invert@> -WIDTH <@width@> -SLOPE <@slope@> -ROUGH <@rough@> -\end{lstlisting} +\item \textcolor{blue}{\texttt{withdrawal}---real or character value that defines the maximum withdrawal rate $(L^3 T^{-1})$ for the lake. Value must be greater than or equal to zero. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} \item \textcolor{blue}{\texttt{rate}---real or character value that defines the extraction rate for the lake outflow. A positive value indicates inflow and a negative value indicates outflow from the lake. RATE only applies to active (IBOUND $>$ 0) lakes. A specified RATE is only applied if COUTTYPE for the OUTLETNO is SPECIFIED. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. By default, the RATE for each SPECIFIED lake outlet is zero.} \item \textcolor{blue}{\texttt{invert}---real or character value that defines the invert elevation for the lake outlet. A specified INVERT value is only used for active lakes if COUTTYPE for lake outlet OUTLETNO is not SPECIFIED. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} -\item \textcolor{blue}{\texttt{rough}---real or character value that defines the width of the lake outlet. A specified WIDTH value is only used for active lakes if COUTTYPE for lake outlet OUTLETNO is not SPECIFIED. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} +\item \textcolor{blue}{\texttt{rough}---real value that defines the roughness coefficient for the lake outlet. Any value can be specified if COUTTYPE is not MANNING. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} \item \textcolor{blue}{\texttt{width}---real or character value that defines the width of the lake outlet. A specified WIDTH value is only used for active lakes if COUTTYPE for lake outlet OUTLETNO is not SPECIFIED. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} \item \textcolor{blue}{\texttt{slope}---real or character value that defines the bed slope for the lake outlet. A specified SLOPE value is only used for active lakes if COUTTYPE for lake outlet OUTLETNO is MANNING. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} +\item \texttt{AUXILIARY}---keyword for specifying auxiliary variable. + +\item \texttt{auxname}---name for the auxiliary variable to be assigned AUXVAL. AUXNAME must match one of the auxiliary variable names defined in the OPTIONS block. If AUXNAME does not match one of the auxiliary variable names defined in the OPTIONS block the data are ignored. + +\item \textcolor{blue}{\texttt{auxval}---value for the auxiliary variable. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} + \end{description} diff --git a/doc/mf6io/mf6ivar/tex/gwf-lak-options.dat b/doc/mf6io/mf6ivar/tex/gwf-lak-options.dat index 38ff9453e5a..dbf4f7b5949 100644 --- a/doc/mf6io/mf6ivar/tex/gwf-lak-options.dat +++ b/doc/mf6io/mf6ivar/tex/gwf-lak-options.dat @@ -7,6 +7,7 @@ BEGIN OPTIONS [SAVE_FLOWS] [STAGE FILEOUT ] [BUDGET FILEOUT ] + [PACKAGE_CONVERGENCE FILEOUT ] [TS6 FILEIN ] [OBS6 FILEIN ] [MOVER] diff --git a/doc/mf6io/mf6ivar/tex/gwf-lak-period.dat b/doc/mf6io/mf6ivar/tex/gwf-lak-period.dat index 76531cb9daa..bf77c07f040 100644 --- a/doc/mf6io/mf6ivar/tex/gwf-lak-period.dat +++ b/doc/mf6io/mf6ivar/tex/gwf-lak-period.dat @@ -1,8 +1,5 @@ BEGIN PERIOD - - - ... - - + + ... END PERIOD diff --git a/doc/mf6io/mf6ivar/tex/gwf-maw-desc.tex b/doc/mf6io/mf6ivar/tex/gwf-maw-desc.tex index 852d22dffbf..c4ebc2cff72 100644 --- a/doc/mf6io/mf6ivar/tex/gwf-maw-desc.tex +++ b/doc/mf6io/mf6ivar/tex/gwf-maw-desc.tex @@ -63,7 +63,7 @@ \item \texttt{strt}---starting head for the multi-aquifer well. -\item \texttt{condeqn}---character string that defines the conductance equation that is used to calculate the saturated conductance for the multi-aquifer well. Possible multi-aquifer well CONDEQN strings include: SPECIFIED--character keyword to indicate the multi-aquifer well saturated conductance will be specified. THIEM--character keyword to indicate the multi-aquifer well saturated conductance will be calculated using the Thiem equation, which considers the cell top and bottom, aquifer hydraulic conductivity, and effective cell and well radius. SKIN--character keyword to indicate that the multi-aquifer well saturated conductance will be calculated using the cell top and bottom, aquifer and screen hydraulic conductivity, and well and skin radius. CUMULATIVE--character keyword to indicate that the multi-aquifer well saturated conductance will be calculated using a combination of the Thiem and SKIN equations. MEAN--character keyword to indicate the multi-aquifer well saturated conductance will be calculated using the aquifer and screen top and bottom, aquifer and screen hydraulic conductivity, and well and skin radius. +\item \texttt{condeqn}---character string that defines the conductance equation that is used to calculate the saturated conductance for the multi-aquifer well. Possible multi-aquifer well CONDEQN strings include: SPECIFIED--character keyword to indicate the multi-aquifer well saturated conductance will be specified. THIEM--character keyword to indicate the multi-aquifer well saturated conductance will be calculated using the Thiem equation, which considers the cell top and bottom, aquifer hydraulic conductivity, and effective cell and well radius. SKIN--character keyword to indicate that the multi-aquifer well saturated conductance will be calculated using the cell top and bottom, aquifer and screen hydraulic conductivity, and well and skin radius. CUMULATIVE--character keyword to indicate that the multi-aquifer well saturated conductance will be calculated using a combination of the Thiem and SKIN equations. MEAN--character keyword to indicate the multi-aquifer well saturated conductance will be calculated using the aquifer and screen top and bottom, aquifer and screen hydraulic conductivity, and well and skin radius. The CUMULATIVE conductance equation is identical to the SKIN LOSSTYPE in the Multi-Node Well (MNW2) package for MODFLOW-2005. The program will terminate with an error condition if CONDEQN is SKIN or CUMULATIVE and the calculated saturated conductance is less than zero; if an error condition occurs, it is suggested that the THEIM or MEAN conductance equations be used for these multi-aquifer wells. \item \texttt{ngwfnodes}---integer value that defines the number of GWF nodes connected to this (WELLNO) multi-aquifer well. NGWFNODES must be greater than zero. @@ -85,7 +85,7 @@ \item \texttt{scrn\_bot}---value that defines the bottom elevation of the screen for the multi-aquifer well connection. If the specified SCRN\_BOT is less than the bottom of the GWF cell it is set equal to the bottom of the cell. SCRN\_BOT can be any value if CONDEQN is SPECIFIED, THIEM, SKIN, or COMPOSITE and SCRN\_BOT is set to the bottom of the cell. -\item \texttt{hk\_skin}---value that defines the skin (filter pack) hydraulic conductivity (if CONDEQN for the multi-aquifer well is SKIN, CUMULATIVE, or MEAN) or conductance (if CONDEQN for the multi-aquifer well is SPECIFIED) for each GWF node connected to the multi-aquifer well (NGWFNODES). HK\_SKIN can be any value if CONDEQN is THIEM. +\item \texttt{hk\_skin}---value that defines the skin (filter pack) hydraulic conductivity (if CONDEQN for the multi-aquifer well is SKIN, CUMULATIVE, or MEAN) or conductance (if CONDEQN for the multi-aquifer well is SPECIFIED) for each GWF node connected to the multi-aquifer well (NGWFNODES). If CONDEQN is SPECIFIED, HK\_SKIN must be greater than or equal to zero. HK\_SKIN can be any value if CONDEQN is THIEM. Otherwise, HK\_SKIN must be greater than zero. If CONDEQN is SKIN, the contrast between the cell transmissivity (the product of geometric mean horizontal hydraulic conductivity and the cell thickness) and the well transmissivity (the product of HK\_SKIN and the screen thicknesses) must be greater than one in node CELLID or the program will terminate with an error condition; if an error condition occurs, it is suggested that the HK\_SKIN be reduced to a value less than K11 and K22 in node CELLID or the THEIM or MEAN conductance equations be used for these multi-aquifer wells. \item \texttt{radius\_skin}---real value that defines the skin radius (filter pack radius) for the multi-aquifer well. RADIUS\_SKIN can be any value if CONDEQN is SPECIFIED or THIEM. Otherwise, RADIUS\_SKIN must be greater than RADIUS for the multi-aquifer well. @@ -124,19 +124,19 @@ \item \textcolor{blue}{\texttt{well\_head}---is the head in the multi-aquifer well. WELL\_HEAD is only applied to constant head (STATUS is CONSTANT) and inactive (STATUS is INACTIVE) multi-aquifer wells. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} -\item \texttt{head\_limit}---is the limiting water level (head) in the well, which is the minimum of the well RATE or the well inflow rate from the aquifer. HEAD\_LIMIT is only applied to discharging wells (RATE $<$ 0). HEAD\_LIMIT can be deactivated by specifying the text string `OFF'. The HEAD\_LIMIT option is based on the HEAD\_LIMIT functionality available in the MNW2~\citep{konikow2009} package for MODFLOW-2005. The HEAD\_LIMIT option has been included to facilitate backward compatibility with previous versions of MODFLOW but use of the RATE\_SCALING option instead of the HEAD\_LIMIT option is recommended. By default, HEAD\_LIMIT is `OFF'. +\item \texttt{head\_limit}---is the limiting water level (head) in the well, which is the minimum of the well RATE or the well inflow rate from the aquifer. HEAD\_LIMIT can be applied to extraction wells (RATE $<$ 0) or injection wells (RATE $>$ 0). HEAD\_LIMIT can be deactivated by specifying the text string `OFF'. The HEAD\_LIMIT option is based on the HEAD\_LIMIT functionality available in the MNW2~\citep{konikow2009} package for MODFLOW-2005. The HEAD\_LIMIT option has been included to facilitate backward compatibility with previous versions of MODFLOW but use of the RATE\_SCALING option instead of the HEAD\_LIMIT option is recommended. By default, HEAD\_LIMIT is `OFF'. -\item \texttt{SHUT\_OFF}---keyword for activating well shut off capability. Subsequent values define the minimum and maximum pumping rate that a well must exceed to shutoff or reactivate a well, respectively, during a stress period. SHUT\_OFF is only applied to discharging wells (RATE$<0$) and if HEAD\_LIMIT is specified (not set to `OFF'). If HEAD\_LIMIT is specified, SHUT\_OFF can be deactivated by specifying a minimum value equal to zero. The SHUT\_OFF option is based on the SHUT\_OFF functionality available in the MNW2~\citep{konikow2009} package for MODFLOW-2005. The SHUT\_OFF option has been included to facilitate backward compatibility with previous versions of MODFLOW but use of the RATE\_SCALING option instead of the SHUT\_OFF option is recommended. By default, SHUT\_OFF is not used. +\item \texttt{SHUT\_OFF}---keyword for activating well shut off capability. Subsequent values define the minimum and maximum pumping rate that a well must exceed to shutoff or reactivate a well, respectively, during a stress period. SHUT\_OFF is only applied to injection wells (RATE$<0$) and if HEAD\_LIMIT is specified (not set to `OFF'). If HEAD\_LIMIT is specified, SHUT\_OFF can be deactivated by specifying a minimum value equal to zero. The SHUT\_OFF option is based on the SHUT\_OFF functionality available in the MNW2~\citep{konikow2009} package for MODFLOW-2005. The SHUT\_OFF option has been included to facilitate backward compatibility with previous versions of MODFLOW but use of the RATE\_SCALING option instead of the SHUT\_OFF option is recommended. By default, SHUT\_OFF is not used. \item \texttt{minrate}---is the minimum rate that a well must exceed to shutoff a well during a stress period. The well will shut down during a time step if the flow rate to the well from the aquifer is less than MINRATE. If a well is shut down during a time step, reactivation of the well cannot occur until the next time step to reduce oscillations. MINRATE must be less than maxrate. \item \texttt{maxrate}---is the maximum rate that a well must exceed to reactivate a well during a stress period. The well will reactivate during a timestep if the well was shutdown during the previous time step and the flow rate to the well from the aquifer exceeds maxrate. Reactivation of the well cannot occur until the next time step if a well is shutdown to reduce oscillations. maxrate must be greater than MINRATE. -\item \texttt{RATE\_SCALING}---activate rate scaling. If RATE\_SCALING is specified, both PUMP\_ELEVATION and SCALING\_LENGTH must be specified. RATE\_SCALING cannot be used with HEAD\_LIMIT. +\item \texttt{RATE\_SCALING}---activate rate scaling. If RATE\_SCALING is specified, both PUMP\_ELEVATION and SCALING\_LENGTH must be specified. RATE\_SCALING cannot be used with HEAD\_LIMIT. RATE\_SCALING can be used for extraction or injection wells. For extraction wells, the extraction rate will start to decrease once the head in the well lowers to a level equal to the pump elevation plus the scaling length. If the head in the well drops below the pump elevation, then the extraction rate is calculated to be zero. For an injection well, the injection rate will begin to decrease once the head in the well rises above the specified pump elevation. If the head in the well rises above the pump elevation plus the scaling length, then the injection rate will be set to zero. -\item \texttt{pump\_elevation}---is the elevation of the multi-aquifer well pump (PUMP\_ELEVATION). PUMP\_ELEVATION cannot be less than the bottom elevation (BOTTOM) of the multi-aquifer well. By default, PUMP\_ELEVATION is set equal to the bottom of the largest GWF node number connected to a MAW well. +\item \texttt{pump\_elevation}---is the elevation of the multi-aquifer well pump (PUMP\_ELEVATION). PUMP\_ELEVATION should not be less than the bottom elevation (BOTTOM) of the multi-aquifer well. -\item \texttt{scaling\_length}---height above the pump elevation (SCALING\_LENGTH) below which the pumping rate is reduced. The default value for SCALING\_LENGTH is the well radius. +\item \texttt{scaling\_length}---height above the pump elevation (SCALING\_LENGTH). If the simulated well head is below this elevation (pump elevation plus the scaling length), then the pumping rate is reduced. \item \texttt{AUXILIARY}---keyword for specifying auxiliary variable. diff --git a/doc/mf6io/mf6ivar/tex/gwf-npf-desc.tex b/doc/mf6io/mf6ivar/tex/gwf-npf-desc.tex index 37e572ac061..e188b71d686 100644 --- a/doc/mf6io/mf6ivar/tex/gwf-npf-desc.tex +++ b/doc/mf6io/mf6ivar/tex/gwf-npf-desc.tex @@ -3,7 +3,7 @@ \item \textbf{Block: OPTIONS} \begin{description} -\item \texttt{SAVE\_FLOWS}---keyword to indicate that cell-by-cell flow terms will be written to the file specified with ``BUDGET SAVE FILE'' in Output Control. +\item \texttt{SAVE\_FLOWS}---keyword to indicate that budget flow terms will be written to the file specified with ``BUDGET SAVE FILE'' in Output Control. \item \texttt{alternative\_cell\_averaging}---is a text keyword to indicate that an alternative method will be used for calculating the conductance for horizontal cell connections. The text value for ALTERNATIVE\_CELL\_AVERAGING can be ``LOGARITHMIC'', ``AMT-LMK'', or ``AMT-HMK''. ``AMT-LMK'' signifies that the conductance will be calculated using arithmetic-mean thickness and logarithmic-mean hydraulic conductivity. ``AMT-HMK'' signifies that the conductance will be calculated using arithmetic-mean thickness and harmonic-mean hydraulic conductivity. If the user does not specify a value for ALTERNATIVE\_CELL\_AVERAGING, then the harmonic-mean method will be used. This option cannot be used if the XT3D option is invoked. @@ -27,7 +27,13 @@ \item \texttt{RHS}---If the RHS keyword is also included, then the XT3D additional terms will be added to the right-hand side. If the RHS keyword is excluded, then the XT3D terms will be put into the coefficient matrix. -\item \texttt{SAVE\_SPECIFIC\_DISCHARGE}---keyword to indicate that x, y, and z components of specific discharge will be calculated at cell centers and written to the cell-by-cell flow file, which is specified with ``BUDGET SAVE FILE'' in Output Control. +\item \texttt{SAVE\_SPECIFIC\_DISCHARGE}---keyword to indicate that x, y, and z components of specific discharge will be calculated at cell centers and written to the budget file, which is specified with ``BUDGET SAVE FILE'' in Output Control. If this option is activated, then additional information may be required in the discretization packages and the GWF Exchange package (if GWF models are coupled). Specifically, ANGLDEGX must be specified in the CONNECTIONDATA block of the DISU Package; ANGLDEGX must also be specified for the GWF Exchange as an auxiliary variable. + +\item \texttt{SAVE\_SATURATION}---keyword to indicate that cell saturation will be written to the budget file, which is specified with ``BUDGET SAVE FILE'' in Output Control. Saturation will be saved to the budget file as an auxiliary variable saved with the DATA-SAT text label. Saturation is a cell variable that ranges from zero to one and can be used by post processing programs to determine how much of a cell volume is saturated. If ICELLTYPE is 0, then saturation is always one. + +\item \texttt{K22OVERK}---keyword to indicate that specified K22 is a ratio of K22 divided by K. If this option is specified, then the K22 array entered in the NPF Package will be multiplied by K after being read. + +\item \texttt{K33OVERK}---keyword to indicate that specified K33 is a ratio of K33 divided by K. If this option is specified, then the K33 array entered in the NPF Package will be multiplied by K after being read. \item \texttt{VKD6}---keyword to specify that record corresponds to a vkd file. @@ -43,9 +49,9 @@ \item \texttt{k}---is the hydraulic conductivity. For the common case in which the user would like to specify the horizontal hydraulic conductivity and the vertical hydraulic conductivity, then K should be assigned as the horizontal hydraulic conductivity, K33 should be assigned as the vertical hydraulic conductivity, and texttt{K22} and the three rotation angles should not be specified. When more sophisticated anisotropy is required, then K corresponds to the K11 hydraulic conductivity axis. All included cells (IDOMAIN $>$ 0) must have a K value greater than zero. -\item \texttt{k22}---is the hydraulic conductivity of the second ellipsoid axis; for an unrotated case this is the hydraulic conductivity in the y direction. If K22 is not included in the GRIDDATA block, then K22 is set equal to K. For a regular MODFLOW grid (DIS Package is used) in which no rotation angles are specified, K22 is the hydraulic conductivity along columns in the y direction. For an unstructured DISU grid, the user must assign principal x and y axes and provide the angle for each cell face relative to the assigned x direction. All included cells (IDOMAIN $>$ 0) must have a K22 value greater than zero. +\item \texttt{k22}---is the hydraulic conductivity of the second ellipsoid axis (or the ratio of K22/K if the K22OVERK option is specified); for an unrotated case this is the hydraulic conductivity in the y direction. If K22 is not included in the GRIDDATA block, then K22 is set equal to K. For a regular MODFLOW grid (DIS Package is used) in which no rotation angles are specified, K22 is the hydraulic conductivity along columns in the y direction. For an unstructured DISU grid, the user must assign principal x and y axes and provide the angle for each cell face relative to the assigned x direction. All included cells (IDOMAIN $>$ 0) must have a K22 value greater than zero. -\item \texttt{k33}---is the hydraulic conductivity of the third ellipsoid axis; for an unrotated case, this is the vertical hydraulic conductivity. When anisotropy is applied, K33 corresponds to the K33 tensor component. All included cells (IDOMAIN $>$ 0) must have a K33 value greater than zero. +\item \texttt{k33}---is the hydraulic conductivity of the third ellipsoid axis (or the ratio of K33/K if the K33OVERK option is specified); for an unrotated case, this is the vertical hydraulic conductivity. When anisotropy is applied, K33 corresponds to the K33 tensor component. All included cells (IDOMAIN $>$ 0) must have a K33 value greater than zero. \item \texttt{angle1}---is a rotation angle of the hydraulic conductivity tensor in degrees. The angle represents the first of three sequential rotations of the hydraulic conductivity ellipsoid. With the K11, K22, and K33 axes of the ellipsoid initially aligned with the x, y, and z coordinate axes, respectively, ANGLE1 rotates the ellipsoid about its K33 axis (within the x - y plane). A positive value represents counter-clockwise rotation when viewed from any point on the positive K33 axis, looking toward the center of the ellipsoid. A value of zero indicates that the K11 axis lies within the x - z plane. If ANGLE1 is not specified, default values of zero are assigned to ANGLE1, ANGLE2, and ANGLE3, in which case the K11, K22, and K33 axes are aligned with the x, y, and z axes, respectively. diff --git a/doc/mf6io/mf6ivar/tex/gwf-npf-options.dat b/doc/mf6io/mf6ivar/tex/gwf-npf-options.dat index f0eaf1942bf..c2a4907252c 100644 --- a/doc/mf6io/mf6ivar/tex/gwf-npf-options.dat +++ b/doc/mf6io/mf6ivar/tex/gwf-npf-options.dat @@ -7,5 +7,8 @@ BEGIN OPTIONS [REWET WETFCT IWETIT IHDWET ] [XT3D [RHS]] [SAVE_SPECIFIC_DISCHARGE] + [SAVE_SATURATION] + [K22OVERK] + [K33OVERK] [VKD6 FILEIN ] END OPTIONS diff --git a/doc/mf6io/mf6ivar/tex/gwf-rch-desc.tex b/doc/mf6io/mf6ivar/tex/gwf-rch-desc.tex index 7942d917a90..b746d61c115 100644 --- a/doc/mf6io/mf6ivar/tex/gwf-rch-desc.tex +++ b/doc/mf6io/mf6ivar/tex/gwf-rch-desc.tex @@ -41,7 +41,7 @@ \item \texttt{cellid}---is the cell identifier, and depends on the type of grid that is used for the simulation. For a structured grid that uses the DIS input file, CELLID is the layer, row, and column. For a grid that uses the DISV input file, CELLID is the layer and CELL2D number. If the model uses the unstructured discretization (DISU) input file, CELLID is the node number for the cell. -\item \textcolor{blue}{\texttt{recharge}---is the recharge flux rate ($LT^{-1}$). This rate is multiplied inside the program by the surface area of the cell to calculate the volumetric recharge rate. A time-series name may be specified.} +\item \textcolor{blue}{\texttt{recharge}---is the recharge flux rate ($LT^{-1}$). This rate is multiplied inside the program by the surface area of the cell to calculate the volumetric recharge rate. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} \item \textcolor{blue}{\texttt{aux}---represents the values of the auxiliary variables for each recharge. The values of auxiliary variables must be present for each recharge. The values must be specified in the order of the auxiliary variables specified in the OPTIONS block. If the package supports time series and the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} diff --git a/doc/mf6io/mf6ivar/tex/gwf-sfr-desc.tex b/doc/mf6io/mf6ivar/tex/gwf-sfr-desc.tex index 0b70e010761..506a2d2caaa 100644 --- a/doc/mf6io/mf6ivar/tex/gwf-sfr-desc.tex +++ b/doc/mf6io/mf6ivar/tex/gwf-sfr-desc.tex @@ -25,6 +25,10 @@ \item \texttt{budgetfile}---name of the binary output file to write budget information. +\item \texttt{PACKAGE\_CONVERGENCE}---keyword to specify that record corresponds to the package convergence comma spaced values file. + +\item \texttt{package\_convergence\_filename}---name of the comma spaced values output file to write package convergence information. + \item \texttt{TS6}---keyword to specify that record corresponds to a time-series file. \item \texttt{FILEIN}---keyword to specify that an input filename is expected next. @@ -37,7 +41,7 @@ \item \texttt{MOVER}---keyword to indicate that this instance of the SFR Package can be used with the Water Mover (MVR) Package. When the MOVER option is specified, additional memory is allocated within the package to store the available, provided, and received water. -\item \texttt{maximum\_iterations}---value that defines an maximum number of Streamflow Routing Newton-Raphson iterations allowed for a reach. By default, MAXSFRIT is equal to 100. +\item \texttt{maximum\_iterations}---value that defines the maximum number of Streamflow Routing Newton-Raphson iterations allowed for a reach. By default, MAXSFRIT is equal to 100. \item \texttt{maximum\_depth\_change}---value that defines the depth closure tolerance. By default, DMAXCHG is equal to $1 \times 10^{-5}$. @@ -119,12 +123,12 @@ RAINFALL <@rainfall@> EVAPORATION <@evaporation@> RUNOFF <@runoff@> -DIVERSION <@divrate@> +DIVERSION <@divflow@> UPSTREAM_FRACTION AUXILIARY <@auxval@> \end{lstlisting} -\item \texttt{status}---keyword option to define stream reach status. STATUS can be ACTIVE, INACTIVE, or SIMPLE. The SIMPLE STATUS option simulates streamflow using a user-specified stage for a reach or a stage set to the top of the reach (depth = 0). In cases where the simulated leakage calculated using the specified stage exceeds the sum of inflows to the reach, the stage is set to the top of the reach and leakage is set equal to the sum of inflows. Upstream factions should be changed using the UPSTREAM\_FRACTION SFRSETTING if the status for one or more reaches is changed to ACTIVE or INACTIVE. For example, if one of two downstream connections for a reach is inactivated, the upstream fraction for the active and inactive downstream reach should be changed to 1.0 and 0.0, respectively, to ensure that the active reach receives all of the downstream outflow from the upstream reach. By default, STATUS is ACTIVE. +\item \texttt{status}---keyword option to define stream reach status. STATUS can be ACTIVE, INACTIVE, or SIMPLE. The SIMPLE STATUS option simulates streamflow using a user-specified stage for a reach or a stage set to the top of the reach (depth = 0). In cases where the simulated leakage calculated using the specified stage exceeds the sum of inflows to the reach, the stage is set to the top of the reach and leakage is set equal to the sum of inflows. Upstream fractions should be changed using the UPSTREAM\_FRACTION SFRSETTING if the status for one or more reaches is changed to ACTIVE or INACTIVE. For example, if one of two downstream connections for a reach is inactivated, the upstream fraction for the active and inactive downstream reach should be changed to 1.0 and 0.0, respectively, to ensure that the active reach receives all of the downstream outflow from the upstream reach. By default, STATUS is ACTIVE. \item \textcolor{blue}{\texttt{manning}---real or character value that defines the Manning's roughness coefficient for the reach. MANNING must be greater than zero. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} @@ -142,7 +146,7 @@ \item \texttt{idv}---diversion number. -\item \textcolor{blue}{\texttt{divrate}---real or character value that defines the volumetric diversion (DIVFLOW) rate for the streamflow routing reach. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} +\item \textcolor{blue}{\texttt{divflow}---real or character value that defines the volumetric diversion (DIVFLOW) rate for the streamflow routing reach. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} \item \texttt{upstream\_fraction}---real value that defines the fraction of upstream flow (USTRF) from each upstream reach that is applied as upstream inflow to the reach. The sum of all USTRF values for all reaches connected to the same upstream reach must be equal to one. diff --git a/doc/mf6io/mf6ivar/tex/gwf-sfr-options.dat b/doc/mf6io/mf6ivar/tex/gwf-sfr-options.dat index 3510df9f757..a9855b166e0 100644 --- a/doc/mf6io/mf6ivar/tex/gwf-sfr-options.dat +++ b/doc/mf6io/mf6ivar/tex/gwf-sfr-options.dat @@ -7,6 +7,7 @@ BEGIN OPTIONS [SAVE_FLOWS] [STAGE FILEOUT ] [BUDGET FILEOUT ] + [PACKAGE_CONVERGENCE FILEOUT ] [TS6 FILEIN ] [OBS6 FILEIN ] [MOVER] diff --git a/doc/mf6io/mf6ivar/tex/gwf-sto-desc.tex b/doc/mf6io/mf6ivar/tex/gwf-sto-desc.tex index 71ceeab5621..dd0f4e2aa0a 100644 --- a/doc/mf6io/mf6ivar/tex/gwf-sto-desc.tex +++ b/doc/mf6io/mf6ivar/tex/gwf-sto-desc.tex @@ -13,7 +13,7 @@ \begin{description} \item \texttt{iconvert}---is a flag for each cell that specifies whether or not a cell is convertible for the storage calculation. 0 indicates confined storage is used. $>$0 indicates confined storage is used when head is above cell top and a mixed formulation of unconfined and confined storage is used when head is below cell top. -\item \texttt{ss}---is specific storage (or the storage coefficient if STORAGECOEFFICIENT is specified as an option). Specific storage values must be greater than or equal to 0. +\item \texttt{ss}---is specific storage (or the storage coefficient if STORAGECOEFFICIENT is specified as an option). Specific storage values must be greater than or equal to 0. If the CSUB Package is included in the GWF model, specific storage must be zero for every cell. \item \texttt{sy}---is specific yield. Specific yield values must be greater than or equal to 0. Specific yield does not have to be specified if there are no convertible cells (ICONVERT=0 in every cell). @@ -23,9 +23,9 @@ \begin{description} \item \texttt{iper}---integer value specifying the starting stress period number for which the data specified in the PERIOD block apply. IPER must be less than or equal to NPER in the TDIS Package and greater than zero. The IPER value assigned to a stress period block must be greater than the IPER value assigned for the previous PERIOD block. The information specified in the PERIOD block will continue to apply for all subsequent stress periods, unless the program encounters another PERIOD block. -\item \texttt{STEADY-STATE}---keyword to indicate that stress-period IPER is steady-state. Steady-state conditions will apply until the TRANSIENT keyword is specified in a subsequent BEGIN PERIOD block. +\item \texttt{STEADY-STATE}---keyword to indicate that stress period IPER is steady-state. Steady-state conditions will apply until the TRANSIENT keyword is specified in a subsequent BEGIN PERIOD block. If the CSUB Package is included in the GWF model, only the first and last stress period can be steady-state. -\item \texttt{TRANSIENT}---keyword to indicate that stress-period IPER is transient. Transient conditions will apply until the STEADY-STATE keyword is specified in a subsequent BEGIN PERIOD block. +\item \texttt{TRANSIENT}---keyword to indicate that stress period IPER is transient. Transient conditions will apply until the STEADY-STATE keyword is specified in a subsequent BEGIN PERIOD block. \end{description} diff --git a/doc/mf6io/mf6ivar/tex/gwf-uzf-desc.tex b/doc/mf6io/mf6ivar/tex/gwf-uzf-desc.tex index 4236ec9bfcb..8847cb70723 100644 --- a/doc/mf6io/mf6ivar/tex/gwf-uzf-desc.tex +++ b/doc/mf6io/mf6ivar/tex/gwf-uzf-desc.tex @@ -21,6 +21,10 @@ \item \texttt{budgetfile}---name of the binary output file to write budget information. +\item \texttt{PACKAGE\_CONVERGENCE}---keyword to specify that record corresponds to the package convergence comma spaced values file. + +\item \texttt{package\_convergence\_filename}---name of the comma spaced values output file to write package convergence information. + \item \texttt{TS6}---keyword to specify that record corresponds to a time-series file. \item \texttt{FILEIN}---keyword to specify that an input filename is expected next. @@ -33,7 +37,7 @@ \item \texttt{MOVER}---keyword to indicate that this instance of the UZF Package can be used with the Water Mover (MVR) Package. When the MOVER option is specified, additional memory is allocated within the package to store the available, provided, and received water. -\item \texttt{SIMULATE\_ET}---keyword specifying that ET in the unsaturated (UZF) and saturated zones (GWF) will be simulated. ET can be simulated in the UZF cell and not the GWF cell by emitting keywords LINEAR\_GWET and SQUARE\_GWET. +\item \texttt{SIMULATE\_ET}---keyword specifying that ET in the unsaturated (UZF) and saturated zones (GWF) will be simulated. ET can be simulated in the UZF cell and not the GWF cell by omitting keywords LINEAR\_GWET and SQUARE\_GWET. \item \texttt{LINEAR\_GWET}---keyword specifying that groundwater ET will be simulated using the original ET formulation of MODFLOW-2005. @@ -49,11 +53,11 @@ \item \textbf{Block: DIMENSIONS} \begin{description} -\item \texttt{nuzfcells}---is the number of UZF cells. More than 1 UZF cell can be assigned to a GWF cell; however, only 1 GWF cell can be assigned to a single UZF cell. If the MULTILAYER option is used then UZF cells can be assigned to GWF cells below (in deeper layers than) the upper most active GWF cells. +\item \texttt{nuzfcells}---is the number of UZF cells. More than one UZF cell can be assigned to a GWF cell; however, only one GWF cell can be assigned to a single UZF cell. If more than one UZF cell is assigned to a GWF cell, then an auxiliary variable should be used to reduce the surface area of the UZF cell with the AUXMULTNAME option. -\item \texttt{ntrailwaves}---is the number of trailing waves. NTRAILWAVES has a default value of 7 and can be increased to lower mass balance error in the unsaturated zone. +\item \texttt{ntrailwaves}---is the number of trailing waves. A recommended value of 7 can be used for NTRAILWAVES. This value can be increased to lower mass balance error in the unsaturated zone. -\item \texttt{nwavesets}---is the number of UZF cells specified. NWAVSETS has a default value of 40 and can be increased if more waves are required to resolve variations in water content within the unsaturated zone. +\item \texttt{nwavesets}---is the number of wave sets. A recommended value of 40 can be used for NWAVESETS. This value can be increased if more waves are required to resolve variations in water content within the unsaturated zone. \end{description} \item \textbf{Block: PACKAGEDATA} @@ -65,7 +69,7 @@ \item \texttt{landflag}---integer value set to one for land surface cells indicating that boundary conditions can be applied and data can be specified in the PERIOD block. A value of 0 specifies a non-land surface cell. -\item \texttt{ivertcon}---integer value set to specify underlying UZF cell that receives water flowing to bottom of cell. If unsaturated zone flow reaches water table before the cell bottom then water is added to GWF cell instead of flowing to underlying UZF cell. A value of 0 indicates the UZF cell is not connected to an underlying UZF cell. +\item \texttt{ivertcon}---integer value set to specify underlying UZF cell that receives water flowing to bottom of cell. If unsaturated zone flow reaches the water table before the cell bottom, then water is added to the GWF cell instead of flowing to the underlying UZF cell. A value of 0 indicates the UZF cell is not connected to an underlying UZF cell. \item \texttt{surfdep}---is the surface depression depth of the UZF cell. diff --git a/doc/mf6io/mf6ivar/tex/gwf-uzf-options.dat b/doc/mf6io/mf6ivar/tex/gwf-uzf-options.dat index cfc7b57d172..26ac2b98fc9 100644 --- a/doc/mf6io/mf6ivar/tex/gwf-uzf-options.dat +++ b/doc/mf6io/mf6ivar/tex/gwf-uzf-options.dat @@ -6,6 +6,7 @@ BEGIN OPTIONS [PRINT_FLOWS] [SAVE_FLOWS] [BUDGET FILEOUT ] + [PACKAGE_CONVERGENCE FILEOUT ] [TS6 FILEIN ] [OBS6 FILEIN ] [MOVER] diff --git a/doc/mf6io/mf6ivar/tex/sim-nam-desc.tex b/doc/mf6io/mf6ivar/tex/sim-nam-desc.tex index b6e9776f500..3efe21201c4 100644 --- a/doc/mf6io/mf6ivar/tex/sim-nam-desc.tex +++ b/doc/mf6io/mf6ivar/tex/sim-nam-desc.tex @@ -9,6 +9,8 @@ \item \texttt{memory\_print\_option}---is a flag that controls printing of detailed memory manager usage to the end of the simulation list file. NONE means do not print detailed information. SUMMARY means print only the total memory for each simulation component. ALL means print information for each variable stored in the memory manager. NONE is default if MEMORY\_PRINT\_OPTION is not specified. +\item \texttt{maxerrors}---maximum number of errors that will be stored and printed. + \end{description} \item \textbf{Block: TIMING} diff --git a/doc/mf6io/mf6ivar/tex/sim-nam-options.dat b/doc/mf6io/mf6ivar/tex/sim-nam-options.dat index 183a995112a..5f007b32f0d 100644 --- a/doc/mf6io/mf6ivar/tex/sim-nam-options.dat +++ b/doc/mf6io/mf6ivar/tex/sim-nam-options.dat @@ -2,4 +2,5 @@ BEGIN OPTIONS [CONTINUE] [NOCHECK] [MEMORY_PRINT_OPTION ] + [MAXERRORS ] END OPTIONS diff --git a/doc/mf6io/mf6ivar/tex/sln-ims-desc.tex b/doc/mf6io/mf6ivar/tex/sln-ims-desc.tex index 0489fd03c16..cb616cb360a 100644 --- a/doc/mf6io/mf6ivar/tex/sln-ims-desc.tex +++ b/doc/mf6io/mf6ivar/tex/sln-ims-desc.tex @@ -13,6 +13,10 @@ \item \texttt{csvfile}---name of the ascii comma separated values output file to write solver convergence information. If PRINT\_OPTION is NONE or SUMMARY, comma separated values output includes maximum head change convergence information at the end of each outer iteration for each time step. If PRINT\_OPTION is ALL, comma separated values output includes maximum head change and maximum residual convergence information for the solution and each model (if the solution includes more than one model) and linear acceleration information for each inner iteration. +\item \texttt{NO\_PTC}---is a flag that is used to disable pseudo-transient continuation (PTC). Option only applies to steady-state stress periods for models using the Newton-Raphson formulation. For many problems, PTC can significantly improve convergence behavior for steady-state simulations, and for this reason it is active by default. In some cases, however, PTC can worsen the convergence behavior, especially when the initial conditions are similar to the solution. When the initial conditions are similar to, or exactly the same as, the solution and convergence is slow, then the NO\_PTC FIRST option should be used to deactivate PTC for the first stress period. The NO\_PTC ALL option should also be used in order to compare convergence behavior with other MODFLOW versions, as PTC is only available in MODFLOW 6. + +\item \texttt{no\_ptc\_option}---is an optional keyword that is used to define options for disabling pseudo-transient continuation (PTC). FIRST is an optional keyword to disable PTC for the first stress period, if steady-state and one or more model is using the Newton-Raphson formulation. ALL is an optional keyword to disable PTC for all steady-state stress periods for models using the Newton-Raphson formulation. If NO\_PTC\_OPTION is not specified, the NO\_PTC ALL option is used. + \end{description} \item \textbf{Block: NONLINEAR} diff --git a/doc/mf6io/mf6ivar/tex/sln-ims-options.dat b/doc/mf6io/mf6ivar/tex/sln-ims-options.dat index d9a6656f470..d95375a3d7d 100644 --- a/doc/mf6io/mf6ivar/tex/sln-ims-options.dat +++ b/doc/mf6io/mf6ivar/tex/sln-ims-options.dat @@ -2,4 +2,5 @@ BEGIN OPTIONS [PRINT_OPTION ] [COMPLEXITY ] [CSV_OUTPUT FILEOUT ] + [NO_PTC []] END OPTIONS diff --git a/doc/mf6io/mf6ivar/tex/utl-lak-tab-desc.tex b/doc/mf6io/mf6ivar/tex/utl-lak-tab-desc.tex index f5655f608b0..58db7dd7739 100644 --- a/doc/mf6io/mf6ivar/tex/utl-lak-tab-desc.tex +++ b/doc/mf6io/mf6ivar/tex/utl-lak-tab-desc.tex @@ -5,7 +5,7 @@ \begin{description} \item \texttt{nrow}---integer value specifying the number of rows in the lake table. There must be NROW rows of data in the TABLE block. -\item \texttt{ncol}---integer value specifying the number of colums in the lake table. There must be NCOL columns of data in the TABLE block. For lakes with HORIZONTAL and/or VERTICAL CTYPE connections, NCOL must be equal to 3. For lakes with EMBEDDEDH or EMBEDDEDV CTYPE connections, NCOL must be equal to 4. +\item \texttt{ncol}---integer value specifying the number of columns in the lake table. There must be NCOL columns of data in the TABLE block. For lakes with HORIZONTAL and/or VERTICAL CTYPE connections, NCOL must be equal to 3. For lakes with EMBEDDEDH or EMBEDDEDV CTYPE connections, NCOL must be equal to 4. \end{description} \item \textbf{Block: TABLE} diff --git a/doc/mf6io/mf6ivar/tex/utl-obs-desc.tex b/doc/mf6io/mf6ivar/tex/utl-obs-desc.tex index da05d1b0dad..ad5ef163d58 100644 --- a/doc/mf6io/mf6ivar/tex/utl-obs-desc.tex +++ b/doc/mf6io/mf6ivar/tex/utl-obs-desc.tex @@ -3,8 +3,6 @@ \item \textbf{Block: OPTIONS} \begin{description} -\item \texttt{precision}---Keyword and precision specifier for output of binary data, which can be either SINGLE or DOUBLE. The default is DOUBLE. When simulated values are written to a file specified as file type DATA(BINARY) in the Name File, the precision specifier controls whether the data (including simulated values and, for continuous observations, time values) are written as single- or double-precision. - \item \texttt{digits}---Keyword and an integer digits specifier used for conversion of simulated values to text on output. The default is 5 digits. When simulated values are written to a file specified as file type DATA in the Name File, the digits specifier controls the number of significant digits with which simulated values are written to the output file. The digits specifier has no effect on the number of significant digits with which the simulation time is written for continuous observations. \item \texttt{PRINT\_INPUT}---keyword to indicate that the list of observation information will be written to the listing file immediately after it is read. diff --git a/doc/mf6io/mf6ivar/tex/utl-obs-options.dat b/doc/mf6io/mf6ivar/tex/utl-obs-options.dat index be7be854264..e5a078455b0 100644 --- a/doc/mf6io/mf6ivar/tex/utl-obs-options.dat +++ b/doc/mf6io/mf6ivar/tex/utl-obs-options.dat @@ -1,5 +1,4 @@ BEGIN OPTIONS - [PRECISION ] [DIGITS ] [PRINT_INPUT] END OPTIONS diff --git a/doc/mf6io/mf6noname.tex b/doc/mf6io/mf6noname.tex index c5eefd156dd..203aa812de8 100644 --- a/doc/mf6io/mf6noname.tex +++ b/doc/mf6io/mf6noname.tex @@ -4,6 +4,7 @@ ERROR REPORT: mf6.exe: mfsim.nam is not present in working directory. + 1 errors detected. Stopping due to error(s) 2 diff --git a/doc/mf6io/mf6output.tex b/doc/mf6io/mf6output.tex index c2a81d3d450..3a15ef3f1e9 100644 --- a/doc/mf6io/mf6output.tex +++ b/doc/mf6io/mf6output.tex @@ -2,9 +2,9 @@ \begin{lstlisting}[style=modeloutput] MODFLOW 6 U.S. GEOLOGICAL SURVEY MODULAR HYDROLOGIC MODEL - VERSION 6.0.3 08/09/2018 + VERSION 6.1.0 12/12/2019 - MODFLOW 6 compiled Aug 09 2018 13:40:32 with IFORT compiler (ver. 18.0.3) + MODFLOW 6 compiled Dec 12 2019 13:30:12 with IFORT compiler (ver. 19.0.5) This software has been approved for release by the U.S. Geological Survey (USGS). Although the software has been subjected to rigorous @@ -19,13 +19,13 @@ Resources Software User Rights Notice for complete use, copyright, and distribution information. - Run start date and time (yyyy/mm/dd hh:mm:ss): 2018/08/09 13:42:55 + Run start date and time (yyyy/mm/dd hh:mm:ss): 2019/12/12 13:32:39 Writing simulation list file: mfsim.lst Using Simulation name file: mfsim.nam Solving: Stress period: 1 Time step: 1 - Run end date and time (yyyy/mm/dd hh:mm:ss): 2018/08/09 13:42:55 - Elapsed run time: 0.125 Seconds + Run end date and time (yyyy/mm/dd hh:mm:ss): 2019/12/12 13:32:39 + Elapsed run time: 0.073 Seconds Normal termination of simulation. diff --git a/doc/mf6io/mf6switches.tex b/doc/mf6io/mf6switches.tex index 2051f8b8fca..1c72bd41bca 100644 --- a/doc/mf6io/mf6switches.tex +++ b/doc/mf6io/mf6switches.tex @@ -1,6 +1,6 @@ {\small \begin{lstlisting}[style=modeloutput] -mf6.exe - MODFLOW 6.0.3 08/09/2018 (compiled Aug 09 2018 13:40:32) +mf6.exe - MODFLOW 6.1.0 12/12/2019 (compiled Dec 12 2019 13:30:12) usage: mf6.exe run MODFLOW 6 using "mfsim.nam" or: mf6.exe [options] retrieve program information @@ -9,6 +9,7 @@ -v --version Display program version information. -dev --develop Display program develop option mode. -c --compiler Display compiler information. + -s --silent STDOUT output piped to mfsim.stdout file. Bug reporting and contributions are welcome from the community. Questions can be asked on the issues page[1]. Before creating a new diff --git a/doc/version.py b/doc/version.py index 255c03e77b4..09f98fe3041 100644 --- a/doc/version.py +++ b/doc/version.py @@ -2,8 +2,8 @@ # created on...February 22, 2018 10:50:04 major = 6 -minor = 0 -micro = 3 +minor = 1 +micro = 0 build = 0 commit = 0 diff --git a/doc/version.tex b/doc/version.tex index 1a62f9c512f..708573d2c7a 100644 --- a/doc/version.tex +++ b/doc/version.tex @@ -1,3 +1,3 @@ -\newcommand{\modflowversion}{mf6.0.3.8} -\newcommand{\modflowdate}{September 06, 2018} +\newcommand{\modflowversion}{mf6.1.1} +\newcommand{\modflowdate}{December 12, 2019} \newcommand{\currentmodflowversion}{Version \modflowversion---\modflowdate} diff --git a/hook_files.py b/hook_files.py index 631cb28ce52..c92fc748443 100644 --- a/hook_files.py +++ b/hook_files.py @@ -1,26 +1,26 @@ -#!/usr/bin/python - -import os - -# 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 - -if __name__ == "__main__": - for p, f in zip(paths, files): - if p == '.': - fpth = f - else: - fpth = os.path.join(p, f) - print('git hooks are modifying...{}'.format(fpth)) +#!/usr/bin/python + +import os + +# 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 + +if __name__ == "__main__": + for p, f in zip(paths, files): + if p == '.': + fpth = f + else: + fpth = os.path.join(p, f) + print('git hooks are modifying...{}'.format(fpth)) diff --git a/make/makefile b/make/makefile index d23963fbba6..cb434f1f73a 100644 --- a/make/makefile +++ b/make/makefile @@ -1,4 +1,4 @@ -# makefile created on 2018-08-09 13:40:29.002336 +# makefile created on 2019-12-12 13:30:06.459304 # by pymake (version 1.1.0) # using the gfortran fortran and gcc c/c++ compilers. @@ -47,103 +47,105 @@ FFLAGS = -O2 -fbacktrace # Define the C compile flags CC = gcc -CFLAGS = -O3 -D_UF +CFLAGS = -O2 -D_UF # Define the libraries SYSLIBS = OBJECTS = \ $(OBJDIR)/kind.o \ -$(OBJDIR)/HashTable.o \ $(OBJDIR)/version.o \ +$(OBJDIR)/BaseGeometry.o \ +$(OBJDIR)/Xt3dAlgorithm.o \ +$(OBJDIR)/ims8reordering.o \ $(OBJDIR)/Constants.o \ -$(OBJDIR)/compilerversion.o \ -$(OBJDIR)/OpenSpec.o \ -$(OBJDIR)/SmoothingFunctions.o \ +$(OBJDIR)/List.o \ $(OBJDIR)/SimVariables.o \ $(OBJDIR)/Timer.o \ -$(OBJDIR)/List.o \ -$(OBJDIR)/Sparse.o \ -$(OBJDIR)/Xt3dAlgorithm.o \ -$(OBJDIR)/BaseGeometry.o \ -$(OBJDIR)/Memory.o \ -$(OBJDIR)/ims8reordering.o \ -$(OBJDIR)/mf6lists.o \ -$(OBJDIR)/ObsOutput.o \ -$(OBJDIR)/ArrayHandlers.o \ +$(OBJDIR)/HashTable.o \ +$(OBJDIR)/genericutils.o \ $(OBJDIR)/StringList.o \ -$(OBJDIR)/TimeSeriesRecord.o \ +$(OBJDIR)/OpenSpec.o \ +$(OBJDIR)/Memory.o \ $(OBJDIR)/MemoryList.o \ +$(OBJDIR)/ArrayHandlers.o \ $(OBJDIR)/Sim.o \ +$(OBJDIR)/compilerversion.o \ +$(OBJDIR)/Budget.o \ +$(OBJDIR)/SmoothingFunctions.o \ +$(OBJDIR)/TimeSeriesRecord.o \ +$(OBJDIR)/mf6lists.o \ +$(OBJDIR)/ObsOutput.o \ +$(OBJDIR)/sort.o \ +$(OBJDIR)/Sparse.o \ $(OBJDIR)/Iunit.o \ $(OBJDIR)/InputOutput.o \ -$(OBJDIR)/RectangularChGeometry.o \ +$(OBJDIR)/ObsOutputList.o \ +$(OBJDIR)/PrintSaveManager.o \ +$(OBJDIR)/CircularGeometry.o \ +$(OBJDIR)/RectangularGeometry.o \ $(OBJDIR)/ArrayReaders.o \ +$(OBJDIR)/DisvGeom.o \ +$(OBJDIR)/MemoryManager.o \ $(OBJDIR)/ListReader.o \ -$(OBJDIR)/RectangularGeometry.o \ -$(OBJDIR)/sort.o \ +$(OBJDIR)/RectangularChGeometry.o \ $(OBJDIR)/BlockParser.o \ -$(OBJDIR)/Budget.o \ -$(OBJDIR)/PrintSaveManager.o \ -$(OBJDIR)/MemoryManager.o \ -$(OBJDIR)/ObsOutputList.o \ -$(OBJDIR)/ims8linear.o \ -$(OBJDIR)/CircularGeometry.o \ $(OBJDIR)/comarg.o \ -$(OBJDIR)/DisvGeom.o \ -$(OBJDIR)/TimeSeries.o \ -$(OBJDIR)/Mover.o \ -$(OBJDIR)/Connections.o \ -$(OBJDIR)/TimeSeriesLink.o \ -$(OBJDIR)/BaseModel.o \ -$(OBJDIR)/PackageMover.o \ $(OBJDIR)/NameFile.o \ $(OBJDIR)/tdis.o \ -$(OBJDIR)/BndUzfKinematic.o \ +$(OBJDIR)/Connections.o \ +$(OBJDIR)/PackageMover.o \ +$(OBJDIR)/ims8linear.o \ +$(OBJDIR)/TimeSeries.o \ $(OBJDIR)/TimeSeriesFileList.o \ -$(OBJDIR)/BaseSolution.o \ +$(OBJDIR)/BaseModel.o \ +$(OBJDIR)/Mover.o \ +$(OBJDIR)/UzfCellGroup.o \ +$(OBJDIR)/TimeSeriesLink.o \ $(OBJDIR)/TimeSeriesManager.o \ +$(OBJDIR)/BaseSolution.o \ $(OBJDIR)/SolutionGroup.o \ -$(OBJDIR)/BaseExchange.o \ $(OBJDIR)/DiscretizationBase.o \ -$(OBJDIR)/NumericalPackage.o \ -$(OBJDIR)/OutputControlData.o \ -$(OBJDIR)/gwf3sto8.o \ $(OBJDIR)/Xt3dInterface.o \ -$(OBJDIR)/OutputControl.o \ -$(OBJDIR)/gwf3mvr8.o \ -$(OBJDIR)/gwf3oc8.o \ -$(OBJDIR)/gwf3ic8.o \ -$(OBJDIR)/gwf3dis8.o \ -$(OBJDIR)/gwf3disu8.o \ -$(OBJDIR)/gwf3disv8.o \ -$(OBJDIR)/Observe.o \ $(OBJDIR)/TimeArray.o \ -$(OBJDIR)/ObsContainer.o \ -$(OBJDIR)/gwf3hfb8.o \ -$(OBJDIR)/gwf3npf8.o \ +$(OBJDIR)/gwf3disu8.o \ $(OBJDIR)/TimeArraySeries.o \ +$(OBJDIR)/Observe.o \ +$(OBJDIR)/TimeArraySeriesLink.o \ +$(OBJDIR)/NumericalPackage.o \ +$(OBJDIR)/gwf3ic8.o \ $(OBJDIR)/ObsUtility.o \ +$(OBJDIR)/gwf3sto8.o \ +$(OBJDIR)/ObsContainer.o \ +$(OBJDIR)/BaseExchange.o \ $(OBJDIR)/Obs3.o \ -$(OBJDIR)/gwf3obs8.o \ -$(OBJDIR)/TimeArraySeriesLink.o \ +$(OBJDIR)/OutputControlData.o \ +$(OBJDIR)/gwf3disv8.o \ +$(OBJDIR)/gwf3dis8.o \ +$(OBJDIR)/gwf3csub8.o \ $(OBJDIR)/TimeArraySeriesManager.o \ +$(OBJDIR)/gwf3npf8.o \ +$(OBJDIR)/gwf3obs8.o \ +$(OBJDIR)/OutputControl.o \ +$(OBJDIR)/gwf3mvr8.o \ +$(OBJDIR)/gwf3hfb8.o \ +$(OBJDIR)/gwf3oc8.o \ $(OBJDIR)/BoundaryPackage.o \ -$(OBJDIR)/gwf3maw8.o \ -$(OBJDIR)/gwf3rch8.o \ -$(OBJDIR)/gwf3wel8.o \ $(OBJDIR)/gwf3sfr8.o \ +$(OBJDIR)/gwf3riv8.o \ +$(OBJDIR)/gwf3ghb8.o \ +$(OBJDIR)/gwf3uzf8.o \ $(OBJDIR)/gwf3chd8.o \ +$(OBJDIR)/gwf3lak8.o \ $(OBJDIR)/gwf3drn8.o \ -$(OBJDIR)/gwf3ghb8.o \ +$(OBJDIR)/gwf3wel8.o \ $(OBJDIR)/NumericalModel.o \ $(OBJDIR)/gwf3evt8.o \ -$(OBJDIR)/gwf3lak8.o \ -$(OBJDIR)/gwf3riv8.o \ -$(OBJDIR)/gwf3uzf8.o \ +$(OBJDIR)/gwf3maw8.o \ +$(OBJDIR)/gwf3rch8.o \ $(OBJDIR)/NumericalExchange.o \ -$(OBJDIR)/GhostNode.o \ $(OBJDIR)/NumericalSolution.o \ +$(OBJDIR)/GhostNode.o \ $(OBJDIR)/gwf3.o \ $(OBJDIR)/GwfGwfExchange.o \ $(OBJDIR)/SimulationCreate.o \ diff --git a/msvs/mf6.sln b/msvs/mf6.sln index 14c7d732dae..33cc6bcd9d8 100644 --- a/msvs/mf6.sln +++ b/msvs/mf6.sln @@ -1,32 +1,54 @@ - -Microsoft Visual Studio Solution File, Format Version 12.00 -# Visual Studio 2012 -Project("{6989167D-11E4-40FE-8C1A-2192A86A7E90}") = "mf6", "mf6.vfproj", "{369C1E2E-A513-4E83-A076-923534E30304}" -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 - {369C1E2E-A513-4E83-A076-923534E30304}.Debug|Win32.ActiveCfg = Debug|Win32 - {369C1E2E-A513-4E83-A076-923534E30304}.Debug|Win32.Build.0 = Debug|Win32 - {369C1E2E-A513-4E83-A076-923534E30304}.Debug|x64.ActiveCfg = Debug|x64 - {369C1E2E-A513-4E83-A076-923534E30304}.Debug|x64.Build.0 = Debug|x64 - {369C1E2E-A513-4E83-A076-923534E30304}.Profile|Win32.ActiveCfg = Profile|x64 - {369C1E2E-A513-4E83-A076-923534E30304}.Profile|Win32.Build.0 = Profile|x64 - {369C1E2E-A513-4E83-A076-923534E30304}.Profile|x64.ActiveCfg = Profile|x64 - {369C1E2E-A513-4E83-A076-923534E30304}.Profile|x64.Build.0 = Profile|x64 - {369C1E2E-A513-4E83-A076-923534E30304}.Release|Win32.ActiveCfg = Release|x64 - {369C1E2E-A513-4E83-A076-923534E30304}.Release|Win32.Build.0 = Release|x64 - {369C1E2E-A513-4E83-A076-923534E30304}.Release|x64.ActiveCfg = Release|x64 - {369C1E2E-A513-4E83-A076-923534E30304}.Release|x64.Build.0 = Release|x64 - EndGlobalSection - GlobalSection(SolutionProperties) = preSolution - HideSolutionNode = FALSE - 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}") = "mf6", "mf6.vfproj", "{369C1E2E-A513-4E83-A076-923534E30304}" + ProjectSection(ProjectDependencies) = postProject + {380139B4-29CE-4CF3-BD74-5AA979FD0F43} = {380139B4-29CE-4CF3-BD74-5AA979FD0F43} + EndProjectSection +EndProject +Project("{6989167D-11E4-40FE-8C1A-2192A86A7E90}") = "mf6core", "mf6core.vfproj", "{380139B4-29CE-4CF3-BD74-5AA979FD0F43}" +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 + {369C1E2E-A513-4E83-A076-923534E30304}.Debug|Win32.ActiveCfg = Debug|Win32 + {369C1E2E-A513-4E83-A076-923534E30304}.Debug|Win32.Build.0 = Debug|Win32 + {369C1E2E-A513-4E83-A076-923534E30304}.Debug|x64.ActiveCfg = Debug|x64 + {369C1E2E-A513-4E83-A076-923534E30304}.Debug|x64.Build.0 = Debug|x64 + {369C1E2E-A513-4E83-A076-923534E30304}.Profile|Win32.ActiveCfg = Profile|x64 + {369C1E2E-A513-4E83-A076-923534E30304}.Profile|Win32.Build.0 = Profile|x64 + {369C1E2E-A513-4E83-A076-923534E30304}.Profile|x64.ActiveCfg = Profile|x64 + {369C1E2E-A513-4E83-A076-923534E30304}.Profile|x64.Build.0 = Profile|x64 + {369C1E2E-A513-4E83-A076-923534E30304}.Release|Win32.ActiveCfg = Release|x64 + {369C1E2E-A513-4E83-A076-923534E30304}.Release|Win32.Build.0 = Release|x64 + {369C1E2E-A513-4E83-A076-923534E30304}.Release|x64.ActiveCfg = Release|x64 + {369C1E2E-A513-4E83-A076-923534E30304}.Release|x64.Build.0 = Release|x64 + {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 + EndGlobalSection + GlobalSection(SolutionProperties) = preSolution + HideSolutionNode = FALSE + EndGlobalSection + GlobalSection(ExtensibilityGlobals) = postSolution + SolutionGuid = {A077BEB2-AC7C-4B3D-AC89-2F6B4A677AF2} + EndGlobalSection +EndGlobal diff --git a/msvs/mf6.vfproj b/msvs/mf6.vfproj index 9172c179b9e..a686331b261 100644 --- a/msvs/mf6.vfproj +++ b/msvs/mf6.vfproj @@ -1,181 +1,72 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/msvs/mf6bmi.sln b/msvs/mf6bmi.sln new file mode 100644 index 00000000000..3056cb4478e --- /dev/null +++ b/msvs/mf6bmi.sln @@ -0,0 +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 diff --git a/msvs/mf6bmi.vfproj b/msvs/mf6bmi.vfproj new file mode 100644 index 00000000000..f21120a60de --- /dev/null +++ b/msvs/mf6bmi.vfproj @@ -0,0 +1,33 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/msvs/mf6core.vfproj b/msvs/mf6core.vfproj new file mode 100644 index 00000000000..7420bd48c9c --- /dev/null +++ b/msvs/mf6core.vfproj @@ -0,0 +1,162 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/post-merge.py b/post-merge.py index a0112d37050..1784c5f7d4f 100644 --- a/post-merge.py +++ b/post-merge.py @@ -1,40 +1,40 @@ -#!/usr/bin/python - -from __future__ import print_function -import subprocess -import os - -from hook_files import paths, files - -def unstage_files(): - for p, f in zip(paths, files): - if p == '.': - fpth = f - else: - fpth = os.path.join(p, f) - - # reset select files - cargs = ['git', 'reset', 'HEAD', fpth] - try: - # add modified version file - print('Resetting...{}'.format(fpth)) - b = subprocess.Popen(cargs, - stdout=subprocess.PIPE).communicate()[0] - except: - print('Could not reset...{}'.format(fpth)) - sys.exit(1) - - # checkout existing files - cargs = ['git', 'checkout', fpth] - try: - # add modified version file - print('Checking out existing...{}'.format(fpth)) - b = subprocess.Popen(cargs, - stdout=subprocess.PIPE).communicate()[0] - except: - print('Could not check out existing...{}'.format(fpth)) - sys.exit(1) - return - -if __name__ == "__main__": - unstage_files() +#!/usr/bin/python + +from __future__ import print_function +import subprocess +import os + +from hook_files import paths, files + +def unstage_files(): + for p, f in zip(paths, files): + if p == '.': + fpth = f + else: + fpth = os.path.join(p, f) + + # reset select files + cargs = ['git', 'reset', 'HEAD', fpth] + try: + # add modified version file + print('Resetting...{}'.format(fpth)) + b = subprocess.Popen(cargs, + stdout=subprocess.PIPE).communicate()[0] + except: + print('Could not reset...{}'.format(fpth)) + sys.exit(1) + + # checkout existing files + cargs = ['git', 'checkout', fpth] + try: + # add modified version file + print('Checking out existing...{}'.format(fpth)) + b = subprocess.Popen(cargs, + stdout=subprocess.PIPE).communicate()[0] + except: + print('Could not check out existing...{}'.format(fpth)) + sys.exit(1) + return + +if __name__ == "__main__": + unstage_files() diff --git a/post-merge.sh b/post-merge.sh deleted file mode 100755 index d93742a87b7..00000000000 --- a/post-merge.sh +++ /dev/null @@ -1,5 +0,0 @@ -#!/bin/sh -echo 'Running python' -python post-merge.py - -echo 'Finished post-merge' diff --git a/pre-commit.sh b/pre-commit.sh deleted file mode 100755 index 6740edd0e81..00000000000 --- a/pre-commit.sh +++ /dev/null @@ -1,5 +0,0 @@ -#!/bin/sh -echo 'Running python' -python pre-commit.py - -echo 'Finished pre-commit' diff --git a/pymake/excludefiles.txt b/pymake/excludefiles.txt new file mode 100644 index 00000000000..0b5171d2e2b --- /dev/null +++ b/pymake/excludefiles.txt @@ -0,0 +1,4 @@ +../src/mf6_duplicate.f90 +../src/bibbab.f90 + + diff --git a/pymake/makebin.py b/pymake/makebin.py index 855c3ae12db..99088c5c7ac 100755 --- a/pymake/makebin.py +++ b/pymake/makebin.py @@ -14,6 +14,8 @@ args.subdirs = True -pymake.pymake.main(args.srcdir, args.target, args.fc, args.cc, args.makeclean, - args.expedite, args.dryrun, args.double, args.debug, - args.subdirs, args.fflags, args.arch, args.makefile) +pymake.pymake.main(args.srcdir, args.target, fc=args.fc, cc=args.cc, + makeclean=args.makeclean, expedite=args.expedite, + dryrun=args.dryrun, double=args.double, debug=args.debug, + include_subdirs=args.subdirs, fflags=args.fflags, + arch=args.arch, makefile=args.makefile, srcdir2=args.commonsrc) diff --git a/pymake/makefile b/pymake/makefile index 16d31572a0a..246ec2b1d3c 100644 --- a/pymake/makefile +++ b/pymake/makefile @@ -1,4 +1,4 @@ -# makefile created on 2018-02-12 16:22:35.408327 +# makefile created on 2019-11-01 18:38:32.979161 # by pymake (version 1.1.0) # using the gfortran fortran and gcc c/c++ compilers. @@ -8,142 +8,118 @@ OBJDIR = ./obj_temp BINDIR = . PROGRAM = mf6 -SOURCEDIR1=../src -SOURCEDIR2=../src/Exchange -SOURCEDIR3=../src/Model -SOURCEDIR4=../src/Model/Geometry -SOURCEDIR5=../src/Model/GroundWaterFlow -SOURCEDIR6=../src/Model/ModelUtilities -SOURCEDIR7=../src/Solution -SOURCEDIR8=../src/Solution/SparseMatrixSolver -SOURCEDIR9=../src/Timing -SOURCEDIR10=../src/Utilities -SOURCEDIR11=../src/Utilities/Memory -SOURCEDIR12=../src/Utilities/Observation -SOURCEDIR13=../src/Utilities/OutputControl -SOURCEDIR14=../src/Utilities/TimeSeries - -VPATH = \ -${SOURCEDIR1} \ -${SOURCEDIR2} \ -${SOURCEDIR3} \ -${SOURCEDIR4} \ -${SOURCEDIR5} \ -${SOURCEDIR6} \ -${SOURCEDIR7} \ -${SOURCEDIR8} \ -${SOURCEDIR9} \ -${SOURCEDIR10} \ -${SOURCEDIR11} \ -${SOURCEDIR12} \ -${SOURCEDIR13} \ -${SOURCEDIR14} +VPATH = ./src_temp/Utilities ./src_temp/Model/Geometry ./src_temp/Model/ModelUtilities ./src_temp/Solution/SparseMatrixSolver ./src_temp/Utilities/TimeSeries ./src_temp ./src_temp/Utilities/Memory ./src_temp/Utilities/Observation ./src_temp/Utilities/OutputControl ./src_temp/Timing ./src_temp/Model ./src_temp/Solution ./src_temp/Model/GroundWaterFlow ./src_temp/Exchange .SUFFIXES: .c .cpp .f .f90 .F90 .fpp .o # Define the Fortran compile flags FC = gfortran -FFLAGS = -O2 -fbacktrace -ffpe-summary=overflow -ffpe-trap=overflow,zero,invalid +FFLAGS = -O2 -ffpe-summary=overflow -ffpe-trap=overflow,zero,invalid -fbacktrace -MMD -cpp # Define the C compile flags CC = gcc -CFLAGS = -O3 -D_UF +CFLAGS = -O2 -D_UF -MMD -cpp # Define the libraries SYSLIBS = -lc OBJECTS = \ -$(OBJDIR)/OpenSpec.o \ $(OBJDIR)/kind.o \ +$(OBJDIR)/version.o \ $(OBJDIR)/List.o \ $(OBJDIR)/SimVariables.o \ -$(OBJDIR)/ims8reordering.o \ +$(OBJDIR)/compilerversion.o \ $(OBJDIR)/BaseGeometry.o \ -$(OBJDIR)/Sparse.o \ $(OBJDIR)/HashTable.o \ -$(OBJDIR)/TimeSeriesRecord.o \ $(OBJDIR)/Xt3dAlgorithm.o \ +$(OBJDIR)/ims8reordering.o \ $(OBJDIR)/StringList.o \ +$(OBJDIR)/OpenSpec.o \ +$(OBJDIR)/Sparse.o \ $(OBJDIR)/Constants.o \ -$(OBJDIR)/SmoothingFunctions.o \ -$(OBJDIR)/compilerversion.o \ -$(OBJDIR)/ObsOutput.o \ +$(OBJDIR)/TimeSeriesRecord.o \ $(OBJDIR)/mf6lists.o \ $(OBJDIR)/ArrayHandlers.o \ +$(OBJDIR)/Sim.o \ +$(OBJDIR)/SmoothingFunctions.o \ +$(OBJDIR)/Iunit.o \ $(OBJDIR)/Memory.o \ -$(OBJDIR)/Timer.o \ $(OBJDIR)/MemoryList.o \ -$(OBJDIR)/Sim.o \ +$(OBJDIR)/Timer.o \ +$(OBJDIR)/genericutils.o \ +$(OBJDIR)/ObsOutput.o \ +$(OBJDIR)/sort.o \ $(OBJDIR)/Budget.o \ -$(OBJDIR)/Iunit.o \ $(OBJDIR)/InputOutput.o \ $(OBJDIR)/CircularGeometry.o \ +$(OBJDIR)/RectangularChGeometry.o \ $(OBJDIR)/BlockParser.o \ -$(OBJDIR)/MemoryManager.o \ +$(OBJDIR)/ArrayReaders.o \ $(OBJDIR)/ObsOutputList.o \ +$(OBJDIR)/NameFile.o \ $(OBJDIR)/ListReader.o \ -$(OBJDIR)/RectangularChGeometry.o \ -$(OBJDIR)/BaseModel.o \ -$(OBJDIR)/Mover.o \ $(OBJDIR)/PrintSaveManager.o \ -$(OBJDIR)/ArrayReaders.o \ -$(OBJDIR)/ims8linear.o \ -$(OBJDIR)/TimeSeries.o \ $(OBJDIR)/RectangularGeometry.o \ $(OBJDIR)/DisvGeom.o \ -$(OBJDIR)/NameFile.o \ +$(OBJDIR)/MemoryManager.o \ $(OBJDIR)/tdis.o \ -$(OBJDIR)/TimeSeriesFileList.o \ -$(OBJDIR)/BaseSolution.o \ +$(OBJDIR)/Connections.o \ +$(OBJDIR)/comarg.o \ +$(OBJDIR)/TimeSeries.o \ $(OBJDIR)/PackageMover.o \ $(OBJDIR)/TimeSeriesLink.o \ -$(OBJDIR)/TimeSeriesManager.o \ +$(OBJDIR)/ims8linear.o \ $(OBJDIR)/BndUzfKinematic.o \ -$(OBJDIR)/Connections.o \ -$(OBJDIR)/SolutionGroup.o \ -$(OBJDIR)/BaseExchange.o \ +$(OBJDIR)/TimeSeriesFileList.o \ +$(OBJDIR)/Mover.o \ +$(OBJDIR)/BaseModel.o \ +$(OBJDIR)/TimeSeriesManager.o \ +$(OBJDIR)/BaseSolution.o \ $(OBJDIR)/DiscretizationBase.o \ -$(OBJDIR)/TimeArray.o \ -$(OBJDIR)/gwf3dis8.o \ $(OBJDIR)/OutputControlData.o \ -$(OBJDIR)/TimeArraySeries.o \ $(OBJDIR)/gwf3disu8.o \ -$(OBJDIR)/Xt3dInterface.o \ -$(OBJDIR)/NumericalPackage.o \ +$(OBJDIR)/gwf3disv8.o \ +$(OBJDIR)/SolutionGroup.o \ +$(OBJDIR)/gwf3dis8.o \ $(OBJDIR)/Observe.o \ -$(OBJDIR)/ObsUtility.o \ +$(OBJDIR)/TimeArray.o \ +$(OBJDIR)/TimeArraySeries.o \ +$(OBJDIR)/NumericalPackage.o \ +$(OBJDIR)/Xt3dInterface.o \ $(OBJDIR)/gwf3ic8.o \ -$(OBJDIR)/gwf3disv8.o \ +$(OBJDIR)/BaseExchange.o \ $(OBJDIR)/OutputControl.o \ -$(OBJDIR)/gwf3sto8.o \ -$(OBJDIR)/TimeArraySeriesLink.o \ $(OBJDIR)/gwf3hfb8.o \ +$(OBJDIR)/ObsContainer.o \ $(OBJDIR)/gwf3oc8.o \ -$(OBJDIR)/gwf3npf8.o \ $(OBJDIR)/gwf3mvr8.o \ +$(OBJDIR)/gwf3npf8.o \ +$(OBJDIR)/ObsUtility.o \ +$(OBJDIR)/TimeArraySeriesLink.o \ $(OBJDIR)/TimeArraySeriesManager.o \ -$(OBJDIR)/ObsContainer.o \ +$(OBJDIR)/gwf3sto8.o \ $(OBJDIR)/Obs3.o \ $(OBJDIR)/BoundaryPackage.o \ -$(OBJDIR)/gwf3uzf8.o \ -$(OBJDIR)/gwf3sfr8.o \ -$(OBJDIR)/gwf3evt8.o \ +$(OBJDIR)/NumericalModel.o \ $(OBJDIR)/gwf3chd8.o \ -$(OBJDIR)/gwf3obs8.o \ -$(OBJDIR)/gwf3wel8.o \ $(OBJDIR)/gwf3lak8.o \ +$(OBJDIR)/gwf3riv8.o \ $(OBJDIR)/gwf3ghb8.o \ -$(OBJDIR)/gwf3maw8.o \ +$(OBJDIR)/gwf3obs8.o \ +$(OBJDIR)/gwf3sfr8.o \ +$(OBJDIR)/NumericalExchange.o \ +$(OBJDIR)/gwf3evt8.o \ $(OBJDIR)/gwf3drn8.o \ -$(OBJDIR)/gwf3riv8.o \ +$(OBJDIR)/gwf3maw8.o \ +$(OBJDIR)/gwf3wel8.o \ +$(OBJDIR)/gwf3uzf8.o \ $(OBJDIR)/gwf3rch8.o \ -$(OBJDIR)/NumericalModel.o \ -$(OBJDIR)/NumericalExchange.o \ $(OBJDIR)/GhostNode.o \ $(OBJDIR)/NumericalSolution.o \ $(OBJDIR)/gwf3.o \ $(OBJDIR)/GwfGwfExchange.o \ $(OBJDIR)/SimulationCreate.o \ +$(OBJDIR)/mf6lib.o \ $(OBJDIR)/mf6.o # Define task functions @@ -162,30 +138,43 @@ $(PROGRAM) : $(OBJECTS) $(OBJDIR)/%.o : %.f @mkdir -p $(@D) $(FC) $(FFLAGS) -c $< -o $@ -I$(OBJDIR) -J$(OBJDIR) + cat ./obj_temp/$*.d >> Dependencies + rm -f $*.d $(OBJDIR)/%.o : %.f90 @mkdir -p $(@D) $(FC) $(FFLAGS) -c $< -o $@ -I$(OBJDIR) -J$(OBJDIR) + cat ./obj_temp/$*.d >> Dependencies + rm -f $*.d $(OBJDIR)/%.o : %.F90 @mkdir -p $(@D) $(FC) $(FFLAGS) -c $< -o $@ -I$(OBJDIR) -J$(OBJDIR) + cat ./obj_temp/$*.d >> Dependencies + rm -f $*.d $(OBJDIR)/%.o : %.fpp @mkdir -p $(@D) $(FC) $(FFLAGS) -c $< -o $@ -I$(OBJDIR) -J$(OBJDIR) + cat ./obj_temp/$*.d >> Dependencies + rm -f $*.d $(OBJDIR)/%.o : %.c @mkdir -p $(@D) $(CC) $(CFLAGS) -c $< -o $@ + cat ./obj_temp/$*.d >> Dependencies + rm -f $*.d $(OBJDIR)/%.o : %.cpp @mkdir -p $(@D) $(CC) $(CFLAGS) -c $< -o $@ + cat ./obj_temp/$*.d >> Dependencies + rm -f $*.d # Clean the object and module files and the executable .PHONY : clean clean : + -rm -r Dependencies -rm -rf $(OBJDIR) -rm -rf $(PROGRAM) @@ -194,3 +183,7 @@ clean : cleanobj : -rm -rf $(OBJDIR) +# Touch dependencies +Dependencies : + touch Dependencies + diff --git a/requirements.travis.txt b/requirements.travis.txt index a9ea7af38d7..402e4224c10 100644 --- a/requirements.travis.txt +++ b/requirements.travis.txt @@ -1,5 +1,11 @@ -pydotplus>=2.0 +conda-build matplotlib netcdf4 pyproj pyshp +shapely +tk +pip +nose-timer +pydotplus +bmipy 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 19132281334..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, iasln, 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 - integer(I4B), dimension(:), intent(in) :: iasln - 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, iasln, 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 - integer(I4B), dimension(:), intent(in) :: iasln - 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, iasln, 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, 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) - ! - ! -- 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) - ! - ! -- 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 81cabadc178..a96719d569d 100644 --- a/src/Exchange/GwfGwfExchange.f90 +++ b/src/Exchange/GwfGwfExchange.f90 @@ -1,2081 +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 - 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 - - 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 - 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, iasln, 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, LENMODELNAME - 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=LENMODELNAME) :: packname1 - character(len=LENMODELNAME) :: packname2 - character(len=LENBUDTXT), dimension(1) :: budtxt - real(DP), dimension(2, 1) :: budterm - integer(I4B) :: i, n1, n2, n1u, n2u - integer(I4B) :: ibinun1, ibinun2 - integer(I4B) :: ibdlbl - integer(I4B) :: icbcfl, ibudfl - real(DP) :: ratin, ratout, rrate, deltaqgnc - ! -- formats - character(len=*), parameter :: fmttkk = & - "(1X,/1X,A,' PERIOD ',I0,' STEP ',I0)" -! ------------------------------------------------------------------------------ - ! - budtxt(1) = ' FLOW-JA-FACE' - packname1 = 'EXG '//this%name - packname1 = adjustr(packname1) - packname2 = 'EXG '//this%name - packname2 = adjustr(packname2) - ! - ! -- 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 - ibdlbl = 0 - ! - ! -- 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 - if(ibdlbl == 0) write(this%gwfmodel1%iout,fmttkk) packname1, & - kper, kstp - call this%gwfmodel1%dis%print_list_entry(i, n1, rrate, & - this%gwfmodel1%iout, bname) - endif - ibdlbl = 1 - 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 - ibdlbl = 0 - ! - ! -- 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 - if(ibdlbl == 0) write(this%gwfmodel2%iout,fmttkk) packname2, & - kper, kstp - call this%gwfmodel2%dis%print_list_entry(i, n2, -rrate, & - this%gwfmodel2%iout, bname) - endif - ibdlbl = 1 - 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) - ! - ! -- 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) - ! - ! -- 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) - ! - ! -- 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=LENORIGIN) :: origin -! ------------------------------------------------------------------------------ - ! - ! -- 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(:) = '' - ! - ! -- 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 6498c8f1c2f..aa72d09acd5 100644 --- a/src/Model/GroundWaterFlow/gwf3.f90 +++ b/src/Model/GroundWaterFlow/gwf3.f90 @@ -1,1466 +1,1535 @@ -module GwfModule - - use KindModule, only: DP, I4B - use InputOutputModule, only: ParseLine, upcase - use ConstantsModule, only: LENFTYPE, DZERO, 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 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(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 :: 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 ', ' ', ' ', ' ', & ! 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 InputOutputModule, 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 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, this%iout, 80) - call write_centered(MFTITLE, this%iout, 80) - call write_centered('GROUNDWATER FLOW MODEL (GWF)', this%iout, 80) - call write_centered('VERSION '//VERSION, this%iout, 80) - ! - ! -- Write if develop mode - if (IDEVELOPMODE == 1) call write_centered('***DEVELOP MODE***', & - this%iout, 80) - ! - ! -- Write compiler version - call get_compiler(compiler) - call write_centered(' ', this%iout, 80) - call write_centered(trim(adjustl(compiler)), this%iout, 80) - ! - ! -- 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('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 ic_cr(this%ic, this%name, this%inic, this%iout, this%dis) - call mvr_cr(this%mvr, this%name, this%inmvr, this%iout) - 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%xt3d, this%ingnc) - call this%oc%oc_df() - 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 = 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 assigned - 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 internal 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, & - this%dis%nodes, this%ia, this%ja) - ! - ! -- 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, this%dis%nodes, & - this%ia, this%ja, 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%dis, 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%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%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%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, 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 - ! - ! -- Fill standard conductance terms - if(this%innpf > 0) call this%npf%npf_fc(kiter, this%dis%nodes, & - this%nja, njasln, amatsln, & - this%idxglo, this%rhs, this%x) - if(this%inhfb > 0) call this%hfb%hfb_fc(kiter, this%dis%nodes, & - this%nja, njasln, amatsln, & - this%idxglo, this%rhs, this%x) - if(this%ingnc > 0) call this%gnc%gnc_fc(kiter, this%ia, amatsln) - if(this%insto > 0) then - call this%sto%sto_fc(kiter, this%dis%nodes, this%xold, & - this%x, this%nja, 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, this%dis%nodes, this%nja, 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%dis%nodes, this%xold, this%x, & - this%nja, 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, icnvg) -! ****************************************************************************** -! 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(inout) :: icnvg - ! -- local - class(BndType), pointer :: packobj - integer(I4B) :: ip - ! -- formats -! ------------------------------------------------------------------------------ - ! - ! -- If mover is on, then at least 2 outers required - if (this%inmvr > 0) call this%mvr%mvr_cc(kiter, iend, icnvg) - ! - ! -- Call package cc routines - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_cc(iend, icnvg) - enddo - ! - ! -- return - return - end subroutine gwf_cc - - subroutine gwf_ptcchk(this, iptc) -! ****************************************************************************** -! gwf_ptc -- 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 appled to problems without - ! storage - iptc = 0 - if (this%iss > 0) then - if (this%insto == 0) then - ! -- and problems using Newton-Raphson - if (this%inewton > 0) then - iptc = this%inewton - else - iptc = this%npf%inewton - end if - 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) :: q - real(DP) :: diag - real(DP) :: diagcnt - real(DP) :: diagmin -! ------------------------------------------------------------------------------ - ! -- set temporary flag indicating if pseudo-transient continuation should - ! be used for this model and time step - iptct = 0 - ! -- only apply pseudo-transient continuation for problems without storage - if (this%iss > 0) then - if (this%insto == 0) then - ! -- and problems using Newton-Raphson - if (this%inewton > 0) then - iptct = this%inewton - else - iptct = this%npf%inewton - end if - end if - end if - ! - ! -- calculate pseudo-transient continuation factor for model - if (iptct > 0) then - diagmin = DEP20 - diagcnt = DZERO - do n = 1, this%dis%nodes - if (this%npf%ibound(n) < 1) cycle - jcol = n + this%moffset - v = this%dis%get_cell_volume(n, x(jcol)) - if (v > DZERO) then - q = DZERO - do j = ia(jcol), ia(jcol+1)-1 - jj = ja(j) - q = q + amatsln(j) * x(jcol) - end do - q = q - rhs(jcol) - else - cycle - end if - q = q / v - if (abs(q) > ptcf) ptcf = abs(q) - j = ia(jcol) - diag = abs(amatsln(j)) - diagcnt = diagcnt + DONE - if (diag > DZERO) then - if (diag < diagmin) diagmin = diag - end if - end do - if (diagcnt > DZERO) then - if (ptcf < diagmin) ptcf = diagmin - 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) -! ****************************************************************************** -! 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 - ! -- local - !integer(I4B) :: n - !integer(I4B) :: jcol - !real(DP) :: botm - 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) - 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) - 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%neq, this%nja, this%x, & - this%flowja) - if(this%inhfb > 0) call this%hfb%hfb_flowja(this%neq, this%nja, 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 - ! - ! -- Node Property Flow - if(this%innpf > 0) then - call this%npf%npf_bdadj(this%nja, 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) - ! - ! -- 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%neq, this%nja, 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 - class(BndType), pointer :: packobj -! ------------------------------------------------------------------------------ - ! - 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%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%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%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%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%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 -! ------------------------------------------------------------------------------ - ! - ! -- Now supporting new-style WEL and GHB packages. - ! -- 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 - ! - ! -- Packages is the bndlist that is associated with the parent model - ! -- The following statement puts a pointer to this package in the ipakid - ! -- position of packages. - 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 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 3e51d621289..bfbdc1964ee 100644 --- a/src/Model/GroundWaterFlow/gwf3chd8.f90 +++ b/src/Model/GroundWaterFlow/gwf3chd8.f90 @@ -1,463 +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 - ! - ! -- 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: kstp, kper, 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 - integer(I4B) :: i, node, ibinun, n2 - real(DP) :: rrate, chin, chout, q - integer(I4B) :: ibdlbl, naux, ipos - ! -- for observations - character(len=LENBOUNDNAME) :: bname - ! -- formats - character(len=*), parameter :: fmttkk = & - "(1X,/1X,A,' PERIOD ',I0,' STEP ',I0)" -! ------------------------------------------------------------------------------ - ! - chin = DZERO - chout = DZERO - ibdlbl = 0 - ! - ! -- 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 - ! - ! -- 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 - if(ibdlbl == 0) write(this%iout,fmttkk) & - this%text // ' (' // trim(this%name) // ')', kper, kstp - call this%dis%print_list_entry(i, node, rrate, this%iout, & - bname) - ibdlbl=1 - 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 new file mode 100644 index 00000000000..a0f2a2e697a --- /dev/null +++ b/src/Model/GroundWaterFlow/gwf3csub8.f90 @@ -0,0 +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 diff --git a/src/Model/GroundWaterFlow/gwf3dis8.f90 b/src/Model/GroundWaterFlow/gwf3dis8.f90 index c6056640a4d..37b4369ee65 100644 --- a/src/Model/GroundWaterFlow/gwf3dis8.f90 +++ b/src/Model/GroundWaterFlow/gwf3dis8.f90 @@ -1,1747 +1,1917 @@ -module GwfDisModule - - 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 BlockParserModule, only: BlockParserType - use MemoryManagerModule, only: mem_allocate - use TdisModule, only: kstp, kper, pertim, totim, delt - - implicit none - private - public dis_cr, 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 - 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) - 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 :: botm => null() ! top and bottom elevations for each cell (ncol, nrow, nlay) - integer(I4B), dimension(:, :, :), pointer :: idomain => null() ! idomain (ncol, nrow, nlay) - contains - procedure :: dis_df => dis3d_df - procedure :: dis_da => dis3d_da - 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 :: get_nodeuser - procedure :: nodeu_to_string - 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_griddata - 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 dis3d_df(this) -! ****************************************************************************** -! read_from_file -- Allocate and read discretization information -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DNODATA - ! -- dummy - class(GwfDisType) :: this - ! -- locals -! ------------------------------------------------------------------------------ - ! - ! -- Identify - 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_griddata() - ! - ! -- 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) - ! - ! -- Deallocate Arrays - call mem_deallocate(this%nodereduced) - call mem_deallocate(this%nodeuser) - deallocate(this%botm) - 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 - 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 - ! - ! -- Return - return - end subroutine read_dimensions - - subroutine read_griddata(this) -! ****************************************************************************** -! read_griddata -- Read data -! ****************************************************************************** -! -! 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, node, noder, i, j, k - integer(I4B) :: ierr - integer(I4B) :: nrsize, nvals - logical :: isfound, endOfBlock - real(DP) :: dz - integer(I4B), parameter :: nname = 5 - logical, dimension(nname) :: lname - character(len=24),dimension(nname) :: aname - character(len=300) :: ermsg - ! -- 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: ',I7," // & - "/1X, 'NUMBER OF NODES IN SOLUTION: ', I7, //)" - ! -- 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'/ -! ------------------------------------------------------------------------------ - ! - ! -- Allocate arrays used in this subroutine - call mem_allocate(this%delr, this%ncol, 'DELR', this%origin) - call mem_allocate(this%delc, this%nrow, 'DELC', this%origin) - allocate(this%idomain(this%ncol, this%nrow, this%nlay)) - allocate(this%botm(this%ncol, this%nrow, 0:this%nlay)) - ! - ! --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%botm(:,:,0), 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%botm(:,:,1:this%nlay), & - 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%botm(:,:,1:this%nlay), & - 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 - ! - ! -- If IDOMAIN was not read, then set all values to 1, otherwise - ! count active cells - if(.not. lname(5)) then - do k = 1, this%nlay - do i = 1, this%nrow - do j = 1, this%ncol - this%idomain(j, i, k) = 1 - enddo - enddo - enddo - this%nodes = this%nodesuser - else - 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 - endif - ! - ! -- 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 - dz = this%botm(j, i, k - 1) - this%botm(j, i, k) - if (dz <= DZERO) then - n = n + 1 - write(ermsg, fmt=fmtdz) k, i, j, this%botm(j, i, k - 1), & - this%botm(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 botm 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 - this%top(noder) = this%botm(j, i, k - 1) - this%bot(noder) = this%botm(j, i, k) - this%area(noder) = this%delr(j) * this%delc(i) - enddo - enddo - 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 read_griddata - - 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%botm(:, :, 0) ! top - write(iunit) this%botm(:, :, 1:) ! botm - 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 - - 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 - - function get_nodeuser(this, noder) & - result(nodenumber) -! ****************************************************************************** -! get_nodeuser -- Return the user nodenumber from the reduced node number -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - ! -- return - integer(I4B) :: nodenumber - ! -- dummy - class(GwfDisType) :: 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 - - 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. -! ****************************************************************************** - implicit none - ! -- 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. -! ****************************************************************************** - implicit none - ! -- 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 -! ------------------------------------------------------------------------------ - ! - ! -- Calculate cell center z values - z1 = this%bot(noden) + DHALF * (this%top(noden) - this%bot(noden)) - z2 = this%bot(nodem) + DHALF * (this%top(nodem) - this%bot(nodem)) - ! - ! -- 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 - conlen = abs(z2 - z1) - else - ! - if(nozee) then - z1 = DZERO - z2 = DZERO - else - z1 = z1 * satn - z2 = z2 * satm - 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 connection_vector - - 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) :: nodeu, noder - 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 - do nodeu = 1, this%nodesuser - noder = this%get_nodenumber(nodeu, 0) - if (noder <= 0) cycle - iarray(noder) = itemp(nodeu) - enddo - 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 - integer(I4B) :: nodeu, noder - 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 - do nodeu = 1, this%nodesuser - noder = this%get_nodenumber(nodeu, 0) - if(noder <= 0) cycle - darray(noder) = dtemp(nodeu) - enddo - 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 - if(this%ndim == 3) then - nlay = this%mshape(1) - nrow = this%mshape(2) - ncol = this%mshape(3) - elseif(this%ndim == 2) then - nlay = this%mshape(1) - nrow = 1 - ncol = this%mshape(2) - else - nlay = 1 - nrow = 1 - ncol = this%nodes - endif - ! - ! -- Read the array - if(this%ndim > 1) then - 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 - ! - else - ! - ! -- Read unstructured and then copy into darray - call ReadArray(inunit, this%dbuff, aname, this%ndim, maxbnd, iout, 0) - do ipos = 1, maxbnd - darray(icolbnd, ipos) = this%dbuff(ipos) - enddo - endif - ! - ! -- 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 b1f194bdf85..1ff48a22c2a 100644 --- a/src/Model/GroundWaterFlow/gwf3disu8.f90 +++ b/src/Model/GroundWaterFlow/gwf3disu8.f90 @@ -1,1536 +1,1969 @@ -module GwfDisuModule - - use ArrayReadersModule, only: ReadArray - use KindModule, only: DP, I4B - use ConstantsModule, only: LENMODELNAME, LENORIGIN, LINELENGTH - use ConnectionsModule, only: ConnectionsType - 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 - - type, extends(DisBaseType) :: GwfDisuType - 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 - contains - procedure :: dis_df => disu_df - procedure :: dis_da => disu_da - procedure :: get_nodenumber_idx1 - procedure :: get_nodeuser - procedure :: nodeu_to_string - 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 :: read_layer_array - procedure, public :: record_srcdst_list_header - procedure, public :: nlarray_to_nodelist - ! -- private - procedure :: allocate_scalars - procedure :: allocate_arrays - procedure :: read_options - procedure :: read_dimensions - procedure :: read_data - 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_df(this) -! ****************************************************************************** -! disu_df -- Read discretization information from DISU input file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfDisuType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- Identify - 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%allocate_arrays() - call this%read_data() - ! - ! -- Create and fill the connections object - allocate(this%con) - call this%con%read_from_block(this%name_model, this%nodes, this%nja, & - this%inunit, this%iout) - this%njas = this%con%njas - ! - ! -- 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 - ! - ! -- Return - return - end subroutine disu_df - - subroutine disu_da(this) -! ****************************************************************************** -! disu_da -- Deallocate discretization object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_deallocate - ! -- dummy - class(GwfDisuType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- 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 - - integer(I4B) function get_nodeuser(this, noder) & - result(nodenumber) -! ****************************************************************************** -! get_nodeuser -- Return the user nodenumber from the reduced node number -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GwfDisuType) :: this - integer(I4B), intent(in) :: noder -! ------------------------------------------------------------------------------ - ! - nodenumber = noder - ! - ! -- return - return - end function get_nodeuser - - 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) :: ierr - logical :: isfound, endOfBlock -! ------------------------------------------------------------------------------ - ! - ! -- Initialize dimensions - this%nodes = -1 - this%nja = -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%nodes = this%parser%GetInteger() - write(this%iout,'(4x,a,i0)') 'NODES = ', this%nodes - case ('NJA') - this%nja = this%parser%GetInteger() - write(this%iout,'(4x,a,i0)') 'NJA = ', this%nja - 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 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 OPTIONS' - else - call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- Set nodesuser to nodes - this%nodesuser = this%nodes - ! - ! -- verify dimensions were set - if(this%nodes < 1) then - call store_error( & - 'ERROR. NODES WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.') - call ustop() - endif - if(this%nja < 1) then - call store_error( & - 'ERROR. NJA WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.') - call ustop() - endif - ! - ! -- Return - return - end subroutine read_dimensions - - subroutine read_data(this) -! ****************************************************************************** -! read_data -- Read discretization data -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - use ConstantsModule, only: LINELENGTH, DZERO - 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 - real(DP) :: dz - integer(I4B), parameter :: nname = 3 - logical,dimension(nname) :: lname - character(len=24),dimension(nname) :: aname(nname) - ! -- formats - 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))" - ! -- data - data aname(1) /' TOP'/ - data aname(2) /' BOT'/ - data aname(3) /' AREA'/ -! ------------------------------------------------------------------------------ - ! - ! -- 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%top, aname(1), & - this%ndim, this%nodes, this%iout, 0) - lname(1) = .true. - case ('BOT') - call ReadArray(this%parser%iuactive, this%bot, aname(2), & - this%ndim, this%nodes, this%iout, 0) - lname(2) = .true. - case ('AREA') - call ReadArray(this%parser%iuactive, this%area, aname(3), & - this%ndim, this%nodes, this%iout, 0) - lname(3) = .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(.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 - ! - ! -- Check for zero and negative thickness and zero or negative areas - do n = 1, this%nodes - dz = this%top(n) - this%bot(n) - if (dz <= DZERO) then - write(errmsg, fmt=fmtdz) n, this%top(n), this%bot(n) - call store_error(errmsg) - endif - if (this%area(n) <= DZERO) then - write(errmsg, fmt=fmtarea) n, this%area(n) - call store_error(errmsg) - endif - enddo - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Return - return - end subroutine read_data - - 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 - character(len=LINELENGTH) :: line - 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 - character(len=LINELENGTH) :: line - 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%nodes)) - do i = 1, this%nodes - maxnnz(i) = 5 - enddo - call vertspm%init(this%nodes, 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%nodes - 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 - allocate(this%iavert(this%nodes+1)) - allocate(this%javert(vertspm%nnz)) - call vertspm%filliaja(this%iavert, this%javert, ierr) - call vertspm%destroy() - ! - ! -- Write information - write(this%iout, fmtncpl) this%nodes - 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%nodes - 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%nodes - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'BOT ', 'DOUBLE ', 'NDIM 1 ', this%nodes - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'IA ', 'INTEGER ', 'NDIM 1 ', this%nodes + 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%nodes - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'CELLY ', 'DOUBLE ', 'NDIM 1 ', this%nodes - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'IAVERT ', 'INTEGER ', 'NDIM 1 ', this%nodes + 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%nodes ! nodes - write(iunit) this%nja ! nja - write(iunit) this%xorigin ! xorigin - write(iunit) this%yorigin ! yorigin - write(iunit) this%angrot ! angrot - write(iunit) this%top ! top - write(iunit) this%bot ! bot - write(iunit) this%con%ia ! ia - write(iunit) this%con%ja ! 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%nodes) ! cellx - write(iunit) (this%cellxy(2, i), i = 1, this%nodes) ! 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 - nodenumber = nodeu - ! - ! -- 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 - xn = this%cellxy(1, noden) - yn = this%cellxy(2, noden) - xm = this%cellxy(1, nodem) - ym = this%cellxy(2, nodem) - ! - ! -- 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 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%nvert, 'NVERT', this%origin) - ! - ! -- Set values - this%ndim = 1 - 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 -! ------------------------------------------------------------------------------ - ! - ! -- Allocate arrays in DisBaseType (mshape, top, bot, area) - call this%DisBaseType%allocate_arrays() - ! - ! -- Allocate arrays in DISU - call mem_allocate(this%vertices, 2, this%nvert, 'VERTICES', this%origin) - if(this%nvert > 0) then - call mem_allocate(this%cellxy, 2, this%nodes, 'CELLXY', this%origin) - else - call mem_allocate(this%cellxy, 2, 0, 'CELLXY', this%origin) - endif - ! - ! -- Initialize - this%mshape(1) = this%nodes - ! - ! -- 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%nodes - ! - ! -- 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) :: nlay - integer(I4B) :: nrow - integer(I4B) :: ncol - integer(I4B) :: nval - integer(I4B) :: nodeu, noder - 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 = 1 - nrow = 1 - ncol = this%nodes - ! - 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 - do nodeu = 1, this%nodesuser - noder = this%get_nodenumber(nodeu, 0) - if(noder <= 0) cycle - iarray(noder) = itemp(nodeu) - enddo - 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) :: nlay - integer(I4B) :: nrow - integer(I4B) :: ncol - integer(I4B) :: nval - integer(I4B) :: nodeu, noder - 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 = 1 - nrow = 1 - ncol = this%nodes - ! - if(this%nodes < this%nodesuser) then - nval = this%nodesuser - dtemp => this%dbuff - else - nval = this%nodes - dtemp => darray - endif - ! - ! -- Read the array - ! -- Read structured input - 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 - do nodeu = 1, this%nodesuser - noder = this%get_nodenumber(nodeu, 0) - if(noder <= 0) cycle - darray(noder) = dtemp(nodeu) - enddo - 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(GwfDisuType) :: this - integer(I4B), intent(in) :: maxbnd - integer(I4B), intent(in) :: ncolbnd - 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) :: ipos -! ------------------------------------------------------------------------------ - ! - ! -- Read unstructured and then copy into darray - call ReadArray(inunit, this%dbuff, aname, this%ndim, maxbnd, iout, 0) - do ipos = 1, maxbnd - darray(icolbnd, ipos) = this%dbuff(ipos) - 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(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) :: 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%nodes - ! - nval = this%nodes - dtemp => darray - ! - ! -- 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%nodes - ! - ! -- 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(GwfDisuType) :: 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) :: noder - character(len=LINELENGTH) :: errmsg -! ------------------------------------------------------------------------------ - ! - ! -- 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 - ! - ! -- return - end subroutine nlarray_to_nodelist - -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 8f097fd4cea..bc46a41afea 100644 --- a/src/Model/GroundWaterFlow/gwf3disv8.f90 +++ b/src/Model/GroundWaterFlow/gwf3disv8.f90 @@ -1,2129 +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, 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 - 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) - 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 :: botm => null() ! top and bottom elevations for each cell (ncpl, 1, 0:nlay) - integer(I4B), dimension(:, :, :), pointer :: 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, 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 :: get_nodeuser - procedure :: nodeu_to_string - 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_griddata - 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_df(this) -! ****************************************************************************** -! read_from_file -- Allocate and read discretization information -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfDisvType) :: this - ! -- locals -! ------------------------------------------------------------------------------ - ! - ! -- Identify - 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_griddata() - ! - ! -- Read VERTICES block - call this%read_vertices() - ! - ! -- Read CELL2D block - call this%read_cell2d() - ! - ! -- 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 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) - deallocate(this%botm) - 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, 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 -! ------------------------------------------------------------------------------ - ! - ! -- 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 - ! - ! -- Return - return - end subroutine read_dimensions - - subroutine read_griddata(this) -! ****************************************************************************** -! read_griddata -- Read cell information (TOP, BOTM, IDOMAIN) -! ****************************************************************************** -! -! 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, node, noder, j, k - integer(I4B) :: ierr - logical :: isfound, endOfBlock - real(DP) :: dz - 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: ',I7," // & - "/1X, 'NUMBER OF NODES IN SOLUTION: ', I7, //)" - ! -- data - data aname(1) /'TOP ELEVATION OF LAYER 1'/ - data aname(2) /' MODEL LAYER BOTTOM EL.'/ - data aname(3) /' IDOMAIN'/ -! ------------------------------------------------------------------------------ - ! - ! -- Allocate botm here (cannot use mem manager because starts at 0) - allocate(this%botm(this%ncpl, 1, 0:this%nlay)) - allocate(this%idomain(this%ncpl, 1, this%nlay)) - ! - ! --Read 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%botm(:, :, 0), & - 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%botm(:,:,1:this%nlay), aname(2), this%ndim, & - this%ncpl, 1, this%nlay, this%iout, 1, this%nlay) - else - call ReadArray(this%parser%iuactive, & - this%botm(:, :, 1:this%nlay), 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 - ! - ! -- If IDOMAIN was not read, then set all values to 1, otherwise - ! count active cells - if(.not. lname(3)) then - do k = 1, this%nlay - do j = 1, this%ncpl - this%idomain(j, 1, k) = 1 - enddo - enddo - this%nodes = this%nodesuser - else - 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 - endif - ! - ! -- 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 - dz = this%botm(j, 1, k - 1) - this%botm(j, 1, k) - if (dz <= DZERO) then - write(ermsg, fmt=fmtdz) k, j, this%botm(j, 1, k - 1), & - this%botm(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 botm 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 - this%top(noder) = this%botm(j, 1, k - 1) - this%bot(noder) = this%botm(j, 1, k) - enddo - enddo - ! - ! -- Return - return - end subroutine read_griddata - - 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%area, & - 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%botm(:, :, 0) ! top - write(iunit) this%botm(:, :, 1:) ! 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 - - 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 - - function get_nodeuser(this, noder) & - result(nodenumber) -! ****************************************************************************** -! get_nodeuser -- Return the user nodenumber from the reduced node number -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - ! -- return - integer(I4B) :: nodenumber - class(GwfDisvType) :: 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 - -! subroutine connection_normal(this, noden, nodem, ihc, xcomp, ycomp, zcomp) -!! ****************************************************************************** -!! 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: DZERO, DONE -! ! -- 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 -! ! -- local -!! ------------------------------------------------------------------------------ -! ! -! ! -- Set cell1 and cell2 to nodes nodered and mred -! call this%cell1%set_nodered(noden) -! call this%cell2%set_nodered(nodem) -! ! -! ! -- 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 -! call this%cell1%edge_normal(this%cell2, xcomp, ycomp) -! zcomp = DZERO -! endif -! ! -! ! -- return -! return -! end subroutine connection_normal - - 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 -! ! -- 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 -! real(DP) :: zn, zm -!! ------------------------------------------------------------------------------ -! ! -! ! -- Set cell1 and cell2 to nodes noden and nodem -! call this%cell1%set_nodered(noden) -! call this%cell2%set_nodered(nodem) -! ! -! ! -- 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 -! ! -! ! -- Cell centers are calculated without consideration for saturation. -! ! This routine only used by XT3D at the moment, and so the NPF -! ! options for vertical conductance do not need to be supported -! ! here. -! zn = this%cell1%bot + DHALF * (this%cell1%top - this%cell1%bot) -! zm = this%cell2%bot + DHALF * (this%cell2%top - this%cell2%bot) -! conlen = abs(zm - zn) -! else -! ! -! ! -- horizontal connection, with possible z component due to cell offsets -! ! and/or water table conditions -! call this%cell1%connection_vector(this%cell2, nozee, satn, satm, xcomp, & -! ycomp, zcomp, conlen) -! endif -! ! -! ! -- return -! return -! end subroutine connection_vector - - 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 - - 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. -! ****************************************************************************** - implicit none - ! -- 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. -! ****************************************************************************** - implicit none - ! -- 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) :: nodeu, noder - 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 - do nodeu = 1, this%nodesuser - noder = this%get_nodenumber(nodeu, 0) - if(noder <= 0) cycle - iarray(noder) = itemp(nodeu) - enddo - 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 - integer(I4B) :: nodeu, noder - 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 - do nodeu = 1, this%nodesuser - noder = this%get_nodenumber(nodeu, 0) - if(noder <= 0) cycle - darray(noder) = dtemp(nodeu) - enddo - 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 2fe3278a25b..2704342b230 100644 --- a/src/Model/GroundWaterFlow/gwf3drn8.f90 +++ b/src/Model/GroundWaterFlow/gwf3drn8.f90 @@ -1,355 +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 - ! - ! -- 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) -! ****************************************************************************** -! drn_cf -- Formulate the HCOF and RHS terms -! Subroutine: (1) skip if no drains -! (2) calculate hcof and rhs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(DrnType) :: this - integer(I4B) :: i, node - real(DP) :: drnelev, cdrn -! ------------------------------------------------------------------------------ - ! - ! -- Return if no drains - if(this%nbound == 0) return - ! - ! -- pakmvrobj cf - if(this%imover == 1) 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 af3cdc3d021..82612fdf35d 100644 --- a/src/Model/GroundWaterFlow/gwf3evt8.f90 +++ b/src/Model/GroundWaterFlow/gwf3evt8.f90 @@ -1,1228 +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 - ! 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) -! ****************************************************************************** -! evt_cf -- Formulate the HCOF and RHS terms -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(EvtType) :: this - ! -- 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 from RHS - this%rhs(i) = this%rhs(i) + petm0 - 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 = -(abs(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) :: atemp - character(len=24), dimension(6) :: aname - character(len=100) :: ermsg, keyword - 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 b8648921a42..720ee0bfd55 100644 --- a/src/Model/GroundWaterFlow/gwf3ghb8.f90 +++ b/src/Model/GroundWaterFlow/gwf3ghb8.f90 @@ -1,343 +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 - ! - ! -- 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) -! ****************************************************************************** -! ghb_cf -- Formulate the HCOF and RHS terms -! Subroutine: (1) skip if no ghbs -! (2) calculate hcof and rhs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - class(GhbType) :: this - integer(I4B) :: i, node -! ------------------------------------------------------------------------------ - ! - ! -- Return if no ghbs - if(this%nbound.eq.0) return - ! - ! -- packmvrobj cf - if(this%imover == 1) 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 6acfa00479a..558f3d97ddc 100644 --- a/src/Model/GroundWaterFlow/gwf3hfb8.f90 +++ b/src/Model/GroundWaterFlow/gwf3hfb8.f90 @@ -1,871 +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, nodes, nja, 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) :: 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) :: 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 -! ------------------------------------------------------------------------------ - ! - 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, nodes, nja, 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 - integer(I4B),intent(in) :: nodes - integer(I4B),intent(in) :: nja - real(DP),intent(inout),dimension(nodes) :: hnew - real(DP),intent(inout),dimension(nja) :: 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(nodes, n, m, nja, 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, 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) - ! - ! -- 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 0c9a9ccbc70..e9a6288fa96 100644 --- a/src/Model/GroundWaterFlow/gwf3lak8.f90 +++ b/src/Model/GroundWaterFlow/gwf3lak8.f90 @@ -1,6084 +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, & - DNODATA - 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 BudgetModule, only : BudgetType - - 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, & - store_error_unit - use ArrayHandlersModule, only: ExpandArray - use BlockParserModule, only: BlockParserType - use BaseDisModule, only: DisBaseType - ! - implicit none - ! - private - 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 :: 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() - ! - ! -- 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() - ! - ! -- derived types - type(BudgetType), pointer :: budget => 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 - ! - ! -- 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_bd_obs - procedure, private :: lak_calculate_sarea - procedure, private :: lak_calculate_warea - procedure, private :: lak_calculate_conn_warea - procedure, private :: lak_calculate_vol - procedure, private :: lak_calculate_conductance - procedure, private :: lak_calculate_cond_head - procedure, private :: lak_calculate_conn_conductance - 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 - 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 - ! - ! -- 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%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%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) - ! - ! -- 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. nlakecon 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%noutlets) then - write(errmsg,'(4x,a,1x,i4,1x,a,1x,i6)') & - '****ERROR. lakein FOR OUTLET ', n, 'MUST BE > 0 and <= ', & - this%noutlets - 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%noutlets - 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() - ! - ! -- 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 BudgetModule, only: budget_cr - 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 - integer(I4B) :: ival - 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 -! ------------------------------------------------------------------------------ - - ! -- setup the lake budget - call budget_cr(this%budget, this%origin) - ival = this%bditems - call this%budget%budget_df(ival, this%name, 'L**3') - ! - ! -- 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(ilak, 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, ilak, 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) :: ilak - 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(ilak, 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_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 inflow terms to 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(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 - !write(*,'(i4,4(g15.6))') i, sm, vol, ds, fm - 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 - 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) - 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) - 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) - 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) - 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) - 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('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 -! ------------------------------------------------------------------------------ - ! - ! -- Advance the time series - call this%TsManager%ad() - ! - ! -- 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) - ! ****************************************************************************** - ! lak_cf -- Formulate the HCOF and RHS terms - ! Subroutine: (1) skip if no lakes - ! (2) calculate hcof and rhs - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - class(LakType) :: this - integer(I4B) :: j, n - integer(I4B) :: igwfnode - real(DP) :: hlak, blak - ! ------------------------------------------------------------------------------ - !! - !! -- Calculate lak conductance and update package RHS and HCOF - !call this%lak_cfupdate() - ! - ! -- - do n = 1, this%nlakes - this%seep0(n) = this%seep(n) - end do - ! - ! - do n = 1, this%nlakes - ! write(*,'(4x,1x,i4.4,1x,g15.7)') n, this%xnewpak(n) - this%s0(n) = this%xnewpak(n) - end do - ! - ! -- pakmvrobj cf - if(this%imover == 1) 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 - ! - ! -- 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 - !! - !! - !do n = 1, this%nlakes - !! write(*,'(4x,1x,i4.4,1x,g15.7)') n, this%xnewpak(n) - ! this%s0(n) = this%xnewpak(n) - !end do - ! - ! - ! -- 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 - ! - ! -- write some output to the screen - !do n = 1, this%nlakes - !! write(*,'(4x,i4,2(1x,g15.7))') n, this%seep0(n), this%seep(n) - ! write(*,'(4x,i4,2(1x,g15.7))') n, this%s0(n), this%xnewpak(n) - !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, iend, icnvg) -! ************************************************************************** -! lak_cc -- Final convergence check for package -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - ! -- dummy - class(LakType), intent(inout) :: this - integer(I4B), intent(in) :: iend - integer(I4B), intent(inout) :: icnvg - ! -- local - integer(I4B) :: n - integer(I4B) :: ifirst - real(DP) :: dh - real(DP) :: residb - real(DP) :: inf - real(DP) :: outf - real(DP) :: avgf - real(DP) :: ra - real(DP) :: ro - real(DP) :: qinf - real(DP) :: ex - real(DP) :: pd - ! format -02000 format(4x,'LAKE PACKAGE FAILED CONVERGENCE CRITERIA',//, & - 4x,a10,4(1x,a15),/,4x,74('-')) -02010 format(4x,i10,4(1x,G15.7)) -02020 format(4x,74('-')) -02030 format('CONVERGENCE FAILED AS A RESULT OF LAKE PACKAGE',1x,a) -! -------------------------------------------------------------------------- - ifirst = 1 - if (this%iconvchk /= 0) then - final_check: do n = 1, this%nlakes - if (this%iboundpak(n) < 1) cycle - dh = ABS(this%s0(n) - this%xnewpak(n)) - call this%lak_calculate_residual(n, this%xnewpak(n), residb) - call this%lak_calculate_available(n, this%xnewpak(n), inf, & - ra, ro, qinf, ex) - outf = inf - residb - avgf = DHALF * (inf + outf) - pd = DZERO - if (this%iconvresidchk /= 0) then - if (avgf > DZERO) then - pd = 100.d0 * residb / avgf - end if - end if - !write(*,'(1x,i4,6(1x,g10.4))') n, this%s0(n), this%xnewpak(n), residb, outf, inf, pd - if (dh > this%delh .or. ABS(pd) > this%pdmax) then - icnvg = 0 - ! write convergence check information if this is the last outer iteration - if (iend == 1) then - if (ifirst == 1) then - ifirst = 0 - write(*,2030) this%name - write(this%iout, 2000) ' LAKE', & - ' MAX. DH', ' DH CRITERIA', & - ' PCT DIFF.', 'PCT DIFF. CRIT.' - end if - write(this%iout,2010) n, dh, this%delh, pd, this%pdmax - else - exit final_check - end if - end if - end do final_check - if (ifirst == 0) then - write(this%iout,2020) - 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) :: gwfratin, gwfratout - real(DP) :: rainin, rainout - real(DP) :: evapin, evapout - real(DP) :: within, without - real(DP) :: roin, roout - real(DP) :: qinfin, qinfout - real(DP) :: extin, extout - real(DP) :: storatin, storatout - real(DP) :: ratin, ratout - real(DP) :: chratin, chratout - real(DP) :: mvrratin - real(DP) :: qtomvr - integer(I4B) :: naux - ! -- for budget - integer(I4B) :: i, j, n, n2 - integer(I4B) :: ii - integer(I4B) :: igwfnode - integer(I4B) :: nlen, n1 - real(DP) :: hlak, hgwf - real(DP) :: v0, v1 - real(DP) :: blak - real(DP) :: s - real(DP) :: d - real(DP) :: v - real(DP) :: q - real(DP) :: q2 - ! -- 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) - ! - ! -- lak budget routines (start by resetting) - call this%budget%reset() - ! - ! -- add to lake budget terms - ! -- gwf flow - gwfratin = DZERO - gwfratout = DZERO - rainin = DZERO - rainout = DZERO - evapin = DZERO - evapout = DZERO - within = DZERO - without = DZERO - roin = DZERO - roout = DZERO - qinfin = DZERO - qinfout = DZERO - extin = DZERO - extout = DZERO - storatin = DZERO - storatout = DZERO - ratin = DZERO - ratout = DZERO - chratin = DZERO - chratout = DZERO - mvrratin = DZERO - qtomvr = 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) - ! - ! -- See if flow is into lake or out of lake. - if (rrate < DZERO) then - ! - ! -- Flow is out of lake subtract rate from ratout. - rainout = rainout - rrate - else - ! - ! -- Flow is into lake; add rate to ratin. - rainin = rainin + rrate - end if - ! -- evaporation - rrate = this%evap(n) - call this%lak_accumulate_chterm(n, rrate, chratin, chratout) - ! - ! -- See if flow is into lake or out of lake. - if (rrate < DZERO) then - ! - ! -- Flow is out of lake subtract rate from ratout. - evapout = evapout - rrate - else - ! - ! -- Flow is into lake; add rate to ratin. - evapin = evapin + rrate - end if - ! -- runoff - rrate = this%runoff(n)%value - call this%lak_accumulate_chterm(n, rrate, chratin, chratout) - ! - ! -- See if flow is into lake or out of lake. - if (rrate < DZERO) then - ! - ! -- Flow is out of lake subtract rate from ratout. - roout = roout - rrate - else - ! - ! -- Flow is into lake; add rate to ratin. - roin = roin + rrate - end if - ! -- inflow - rrate = this%inflow(n)%value - call this%lak_accumulate_chterm(n, rrate, chratin, chratout) - ! - ! -- See if flow is into lake or out of lake. - if (rrate < DZERO) then - ! - ! -- Flow is out of lake subtract rate from ratout. - qinfout = qinfout - rrate - else - ! - ! -- Flow is into lake; add rate to ratin. - qinfin = qinfin + rrate - end if - ! -- withdrawals - rrate = this%withr(n) - call this%lak_accumulate_chterm(n, rrate, chratin, chratout) - ! - ! -- See if flow is into lake or out of lake. - if (rrate < DZERO) then - ! - ! -- Flow is out of lake subtract rate from ratout. - without = without - rrate - else - ! - ! -- Flow is into lake; add rate to ratin. - within = within + rrate - end if - ! - ! -- 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) - !else - ! rrate = -v1 / delt - end if - end if - this%qsto(n) = rrate - ! - ! -- See if storage flow is into maw or out of maw. - if(rrate < DZERO) then - ! - ! -- Flow is out of lake subtract rate from ratout. - storatout = storatout - rrate - else - ! - ! -- Flow is into lake; add rate to ratin. - storatin = storatin + rrate - endif - ! - ! -- add external outlets - call this%lak_get_external_outlet(n, rrate) - call this%lak_accumulate_chterm(n, rrate, chratin, chratout) - if (this%imover == 1) then - call this%lak_get_external_mover(n, q) - rrate = rrate + q - call this%lak_get_outlet_tomover(n, q2) - qtomvr = qtomvr + q2 - end if - ! - ! -- See if flow is into lake or out of lake. - if (rrate < DZERO) then - ! - ! -- Flow is out of lake subtract rate from ratout. - extout = extout - rrate - else - ! - ! -- Flow is into lake; add rate to ratin. - extin = extin + rrate - end if - ! - ! -- 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) - mvrratin = mvrratin + rrate - 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) - 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) - ! - ! -- See if flow is into lake or out of lake. - if(rrate < DZERO) then - ! - ! -- Flow is out of lake subtract rate from ratout. - gwfratout = gwfratout - rrate - else - ! - ! -- Flow is into lake; add rate to ratin. - gwfratin = gwfratin + rrate - endif - end do - - end do - ! -- add calculated terms - call this%budget%addentry(qinfin, qinfout, delt, & - this%clakbudget(5), isuppress_output) - if (this%imover == 1) then - call this%budget%addentry(mvrratin, DZERO, delt, & - this%clakbudget(10), isuppress_output) - end if - call this%budget%addentry(rainin, rainout, delt, & - this%clakbudget(2), isuppress_output) - call this%budget%addentry(roin, roout, delt, & - this%clakbudget(4), isuppress_output) - call this%budget%addentry(gwfratin, gwfratout, delt, & - this%clakbudget(1), isuppress_output) - call this%budget%addentry(evapin, evapout, delt, & - this%clakbudget(3), isuppress_output) - call this%budget%addentry(within, without, delt, & - this%clakbudget(6), isuppress_output) - call this%budget%addentry(extin, extout, delt, & - this%clakbudget(7), isuppress_output) - if (this%imover == 1) then - call this%budget%addentry(DZERO, qtomvr, delt, & - this%clakbudget(11), isuppress_output) - end if - call this%budget%addentry(storatin, storatout, delt, & - this%clakbudget(8), isuppress_output) - call this%budget%addentry(chratin, chratout, delt, & - this%clakbudget(9), isuppress_output) - ! -- 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) < 1) 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 - ! - ! -- Set unit number for binary budget output - ibinun = 0 - if(this%ibudgetout /= 0) then - ibinun = this%ibudgetout - end if - if(icbcfl == 0) ibinun = 0 - if (isuppress_output /= 0) ibinun = 0 - ! - ! -- write lake binary budget output - if (ibinun > 0) then - ! FLOW JA FACE - lake to lake connections using outlets - 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 - naux = 0 - call ubdsv06(kstp, kper, ' FLOW-JA-FACE', this%name_model, this%name, & - this%name_model, this%name, & - ibinun, naux, this%cauxcbc, nlen*2, 1, 1, & - nlen*2, this%iout, delt, pertim, totim) - do n = 1, this%noutlets - if (this%lakein(n) > 0 .and. this%lakeout(n) > 0) then - q = this%simoutrate(n) - if (this%imover == 1) then - q = q + this%pakmvrobj%get_qtomvr(n) - end if - n1 = this%lakein(n) - n2 = this%lakeout(n) - call this%dis%record_mf6_list_entry(ibinun, n1, n2, q, naux, & - this%qauxcbc, & - olconv=.FALSE., & - olconv2=.FALSE.) - call this%dis%record_mf6_list_entry(ibinun, n2, n1, -q, naux, & - this%qauxcbc, & - olconv=.FALSE., & - olconv2=.FALSE.) - - end if - end do - end if - ! LEAKAGE - naux = this%cbcauxitems - this%cauxcbc(1) = ' FLOW-AREA' - call ubdsv06(kstp, kper, this%clakbudget(1), this%name_model, this%name, & - this%name_model, this%name_model, & - ibinun, naux, this%cauxcbc, this%maxbound, 1, 1, & - this%maxbound, this%iout, delt, pertim, totim) - 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%dis%record_mf6_list_entry(ibinun, n, n2, q, naux, & - this%qauxcbc, & - olconv=.FALSE.) - - end do - end do - ! INFLOW - naux = 0 - call ubdsv06(kstp, kper, this%clakbudget(5), this%name_model, this%name, & - this%name_model, this%name, & - ibinun, naux, this%auxname, this%nlakes, 1, 1, & - this%nlakes, this%iout, delt, pertim, totim) - do n = 1, this%nlakes - q = this%inflow(n)%value - call this%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%auxvar(:,n), & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - ! RUNOFF - naux = 0 - call ubdsv06(kstp, kper, this%clakbudget(4), this%name_model, this%name, & - this%name_model, this%name, & - ibinun, naux, this%auxname, this%nlakes, 1, 1, & - this%nlakes, this%iout, delt, pertim, totim) - do n = 1, this%nlakes - q = this%runoff(n)%value - call this%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%auxvar(:,n), & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - ! RAIN - naux = 0 - call ubdsv06(kstp, kper, this%clakbudget(2), this%name_model, this%name, & - this%name_model, this%name, & - ibinun, naux, this%auxname, this%nlakes, 1, 1, & - this%nlakes, this%iout, delt, pertim, totim) - do n = 1, this%nlakes - q = this%precip(n) - call this%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%auxvar(:,n), & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - ! EVAPORATION - naux = 0 - call ubdsv06(kstp, kper, this%clakbudget(3), this%name_model, this%name, & - this%name_model, this%name, & - ibinun, naux, this%auxname, this%nlakes, 1, 1, & - this%nlakes, this%iout, delt, pertim, totim) - do n = 1, this%nlakes - q = this%evap(n) - call this%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%auxvar(:,n), & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - ! WITHDRAWAL - naux = 0 - call ubdsv06(kstp, kper, this%clakbudget(6), this%name_model, this%name, & - this%name_model, this%name, & - ibinun, naux, this%auxname, this%nlakes, 1, 1, & - this%nlakes, this%iout, delt, pertim, totim) - do n = 1, this%nlakes - q = this%withr(n) - call this%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%auxvar(:,n), & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - ! EXTERNAL OUTFLOW - naux = 0 - call ubdsv06(kstp, kper, this%clakbudget(7), this%name_model, this%name, & - this%name_model, this%name, & - ibinun, naux, this%auxname, this%nlakes, 1, 1, & - this%nlakes, this%iout, delt, pertim, totim) - 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%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%auxvar(:,n), & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - ! STORAGE - naux = this%cbcauxitems - this%cauxcbc(1) = ' VOLUME' - call ubdsv06(kstp, kper, this%clakbudget(8), this%name_model, this%name, & - this%name_model, this%name, & - ibinun, naux, this%cauxcbc, this%nlakes, 1, 1, & - this%nlakes, this%iout, delt, pertim, totim) - 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%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%qauxcbc, & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - ! CONSTANT FLOW - naux = 0 - call ubdsv06(kstp, kper, this%clakbudget(9), this%name_model, this%name, & - this%name_model, this%name, & - ibinun, naux, this%auxname, this%nlakes, 1, 1, & - this%nlakes, this%iout, delt, pertim, totim) - do n = 1, this%nlakes - q = this%chterm(n) - call this%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%auxvar(:,n), & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - ! MOVER - if (this%imover == 1) then - ! FROM MOVER - naux = 0 - call ubdsv06(kstp, kper, this%clakbudget(10), this%name_model, & - this%name, this%name_model, this%name, & - ibinun, naux, this%auxname, & - this%nlakes, 1, 1, & - this%nlakes, this%iout, delt, pertim, totim) - do n = 1, this%nlakes - q = this%pakmvrobj%get_qfrommvr(n) - call this%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%auxvar(:,n), & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - ! TO MOVER - naux = 0 - call ubdsv06(kstp, kper, this%clakbudget(11), this%name_model, & - this%name, this%name_model, this%name, & - ibinun, naux, this%auxname, & - this%noutlets, 1, 1, & - this%noutlets, this%iout, delt, pertim, totim) - do n = 1, this%noutlets - q = this%pakmvrobj%get_qtomvr(n) - if (q > DZERO) then - q = -q - end if - call this%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%auxvar(:,n), & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - end if - ! AUXILIARY VARIABLES - naux = this%naux - if (naux > 0) then - call ubdsv06(kstp, kper, ' AUXILIARY', this%name_model, this%name,& - this%name_model, this%name, & - ibinun, naux, this%auxname, this%nlakes, 1, 1, & - this%nlakes, this%iout, delt, pertim, totim) - do n = 1, this%nlakes - q = DZERO - ! fill auxvar - do i = 1, naux - ii = (n-1) * naux + i - this%auxvar(i,n) = this%lauxvar(ii)%value - end do - call this%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%auxvar(:,n), & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - end if - end if - ! -- return - return - end subroutine lak_bd - - subroutine lak_ot(this, kstp, kper, iout, ihedfl, ibudfl) - ! ************************************************************************** - ! pak1t -- 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) :: j - integer(I4B) :: iloc - real(DP) :: hlak - real(DP) :: q - real(DP) :: qin - real(DP) :: qinternalin - real(DP) :: qro - real(DP) :: qrai - real(DP) :: qleakin - real(DP) :: qleakout - real(DP) :: qevt - real(DP) :: qwdw - real(DP) :: qext - real(DP) :: qinternalout - real(DP) :: qsto - real(DP) :: qch - real(DP) :: qtomover - real(DP) :: qfrommover - real(DP) :: qtin - real(DP) :: qtout - real(DP) :: qerr - real(DP) :: qavg - real(DP) :: qerrpd - ! 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, 1, 'lake', n, q, left=.TRUE.) - end if - call UWWORD(line, iloc, 6, 1, 'lake', n, q, CENTER=.TRUE.) - call UWWORD(line, iloc, 11, 1, 'lake', n, q, CENTER=.TRUE.) - ! -- 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, 1, 'name', n, q, left=.TRUE.) - end if - call UWWORD(line, iloc, 6, 1, 'no.', n, q, CENTER=.TRUE.) - call UWWORD(line, iloc, 11, 1, 'stage', n, q, CENTER=.TRUE.) - ! -- 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, 1, this%lakename(n), n, q, left=.TRUE.) - end if - call UWWORD(line, iloc, 6, 2, text, n, q) - call UWWORD(line, iloc, 11, 3, text, n, this%xnewpak(n)) - write(iout, '(1X,A)') line(1:iloc) - end do - end if - ! - ! -- write lake rates - if (ibudfl /= 0 .and. this%iprflow /= 0) then - write (iout, 2000) 'LAKE (', trim(this%name), ') FLOWS', kper, kstp - iloc = 1 - line = '' - if (this%inamedbound==1) then - call UWWORD(line, iloc, 16, 1, 'lake', n, q, left=.TRUE.) - end if - call UWWORD(line, iloc, 6, 1, 'lake', n, q, CENTER=.TRUE.) - call UWWORD(line, iloc, 11, 1, 'lake', n, q, CENTER=.TRUE., SEP=' ') - if (this%noutlets > 0) then - call UWWORD(line, iloc, 11, 1, 'internal', n, q, CENTER=.TRUE., SEP=' ') - end if - call UWWORD(line, iloc, 11, 1, 'lake', n, q, CENTER=.TRUE., SEP=' ') - if (this%imover == 1) then - call UWWORD(line, iloc, 11, 1, 'lake', n, q, CENTER=.TRUE., SEP=' ') - end if - call UWWORD(line, iloc, 11, 1, 'lake', n, q, CENTER=.TRUE., SEP=' ') - call UWWORD(line, iloc, 11, 1, 'lake', n, q, CENTER=.TRUE., SEP=' ') - call UWWORD(line, iloc, 11, 1, 'lake', n, q, CENTER=.TRUE., SEP=' ') - call UWWORD(line, iloc, 11, 1, 'lake', n, q, CENTER=.TRUE., SEP=' ') - call UWWORD(line, iloc, 11, 1, 'lake', n, q, CENTER=.TRUE., SEP=' ') - call UWWORD(line, iloc, 11, 1, 'lake', n, q, CENTER=.TRUE., SEP=' ') - if (this%noutlets > 0) then - call UWWORD(line, iloc, 11, 1, 'external', n, q, CENTER=.TRUE., SEP=' ') - call UWWORD(line, iloc, 11, 1, 'internal', n, q, CENTER=.TRUE., SEP=' ') - if (this%imover == 1) then - call UWWORD(line, iloc, 11, 1, 'lake', n, q, CENTER=.TRUE., SEP=' ') - end if - end if - call UWWORD(line, iloc, 11, 1, 'constant', n, q, CENTER=.TRUE., SEP=' ') - call UWWORD(line, iloc, 11, 1, 'lake', n, q, CENTER=.TRUE., SEP=' ') - call UWWORD(line, iloc, 11, 1, 'percent', n, q, CENTER=.TRUE.) - ! -- 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, 1, 'name', n, q, left=.TRUE.) - end if - call UWWORD(line, iloc, 6, 1, 'no.', n, q, CENTER=.TRUE.) - call UWWORD(line, iloc, 11, 1, 'inflow', n, q, CENTER=.TRUE., SEP=' ') - if (this%noutlets > 0) then - call UWWORD(line, iloc, 11, 1, 'inflow', n, q, CENTER=.TRUE., SEP=' ') - end if - call UWWORD(line, iloc, 11, 1, 'runoff', n, q, CENTER=.TRUE., SEP=' ') - if (this%imover == 1) then - call UWWORD(line, iloc, 11, 1, 'from mvr', n, q, CENTER=.TRUE., SEP=' ') - end if - call UWWORD(line, iloc, 11, 1, 'rainfall', n, q, CENTER=.TRUE., SEP=' ') - call UWWORD(line, iloc, 11, 1, 'leakage in', n, q, CENTER=.TRUE., SEP=' ') - call UWWORD(line, iloc, 11, 1, 'leakage out', n, q, CENTER=.TRUE., SEP=' ') - call UWWORD(line, iloc, 11, 1, 'evaporation', n, q, CENTER=.TRUE., SEP=' ') - call UWWORD(line, iloc, 11, 1, 'withdrawal', n, q, CENTER=.TRUE., SEP=' ') - call UWWORD(line, iloc, 11, 1, 'storage', n, q, CENTER=.TRUE., SEP=' ') - if (this%noutlets > 0) then - call UWWORD(line, iloc, 11, 1, 'outflow', n, q, CENTER=.TRUE., SEP=' ') - call UWWORD(line, iloc, 11, 1, 'outflow', n, q, CENTER=.TRUE., SEP=' ') - if (this%imover == 1) then - call UWWORD(line, iloc, 11, 1, 'to mvr', n, q, CENTER=.TRUE., SEP=' ') - end if - end if - call UWWORD(line, iloc, 11, 1, 'flow', n, q, CENTER=.TRUE., SEP=' ') - call UWWORD(line, iloc, 11, 1, 'in - out', n, q, CENTER=.TRUE., SEP=' ') - call UWWORD(line, iloc, 11, 1, 'difference', n, q, CENTER=.TRUE.) - ! -- 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, 1, this%lakename(n), n, q, left=.TRUE.) - end if - call UWWORD(line, iloc, 6, 2, text, n, q) - qtin = DZERO - qtout = DZERO - qin = this%inflow(n)%value - call UWWORD(line, iloc, 11, 3, text, n, qin, SEP=' ') - qinternalin = DZERO - if (this%noutlets > 0) then - call this%lak_get_internal_inlet(n, qinternalin) - call UWWORD(line, iloc, 11, 3, text, n, qinternalin, SEP=' ') - end if - qro = this%runoff(n)%value - call UWWORD(line, iloc, 11, 3, text, n, qro, SEP=' ') - qfrommover = DZERO - if (this%imover == 1) then - qfrommover = this%pakmvrobj%get_qfrommvr(n) - call UWWORD(line, iloc, 11, 3, text, n, qfrommover, SEP=' ') - end if - qrai = this%precip(n) - call UWWORD(line, iloc, 11, 3, text, n, qrai, SEP=' ') - ! leakage - qleakin = DZERO - qleakout = DZERO - hlak = this%xnewpak(n) - do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 - q = this%qleak(j) - if (q < DZERO) then - qleakout = qleakout + q - qtout = qtout + q - else - qleakin = qleakin + q - qtin = qtin + q - end if - end do - call UWWORD(line, iloc, 11, 3, text, n, qleakin, SEP=' ') - call UWWORD(line, iloc, 11, 3, text, n, qleakout, SEP=' ') - qevt = this%evap(n) - call UWWORD(line, iloc, 11, 3, text, n, qevt, SEP=' ') - qwdw = this%withr(n) - call UWWORD(line, iloc, 11, 3, text, n, qwdw, SEP=' ') - ! storage changes - qsto = DZERO - qsto = this%qsto(n) - if (qsto < DZERO) then - qtout = qtout + qsto - else - qtin = qtin + qsto - end if - call UWWORD(line, iloc, 11, 3, text, n, qsto, SEP=' ') - qext = DZERO - qtomover = DZERO - qinternalout = DZERO - if (this%noutlets > 0) then - ! external outflow - call this%lak_get_external_outlet(n, qext) - ! internal outflow - call this%lak_get_internal_outlet(n, qinternalout) - ! subtract tomover from external or internal outflow - if (this%imover == 1) then - if (qext < DZERO) then - call this%lak_get_external_mover(n, qtomover) - qext = qext + qtomover - else if (qinternalout < DZERO) then - call this%lak_get_internal_mover(n, qtomover) - qinternalout = qinternalout + qtomover - end if - if (qtomover > DZERO) then - qtomover = -qtomover - end if - end if - ! write external outflow, internal outflow, and tomover - call UWWORD(line, iloc, 11, 3, text, n, qext, SEP=' ') - call UWWORD(line, iloc, 11, 3, text, n, qinternalout, SEP=' ') - if (this%imover == 1) then - call UWWORD(line, iloc, 11, 3, text, n, qtomover, SEP=' ') - end if - end if - ! constant flow - qch = this%chterm(n) - if (qch < DZERO) then - qtout = qtout + qch - else - qtin = qtin + qch - end if - call UWWORD(line, iloc, 11, 3, text, n, qch, SEP=' ') - ! complete qtin - qtin = qtin + qin + qinternalin + qro + qfrommover + qrai - ! complete qtout - qtout = qtout + qevt + qwdw + qext + qtomover + qinternalout - ! error - qerr = qtin + qtout - ! percent difference - qavg = DHALF * (qtin - qtout) - qerrpd = DZERO - if (qavg /= DZERO) then - qerrpd = DHUNDRED * qerr / qavg - end if - call UWWORD(line, iloc, 11, 3, text, n, qerr, SEP=' ') - call UWWORD(line, iloc, 11, 3, text, n, qerrpd) - ! -- write data for lake - write(iout, '(1X,A)') line(1:iloc) - end do - - end if - ! - ! -- Output lake budget - call this%budget%budget_ot(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 - ! - ! -- Lake objects - call this%budget%budget_da() - deallocate(this%budget) - ! - ! -- 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 - ! - ! -- scalars - call mem_deallocate(this%iprhed) - call mem_deallocate(this%istageout) - call mem_deallocate(this%ibudgetout) - 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) - ! - ! -- 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,'"') -30 format('Error: Boundary name not provided for observation "',a, & - '" in package "',a,'"') -60 format('Error: Invalid node number in OBS input: ',i0) - ! - 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_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 - !write(*,'(i1,3(1x,g15.7))') 0, resid, resid1, dh - else - if (resid < DZERO) then - resid = DZERO - end if - call this%lak_vol2stage(n, resid, dh) - dh = hlak - dh - this%ncncvr(n) = 1 - !write(*,'(i1,3(1x,g15.7))') 1, resid, resid1, dh - 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 - !write(*,*) 'using bisection' - ! -- 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 - ! - !write(*,'(4x,2(i4.4,1x),2(g15.7,1x))') n, iter, this%seep0(n), this%seep(n) - ! - ! -- 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 the aquifer sources to the lake - !do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 - ! igwfnode = this%cellid(j) - ! 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 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 - - -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 ed27b78439a..1530c8eb81f 100644 --- a/src/Model/GroundWaterFlow/gwf3maw8.f90 +++ b/src/Model/GroundWaterFlow/gwf3maw8.f90 @@ -1,4231 +1,4376 @@ -module mawmodule - ! - use KindModule, only: DP, I4B - use ConstantsModule, only: LINELENGTH, LENBOUNDNAME, LENTIMESERIESNAME, & - & DZERO, DEM6, DEM4, DEM2, DHALF, DP7, DP9, DONE, & - & DTWO, DPI, DEIGHT, DHUNDRED, DEP20, & - & NAMEDBOUNDFLAG, LENPACKAGENAME, LENAUXNAME, & - & LENFTYPE, DHNOFLO, DHDRY, DNODATA, MAXCHARLEN - use SmoothingModule, only: sQuadraticSaturation, sQSaturation, & - & sQuadraticSaturationDerivative, sQSaturationDerivative - use BndModule, only: BndType - use BudgetModule, only : BudgetType - - 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 - ! - 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 budgets - integer(I4B), pointer :: bditems => NULL() - ! - ! -- for underrelaxation of estimated well q if using shutoff - real(DP), pointer :: theta => NULL() - real(DP), pointer :: kappa => NULL() - ! - ! -- derived types - type(BudgetType), pointer :: budget => NULL() - type(MawWellType), dimension(:), pointer, contiguous :: mawwells => 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 :: 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 - 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 - ! - ! -- 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) - 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 SimModule, only: ustop, store_error, count_errors, store_error_unit - 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 - use SimModule, only: ustop, store_error, count_errors - ! -- 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 - use SimModule, only: ustop, store_error, count_errors - ! -- 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() - ! - ! -- return - return - end subroutine maw_read_dimensions - - - subroutine maw_read_initial_attr(this) -! ****************************************************************************** -! pak1read_dimensions -- Read the initial parameters for this package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, count_errors - use MemoryManagerModule, only: mem_setptr - use BudgetModule, only: budget_cr - ! -- dummy - class(MawType),intent(inout) :: this - ! -- local - integer(I4B) :: j, n - integer(I4B) :: nn - integer(I4B) :: inode - integer(I4B) :: idx - integer(I4B) :: ival - real(DP) :: k11, k22 - character (len=10), dimension(0:4) :: ccond - character (len=30) :: nodestr - character (len=10) :: crskin, ckskin - ! -- 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))" -! ------------------------------------------------------------------------------ - ! - ! -- setup the maw budget - call budget_cr(this%budget, this%origin) - ival = this%bditems - if (this%iflowingwells /= 1) ival = this%bditems - 1 - call this%budget%budget_df(ival, this%name, 'L**3') - ! - ! -- 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() - ! - ! -- set initial pump elevation and calculate the saturated conductance - do n = 1, this%nmawwells - ! -- initial pump elevation is set at the lowest screen elevation - this%mawwells(n)%pumpelev = this%mawwells(n)%botscrn(1) - do j = 2, this%mawwells(n)%ngwfnodes - if (this%mawwells(n)%botscrn(j) < this%mawwells(n)%pumpelev) then - this%mawwells(n)%pumpelev = this%mawwells(n)%botscrn(j) - end if - end do - ! -- 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 - ! -- write well data - write (this%iout,fmtwelln) ' WELL NO.', ' RADIUS', ' AREA', & - ' WELL BOT.', ' STRT', ' NGWFNODES', & - 'CONDEQN ', 'NAME ' - do n = 1, this%nmawwells - write (this%iout,fmtwelld) n, this%mawwells(n)%radius, this%mawwells(n)%area, & - this%mawwells(n)%bot, this%mawwells(n)%strt, & - this%mawwells(n)%ngwfnodes, & - ccond(this%mawwells(n)%ieqn), & - this%mawwells(n)%name - end do - ! -- write end line - write (this%iout,fmtline) - ! - ! -- write well connection data - write (this%iout,fmtwellcn) ' WELL NO.', 'WELL CONN', & - 'CELL ', & - ' TOP SCRN', ' BOT SCRN', & - ' SKIN RAD.', ' SKIN K', & - ' K11', ' K22', & - 'WELL COND.' - do n = 1, this%nmawwells - do j = 1, this%mawwells(n)%ngwfnodes - nn = this%mawwells(n)%gwfnodes(j) - call this%dis%noder_to_string(nn, nodestr) - crskin = ' ' - ckskin = ' ' - if (this%mawwells(n)%ieqn == 2 .or. & - this%mawwells(n)%ieqn == 3 .or. & - this%mawwells(n)%ieqn == 4) then - write (crskin, '(G10.3)') this%mawwells(n)%sradius(j) - write (ckskin, '(G10.3)') this%mawwells(n)%hk(j) - end if - k11 = this%gwfk11(nn) - if(this%gwfik22 == 0) then - k22 = this%gwfk11(nn) - else - k22 = this%gwfk22(nn) - endif - write (this%iout,fmtwellcd) n, j, nodestr, & - this%mawwells(n)%topscrn(j), & - this%mawwells(n)%botscrn(j), & - crskin, ckskin, & - k11, k22, this%mawwells(n)%satcond(j) - end do - end do - ! - ! -- write end line - write (this%iout,fmtline) - ! - ! -- finished with pointer to gwf hydraulic conductivity - this%gwfk11 => null() - this%gwfk22 => null() - this%gwfik22 => null() - this%gwfsat => null() - ! - ! -- 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 - use SimModule, only: ustop, store_error - ! -- 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 - 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 - ! - ! -- write keyword data to output file - if (this%iprpak /= 0) then - write (this%iout, '(3x,i10,1x,a)') imaw, line(i0:istop) - end if - ! - ! -- 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,i6,1x,a)') & - '****ERROR.', keyword, ' for MAW well', imaw, 'has already been set.' - else - write(errmsg,'(4x,a,1x,a,1x,a,1x,i6,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 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 - ! -- 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,1x,i3,1x,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 - 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 - use SimModule, only: store_error, ustop - ! -- 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 - use SimModule, only: store_error, ustop - ! -- 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 SimModule, only: ustop, store_error - 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 - use SimModule, only: ustop, store_error, count_errors - ! -- dummy - class(MawType),intent(inout) :: this - ! -- local - character (len=16) :: csteady - character (len=10) :: chead, credlen, cmin, cmax - integer(I4B) :: ierr - integer(I4B) :: node, n - integer(I4B) :: isofirst - logical :: isfound, endOfBlock - character(len=LINELENGTH) :: line - character(len=LINELENGTH) :: errmsg - 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')" - character(len=*),parameter :: fmtstdy = & - "(1X,//21X,'MULTI-AQUIFER WELL DATA'," // & - "/21X,'FOR STRESS PERIOD',I6," // & - "/20X,A16,1X,'MAW WELLS'," // & - "//29X,'RATE DATA'," // & - "/1X,65('-'),/1X,' WELL NO. STATUS RATE SPEC. HEAD " // & - " PUMP ELEV RED. LEN.')" - character(len=*), parameter :: fmtwelld = & - "(1X,I10,1X,A10,1X,G10.3,1X,A10,G10.3,1X,A10)" - character(len=*),parameter :: fmtfwh = & - "(1X,//21X,'MULTI-AQUIFER WELL DATA'," // & - "/21X,'FOR STRESS PERIOD',I6," // & - "//25X,'FLOWING WELL DATA'," // & - "/1X,65('-'),/12X,' WELL NO. ELEVATION CONDUCT. RED. LEN.')" - character(len=*), parameter :: fmtfwd = & - "(12X,I10,1X,3(G10.3,1X))" - character(len=*),parameter :: fmtsoh = & - "(1X,//21X,'MULTI-AQUIFER WELL DATA'," // & - "/21X,'FOR STRESS PERIOD',I6," // & - "//25X,'WELL SHUTOFF DATA'," // & - "/1X,65('-'),/12X,' WELL NO. ELEVATION MINQ MAXQ')" - character(len=*), parameter :: fmtsod = & - "(12X,I10,1X,G10.3,1X,2(A10,1X))" - character(len=*), parameter :: fmtline = & - "(1X,65('-'),//)" -! ------------------------------------------------------------------------------ - ! - ! -- initialize flags - isfirst = 1 - ! - ! -- 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 - - this%check_attr = 1 - 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)') ' MAW WELL KEYWORD AND DATA' - write(this%iout,'(3x,78("-"))') - end if - end if - 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) - end do - 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 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 - write (this%iout, fmtstdy) kper, csteady - do n = 1, this%nmawwells - chead = ' -- ' - if (this%iboundpak(n) < 0) then - !write (chead,'(G10.3)') this%xnewpak(n) - write (chead,'(G10.3)') this%mawwells(n)%head%value - end if - credlen = ' -- ' - if (this%mawwells(n)%reduction_length /= DEP20) then - write (credlen,'(G10.3)') this%mawwells(n)%reduction_length - end if - write(this%iout,fmtwelld) n, this%mawwells(n)%status, & - this%mawwells(n)%rate%value, chead, & - this%mawwells(n)%pumpelev, & - credlen - end do - write (this%iout, fmtline) - - if (this%iflowingwells /= 0) then - write (this%iout, fmtfwh) kper - do n = 1, this%nmawwells - if (this%mawwells(n)%fwcond > DZERO) then - write(this%iout,fmtfwd) n, this%mawwells(n)%fwelev, & - this%mawwells(n)%fwcond, & - this%mawwells(n)%fwrlen - end if - end do - write (this%iout, fmtline) - end if - - ! -- shutoff data - isofirst = 1 - do n = 1, this%nmawwells - if (this%mawwells(n)%shutofflevel /= DEP20) then - if (isofirst /= 0) then - isofirst = 0 - write (this%iout, fmtsoh) kper - end if - cmin = ' -- ' - cmax = ' -- ' - if (this%mawwells(n)%shutoffmin > DZERO) then - write (cmin,'(G10.3)') this%mawwells(n)%shutoffmin - write (cmax,'(G10.3)') this%mawwells(n)%shutoffmax - end if - write(this%iout,fmtsod) n, this%mawwells(n)%shutofflevel, & - cmin, cmax - end if - end do - if (isofirst /= 1) then - write (this%iout, fmtline) - 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 -! ------------------------------------------------------------------------------ - ! - !! -- call base advance functionality - !call this%BndType%bnd_ad() - ! - ! -- Advance the time series - call this%TsManager%ad() - ! - ! -- 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) - ! ****************************************************************************** - ! maw_cf -- Formulate the HCOF and RHS terms - ! Subroutine: (1) skip if no multi-aquifer wells - ! (2) calculate hcof and rhs - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - class(MawType) :: this - ! ------------------------------------------------------------------------------ - ! - ! -- Calculate maw conductance and update package RHS and HCOF - call this%maw_cfupdate() - ! - ! -- pakmvrobj cf - if(this%imover == 1) 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, kper, kstp - ! -- 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) -! ****************************************************************************** -! 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 - ! -- local - integer(I4B) :: n - real(DP) :: botw -! ------------------------------------------------------------------------------ - - ! - ! -- 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 - x(n) = xtemp(n)*(DONE-DP9) + botw*DP9 - 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 - real(DP) :: gwfratin, gwfratout - real(DP) :: storatin, storatout - real(DP) :: ratin, ratout - real(DP) :: chrrate, chratin, chratout - real(DP) :: fwratin, fwratout - real(DP) :: mvrratin, mvrratout, mvrfwratout - real(DP) :: ratsum - integer(I4B) :: naux - ! -- for budget - integer(I4B) :: i, j, n - integer(I4B) :: n2 - 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 - real(DP) :: b - real(DP) :: tmaw - real(DP) :: sat - real(DP) :: q - real(DP) :: q2 - real(DP) :: qfact - ! -- 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) - ! - ! -- maw budget routines (start by resetting) - call this%budget%reset() - ! - ! -- add to maw budget terms - ! -- gwf flow - gwfratin = DZERO - gwfratout = DZERO - storatin = DZERO - storatout = DZERO - ratin = DZERO - ratout = DZERO - chratin = DZERO - chratout = DZERO - fwratin = DZERO - fwratout = DZERO - mvrratin = DZERO - mvrratout = DZERO - mvrfwratout = DZERO - ratsum = DZERO - 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 - hmaw = this%xnewpak(n) - ! -- add pumping rate to active maw well - if (this%iboundpak(n) > 0) then - rrate = this%mawwells(n)%ratesim - if (rrate < DZERO) then - ! - ! -- Flow is out of maw subtract rate from ratout. - this%qout(n) = rrate - end if - ! -- add flowing well - this%mawwells(n)%xsto = hmaw - 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 - this%qout(n) = this%qout(n) + rrate - end if - end if - ! - ! -- add rate and fwrate terms to budget terms - ! - ! -- adjust rate for mover - rrate = this%mawwells(n)%ratesim - if (this%imover == 1) then - qfact = DZERO - if (rrate < DZERO) then - if (this%qout(n) < DZERO) then - qfact = rrate / this%qout(n) - end if - end if - rrate = rrate + qfact * this%pakmvrobj%get_qtomvr(n) - end if - ! - ! -- See if flow is into maw or out of maw. - if (rrate < DZERO) then - ! - ! -- Flow is out of maw subtract rate from ratout. - ratout = ratout - rrate - else - ! - ! -- Flow is into maw; add rate to ratin. - ratin = ratin + rrate - end if - ! - ! -- adjust flowing well rate for mover - if (this%iflowingwells > 0) then - rrate = this%qfw(n) - if (this%imover == 1) then - qfact = DZERO - if (rrate < DZERO) then - if (this%qout(n) < DZERO) then - qfact = rrate / this%qout(n) - end if - end if - rrate = rrate + qfact * this%pakmvrobj%get_qtomvr(n) - end if - ! - ! -- See if flowing well flow is into maw or out of maw. - if (rrate < DZERO) then - ! - ! -- Flow is out of maw subtract rate from ratout. - fwratout = fwratout - rrate - else - ! - ! -- Flow is into maw; add rate to ratin. - fwratin = fwratin + rrate - end if - end if - ! -- add maw storage changes - if (this%imawiss /= 1) then - rrate = -this%mawwells(n)%area * (this%mawwells(n)%xsto - this%mawwells(n)%xoldsto) / delt - this%qsto(n) = rrate - ! - ! -- See if storage flow is into maw or out of maw. - if(rrate < DZERO) then - ! - ! -- Flow is out of maw subtract rate from ratout. - storatout = storatout - rrate - else - ! - ! -- Flow is into maw; add rate to ratin. - storatin = storatin + rrate - endif - end if - ! - ! -- add mover terms - if (this%imover == 1) then - ! - ! -- from mover - rrate = this%pakmvrobj%get_qfrommvr(n) - mvrratin = mvrratin + rrate - ! - ! -- to mover - ! - ! -- rate - q2 = this%mawwells(n)%ratesim - if (q2 < DZERO) then - rrate = this%pakmvrobj%get_qtomvr(n) - qfact = DZERO - if (this%qout(n) < DZERO) then - qfact = q2 / this%qout(n) - end if - rrate = rrate * qfact - mvrratout = mvrratout + rrate - end if - ! - ! -- fwrate - if (this%iflowingwells > 0) then - q2 = this%qfw(n) - rrate = this%pakmvrobj%get_qtomvr(n) - qfact = DZERO - if (this%qout(n) < DZERO) then - qfact = q2 / this%qout(n) - end if - rrate = rrate * qfact - mvrfwratout = mvrfwratout + rrate - end if - end if - end if - end do - ! - ! -- gwf flow and constant flow to maw - ibnd = 1 - do n = 1, this%nmawwells - rrate = DZERO - chrrate = DZERO - hmaw = this%xnewpak(n) - 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) - ratsum = ratsum + rrate - this%qleak(ibnd) = rrate - if (this%iboundpak(n) < 0) then - chrrate = chrrate - rrate - end if - ! - ! -- See if flow is into maw or out of maw. - if(rrate < DZERO) then - ! - ! -- Flow is out of maw subtract rate from ratout. - gwfratout = gwfratout - rrate - else - ! - ! -- Flow is into maw; add rate to ratin. - gwfratin = gwfratin + rrate - endif - ! - ! -- See if flow is into maw or out of maw. - if(chrrate < DZERO) then - ! - ! -- Flow is out of maw subtract rate from ratout. - chratout = chratout - chrrate - else - ! - ! -- Flow is into maw; add rate to ratin. - chratin = chratin + chrrate - endif - ibnd = ibnd + 1 - end do - if (this%iboundpak(n) < 0) then - this%mawwells(n)%ratesim = -ratsum - end if - this%qconst(n) = chrrate - end do - ! - ! -- add calculated terms - call this%budget%addentry(gwfratin, gwfratout, delt, & - this%cmawbudget(1), isuppress_output) - if (this%imover == 1) then - call this%budget%addentry(mvrratin, DZERO, delt, & - this%cmawbudget(6), isuppress_output) - end if - call this%budget%addentry(ratin, ratout, delt, & - this%cmawbudget(2), isuppress_output) - if (this%imover == 1) then - call this%budget%addentry(DZERO, mvrratout, delt, & - this%cmawbudget(7), isuppress_output) - end if - if (this%imawissopt /= 1) then - call this%budget%addentry(storatin, storatout, delt, & - this%cmawbudget(3), isuppress_output) - end if - call this%budget%addentry(chratin, chratout, delt, & - this%cmawbudget(4), isuppress_output) - if (this%iflowingwells /= 0) then - call this%budget%addentry(fwratin, fwratout, delt, & - this%cmawbudget(5), isuppress_output) - if (this%imover == 1) then - call this%budget%addentry(DZERO, mvrfwratout, delt, & - this%cmawbudget(8), isuppress_output) - end if - end if - ! - ! -- 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) < 1) 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 - ! - ! -- Set unit number for binary budget output - ibinun = 0 - if(this%ibudgetout /= 0) then - ibinun = this%ibudgetout - end if - if(icbcfl == 0) ibinun = 0 - if (isuppress_output /= 0) ibinun = 0 - ! - ! -- write maw binary budget output - if (ibinun > 0) then - ! GWF FLOW - naux = this%cbcauxitems - this%cauxcbc(1) = ' FLOW-AREA' - call ubdsv06(kstp, kper, this%cmawbudget(1), this%name_model, this%name, & - this%name_model, this%name_model, & - ibinun, naux, this%cauxcbc, this%maxbound, 1, 1, & - this%maxbound, this%iout, delt, pertim, totim) - 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) - ! -- fill qauxcbc - ! -- connection surface area - this%qauxcbc(1) = DTWO * DPI * this%mawwells(n)%radius * sat * (tmaw - bmaw) - ! -- get leakage - q = this%qleak(ibnd) - call this%dis%record_mf6_list_entry(ibinun, n, n2, q, naux, & - this%qauxcbc, & - olconv=.FALSE.) - ibnd = ibnd + 1 - end do - end do - ! WELL RATE - naux = 0 - call ubdsv06(kstp, kper, this%cmawbudget(2), this%name_model, this%name, & - this%name_model, this%name, & - ibinun, naux, this%auxname, this%nmawwells, 1, 1, & - this%nmawwells, this%iout, delt, pertim, totim) - 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%iflowingwells > 0) then - if (this%qout(n) < DZERO) then - qfact = q / this%qout(n) - end if - end if - q = q + qfact * this%pakmvrobj%get_qtomvr(n) - end if - call this%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%auxvar(:,n), & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - ! FLOWING WELL - if (this%iflowingwells > 0) then - naux = 0 - call ubdsv06(kstp, kper, this%cmawbudget(5), & - this%name_model, this%name, & - this%name_model, this%name, & - ibinun, naux, this%auxname, this%nmawwells, 1, 1, & - this%nmawwells, this%iout, delt, pertim, totim) - do n = 1, this%nmawwells - q = this%qfw(n) - if (this%imover == 1) then - qfact = DONE - q2 = this%mawwells(n)%ratesim - ! adjust if well rate is an outflow - if (q2 < DZERO) then - if (this%qout(n) < DZERO) then - qfact = q / this%qout(n) - end if - end if - q = q + qfact * this%pakmvrobj%get_qtomvr(n) - end if - call this%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%auxvar(:,n), & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - end if - ! STORAGE - if (this%imawissopt /= 1) then - naux = this%cbcauxitems - this%cauxcbc(1) = 'VOLUME ' - call ubdsv06(kstp, kper, this%cmawbudget(3), & - this%name_model, this%name, & - this%name_model, this%name, & - ibinun, naux, this%cauxcbc, this%nmawwells, 1, 1, & - this%nmawwells, this%iout, delt, pertim, totim) - 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 - q = this%qsto(n) - this%qauxcbc(1) = v - call this%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%qauxcbc, & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - end if - ! CONSTANT FLOW - naux = 0 - call ubdsv06(kstp, kper, this%cmawbudget(4), this%name_model, this%name, & - this%name_model, this%name, & - ibinun, naux, this%auxname, this%nmawwells, 1, 1, & - this%nmawwells, this%iout, delt, pertim, totim) - do n = 1, this%nmawwells - q = this%qconst(n) - call this%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%auxvar(:,n), & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - ! MOVER - if (this%imover == 1) then - ! FROM MOVER - naux = 0 - call ubdsv06(kstp, kper, this%cmawbudget(6), this%name_model, & - this%name, this%name_model, this%name, & - ibinun, naux, this%auxname, & - this%nmawwells, 1, 1, & - this%nmawwells, this%iout, delt, pertim, totim) - do n = 1, this%nmawwells - if (this%iboundpak(n) == 0) then - q = DZERO - else - q = this%pakmvrobj%get_qfrommvr(n) - end if - call this%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%auxvar(:,n), & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - ! TO MOVER FROM WELL RATE - naux = 0 - call ubdsv06(kstp, kper, this%cmawbudget(7), this%name_model, & - this%name, this%name_model, this%name, & - ibinun, naux, this%auxname, & - this%nmawwells, 1, 1, & - this%nmawwells, this%iout, delt, pertim, totim) - 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%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%auxvar(:,n), & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - ! TO MOVER FROM FLOWING WELL - if (this%iflowingwells > 0) then - naux = 0 - call ubdsv06(kstp, kper, this%cmawbudget(8), this%name_model, & - this%name, this%name_model, this%name, & - ibinun, naux, this%auxname, & - this%nmawwells, 1, 1, & - this%nmawwells, this%iout, delt, pertim, totim) - 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%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%auxvar(:,n), & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - end if - end if - ! AUXILIARY VARIABLES - naux = this%naux - if (naux > 0) then - call ubdsv06(kstp, kper, ' AUXILIARY', this%name_model, this%name,& - this%name_model, this%name, & - ibinun, naux, this%auxname, this%nmawwells, 1, 1, & - this%nmawwells, this%iout, delt, pertim, totim) - do n = 1, this%nmawwells - q = DZERO - ! fill auxvar - do i = 1, naux - this%auxvar(i,n) = this%mawwells(n)%auxvar(i)%value - end do - call this%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%auxvar(:,n), & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - end if - - - end if - ! - ! -- return - return - end subroutine maw_bd - - - subroutine maw_ot(this, kstp, kper, iout, ihedfl, ibudfl) - ! ************************************************************************** - ! pak1t -- Output package budget - ! ************************************************************************** - ! - ! SPECIFICATIONS: - ! -------------------------------------------------------------------------- - ! - use InputOutputModule, only: UWWORD - ! -- 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 - character(len=LINELENGTH) :: line, linesep - character(len=16) :: text - integer(I4B) :: j - integer(I4B) :: n - integer(I4B) :: ibnd - integer(I4B) :: iloc - real(DP) :: q - real(DP) :: qfact - real(DP) :: qgwfin - real(DP) :: qgwfout - real(DP) :: qfrommvr - real(DP) :: qrate - real(DP) :: qfwrate - real(DP) :: qratetomvr - real(DP) :: qfwratetomvr - real(DP) :: qsto - real(DP) :: qconst - real(DP) :: qin - real(DP) :: qout - real(DP) :: qerr - real(DP) :: qavg - real(DP) :: qpd - ! format - 2000 FORMAT ( 1X, ///1X, A, A, A, ' PERIOD ', I6, ' STEP ', I8) - ! -------------------------------------------------------------------------- - ! - ! -- write MAW heads to the listing file - if (ihedfl /= 0 .and. this%iprhed /= 0) then - write (iout, 2000) 'MULTI-AQUIFER WELL (', trim(this%name), ') HEAD', kper, kstp - iloc = 1 - line = '' - if (this%inamedbound==1) then - call UWWORD(line, iloc, 16, 1, 'well', n, q, left=.TRUE.) - end if - call UWWORD(line, iloc, 6, 1, 'well', n, q, CENTER=.TRUE.) - call UWWORD(line, iloc, 11, 1, 'well', n, q, CENTER=.TRUE.) - ! -- 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, 1, 'name', n, q, left=.TRUE.) - end if - call UWWORD(line, iloc, 6, 1, 'no.', n, q, CENTER=.TRUE.) - call UWWORD(line, iloc, 11, 1, 'head', n, q, CENTER=.TRUE.) - ! -- write second line - write(iout,'(1X,A)') line(1:iloc) - write(iout,'(1X,A)') linesep(1:iloc) - ! -- write data - do n = 1, this%nmawwells - iloc = 1 - line = '' - if (this%inamedbound==1) then - call UWWORD(line, iloc, 16, 1, this%mawwells(n)%name, n, q, left=.TRUE.) - end if - call UWWORD(line, iloc, 6, 2, text, n, q) - call UWWORD(line, iloc, 11, 3, text, n, this%xnewpak(n)) - write(iout, '(1X,A)') line(1:iloc) - end do - end if - ! - ! -- write MAW flows to the listing file - if (ibudfl /= 0 .and. this%iprflow /= 0) then - write (iout, 2000) 'MULTI-AQUIFER WELL (', trim(this%name), ') FLOWS', kper, kstp - iloc = 1 - line = '' - if (this%inamedbound==1) then - call UWWORD(line, iloc, 16, 1, 'well', n, q, left=.TRUE.) - end if - call UWWORD(line, iloc, 6, 1, 'well', n, q, CENTER=.TRUE.) - call UWWORD(line, iloc, 11, 1, 'gwf', n, q, CENTER=.TRUE.) - call UWWORD(line, iloc, 11, 1, 'gwf', n, q, CENTER=.TRUE.) - if (this%imover == 1) then - call UWWORD(line, iloc, 11, 1, 'from', n, q, CENTER=.TRUE.) - end if - call UWWORD(line, iloc, 11, 1, 'well', n, q, CENTER=.TRUE.) - if (this%imover == 1) then - call UWWORD(line, iloc, 11, 1, 'rate', n, q, CENTER=.TRUE.) - end if - if (this%iflowingwells > 0) then - call UWWORD(line, iloc, 11, 1, 'flowing', n, q, CENTER=.TRUE.) - if (this%imover == 1) then - call UWWORD(line, iloc, 11, 1, 'flowing', n, q, CENTER=.TRUE.) - end if - end if - if (this%imawissopt /= 1) then - call UWWORD(line, iloc, 11, 1, 'well', n, q, CENTER=.TRUE.) - end if - call UWWORD(line, iloc, 11, 1, 'constant', n, q, CENTER=.TRUE.) - call UWWORD(line, iloc, 11, 1, 'well', n, q, CENTER=.TRUE., SEP=' ') - call UWWORD(line, iloc, 11, 1, 'percent', n, q, CENTER=.TRUE.) - ! -- 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, 1, 'name', n, q, left=.TRUE.) - end if - call UWWORD(line, iloc, 6, 1, 'no.', n, q, CENTER=.TRUE.) - call UWWORD(line, iloc, 11, 1, 'in', n, q, CENTER=.TRUE.) - call UWWORD(line, iloc, 11, 1, 'out', n, q, CENTER=.TRUE.) - if (this%imover == 1) then - call UWWORD(line, iloc, 11, 1, 'mover', n, q, CENTER=.TRUE.) - end if - call UWWORD(line, iloc, 11, 1, 'rate', n, q, CENTER=.TRUE.) - if (this%imover == 1) then - call UWWORD(line, iloc, 11, 1, 'to mvr', n, q, CENTER=.TRUE.) - end if - if (this%iflowingwells > 0) then - call UWWORD(line, iloc, 11, 1, 'rate', n, q, CENTER=.TRUE.) - if (this%imover == 1) then - call UWWORD(line, iloc, 11, 1, 'to mvr', n, q, CENTER=.TRUE.) - end if - end if - if (this%imawissopt /= 1) then - call UWWORD(line, iloc, 11, 1, 'storage', n, q, CENTER=.TRUE.) - end if - call UWWORD(line, iloc, 11, 1, 'flow', n, q, CENTER=.TRUE.) - call UWWORD(line, iloc, 11, 1, 'in - out', n, q, CENTER=.TRUE., SEP=' ') - call UWWORD(line, iloc, 11, 1, 'difference', n, q, CENTER=.TRUE.) - ! -- write second line - write(iout,'(1X,A)') line(1:iloc) - write(iout,'(1X,A)') linesep(1:iloc) - ! - ibnd = 1 - do n = 1, this%nmawwells - qgwfin = DZERO - qgwfout = DZERO - qfrommvr = DZERO - qrate = DZERO - qfwrate = DZERO - qratetomvr = DZERO - qfwratetomvr = DZERO - qsto = DZERO - qconst = DZERO - qin = DZERO - qout = DZERO - qerr = DZERO - qpd = DZERO - qfact = DZERO - do j = 1, this%mawwells(n)%ngwfnodes - q = this%qleak(ibnd) - if (q < DZERO) then - qgwfout = qgwfout + q - else - qgwfin = qgwfin + q - end if - ibnd = ibnd + 1 - end do - iloc = 1 - line = '' - if (this%inamedbound==1) then - call UWWORD(line, iloc, 16, 1, this%mawwells(n)%name, n, q, left=.TRUE.) - end if - call UWWORD(line, iloc, 6, 2, text, n, q) - call UWWORD(line, iloc, 11, 3, text, n, qgwfin) - call UWWORD(line, iloc, 11, 3, text, n, qgwfout) - if (this%imover == 1) then - if (this%iboundpak(n) /= 0) then - qfrommvr = this%pakmvrobj%get_qfrommvr(n) - end if - call UWWORD(line, iloc, 11, 3, text, n, qfrommvr) - end if - if (this%iboundpak(n) < 0) then - q = DZERO - else - q = this%mawwells(n)%ratesim - end if - if (q < DZERO .and. this%qout(n) < DZERO) then - qfact = q / this%qout(n) - if (this%imover == 1) then - q = q + this%pakmvrobj%get_qtomvr(n) * qfact - end if - end if - qrate = q - call UWWORD(line, iloc, 11, 3, text, n, qrate) - if (this%imover == 1) then - qratetomvr = this%pakmvrobj%get_qtomvr(n) * qfact - if (qratetomvr > DZERO) then - qratetomvr = -qratetomvr - end if - call UWWORD(line, iloc, 11, 3, text, n, qratetomvr) - end if - if (this%iflowingwells > 0) then - q = this%qfw(n) - qfact = DONE - if (q < DZERO .and. this%qout(n) < DZERO) then - qfact = q / this%qout(n) - if (this%imover == 1) then - q = q + this%pakmvrobj%get_qtomvr(n) * qfact - end if - end if - qfwrate = q - call UWWORD(line, iloc, 11, 3, text, n, qfwrate) - if (this%imover == 1) then - qfwratetomvr = this%pakmvrobj%get_qtomvr(n) * qfact - if (qfwratetomvr > DZERO) then - qfwratetomvr = -qfwratetomvr - end if - call UWWORD(line, iloc, 11, 3, text, n, qfwratetomvr) - end if - end if - if (this%imawissopt /= 1) then - qsto = this%qsto(n) - call UWWORD(line, iloc, 11, 3, text, n, qsto) - end if - qconst = this%qconst(n) - call UWWORD(line, iloc, 11, 3, text, n, qconst) - ! accumulate qin - qin = qgwfin + qfrommvr - qout = -qgwfout - qratetomvr - qfwratetomvr - if (qrate < DZERO) then - qout = qout - qrate - else - qin = qin + qrate - end if - if (qsto < DZERO) then - qout = qout - qsto - else - qin = qin + qsto - end if - if (qconst < DZERO) then - qout = qout - qconst - else - qin = qin + qconst - end if - qerr = qin - qout - call UWWORD(line, iloc, 11, 3, text, n, qerr, SEP=' ') - qavg = DHALF * (qin + qout) - if (qavg > DZERO) then - qpd = DHUNDRED * qerr / qavg - end if - call UWWORD(line, iloc, 11, 3, text, n, qpd) - write(iout, '(1X,A)') line(1:iloc) - end do - end if - ! - ! -- Output maw budget - call this%budget%budget_ot(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) - ! - ! -- 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) - ! - ! -- objects - call this%budget%budget_da() - deallocate(this%budget) - ! - ! -- 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,'"') -30 format('Error: Boundary name not provided for observation "',a, & - '" in package "',a,'"') -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) - 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 - 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) :: skin - real(DP) :: ravg - real(DP) :: slen - real(DP) :: pavg - real(DP) :: gwfsat - real(DP) :: gwftop - real(DP) :: gwfbot - real(DP) :: denom - real(DP) :: lc1 - real(DP) :: lc2 - real(DP) :: dx - real(DP) :: dy - real(DP) :: Txx - real(DP) :: Tyy - real(DP) :: yx4 - real(DP) :: xy4 - ! -- formats - ! ------------------------------------------------------------------------------ - ! - ! -- 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 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)**0.25D0 - xy4 = (Txx/Tyy)**0.25D0 - eradius = 0.28D0 *((yx4*dx)**2 +(xy4*dy)**2)**0.5D0 / (yx4+xy4) - else - area = this%dis%area(node) - eradius = sqrt(area / (DEIGHT * DPI)) - end if - ! - ! -- conductance calculated using Thiem equation - if (this%mawwells(i)%ieqn == 1) then - c = (DTWO * DPI * tthka * sqrtk11k22) / log(eradius / this%mawwells(i)%radius) - ! -- conductance calculated using skin - else if (this%mawwells(i)%ieqn == 2) then - hks = this%mawwells(i)%hk(j) - ! prevent division by zero - if (tthkw * hks > DZERO) then - skin = (((sqrtk11k22*tthka)/(hks*tthkw)) - DONE) * & - log(this%mawwells(i)%sradius(j)/this%mawwells(i)%radius) - c = (DTWO * DPI * tthka * sqrtk11k22) / skin - end if - ! -- conductance calculated using cumulative Thiem and skin equations - else if (this%mawwells(i)%ieqn == 3) then - ! calculate lc1 - lc1 = log(eradius / this%mawwells(i)%radius) / (DTWO * DPI * tthka * sqrtk11k22) - ! calculate lc2 - hks = this%mawwells(i)%hk(j) - ! prevent division by zero - if (tthkw * hks > DZERO) then - skin = (((sqrtk11k22*tthka)/(hks*tthkw)) - DONE) * & - log(this%mawwells(i)%sradius(j)/this%mawwells(i)%radius) - lc2 = skin / (DTWO * DPI * tthka * sqrtk11k22) - else - lc2 = DZERO - end if - ! calculate conductance - denom = lc1 + lc2 - if (denom > DZERO) then - c = DONE / denom - end if - ! -- conductance calculated using screen elevations, hk, well radius, and screen radius - else 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 = DTWO * DPI * ravg - c = hks * pavg * tthkw / slen - end if - 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 accumulators - q = DZERO - ! -- base pumping rate - rate = this%mawwells(n)%rate%value - if (rate < DZERO) then - !if (this%mawwells(n)%shutoffmin > DZERO) then - 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 (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 - ! -- scale pumpage when hmaw is less than the sum of - ! maw pump elevation (pumpelev) and the specified reduction length - ! Only applied to pumping wells - 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 - ! -- injection is not rate limited - else - q = rate - 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 - - -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 aa0d4f4381c..a3b87c02e49 100644 --- a/src/Model/GroundWaterFlow/gwf3mvr8.f90 +++ b/src/Model/GroundWaterFlow/gwf3mvr8.f90 @@ -1,1014 +1,1242 @@ -!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 -!three arrays: qformvr, qtomvr, and qfrommvr. These arrays are store and -!managed by a separate object PackageMoverType. 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 define the following members: -! -! 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. Create the mover package by calling the cr subroutine: -! -! call mvr_cr(this%mvr, this%name, this%inmvr, this%iout) -! -! 3. The AR method for the mover is called: -! -! if(this%inmvr > 0) call this%mvr%mvr_ar() -! -! Mover aware packages allocate the three vectors (typically to size -! maxbound) -! -! 4. The RP method for the mover is called. This reads the movers active -! for the current period. -! -! if(this%inmvr > 0) call this%mvr%mvr_rp() -! -! 5. The AD method for the mover is called. 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 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%fc() -! -! a. Mover aware packages first set qformvr(:) = 0. -! b. Mover aware packages add qfrommvr terms 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, DZERO, MAXCHARLEN - use MvrModule, only: MvrType - use BudgetModule, only: BudgetType, budget_cr - use NumericalPackageModule, only: NumericalPackageType - use BlockParserModule, only: BlockParserType - - 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() !flag to indicate mover is for an exchange (not for a single model) - integer(I4B), pointer :: imodelnames => null() !flag to 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 !array of package names - type(MvrType), dimension(:), pointer, contiguous :: mvr => null() !array of movers - type(BudgetType), pointer :: budget => null() !mover budget object - 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 :: allocate_scalars - procedure :: allocate_arrays - end type GwfMvrType - - contains - - subroutine mvr_cr(mvrobj, name_parent, inunit, iout, iexgmvr) -! ****************************************************************************** -! 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 -! ------------------------------------------------------------------------------ - ! - ! -- 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 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 package names - call this%read_packages() - ! - ! -- Define the budget object to be the size of package names - call this%budget%budget_df(this%maxpackages, 'WATER MOVER') - ! - ! -- 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 - 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) - ! - ! -- 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 - ! -- opposite direction - ipos = (jj - 1) * this%maxpackages + ii - 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, icnvg) -! ****************************************************************************** -! 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(inout) :: icnvg - ! -- 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 (icnvg == 1 .and. kiter == 1) then - icnvg = 0 - 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: urword, ubdsv06, ubdsvd - ! -- dummy - class(GwfMvrType) :: this - integer(I4B), intent(in) :: icbcfl - integer(I4B), intent(in) :: ibudfl - integer(I4B), intent(in) :: isuppress_output - ! -- locals - character (len=LENBUDTXT) :: text - integer(I4B) :: i - integer(I4B) :: j - integer(I4B) :: n - integer(I4B) :: ipos - integer(I4B) :: ibinun - character (len=LENMODELNAME) :: modelname1, modelname2 - character (len=LENPACKAGENAME) :: packagename1, packagename2 - character (len=LENAUXNAME), dimension(1) :: cauxname - character (len=LENORIGIN+1) :: pakoriginsdummy - integer(I4B) :: ival - integer(I4B) :: naux - integer(I4B) :: nitems - integer(I4B) :: lloc - integer(I4B) :: istart - integer(I4B) :: istop - real(DP) :: rval - real(DP) :: q - real(DP), dimension(1) :: aux - ! -- 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 - ! - ! -- Set unit number for binary budget output - ibinun = 0 - if(this%ibudgetout /= 0) then - ibinun = this%ibudgetout - end if - if(icbcfl == 0) ibinun = 0 - if(isuppress_output /= 0) ibinun = 0 - ! - ! -- write mvr binary budget output - if (ibinun > 0) then - text = 'MOVER FLOW ' - do i = 1, this%maxpackages - ! -- Retrieve modelname1 and packagename1 - lloc = 1 - call urword(this%pakorigins(i), lloc, istart, istop, 1, ival, rval, -1, -1) -!!! modelname1 = this%pakorigins(i)(istart:istop) - pakoriginsdummy = this%pakorigins(i) - modelname1 = pakoriginsdummy(istart:istop) - call urword(this%pakorigins(i), lloc, istart, istop, 1, ival, rval, -1, -1) -!!! packagename1 = this%pakorigins(i)(istart:istop) - 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) -!!! modelname2 = this%pakorigins(j)(istart:istop) - pakoriginsdummy = this%pakorigins(j) - modelname2 = pakoriginsdummy(istart:istop) - call urword(this%pakorigins(j), lloc, istart, istop, 1, ival, rval, -1, -1) -!!! packagename2 = this%pakorigins(j)(istart:istop) - pakoriginsdummy = this%pakorigins(j) - packagename2 = pakoriginsdummy(istart:istop) - ipos = (i - 1) * this%maxpackages + j - nitems = this%ientries(ipos) - naux = 0 - call ubdsv06(kstp, kper, text, modelname1, packagename1, & - modelname2, packagename2, & - ibinun, naux, cauxname, 1, 1, 1, nitems, & - this%iout, delt, pertim, totim) - if (nitems < 1) cycle - do n = 1, this%nmvr - if(this%pakorigins(i) == this%mvr(n)%pname1) then - if(this%pakorigins(j) == this%mvr(n)%pname2) then - q = -this%mvr(n)%qpnew - call ubdsvd(ibinun, this%mvr(n)%irch1, this%mvr(n)%irch2, q, naux, aux) - end if - end if - if(this%pakorigins(i) == this%mvr(n)%pname2) then - if(this%pakorigins(j) == this%mvr(n)%pname1) then - q = this%mvr(n)%qpnew - call ubdsvd(ibinun, this%mvr(n)%irch2, this%mvr(n)%irch1, q, naux, aux) - end if - end if - end do - end do - end do - 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) - ! - ! -- 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) - call this%budget%budget_da() - deallocate(this%budget) - 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 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 - ! -- dummy - class(GwfMvrType) :: this - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- Allocate - allocate(this%mvr(this%maxmvr)) - allocate(this%pakorigins(this%maxpackages)) - allocate(this%paknames(this%maxpackages)) - ! - ! -- 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 - - -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 b26f9ed57cc..9ac8cfce17b 100644 --- a/src/Model/GroundWaterFlow/gwf3npf8.f90 +++ b/src/Model/GroundWaterFlow/gwf3npf8.f90 @@ -1,3270 +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), 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 - 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 :: 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) - ! - 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_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 :: 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 -! ****************************************************************************** -! -! 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, xt3d, ingnc) -! ****************************************************************************** -! npf_df -- Define -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimModule, only: ustop, store_error - use Xt3dModule, only: xt3d_cr - ! -- dummy - class(GwfNpftype) :: this - 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 - ! - ! -- 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 - ! - ! -- 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, nodes, ia, ja) -! ****************************************************************************** -! 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, nodes - integer(I4B), dimension(:), intent(in) :: ia - integer(I4B), dimension(:), intent(in) :: ja - type(sparsematrix), intent(inout) :: sparse - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- Add extended neighbors (neighbors of neighbors) - if(this%ixt3d > 0) call this%xt3d%xt3d_ac(moffset, sparse, nodes, ia, ja) - ! - ! -- Return - return - end subroutine npf_ac - - subroutine npf_mc(this, moffset, nodes, ia, ja, 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, nodes - integer(I4B), dimension(:), intent(in) :: ia - integer(I4B), dimension(:), intent(in) :: ja - integer(I4B), dimension(:), intent(in) :: iasln - integer(I4B), dimension(:), intent(in) :: jasln - ! -- local -! ------------------------------------------------------------------------------ - ! - if(this%ixt3d > 0) call this%xt3d%xt3d_mc(moffset, nodes, ia, ja, iasln, & - jasln, this%inewton) - ! - ! -- Return - return - end subroutine npf_mc - - subroutine npf_ar(this, dis, ic, ibound, hnew) -! ****************************************************************************** -! npf_ar -- Allocate and Read -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfNpftype) :: this - class(DisBaseType), pointer, intent(inout) :: dis - 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%dis => dis - this%ic => ic - this%ibound => ibound - this%hnew => hnew - ! - ! -- allocate arrays - call this%allocate_arrays(dis%nodes, dis%njas) - ! - ! -- read the data block - call this%read_data() - ! - ! -- Initialize and check data - call this%prepcheck() - ! - ! -- xt3d - if(this%ixt3d > 0) call this%xt3d%xt3d_ar(dis, ibound, this%k11, this%ik33,& - this%k33, this%sat, this%ik22, this%k22, this%inewton, this%satmin, & - this%icelltype, this%iangle1, this%iangle2, this%iangle3, & - this%angle1, this%angle2, this%angle3) - ! - ! -- 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, nodes, nja, 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) :: 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, 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, nodes, nja, njasln, amat, idxglo, rhs, hnew) - else - ! - do n = 1, nodes - do ii = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 - 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, nodes, nja, njasln, amat, idxglo, rhs, hnew) -! ****************************************************************************** -! npf_fn -- Fill newton terms -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfNpfType) :: 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,ii,idiag - integer(I4B) :: isymcon, idiagm - integer(I4B) :: iups - integer(I4B) :: idn - real(DP) :: athk - 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 - ! - 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 - 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) -! ****************************************************************************** -! 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 - ! -- local - integer(I4B) :: n - real(DP) :: botm -! ------------------------------------------------------------------------------ - - ! - ! -- 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 - x(n) = xtemp(n)*(DONE-DP9) + botm*DP9 - dx(n) = DZERO - end if - end if - enddo - ! - ! -- return - return - end subroutine npf_nur - - subroutine npf_flowja(this, nodes, nja, hnew, flowja) -! ****************************************************************************** -! npf_flowja -- Budget -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfNpfType) :: this - integer(I4B),intent(in) :: nodes - integer(I4B),intent(in) :: nja - real(DP),intent(inout),dimension(nodes) :: hnew - real(DP),intent(inout),dimension(nja) :: 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(nodes, nja, 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, nja, flowja, icbcfl, icbcun) -! ****************************************************************************** -! npf_bdadj -- Calculate intercell flows -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfNpfType) :: this - integer(I4B),intent(in) :: nja - real(DP),dimension(nja),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 - ! - ! -- Return - return - end subroutine npf_bdadj - - subroutine npf_ot(this, nodes, nja, flowja) -! ****************************************************************************** -! npf_ot -- Budget -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule, only: kper, kstp - use ConstantsModule, only: LENBIGLINE - ! -- dummy - class(GwfNpfType) :: this - integer(I4B),intent(in) :: nodes - integer(I4B),intent(in) :: nja - real(DP),intent(inout),dimension(nja) :: 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%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%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%iangle1) - call mem_deallocate(this%iangle2) - call mem_deallocate(this%iangle3) - call mem_deallocate(this%nedges) - call mem_deallocate(this%lastedge) - ! - ! -- Deallocate arrays - call mem_deallocate(this%icelltype) - call mem_deallocate(this%k11) - call mem_deallocate(this%k22) - call mem_deallocate(this%k33) - 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%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%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%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%angle1, 1, 'ANGLE1', trim(this%origin)) - call mem_allocate(this%angle2, 1, 'ANGLE2', trim(this%origin)) - call mem_allocate(this%angle3, 1, 'ANGLE3', trim(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%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%iperched = 0 - this%ivarcv = 0 - this%idewatcv = 0 - this%ithickstrt = 0 - this%iusgnrhc = 0 - this%inwtupw = 0 - this%icalcspdis = 0 - this%isavspdis = 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%angle1(1) = DZERO - this%angle2(1) = DZERO - this%angle3(1) = DZERO - 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_scalars -- Allocate npf arrays -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(GwfNpftype) :: this - integer(I4B), intent(in) :: ncells - integer(I4B), intent(in) :: njas -! ------------------------------------------------------------------------------ - ! - 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 - call mem_allocate(this%k22, 0, 'K22', trim(this%origin)) - call mem_allocate(this%k33, 0, 'K33', trim(this%origin)) - call mem_allocate(this%wetdry, 0, 'WETDRY', trim(this%origin)) - 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 - ! - ! -- 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 - ! - ! -- 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' - 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_reallocate - use SimModule, only: ustop, store_error, count_errors - ! -- dummy - class(GwfNpftype) :: this - ! -- local - character(len=LINELENGTH) :: line, errmsg, cellstr, keyword - integer(I4B) :: n, istart, istop, lloc, ierr, nerr - logical :: isfound, endOfBlock - logical, dimension(8) :: lname - character(len=24), dimension(8) :: aname - ! -- 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)" - 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)" - ! -- 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 - lname(:) = .false. - ! - ! -- get npfdata 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 ('ICELLTYPE') - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%icelltype, aname(1)) - lname(1) = .true. - case ('K') - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%k11, aname(2)) - lname(2) = .true. - case ('K33') - call mem_reallocate(this%k33, this%dis%nodes, 'K33', & - trim(this%origin)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%k33, aname(3)) - this%ik33 = 1 - lname(3) = .true. - case ('K22') - call mem_reallocate(this%k22, this%dis%nodes, 'K22', & - trim(this%origin)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%k22, aname(4)) - this%ik22 = 1 - lname(4) = .true. - case ('WETDRY') - call mem_reallocate(this%wetdry, this%dis%nodes, 'WETDRY', & - trim(this%origin)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%wetdry, aname(5)) - lname(5) = .true. - case ('ANGLE1') - call mem_reallocate(this%angle1, this%dis%nodes, 'ANGLE1', & - trim(this%origin)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%angle1, aname(6)) - lname(6) = .true. - case ('ANGLE2') - call mem_reallocate(this%angle2, this%dis%nodes, 'ANGLE2', & - trim(this%origin)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%angle2, aname(7)) - lname(7) = .true. - case ('ANGLE3') - call mem_reallocate(this%angle3, this%dis%nodes, 'ANGLE3', & - trim(this%origin)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%angle3, aname(8)) - lname(8) = .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 - 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 or check K11 - if(.not. lname(2)) then - write(errmsg, '(a, a, a)') 'Error in GRIDDATA block: ', & - trim(adjustl(aname(2))), ' not found.' - call store_error(errmsg) - else - 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 - endif - ! - ! -- Check for K33 - if(.not. lname(3)) then - write(this%iout, '(1x, a)') 'K33 not provided. Assuming K33 = K.' - else - nerr = 0 - do n = 1, size(this%k33) - 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 - endif - ! - ! -- Check for K22 - if(.not. lname(4)) then - write(this%iout, '(1x, a)') 'K22 not provided. Assuming K22 = K.' - else - ! -- 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%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 - endif - ! - ! -- Check for WETDRY - if(.not. lname(5) .and. this%irewet == 1) then - write(errmsg, '(a, a, a)') 'Error in GRIDDATA block: ', & - trim(adjustl(aname(5))), ' not found.' - call store_error(errmsg) - endif - ! - ! -- Check for angle conflicts - if (lname(6)) then - this%iangle1 = 1 - 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.' - call mem_reallocate(this%angle1, this%dis%nodes, 'ANGLE1', & - trim(this%origin)) - do n = 1, size(this%angle1) - this%angle1(n) = DZERO - enddo - endif - endif - if (lname(7)) then - this%iangle2 = 1 - if (.not. lname(6)) then - write(errmsg, '(a)') 'ANGLE2 SPECIFIED BUT NOT ANGLE1. ' // & - 'ANGLE2 REQUIRES ANGLE1. ' - call store_error(errmsg) - endif - if (.not. lname(8)) 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 (lname(8)) then - this%iangle3 = 1 - if (.not. lname(6)) then - write(errmsg, '(a)') 'ANGLE3 SPECIFIED BUT NOT ANGLE1. ' // & - 'ANGLE3 REQUIRES ANGLE1. ' - call store_error(errmsg) - endif - if (.not. lname(7)) 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 - ! - 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 - 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=LINELENGTH) :: cellstr, errmsg - 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 :: 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)" -! ------------------------------------------------------------------------------ - ! - ! -- 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 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 - ! - ! -- 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/gwf3obs8.f90 b/src/Model/GroundWaterFlow/gwf3obs8.f90 index 8cca9189610..c25cde16921 100644 --- a/src/Model/GroundWaterFlow/gwf3obs8.f90 +++ b/src/Model/GroundWaterFlow/gwf3obs8.f90 @@ -205,7 +205,6 @@ subroutine gwf_process_head_drawdown_obs_id(obsrv, dis, inunitobs, iout) integer(I4B) :: icol, istart, istop character(len=LINELENGTH) :: ermsg, strng ! formats - 30 format(i10) ! ! -- Initialize variables strng = obsrv%IDstring @@ -240,7 +239,6 @@ subroutine gwf_process_intercell_obs_id(obsrv, dis, inunitobs, iout) integer(I4B) :: icol, istart, istop, jaidx character(len=LINELENGTH) :: ermsg, strng ! formats - 30 format(i10) 70 format('Error: No connection exists between cells identified in text: ',a) ! ! -- Initialize variables 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 1cc834577b9..023c7c9d46a 100644 --- a/src/Model/GroundWaterFlow/gwf3rch8.f90 +++ b/src/Model/GroundWaterFlow/gwf3rch8.f90 @@ -1,904 +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 - ! 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) :: atemp - character(len=24), dimension(2) :: aname - character(len=LINELENGTH) :: keyword - 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) -! ****************************************************************************** -! rch_cf -- Formulate the HCOF and RHS terms -! Subroutine: (1) skip if no recharge -! (2) calculate hcof and rhs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - class(rchtype) :: this - integer(I4B) :: i, node - !real(DP) :: zero = 0.d0 -! ------------------------------------------------------------------------------ - ! - ! -- 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 8fa84840063..3cbff60e8b9 100644 --- a/src/Model/GroundWaterFlow/gwf3riv8.f90 +++ b/src/Model/GroundWaterFlow/gwf3riv8.f90 @@ -1,374 +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 - ! - ! -- 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) -! ****************************************************************************** -! riv_cf -- Formulate the HCOF and RHS terms -! Subroutine: (1) skip in no rivs -! (2) calculate hcof and rhs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(RivType) :: this - integer(I4B) :: i, node - real(DP) :: hriv, criv, rbot -! ------------------------------------------------------------------------------ - ! - ! -- Return if no rivs - if(this%nbound.eq.0) return - ! - ! -- pakmvrobj cf - if(this%imover == 1) 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 4f94fccc3eb..1bb42c0d882 100644 --- a/src/Model/GroundWaterFlow/gwf3sfr8.f90 +++ b/src/Model/GroundWaterFlow/gwf3sfr8.f90 @@ -1,4304 +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, MAXCHARLEN, & - DHNOFLO, DHDRY, DNODATA - use SmoothingModule, only: sQuadraticSaturation, sQSaturation, & - sQuadraticSaturationDerivative, sQSaturationDerivative, & - sCubicSaturation, sChSmooth - use BndModule, only: BndType - use BudgetModule, only : BudgetType - - 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 SparseModule, only: sparsematrix - use RectangularChGeometryModule, only: RectangularChGeometryType - 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 - character (len=8), pointer :: status => null() - integer(I4B), pointer :: iboundpak => null() - integer(I4B), pointer :: reach => null() - integer(I4B), pointer :: igwfnode => null() - integer(I4B), pointer :: igwftopnode => null() - real(DP), pointer :: length => null() - real(DP), pointer :: width => null() - real(DP), pointer :: strtop => null() - real(DP), pointer :: bthick => null() - real(DP), pointer :: hk => null() - real(DP), pointer :: slope => null() - integer(I4B), pointer :: nconn => null() - real(DP), pointer :: ustrf => null() - real(DP), pointer :: ftotnd => null() - ! -- diversion data - integer(I4B), pointer :: ndiv => null() - 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() - ! -- dependent variables - real(DP), pointer :: usflow => null() - real(DP), pointer :: dsflow => null() - real(DP), pointer :: depth => null() - real(DP), pointer :: stage => null() - real(DP), pointer :: gwflow => null() - real(DP), pointer :: simevap => null() - real(DP), pointer :: simrunoff => 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 - ! - type, extends(BndType) :: SfrType - ! -- scalars - ! -- for budgets - ! -- characters - character(len=16), dimension(:), pointer, contiguous :: csfrbudget => 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 :: 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 :: 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() - ! -- derived types - type(BudgetType), pointer :: budget => NULL() - type(SfrDataType), dimension(:), pointer, contiguous :: reaches => NULL() - type(sparsematrix), pointer :: sparse => null() - type(RectangularChGeometryType), dimension(:), pointer, & - contiguous :: geo => 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_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 - ! -- 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 - 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 - ! - ! -- 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%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) - ! - ! -- 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%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 - ! - ! -- 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)) - ! - ! - !-- 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() - ! - ! -- 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('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. - ! - ! -- 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 ConstantsModule, only: LINELENGTH - use InputOutputModule, only: urword - use SimModule, only: ustop, store_error, count_errors, store_error_unit - use TimeSeriesManagerModule, only: read_single_value_or_time_series - use BudgetModule, only: budget_cr - ! -- dummy - class(SfrType),intent(inout) :: this - ! -- local - character (len=LINELENGTH) :: line, errmsg - character(len=LINELENGTH) :: text, cellid, keyword - character (len=10) :: cnum - character (len=10) :: cval - character(len=LENBOUNDNAME) :: bndName, bndNameTemp, manningname - character(len=50), dimension(:), allocatable :: caux - integer(I4B) :: j, n, ierr, ival - integer(I4B) :: ipos - integer(I4B) :: ndiv - logical :: isfound, endOfBlock - integer(I4B) :: i - integer(I4B) :: jj - integer(I4B) :: iaux - integer(I4B) :: nja - integer(I4B), dimension(:), pointer, contiguous :: rowmaxnnz => null() - integer(I4B) :: idiv - integer, allocatable, dimension(:) :: iachk - integer, allocatable, dimension(:) :: nboundchk - ! -- format - ! ------------------------------------------------------------------------------ - ! - call this%obs%obs_ar() - ! - ! -- Allocate arrays in package superclass - call this%sfr_allocate_arrays() - ! - ! -- addition - ! - ! -- allocate space for sfr reach data - allocate(this%reaches(this%maxbound)) - allocate(rowmaxnnz(this%maxbound)) - do i = 1, this%maxbound - rowmaxnnz(i) = 0 - enddo - 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 - nja = 0 - 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) - ! -- set reach number - this%reaches(n)%reach = n - ! -- get model node number - call this%parser%GetCellid(this%dis%ndim, cellid, flag_string=.true.) - this%reaches(n)%igwfnode = this%dis%noder_from_cellid(cellid, & - this%inunit, this%iout, flag_string=.true.) - this%reaches(n)%igwftopnode = this%reaches(n)%igwfnode - this%nodelist(n) = this%reaches(n)%igwfnode - ! -- read the cellid string and determine if 'none' is specified - if (this%reaches(n)%igwfnode < 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%reaches(n)%length = this%parser%GetDouble() - ! -- get reach width - this%reaches(n)%width = this%parser%GetDouble() - ! -- get reach slope - this%reaches(n)%slope = this%parser%GetDouble() - ! -- get reach stream bottom - this%reaches(n)%strtop = this%parser%GetDouble() - ! -- get reach bed thickness - this%reaches(n)%bthick = this%parser%GetDouble() - ! -- get reach bed hk - this%reaches(n)%hk = 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%reaches(n)%nconn = 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 - rowmaxnnz(n) = ival + 1 - nja = nja + ival + 1 !add the connections and the sfr reach - ! -- get upstream fraction for reach - this%reaches(n)%ustrf = this%parser%GetDouble() - ! -- get number of diversions for reach - ival = this%parser%GetInteger() - this%reaches(n)%ndiv = 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)') this%reaches(n)%reach - 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 - - ! -- 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%reaches(n)%strtop - - 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 - ! - ! -- allocate and initialize local variables for reach connections - allocate(nboundchk(this%maxbound)) - do n = 1, this%maxbound - nboundchk(n) = 0 - end do - ! - ! -- 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%reaches(n)%nconn > 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%reaches(n)%nconn - 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%reaches(n)%nconn > 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) - ! - ! -- 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%reaches(n)%ndiv - end do - allocate(iachk(this%maxbound+1)) - allocate(nboundchk(ndiv)) - iachk(1) = 1 - do n = 1, this%maxbound - iachk(n+1) = iachk(n) + this%reaches(n)%ndiv - 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%reaches(n)%ndiv < 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%reaches(n)%ndiv) then - write (cnum, '(i0)') n - errmsg = 'ERROR: reach ' // trim(cnum) - write (cnum, '(i0)') this%reaches(n)%ndiv - 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%reaches(n)%ndiv - 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 package block error messages - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- check the sfr data - ! -- check the base 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 - ! - ! -- calculate the total fraction of connected reaches that are - ! not diversions - call this%sfr_check_ustrf() - ! - ! -- 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 - ! - ! -- write header - if (this%iprpak /= 0) then - write (this%iout, '(//a)') 'SFR GEOMETRY DATA' - write (this%iout, "(40('-'))") - end if - ! - ! -- build the rectangular geo type - allocate(this%geo(this%maxbound)) - do n = 1, this%maxbound - if(this%inamedbound==1) then - bndName = this%boundname(n) - else - write (cnum,'(i10.0)') this%reaches(n)%reach - bndName = 'Reach ' // trim(adjustl(cnum)) - end if - call this%geo(n)%init(n, bndName, & - this%reaches(n)%width, & - this%reaches(n)%length) - if (this%iprpak /= 0) then - call this%geo(n)%print_attributes(this%iout) - end if - end do - if (this%iprpak /= 0) then - write (this%iout, "(40('-'))") - end if - ! - ! -- setup the sfr budget - call budget_cr(this%budget, this%origin) - ival = this%bditems - call this%budget%budget_df(ival, this%name, 'L**3') - ! - ! -- 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_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 - integer(I4B) :: ierr - integer(I4B) :: n - integer(I4B) :: ichkustrm - logical :: isfound, endOfBlock - integer(I4B) :: isfirst - character(len=LINELENGTH) :: line - character(len=LINELENGTH) :: 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,')')" -! ------------------------------------------------------------------------------ - ! - ! -- initialize flags - ichkustrm = 0 - 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%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 - ! - ! -- read data - 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)') ' REACH KEYWORD AND DATA' - write(this%iout,'(3x,78("-"))') - end if - end if - 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) - end do - if (this%iprpak /= 0) then - write(this%iout,'(/,1x,a,1x,i6,/)') & - 'END OF '//trim(adjustl(this%text))//' DATA FOR PERIOD', kper - end if - ! - ! -- check upstream fraction values - if (ichkustrm /= 0) then - call this%sfr_check_ustrf() - end if - - ! -- Reuse data from last stress period - else - write(this%iout,fmtlsp) trim(this%filtyp) - endif - ! - ! -- 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 -! ------------------------------------------------------------------------------ - ! - ! -- Advance the time series manager - call this%TsManager%ad() - ! - ! -- reset upstream flow to zero and set specified stage - do n = 1, this%maxbound - this%reaches(n)%usflow = DZERO - if (this%reaches(n)%iboundpak < 0) then - this%reaches(n)%stage = 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) - ! ****************************************************************************** - ! sfr_cf -- Formulate the HCOF and RHS terms - ! Subroutine: (1) skip in no wells - ! (2) calculate hcof and rhs - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - ! -- dummy variables - class(SfrType) :: this - ! -- local variables - integer(I4B) :: n - integer(I4B) :: igwfnode - - ! ------------------------------------------------------------------------------ - ! - ! -- Return if no sfr reaches - if(this%nbound == 0) return - ! - ! -- find highest active cell - do n = 1, this%nbound - igwfnode = this%reaches(n)%igwftopnode - if (igwfnode > 0) then - if (this%ibound(igwfnode) == 0) then - call this%dis%highest_active(igwfnode, this%ibound) - end if - end if - this%reaches(n)%igwfnode = igwfnode - this%nodelist(n) = igwfnode - end do - ! - ! -- pakmvrobj cf - if(this%imover == 1) 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%reaches(n)%igwfnode - if (node > 0) then - hgwf = this%xnew(node) - else - hgwf = DEP20 - end if - if (this%reaches(n)%iboundpak /= 0) then - call this%sfr_solve(n, hgwf, hhcof, rrhs) - else - this%reaches(n)%depth = DZERO - this%reaches(n)%stage = this%reaches(n)%strtop - 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%reaches(i)%iboundpak < 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_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) :: rain_ratin, rain_ratout - real(DP) :: evap_ratin, evap_ratout - real(DP) :: runoff_ratin, runoff_ratout - real(DP) :: extin_ratin, extin_ratout - real(DP) :: qgwf_ratin, qgwf_ratout - real(DP) :: extout_ratin, extout_ratout - real(DP) :: qmvr_ratin, qmvr_ratout - real(DP) :: qfrommvr, qtomvr - real(DP) :: depth - real(DP) :: a, ae - real(DP) :: qi, qro, qr, qe, qgwf, qext - ! -- for budget - integer(I4B) :: n - integer(I4B) :: n2 - integer(I4B) :: ii - integer(I4B) :: naux - real(DP) :: q - real(DP) :: qt - real(DP) :: d - real(DP) :: v - real(DP) :: qoutflow - ! -- 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) - ! - ! -- sfr budget routines (start by resetting) - call this%budget%reset() - ! - ! -- initialize accumulators - rain_ratin = DZERO - rain_ratout = DZERO - evap_ratin = DZERO - evap_ratout = DZERO - runoff_ratin = DZERO - runoff_ratout = DZERO - extin_ratin = DZERO - extin_ratout = DZERO - qgwf_ratin = DZERO - qgwf_ratout = DZERO - extout_ratin = DZERO - extout_ratout = DZERO - qmvr_ratin = DZERO - qmvr_ratout = DZERO - ! - ! -- sfr budget term calculations - do n = 1, this%maxbound - ! - ! -- rainfall and evaporation - depth = this%reaches(n)%depth - a = this%geo(n)%surface_area() - ae = this%geo(n)%surface_area_wet(depth) - qr = this%reaches(n)%rain%value * a - !qe = -this%reaches(n)%evap%value * ae - qe = -this%reaches(n)%simevap - ! - ! -- inflow and runoff - qi = this%reaches(n)%inflow%value - qro = this%reaches(n)%runoff%value - ! - ! -- 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 - ! - ! -- groundwater leakage - qgwf = -this%reaches(n)%gwflow - ! - ! -- external downstream stream flow - qext = this%reaches(n)%dsflow - qoutflow = DZERO - if (qext > DZERO) then - qext = -qext - end if - do i = 1, this%reaches(n)%nconn - 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%reaches(n)%dsflow - 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 - ! - ! -- accumulate terms - if (qr < DZERO) then - ! - ! -- Flow is out of sfr - rain_ratout = rain_ratout - qr - else - ! - ! -- Flow is into sfr - rain_ratin = rain_ratin + qr - end if - if (qe < DZERO) then - ! - ! -- Flow is out of sfr - evap_ratout = evap_ratout - qe - else - ! - ! -- Flow is into sfr - evap_ratin = evap_ratin + qe - end if - if (qi < DZERO) then - ! - ! -- Flow is out of sfr - extin_ratout = extin_ratout - qi - else - ! - ! -- Flow is into sfr - extin_ratin = extin_ratin + qi - end if - if (qro < DZERO) then - ! - ! -- Flow is out of sfr - runoff_ratout = runoff_ratout - qro - else - ! - ! -- Flow is into sfr - runoff_ratin = runoff_ratin + qro - end if - if (qgwf < DZERO) then - ! - ! -- Flow is out of sfr - qgwf_ratout = qgwf_ratout - qgwf - else - ! - ! -- Flow is into sfr - qgwf_ratin = qgwf_ratin + qgwf - end if - if (qext < DZERO) then - ! - ! -- Flow is out of sfr - extout_ratout = extout_ratout - qext - else - ! - ! -- Flow is into sfr - extout_ratin = extout_ratin + qext - end if - if (qfrommvr < DZERO) then - ! - ! -- Flow is out of sfr - qmvr_ratout = qmvr_ratout - qfrommvr - else - ! - ! -- Flow is into sfr - qmvr_ratin = qmvr_ratin + qfrommvr - end if - if (qtomvr < DZERO) then - ! - ! -- Flow is out of sfr - qmvr_ratout = qmvr_ratout - qtomvr - else - ! - ! -- Flow is into sfr - qmvr_ratin = qmvr_ratin + qtomvr - end if - end do - ! - ! -- add calculated terms - call this%budget%addentry(extin_ratin, extin_ratout, delt, & - this%csfrbudget(4), isuppress_output) - if (this%imover == 1) then - call this%budget%addentry(qmvr_ratin, DZERO, delt, & - this%csfrbudget(7), isuppress_output) - end if - call this%budget%addentry(rain_ratin, rain_ratout, delt, & - this%csfrbudget(1), isuppress_output) - call this%budget%addentry(runoff_ratin, runoff_ratout, delt, & - this%csfrbudget(3), isuppress_output) - call this%budget%addentry(qgwf_ratin, qgwf_ratout, delt, & - this%csfrbudget(5), isuppress_output) - call this%budget%addentry(evap_ratin, evap_ratout, delt, & - this%csfrbudget(2), isuppress_output) - call this%budget%addentry(extout_ratin, extout_ratout, delt, & - this%csfrbudget(6), isuppress_output) - if (this%imover == 1) then - call this%budget%addentry(DZERO, qmvr_ratout, delt, & - this%csfrbudget(8), isuppress_output) - end if - ! - ! -- 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%reaches(n)%depth - v = this%reaches(n)%stage - if (this%reaches(n)%iboundpak < 1) 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 - ! - ! -- Set unit number for binary budget output - ibinun = 0 - if(this%ibudgetout /= 0) then - ibinun = this%ibudgetout - end if - if(icbcfl == 0) ibinun = 0 - if (isuppress_output /= 0) ibinun = 0 - ! - ! -- write sfr binary budget output - if (ibinun > 0) then - ! FLOW JA FACE - naux = this%cbcauxitems - call ubdsv06(kstp, kper, ' FLOW-JA-FACE', this%name_model, this%name, & - this%name_model, this%name, & - ibinun, naux, this%cauxcbc, this%nconn, 1, 1, this%nconn, & - this%iout, delt, pertim, totim) - do n = 1, this%maxbound - do i = 1, this%reaches(n)%nconn - n2 = this%reaches(n)%iconn(i) - ! flow to downstream reaches - if (this%reaches(n)%idir(i) < 0) then - qt = this%reaches(n)%dsflow - q = -this%reaches(n)%qconn(i) - ! flow from upstream reaches - else - qt = this%reaches(n)%usflow - do ii = 1, this%reaches(n2)%nconn - 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%reaches(n)%width - call this%dis%record_mf6_list_entry(ibinun, n, n2, q, naux, & - this%qauxcbc, & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - end do - ! LEAKAGE - naux = this%cbcauxitems - call ubdsv06(kstp, kper, this%csfrbudget(5), this%name_model, this%name, & - this%name_model, this%name_model, & - ibinun, naux, this%cauxcbc, this%maxbound, 1, 1, & - this%maxbound, this%iout, delt, pertim, totim) - do n = 1, this%maxbound - ! -- fill qauxcbc - ! -- reach volume - this%qauxcbc(1) = this%reaches(n)%width * this%reaches(n)%length - ! -- get leakage - n2 = this%reaches(n)%igwfnode - q = -this%reaches(n)%gwflow - call this%dis%record_mf6_list_entry(ibinun, n, n2, q, naux, & - this%qauxcbc, & - olconv=.FALSE.) - end do - ! INFLOW - naux = 0 - call ubdsv06(kstp, kper, this%csfrbudget(4), this%name_model, this%name, & - this%name_model, this%name, & - ibinun, naux, this%auxname, this%maxbound, 1, 1, & - this%maxbound, this%iout, delt, pertim, totim) - do n = 1, this%maxbound - q = this%reaches(n)%inflow%value - call this%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%auxvar(:,n), & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - ! RAIN - naux = 0 - call ubdsv06(kstp, kper, this%csfrbudget(1), this%name_model, this%name, & - this%name_model, this%name, & - ibinun, naux, this%auxname, this%maxbound, 1, 1, & - this%maxbound, this%iout, delt, pertim, totim) - do n = 1, this%maxbound - a = this%geo(n)%surface_area() - q = this%reaches(n)%rain%value * a - call this%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%auxvar(:,n), & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - ! RUNOFF - naux = 0 - call ubdsv06(kstp, kper, this%csfrbudget(3), this%name_model, this%name, & - this%name_model, this%name, & - ibinun, naux, this%auxname, this%maxbound, 1, 1, & - this%maxbound, this%iout, delt, pertim, totim) - do n = 1, this%maxbound - !q = this%reaches(n)%runoff%value - q = this%reaches(n)%simrunoff - call this%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%auxvar(:,n), & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - ! EVAPORATION - naux = 0 - call ubdsv06(kstp, kper, this%csfrbudget(2), this%name_model, this%name, & - this%name_model, this%name, & - ibinun, naux, this%auxname, this%maxbound, 1, 1, & - this%maxbound, this%iout, delt, pertim, totim) - do n = 1, this%maxbound - ae = this%geo(n)%surface_area_wet(depth) - !q = -this%reaches(n)%evap%value * ae - q = -this%reaches(n)%simevap - call this%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%auxvar(:,n), & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - ! EXTERNAL OUTFLOW - naux = 0 - call ubdsv06(kstp, kper, this%csfrbudget(6), this%name_model, this%name, & - this%name_model, this%name, & - ibinun, naux, this%auxname, this%maxbound, 1, 1, & - this%maxbound, this%iout, delt, pertim, totim) - do n = 1, this%maxbound - q = this%reaches(n)%dsflow - if (q > DZERO) q = -q - do i = 1, this%reaches(n)%nconn - 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%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%auxvar(:,n), & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - ! MOVER - if (this%imover == 1) then - ! FROM MOVER - naux = 0 - call ubdsv06(kstp, kper, this%csfrbudget(7), this%name_model, & - this%name, this%name_model, this%name, & - ibinun, naux, this%auxname, & - this%maxbound, 1, 1, & - this%maxbound, this%iout, delt, pertim, totim) - do n = 1, this%maxbound - q = this%pakmvrobj%get_qfrommvr(n) - call this%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%auxvar(:,n), & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - ! TO MOVER - naux = 0 - call ubdsv06(kstp, kper, this%csfrbudget(8), this%name_model, & - this%name, this%name_model, this%name, & - ibinun, naux, this%auxname, & - this%maxbound, 1, 1, & - this%maxbound, this%iout, delt, pertim, totim) - do n = 1, this%maxbound - q = this%pakmvrobj%get_qtomvr(n) - if (q > DZERO) then - q = -q - end if - call this%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%auxvar(:,n), & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - end if - ! AUXILIARY VARIABLES - naux = this%naux - if (naux > 0) then - call ubdsv06(kstp, kper, ' AUXILIARY', this%name_model, this%name,& - this%name_model, this%name, & - ibinun, naux, this%auxname, this%maxbound, 1, 1, & - this%maxbound, this%iout, delt, pertim, totim) - do n = 1, this%maxbound - q = DZERO - ! fill auxvar - do i = 1, naux - this%auxvar(i,n) = this%reaches(n)%auxvar(i)%value - end do - call this%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%auxvar(:,n), & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - end if - - end if - ! - ! - ! -- return - return - end subroutine sfr_bd - - - subroutine sfr_ot(this, kstp, kper, iout, ihedfl, ibudfl) - ! ************************************************************************** - ! pak1t -- Output package budget - ! ************************************************************************** - ! - ! SPECIFICATIONS: - ! -------------------------------------------------------------------------- - use InputOutputModule, only: UWWORD - ! -- 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) :: cellids, cellid - character(len=LINELENGTH) :: line, linesep - character(len=16) :: text - integer(I4B) :: i - integer(I4B) :: n - integer(I4B) :: node - integer(I4B) :: iloc - real(DP) :: hgwf - real(DP) :: sbot - real(DP) :: q - real(DP) :: depth, stage, a, ae - real(DP) :: qu, qr, qe, qi, qro, qgwf, qd, qext - real(DP) :: w, cond, grad - real(DP) :: qfrommvr, qtomvr - real(DP) :: qin, qout, qerr, qavg, qpd - ! format - 2000 FORMAT ( 1X, ///1X, A, A, A, ' PERIOD ', I6, ' STEP ', I8) - ! -------------------------------------------------------------------------- - ! - ! -- set cell id based on discretization - if (this%dis%ndim == 3) then - cellids = '(LAYER,ROW,COLUMN) ' - elseif (this%dis%ndim == 2) then - cellids = '(LAYER,CELL2D) ' - else - cellids = '(NODE) ' - end if - ! - ! -- write sfr stage and depth - if (ihedfl /= 0 .and. this%iprhed /= 0) then - write (iout, 2000) 'SFR (', trim(this%name), ') STAGE', kper, kstp - iloc = 1 - line = '' - if(this%inamedbound==1) then - call UWWORD(line, iloc, 16, 1, 'reach', n, q, left=.TRUE.) - end if - call UWWORD(line, iloc, 6, 1, 'reach', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 20, 1, 'reach ', n, q, left=.TRUE.) - call UWWORD(line, iloc, 11, 1, 'reach', n, q, CENTER=.TRUE.) - call UWWORD(line, iloc, 11, 1, 'reach', n, q, CENTER=.TRUE.) - call UWWORD(line, iloc, 11, 1, 'reach', n, q, CENTER=.TRUE.) - call UWWORD(line, iloc, 11, 1, 'gwf', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'streambed', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'streambed', n, q, CENTER=.TRUE.) - ! -- 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, 1, 'name', n, q, left=.TRUE.) - end if - call UWWORD(line, iloc, 6, 1, 'no.', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 20, 1, cellids, n, q, left=.TRUE.) - call UWWORD(line, iloc, 11, 1, 'stage', n, q, CENTER=.TRUE.) - call UWWORD(line, iloc, 11, 1, 'depth', n, q, CENTER=.TRUE.) - call UWWORD(line, iloc, 11, 1, 'width', n, q, CENTER=.TRUE.) - call UWWORD(line, iloc, 11, 1, 'head', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'conductance', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'gradient', n, q, CENTER=.TRUE.) - ! -- write second line - write(iout,'(1X,A)') line(1:iloc) - write(iout,'(1X,A)') linesep(1:iloc) - ! -- write data - do n = 1, this%maxbound - node = this%reaches(n)%igwfnode - if (node > 0) then - call this%dis%noder_to_string(node, cellid) - hgwf = this%xnew(node) - else - cellid = 'none' - end if - iloc = 1 - line = '' - if(this%inamedbound==1) then - call UWWORD(line, iloc, 16, 1, this%boundname(n), n, q, left=.TRUE.) - end if - call UWWORD(line, iloc, 6, 2, text, n, q, sep=' ') - call UWWORD(line, iloc, 20, 1, cellid, n, q, left=.TRUE.) - depth = this%reaches(n)%depth - stage = this%reaches(n)%stage - w = this%geo(n)%top_width_wet(depth) - call UWWORD(line, iloc, 11, 3, text, n, stage) - call UWWORD(line, iloc, 11, 3, text, n, depth) - call UWWORD(line, iloc, 11, 3, text, n, w) - call this%sfr_calc_cond(n, depth, cond) - if (node > 0) then - sbot = this%reaches(n)%strtop - this%reaches(n)%bthick - if (hgwf < sbot) then - grad = stage - sbot - else - grad = stage - hgwf - end if - grad = grad / this%reaches(n)%bthick - call UWWORD(line, iloc, 11, 3, text, n, hgwf, sep=' ') - call UWWORD(line, iloc, 11, 3, text, n, cond, sep=' ') - call UWWORD(line, iloc, 11, 3, text, n, grad) - else - call UWWORD(line, iloc, 11, 1, '--', n, q, center=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 3, text, n, cond, sep=' ') - call UWWORD(line, iloc, 11, 1, '--', n, q, center=.TRUE.) - end if - write(iout, '(1X,A)') line(1:iloc) - end do - end if - ! - ! -- write sfr rates - if (ibudfl /= 0 .and. this%iprflow /= 0) then - write (iout, 2000) 'SFR (', trim(this%name), ') FLOWS', kper, kstp - iloc = 1 - line = '' - if(this%inamedbound==1) then - call UWWORD(line, iloc, 16, 1, 'reach', n, q, left=.TRUE.) - end if - call UWWORD(line, iloc, 6, 1, 'reach', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 20, 1, 'reach ', n, q, left=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'external', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'reach', n, q, CENTER=.TRUE., sep=' ') - if (this%imover == 1) then - call UWWORD(line, iloc, 11, 1, 'reach', n, q, CENTER=.TRUE., sep=' ') - end if - call UWWORD(line, iloc, 11, 1, 'reach', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'reach', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'reach', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'reach', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'reach', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'external', n, q, CENTER=.TRUE., sep=' ') - if (this%imover == 1) then - call UWWORD(line, iloc, 11, 1, 'reach', n, q, CENTER=.TRUE., sep=' ') - end if - call UWWORD(line, iloc, 11, 1, 'reach', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'percent', n, q, CENTER=.TRUE.) - ! -- 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, 1, 'name', n, q, left=.TRUE.) - end if - call UWWORD(line, iloc, 6, 1, 'no.', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 20, 1, cellids, n, q, left=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'inflow', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'inflow', n, q, CENTER=.TRUE., sep=' ') - if (this%imover == 1) then - call UWWORD(line, iloc, 11, 1, 'from mvr', n, q, CENTER=.TRUE., sep=' ') - end if - call UWWORD(line, iloc, 11, 1, 'rainfall', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'runoff', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'leakage', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'evaporation', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'outflow', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'outflow', n, q, CENTER=.TRUE., sep=' ') - if (this%imover == 1) then - call UWWORD(line, iloc, 11, 1, 'to mvr', n, q, CENTER=.TRUE., sep=' ') - end if - call UWWORD(line, iloc, 11, 1, 'in - out', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'difference', n, q, CENTER=.TRUE.) - ! -- write second line - write(iout,'(1X,A)') line(1:iloc) - write(iout,'(1X,A)') linesep(1:iloc) - ! -- write data - do n = 1, this%maxbound - depth = this%reaches(n)%depth - stage = this%reaches(n)%stage - node = this%reaches(n)%igwfnode - if (node > 0) then - call this%dis%noder_to_string(node, cellid) - else - cellid = 'none' - end if - a = this%geo(n)%surface_area() - ae = this%geo(n)%surface_area_wet(depth) - qu = this%reaches(n)%usflow - qr = this%reaches(n)%rain%value * a - qi = this%reaches(n)%inflow%value - !qro = this%reaches(n)%runoff%value - qro = this%reaches(n)%simrunoff - !qe = this%reaches(n)%evap%value * ae - qe = this%reaches(n)%simevap - if (qe > DZERO) then - qe = -qe - end if - qgwf = this%reaches(n)%gwflow - if (qgwf /= DZERO) then - qgwf = -qgwf - end if - qext = this%reaches(n)%dsflow - qd = DZERO - do i = 1, this%reaches(n)%nconn - if (this%reaches(n)%idir(i) > 0) cycle - qd = qext - qext = DZERO - exit - end do - - if (qd > DZERO) then - qd = -qd - end if - - if (qext > DZERO) then - qext = -qext - end if - ! - ! -- mover term - qfrommvr = DZERO - qtomvr = DZERO - if (this%imover == 1) then - qfrommvr = this%pakmvrobj%get_qfrommvr(n) - qtomvr = this%pakmvrobj%get_qtomvr(n) - if (qd < DZERO) then - qd = qd + qtomvr - end if - if (qext < DZERO) then - qext = qext + qtomvr - end if - if (qtomvr > DZERO) then - qtomvr = -qtomvr - end if - end if - ! - ! -- calculate error - qin = qi + qu + qfrommvr + qr + qro - qout = -qe - qd - qext - qtomvr - if (qgwf < DZERO) then - qout = qout - qgwf - else - qin = qin + qgwf - end if - qerr = qin - qout - qavg = DHALF * (qin + qout) - qpd = DZERO - if (qavg > DZERO) then - qpd = DHUNDRED * qerr / qavg - end if - ! - ! - ! -- fill line - iloc = 1 - line = '' - if (this%inamedbound==1) then - call UWWORD(line, iloc, 16, 1, this%boundname(n), n, q, left=.TRUE.) - end if - call UWWORD(line, iloc, 6, 2, text, n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 20, 1, cellid, n, q, left=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 3, text, n, qi, sep=' ') - call UWWORD(line, iloc, 11, 3, text, n, qu, sep=' ') - if (this%imover == 1) then - call UWWORD(line, iloc, 11, 3, text, n, qfrommvr, sep=' ') - end if - call UWWORD(line, iloc, 11, 3, text, n, qr, sep=' ') - call UWWORD(line, iloc, 11, 3, text, n, qro, sep=' ') - call UWWORD(line, iloc, 11, 3, text, n, qgwf, sep=' ') - call UWWORD(line, iloc, 11, 3, text, n, qe, sep=' ') - call UWWORD(line, iloc, 11, 3, text, n, qd, sep=' ') - call UWWORD(line, iloc, 11, 3, text, n, qext, sep=' ') - if (this%imover == 1) then - call UWWORD(line, iloc, 11, 3, text, n, qtomvr, sep=' ') - end if - call UWWORD(line, iloc, 11, 3, text, n, qerr, sep=' ') - call UWWORD(line, iloc, 11, 3, text, n, qpd) - write(iout, '(1X,A)') line(1:iloc) - end do - end if - ! - ! -- Output sfr budget - call this%budget%budget_ot(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) - call mem_deallocate(this%dbuff) - deallocate(this%cauxcbc) - call mem_deallocate(this%qauxcbc) - ! - ! -- deallocation diversions - do n = 1, this%maxbound - if (this%reaches(n)%ndiv > 0) then - call this%deallocate_diversion(n) - endif - enddo - ! - ! -- deallocate reaches - do n = 1, this%maxbound - call this%deallocate_reach(n) - enddo - deallocate(this%reaches) - ! - ! -- ia ja - deallocate(this%ia) - deallocate(this%ja) - ! - ! -- objects - deallocate(this%geo) - call this%budget%budget_da() - deallocate(this%budget) - ! - ! -- scalars - call mem_deallocate(this%iprhed) - call mem_deallocate(this%istageout) - call mem_deallocate(this%ibudgetout) - 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) - 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%reaches(n)%stage - 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%reaches(n)%usflow - 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%reaches(n)%runoff%value - v = this%reaches(n)%simrunoff - case ('EVAPORATION') - !v = this%reaches(n)%evap%value - v = this%reaches(n)%simevap - case ('SFR') - v = this%reaches(n)%gwflow - case ('UPSTREAM-FLOW') - v = this%reaches(n)%usflow - if (this%imover == 1) then - v = v + this%pakmvrobj%get_qfrommvr(n) - end if - case ('DOWNSTREAM-FLOW') - v = this%reaches(n)%dsflow - 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) :: 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,'"') -30 format('Error: Boundary name not provided for observation "',a, & - '" in package "',a,'"') -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) - 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(ermsg,10)trim(bname), trim(obsrv%name), trim(this%name) - call store_error(ermsg) - endif - else - write (ermsg,30) trim(obsrv%name), trim(this%name) - call store_error(ermsg) - endif - elseif (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)), & - ' reach must be > 0 and <=', this%maxbound, & - '(specified value is ', nn1, ')' - call store_error(ermsg) - else - call ExpandArray(obsrv%indxbnds) - n = size(obsrv%indxbnds) - if (n == 1) then - obsrv%indxbnds(1) = nn1 - else - ermsg = 'Programming error in sfr_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 - nn1 = obsrv%NodeNumber - if (nn1 == NAMEDBOUNDFLAG) 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 reach with a unique boundname.' - call store_error(ermsg) - 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 (ermsg, '(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(ermsg) - 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 - 30 format(i10) - ! - 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) - this%reaches(n)%status = text - if (text == 'INACTIVE') then - this%reaches(n)%iboundpak = 0 - else if (text == 'ACTIVE') then - this%reaches(n)%iboundpak = 1 - else if (text == 'SIMPLE') then - this%reaches(n)%iboundpak = -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%reaches(n)%ndiv < 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%reaches(n)%ndiv) then - write (cnum, '(i0)') n - errmsg = 'ERROR: reach ' // trim(cnum) - write (cnum, '(i0)') this%reaches(n)%ndiv - errmsg = 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%reaches(n)%ustrf = 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 - ! - ! -- write keyword data to output file - if (this%iprpak /= 0) then - write (this%iout, '(3x,i10,1x,a)') n, line(i0:istop) - end if - ! - ! -- return - return - end subroutine sfr_set_stressperiod - - subroutine allocate_reach(this, n) -! ****************************************************************************** -! allocate_reach -- Allocate pointers for reach(n). -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(SfrType) :: this - integer(I4B), intent(in) :: n - ! -- local - character(len=LINELENGTH) :: ermsg - character(len=10) :: crch - integer(I4B) :: iaux -! ------------------------------------------------------------------------------ - ! - ! -- make sure reach has not been allocated - if (associated(this%reaches(n)%reach)) then - write (crch, '(i10)') n - ermsg = 'reach ' // trim(crch) // ' is already allocated' - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - end if - ! -- allocate pointers - allocate(this%reaches(n)%status) - allocate(this%reaches(n)%iboundpak) - allocate(this%reaches(n)%reach) - allocate(this%reaches(n)%igwfnode) - allocate(this%reaches(n)%igwftopnode) - allocate(this%reaches(n)%length) - allocate(this%reaches(n)%width) - allocate(this%reaches(n)%strtop) - allocate(this%reaches(n)%bthick) - allocate(this%reaches(n)%hk) - allocate(this%reaches(n)%slope) - allocate(this%reaches(n)%nconn) - allocate(this%reaches(n)%ustrf) - allocate(this%reaches(n)%ftotnd) - allocate(this%reaches(n)%ndiv) - 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 - allocate(this%reaches(n)%usflow) - allocate(this%reaches(n)%dsflow) - allocate(this%reaches(n)%depth) - allocate(this%reaches(n)%stage) - allocate(this%reaches(n)%gwflow) - allocate(this%reaches(n)%simevap) - allocate(this%reaches(n)%simrunoff) - ! - ! -- initialize a few items - this%reaches(n)%status = 'ACTIVE' - this%reaches(n)%iboundpak = 1 - 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 - this%reaches(n)%usflow = DZERO - this%reaches(n)%dsflow = DZERO - this%reaches(n)%depth = DZERO - this%reaches(n)%stage = DZERO - this%reaches(n)%gwflow = DZERO - this%reaches(n)%simevap = DZERO - this%reaches(n)%simrunoff = DZERO - ! - ! -- 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%reaches(n)%nconn > 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)%status) - deallocate(this%reaches(n)%iboundpak) - deallocate(this%reaches(n)%reach) - deallocate(this%reaches(n)%igwfnode) - deallocate(this%reaches(n)%igwftopnode) - deallocate(this%reaches(n)%length) - deallocate(this%reaches(n)%width) - deallocate(this%reaches(n)%strtop) - deallocate(this%reaches(n)%bthick) - deallocate(this%reaches(n)%hk) - deallocate(this%reaches(n)%slope) - deallocate(this%reaches(n)%nconn) - deallocate(this%reaches(n)%ustrf) - deallocate(this%reaches(n)%ftotnd) - deallocate(this%reaches(n)%ndiv) - 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 - deallocate(this%reaches(n)%usflow) - deallocate(this%reaches(n)%dsflow) - deallocate(this%reaches(n)%depth) - deallocate(this%reaches(n)%stage) - deallocate(this%reaches(n)%gwflow) - deallocate(this%reaches(n)%simevap) - deallocate(this%reaches(n)%simrunoff) - ! - ! -- 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) :: ermsg - 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 - ermsg = 'ERROR: reach ' // trim(adjustl(crch)) // & - & ' diversions are already allocated' - call store_error(ermsg) - 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%reaches(n)%ndiv - 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%reaches(n)%nconn - if (this%reaches(n)%idir(i) < 0) cycle - n2 = this%reaches(n)%iconn(i) - do ii = 1, this%reaches(n2)%nconn - 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 - !qu = this%reaches(n)%usflow - this%reaches(n)%usflow = qu - ! -- calculate remaining terms - qi = this%reaches(n)%inflow%value - qr = this%reaches(n)%rain%value * this%reaches(n)%width * this%reaches(n)%length - qe = this%reaches(n)%evap%value * this%reaches(n)%width * this%reaches(n)%length - 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%reaches(n)%simevap = qe - this%reaches(n)%simrunoff = 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%reaches(n)%iboundpak > 0) then - call this%sfr_rectch_depth(n, qmp, d1) - else - this%reaches(n)%stage = this%reaches(n)%sstage%value - d1 = max(DZERO, this%reaches(n)%stage - this%reaches(n)%strtop) - 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%reaches(n)%strtop - bt = tp - this%reaches(n)%bthick - 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, DONE, 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%reaches(n)%iboundpak < 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 (this%reaches(n)%iboundpak < 0) then - 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%reaches(n)%depth = d1 - this%reaches(n)%stage = 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%reaches(n)%dsflow = qd - ! - ! -- save groundwater leakage - this%reaches(n)%gwflow = qgwf - ! - ! -- route downstream flow - if (qd > DZERO) then - ! - ! -- route water to diversions - do i = 1, this%reaches(n)%nconn - 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%reaches(n)%nconn - if (this%reaches(n)%idir(i) > 0) cycle - if (this%reaches(n)%idiv(i) > 0) cycle - n2 = this%reaches(n)%iconn(i) - f = this%reaches(n2)%ustrf / this%reaches(n)%ftotnd - this%reaches(n)%qconn(i) = qd * f - end do - else - do i = 1, this%reaches(n)%nconn - 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%reaches(n)%usflow - qi = this%reaches(n)%inflow%value - qro = this%reaches(n)%runoff%value - ! - ! -- calculate rainfall and evap - a = this%geo(n)%surface_area() - ae = this%geo(n)%surface_area_wet(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%reaches(n)%slope - r = this%reaches(n)%rough%value - aw = this%geo(n)%area_wet(depth) - wp = this%geo(n)%perimeter_wet(depth) - 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%reaches(n)%igwfnode - 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, depth, cond) - ! - ! -- calculate groundwater leakage - tp = this%reaches(n)%strtop - bt = tp - this%reaches(n)%bthick - 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, depth, cond) - ! ****************************************************************************** - ! sfr_calc_qgwf -- Calculate sfr-aquifer exchange - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - class(SfrType) :: this - integer(I4B), intent(in) :: n - real(DP), intent(in) :: depth - real(DP), intent(inout) :: cond - ! -- local - integer(I4B) :: node - real(DP) :: wp - ! ------------------------------------------------------------------------------ - ! - ! -- initialize a few variables - cond = DZERO - node = this%reaches(n)%igwfnode - if (node > 0) then - if (this%ibound(this%reaches(n)%igwfnode) > 0) then - wp = this%geo(n)%perimeter_wet(depth) - cond = this%reaches(n)%hk * this%reaches(n)%length * wp / this%reaches(n)%bthick - 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%reaches(n)%width - s = this%reaches(n)%slope - 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) :: ermsg - integer(I4B) :: n, nn - real(DP) :: btgwf, bt - ! -- code - ! - ! -- write header - if (this%iprpak /= 0) then - write (this%iout, '(//a)') 'SFR STATIC REACH DATA' - write (this%iout, '(a)') ' REACH CELLID ' // & - ' LENGTH WIDTH SLOPE TOP ' // & - ' THICKNESS HK ROUGHNESS USTR FRAC' - write (this%iout, "(128('-'))") - end if - ! - ! -- check the reach data for simple errors - do n = 1, this%maxbound - write (crch, '(i5)') n - nn = this%reaches(n)%igwfnode - 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%reaches(n)%length <= DZERO) then - ermsg = 'ERROR: Reach ' // crch // ' length must be > 0.0' - call store_error(ermsg) - end if - ! -- check reach width - if (this%reaches(n)%width <= DZERO) then - ermsg = 'ERROR: Reach ' // crch // ' width must be > 0.0' - call store_error(ermsg) - end if - ! -- check reach slope - if (this%reaches(n)%slope <= DZERO) then - ermsg = 'ERROR: Reach ' // crch // ' slope must be > 0.0' - call store_error(ermsg) - end if - ! -- check bed thickness and bed hk for reaches connected to GWF - if (nn > 0) then - bt = this%reaches(n)%strtop - this%reaches(n)%bthick - if (bt <= btgwf .and. this%icheck /= 0) then - write (cval,'(f10.4)') bt - ermsg = 'ERROR: Reach ' // crch // ' bed bottom (rtp-rbth =' // cval - ermsg = trim(adjustl(ermsg)) // ') must be > the bottom of cell (' // nodestr - write (cval,'(f10.4)') btgwf - ermsg = trim(adjustl(ermsg)) // '=' // cval // ').' - call store_error(ermsg) - end if - if (this%reaches(n)%hk < DZERO) then - ermsg = 'ERROR: Reach ' // crch // ' hk must be >= 0.0' - call store_error(ermsg) - end if - end if - ! -- check reach roughness - if (this%reaches(n)%rough%value <= DZERO) then - ermsg = 'ERROR: Reach ' // crch // " Manning's roughness coefficient must be > 0.0" - call store_error(ermsg) - end if - ! -- check reach upstream fraction - if (this%reaches(n)%ustrf < DZERO) then - ermsg = 'ERROR: Reach ' // crch // " upstream fraction must be >= 0.0" - call store_error(ermsg) - end if - ! -- write summary of reach information - if (this%iprpak /= 0) then - write (this%iout,'(i10,1x,a30,2(f10.4,1x),g10.3,1x,2(f10.4,1x),2(g10.3,1x),f10.4)') & - n, nodestr, & - this%reaches(n)%length, this%reaches(n)%width, & - this%reaches(n)%slope, this%reaches(n)%strtop, & - this%reaches(n)%bthick, this%reaches(n)%hk, & - this%reaches(n)%rough%value, this%reaches(n)%ustrf - end if - end do - if (this%iprpak /= 0) then - write (this%iout, "(128('-'))") - end if - - ! -- 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) :: ermsg - character (len=LINELENGTH) :: line - integer(I4B) :: n, nn, nc - integer(I4B) :: i, ii - integer(I4B) :: ifound - integer(I4B) :: ierr - ! -- code - - ! - ! -- check the reach connections for simple errors - ! -- connection header - line = 'REACH' - do n = 1, 24 - write (crch, '(i5)') n - line = trim(line) // crch - end do - if (this%iprpak /= 0) then - write (this%iout, '(//a)') 'SFR REACH CONNECTION DATA' - write (this%iout, '(59x,a)') 'CONNECTED REACH DATA' - write (this%iout, '(a)') line - write (this%iout, "(128('-'))") - end if - ! -- connection check - do n = 1, this%maxbound - write (crch, '(i5)') n - line = crch - eachconn: do i = 1, this%reaches(n)%nconn - nn = this%reaches(n)%iconn(i) - write (crch2, '(i5)') nn - line = trim(line) // crch2 - ifound = 0 - connreach: do ii = 1, this%reaches(nn)%nconn - 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 - ifound = 1 - exit connreach - end if - end do connreach - if (ifound /= 1) then - ermsg = 'ERROR: Reach ' // crch // ' is connected to ' // & - & 'reach ' // crch2 // ' but reach ' // crch2 // & - & ' is not connected to reach ' // crch // '.' - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - end if - end do eachconn - ! write line to output file - if (this%iprpak /= 0) then - write (this%iout, '(a)') trim(line) - end if - end do - if (this%iprpak /= 0) then - write (this%iout, "(128('-'))") - end if - - ! - ! -- check for incorrect connections between upstream connections - ierr = 0 - do n = 1, this%maxbound - write (crch, '(i5)') n - eachconnv: do i = 1, this%reaches(n)%nconn - ! -- 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%reaches(nn)%nconn - ! -- skip downstream connections - if (this%reaches(nn)%idir(ii) < 0) cycle connreachv - nc = this%reaches(nn)%iconn(ii) - ! if nc == 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 - ermsg = 'ERROR: Reach ' // crch // ' is connected to ' // & - 'reach ' // crch2 // ' but streamflow from reach ' // & - crch // ' to reach ' // crch2 // ' is not permitted.' - call store_error(ermsg) - 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 - ! -- downstream connection header - line = 'REACH' - do n = 1, 24 - write (crch, '(i5)') n - line = trim(line) // crch - end do - ! - ! -- write header for downstream connections - if (this%iprpak /= 0) then - write (this%iout, '(//a)') 'SFR DOWNSTREAM CONNECTIONS' - write (this%iout, '(60x,a)') 'DOWNSTREAM REACHES' - write (this%iout, '(a)') line - write (this%iout, "(128('-'))") - end if - do n = 1, this%maxbound - write (crch, '(i5)') n - line = crch - eachconnds: do i = 1, this%reaches(n)%nconn - nn = this%reaches(n)%iconn(i) - if (this%reaches(n)%idir(i) > 0) cycle eachconnds - write (crch2, '(i5)') nn - line = trim(line) // crch2 - ifound = 0 - connreachds: do ii = 1, this%reaches(nn)%nconn - 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 - ermsg = 'ERROR: Reach ' // crch // ' downstream connected reach is ' // & - & 'reach ' // crch2 // ' but reach ' // crch // & - & ' is not the upstream connected reach for reach ' // crch2 // '.' - call store_error(ermsg) - end if - end do eachconnds - ! write line to output file - if (this%iprpak /= 0) then - write (this%iout, '(a)') trim(line) - end if - end do - if (this%iprpak /= 0) then - write (this%iout, "(128('-'))") - end if - ! - ! -- output upstream reaches for each reach - ! -- upstream connection header - line = 'REACH' - do n = 1, 24 - write (crch, '(i5)') n - line = trim(line) // crch - end do - if (this%iprpak /= 0) then - write (this%iout, '(//a)') 'SFR UPSTREAM CONNECTIONS' - write (this%iout, '(61x,a)') 'UPSTREAM REACHES' - write (this%iout, '(a)') line - write (this%iout, "(128('-'))") - end if - do n = 1, this%maxbound - write (crch, '(i5)') n - line = crch - eachconnus: do i = 1, this%reaches(n)%nconn - nn = this%reaches(n)%iconn(i) - if (this%reaches(n)%idir(i) < 0) cycle eachconnus - write (crch2, '(i5)') nn - line = trim(line) // crch2 - end do eachconnus - ! write line to output file - if (this%iprpak /= 0) then - write (this%iout, '(a)') trim(line) - end if - end do - if (this%iprpak /= 0) then - write (this%iout, "(128('-'))") - end if - - ! -- return - return - end subroutine sfr_check_connections - - - subroutine sfr_check_diversions(this) - class(SfrType) :: this - ! -- local - character (len= 5) :: crch - character (len= 5) :: cdiv - character (len= 5) :: crch2 - character (len=10) :: cprior - character (len=LINELENGTH) :: ermsg - character (len=LINELENGTH) :: line - 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 - write (this%iout, '(//a)') 'SFR DIVERSION DATA' - write (this%iout, '(a)') ' REACH DIVERSION REACH2 CPRIOR' - write (this%iout, "(45('-'))") - end if - ! - ! -- check that diversion data are correct - do n = 1, this%maxbound - if (this%reaches(n)%ndiv < 1) cycle - write (crch, '(i5)') n - line = ' ' // crch - do idiv = 1, this%reaches(n)%ndiv - write (cdiv, '(i5)') idiv - line = trim(line) // ' ' // cdiv - ! - nn = this%reaches(n)%diversion(idiv)%reach - write (crch2, '(i5)') nn - line = trim(line) // ' ' // crch2 - ! -- make sure diversion reach is connected to current reach - ifound = 0 - if (nn < 1 .or. nn > this%maxbound) then - write(ermsg,10)idiv, n - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - connreach: do ii = 1, this%reaches(nn)%nconn - 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 - ermsg = '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(ermsg) - end if - ! -- iprior - cprior = this%reaches(n)%diversion(idiv)%cprior - line = trim(line) // ' ' // cprior - ! - ! write final line to output file - if (this%iprpak /= 0) then - write (this%iout, '(a)') trim(line) - end if - end do - end do - if (this%iprpak /= 0) then - write (this%iout, "(45('-'))") - end if - ! - ! -- return - return - end subroutine sfr_check_diversions - - - subroutine sfr_check_ustrf(this) - class(SfrType) :: this - ! -- local - logical :: ladd - character (len=5) :: crch, crch2 - character (len=10) :: cval - character (len=LINELENGTH) :: ermsg - character (len=LINELENGTH) :: line - integer(I4B) :: i, n - integer(I4B) :: n2 - integer(I4B) :: idiv - integer(I4B) :: ids - real(DP) :: f - real(DP) :: rval - ! -- code - ! - ! -- write header - line = 'REACH' - do n = 1, 8 - write (crch, '(i5)') n - line = trim(line) // crch // ' FRACTION' - end do - if (this%iprpak /= 0) then - write (this%iout, '(//a)') 'SFR UPSTREAM FRACTIONS' - write (this%iout, '(47x,a)') 'CONNECTED REACHES UPSTREAM FRACTIONS' - write (this%iout, '(a)') line - write (this%iout, "(128('-'))") - 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 - line = crch - eachconn: do i = 1, this%reaches(n)%nconn - ! -- initialize downstream connection q - this%reaches(n)%qconn(i) = DZERO - ! -- skip upstream connections - if (this%reaches(n)%idir(i) > 0) cycle eachconn - n2 = this%reaches(n)%iconn(i) - ! -- skip inactive downstream reaches - if (this%reaches(n2)%iboundpak == 0) cycle eachconn - write (crch2, '(i5)') n2 - ids = ids + 1 - ladd = .true. - f = f + this%reaches(n2)%ustrf - write (cval, '(f10.4)') this%reaches(n2)%ustrf - line = trim(line) // crch2 // cval - eachdiv: do idiv = 1, this%reaches(n)%ndiv - 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%reaches(n2)%ustrf - end if - end do eachconn - this%reaches(n)%ftotnd = rval - ! - ! -- write upstream fractions - if (this%iprpak /= 0) then - write (this%iout, '(a)') line - end if - if (ids /= 0) then - if (abs(f-DONE) > DEM6) then - write (cval, '(f10.4)') f - ermsg = 'ERROR: upstream fractions for reach ' // crch // ' not equal to one (' - ermsg = trim(adjustl(ermsg)) // cval // '). Check reach connectivity.' - call store_error(ermsg) - end if - end if - end do - if (this%iprpak /= 0) then - write (this%iout, "(128('-'),//)") - end if - ! - ! -- return - return - end subroutine sfr_check_ustrf - - 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 974c9e4b909..e77a2b42f69 100644 --- a/src/Model/GroundWaterFlow/gwf3sto8.f90 +++ b/src/Model/GroundWaterFlow/gwf3sto8.f90 @@ -1,935 +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, nodes, hold, hnew, nja, njasln, amat, & - idxglo, rhs) -! ****************************************************************************** -! sto_fc -- Fill the solution amat and rhs with storage contribution newton -! term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use TdisModule, only: delt - ! -- dummy - class(GwfStoType) :: this - integer(I4B),intent(in) :: kiter - integer(I4B),intent(in) :: nodes - real(DP), intent(in), dimension(nodes) :: hold - real(DP), intent(in), dimension(nodes) :: hnew - 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 - ! -- 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 -! ------------------------------------------------------------------------------ - ! - ! -- 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) < 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, nodes, hold, hnew, nja, 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 - integer(I4B),intent(in) :: nodes - real(DP), intent(in), dimension(nodes) :: hold - real(DP), intent(in), dimension(nodes) :: hnew - 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 - ! -- 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 was 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 - ! - ! -- 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, 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 3ec69ab4360..c2b5ef4009e 100644 --- a/src/Model/GroundWaterFlow/gwf3uzf8.f90 +++ b/src/Model/GroundWaterFlow/gwf3uzf8.f90 @@ -1,3482 +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, DNODATA, & - NAMEDBOUNDFLAG, MAXCHARLEN, & - DHNOFLO, DHDRY - use MemoryTypeModule, only: MemoryTSType - use MemoryManagerModule, only: mem_allocate, mem_reallocate, mem_setptr, & - mem_deallocate - use SparseModule, only: sparsematrix - use BndModule, only: BndType - use UzfKinematicModule - use BudgetModule, only: BudgetType - use BaseDisModule, only: DisBaseType - use ObserveModule, only: ObserveType - use ObsModule, only: ObsType - use InputOutputModule, only: URWORD, UWWORD - use SimModule, only: count_errors, store_error, ustop, & - store_error_unit - use BlockParserModule, only: BlockParserType - - implicit none - ! - character(len=LENFTYPE) :: ftype = 'UZF' - character(len=LENPACKAGENAME) :: text = ' UZF CELLS' - - private - public :: uzf_create - - type, extends(BndType) :: UzfType - ! output integers - integer(I4B), pointer :: iprwcont => null() - integer(I4B), pointer :: iwcontout => null() - integer(I4B), pointer :: ibudgetout => null() - ! - type(BudgetType), pointer :: budget => null() !budget object - 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 - type(UzfKinematicType), pointer :: uzfobj => null() !uzf kinematic object - type(UzfKinematicType), pointer :: uzfobjwork => null() !uzf kinematic work object - type(UzfKinematicType), pointer :: uzfobjbelow => null() !uzf kinematic object of underlying cell - type(UzfKinematicType), dimension(:), pointer, & - contiguous :: elements => null() !array of all the kinematic uzf objects - character(len=72), pointer :: nameuzf => null() !cdl--(not sure. Delete?) - ! - ! -- 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() !cdl--(this should probably be maxbound) - 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 :: mfcellid => 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() - real(DP), pointer :: pdmax => 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 :: uzcelloutput - procedure, private :: findcellabove - procedure, private :: check_cell_area - - 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 - ! - ! -- return - return - end subroutine uzf_create - - subroutine uzf_ar(this) -! ****************************************************************************** -! uzf_ar -- Allocate and Read -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use UzfKinematicModule, only: UzfKinematicType - use MemoryManagerModule, only: mem_allocate, mem_setptr, mem_reallocate - use BudgetModule, only: budget_cr - ! -- dummy - class(UzfType), intent(inout) :: this - ! -- local - integer(I4B) :: i, n -! ------------------------------------------------------------------------------ - ! - call this%obs%obs_ar() - ! - ! -- Allocate arrays in package superclass - call this%uzf_allocate_arrays() - ! - ! -- Allocate UZF objects plus one extra for work array - allocate(this%elements(this%nodes+1)) - do i = 1, this%nodes + 1 - allocate(this%elements(i)) - enddo - ! - ! -- Initialize each UZF object - do i = 1, this%nodes+1 - this%uzfobj => this%elements(i) - call this%uzfobj%init(i,this%nwav) - end do - ! - ! -- 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') - call mem_setptr(this%gwfhcond, 'CONDSAT', trim(this%name_model)//' NPF') - call mem_setptr(this%gwfiss, 'ISS', trim(this%name_model)) -! -! --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 - ! - ! 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 the budget - call budget_cr(this%budget, this%origin) - call this%budget%budget_df(this%bditems, this%name, 'L**3') - ! - ! -- 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 mover -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - !use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(UzfType), intent(inout) :: this - ! -- local - integer (I4B) :: i - integer (I4B) :: j - integer (I4B) :: ipos -! ------------------------------------------------------------------------------ - ! - ! -- call standard BndType allocate scalars - call this%BndType%allocate_arrays() - ! - ! -- allocate uzf specific arrays - call mem_allocate(this%mfcellid, this%nodes, 'MFCELLID', 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) - - - 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 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 - real(DP) :: r - ! -- 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('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. NTRAILSETS WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - this%nwav = this%ntrail*this%nsets - - !! allocate variables - ! call this%allocate_vars() - ! - ! -- Call define_listlabel to construct the list label that is written - ! when PRINT_INPUT option is used. - call this%define_listlabel() -! - 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 - use UzfKinematicModule, only: UzfKinematicType - ! -- 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, ivertflag - real (DP) :: endtim - logical :: isfound, endOfBlock - character(len=LINELENGTH) :: line, errmsg - ! -- table output - character (len=20) :: cellids, cellid - character(len=LINELENGTH) :: linesep - character(len=16) :: text - integer(I4B) :: n - integer(I4B) :: node - integer(I4B) :: iloc - real(DP) :: q - !-- 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 - ! - ! -- set cell id based on discretization - if (this%dis%ndim == 3) then - cellids = '(LAYER,ROW,COLUMN) ' - elseif (this%dis%ndim == 2) then - cellids = '(LAYER,CELL2D) ' - else - cellids = '(NODE) ' - end if - write (this%iout, '(//3a)') & - 'UZF PACKAGE (', trim(adjustl(this%name)), ') STRESS PERIOD DATA' - ! - iloc = 1 - line = '' - if(this%inamedbound==1) then - call UWWORD(line, iloc, 16, 1, 'name', n, q, left=.TRUE.) - end if - call UWWORD(line, iloc, 6, 1, 'no.', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 20, 1, cellids, n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'finf', n, q, CENTER=.TRUE., sep=' ') - if (this%ietflag /= 0) then - call UWWORD(line, iloc, 11, 1, 'pet', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'extdep', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'extwc', n, q, CENTER=.TRUE., sep=' ') - if (this%ietflag == 2) then - call UWWORD(line, iloc, 11, 1, 'ha', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'hroot', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'rootact', n, q, CENTER=.TRUE.) - end if - end if - ! -- create line separator - linesep = repeat('-', iloc) - ! -- write header line and separator - write(this%iout,'(1X,A)') line(1:iloc) - write(this%iout,'(1X,A)') linesep(1:iloc) - end if - ! - 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 - write(errmsg,'(4x,a,1x,i6)') & - '****ERROR. UZFNO MUST BE > 0 and <= ', this%nodes - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- setup pointers - this%uzfobj => this%elements(i) - ivertflag = this%uzfobj%ivertcon - if ( ivertflag > 0 ) then - this%uzfobjbelow => this%elements(ivertflag) - else - ! -- point to i so not null. Does not use in this case. - this%uzfobjbelow => this%elements(i) - end if - ! - ! - 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%mfcellid(i) - if (node > 0) then - call this%dis%noder_to_string(node, cellid) - else - cellid = 'none' - end if - ! - ! -- fill line - ! - iloc = 1 - line = '' - if(this%inamedbound==1) then - call UWWORD(line, iloc, 16, 1, this%boundname(i), n, q, left=.TRUE.) - end if - call UWWORD(line, iloc, 6, 2, text, i, q, sep=' ') - call UWWORD(line, iloc, 20, 1, cellid, n, q, left=.TRUE.) - call UWWORD(line, iloc, 11, 3, text, i, this%sinf(i)%value, sep=' ') - if (this%ietflag /= 0) then - call UWWORD(line, iloc, 11, 3, text, i, this%pet(i)%value, sep=' ') - call UWWORD(line, iloc, 11, 3, text, i, this%extdp(i)%value, sep=' ') - call UWWORD(line, iloc, 11, 3, text, i, this%extwc(i)%value, sep=' ') - if (this%ietflag == 2) then - call UWWORD(line, iloc, 11, 3, text, i, this%ha(i)%value, sep=' ') - call UWWORD(line, iloc, 11, 3, text, i, this%hroot(i)%value, sep=' ') - call UWWORD(line, iloc, 11, 3, text, i, this%rootact(i)%value) - end if - end if - ! -- write line - write(this%iout,'(1X,A)') line(1:iloc) - end if - - end do - if (this%iprpak /= 0) then - write(this%iout,'(1X,A)') linesep(1:iloc) - 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 - this%uzfobj => this%elements(i) - call this%uzfobj%setwaves(i) - end do - end if - this%issflagold = this%issflag - !call this%deallocate_vars() - ! - ! -- 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 - real (DP) :: rval1, rval2, rval3 -! ------------------------------------------------------------------------------ - ! - ! -- Advance the time series - call this%TsManager%ad() - ! - do i = 1, this%nodes - this%uzfobj => this%elements(i) - call this%uzfobj%advance() - end do - ! - ! -- update uzf objects with timeseries aware variables - do i = 1, this%nodes - ! - ! -- setup pointers - this%uzfobj => this%elements(i) - ivertflag = this%uzfobj%ivertcon - if ( ivertflag > 0 ) then - this%uzfobjbelow => this%elements(ivertflag) - else - ! -- point to iuzf so not null. Does not use in this case. - this%uzfobjbelow => this%elements(i) - end if - ! - ! -- recalculate uzfarea - if (this%iauxmultcol > 0) then - ipos = (i - 1) * this%naux + this%iauxmultcol - rval1 = this%lauxvar(ipos)%value - call this%uzfobj%setdatauzfarea(rval1) - end if - ! - ! -- FINF - rval1 = this%sinf(i)%value - call this%uzfobj%setdatafinf(rval1) - ! - ! -- PET, EXTDP - rval1 = this%pet(i)%value - rval2 = this%extdp(i)%value - call this%uzfobj%setdataet(this%uzfobjbelow, ivertflag, rval1, rval2) - ! - ! -- ETWC - rval1 = this%extwc(i)%value - call this%uzfobj%setdataetwc(this%uzfobjbelow, ivertflag, rval1) - ! - ! -- HA, HROOT, ROOTACT - rval1 = this%ha(i)%value - rval2 = this%hroot(i)%value - rval3 = this%rootact(i)%value - call this%uzfobj%setdataetha(this%uzfobjbelow, 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) -! ****************************************************************************** -! 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 - ! -- locals - integer(I4B) :: n -! ------------------------------------------------------------------------------ - ! - ! -- 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 - if(this%imover == 1) 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, iend, icnvg) -! ************************************************************************** -! uzf_cc -- Final convergence check for package -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - use InputOutputModule, only: UWWORD - ! -- dummy - class(Uzftype), intent(inout) :: this - integer(I4B), intent(in) :: iend - integer(I4B), intent(inout) :: icnvg - ! -- local - character(len=LINELENGTH) :: line, linesep - character(len=16) :: text - integer(I4B) :: n - integer(I4B) :: ifirst - integer(I4B) :: iloc - real(DP) :: r - real(DP) :: drejinf - real(DP) :: avgrejinf - real(DP) :: pdrejinf - real(DP) :: drch - real(DP) :: avgrch - real(DP) :: pdrch - real(DP) :: dseep - real(DP) :: avgseep - real(DP) :: pdseep - ! format -! -------------------------------------------------------------------------- - ifirst = 1 - if (this%iconvchk /= 0) then - final_check: do n = 1, this%nodes - drejinf = this%rejinf0(n) - this%rejinf(n) - avgrejinf = DHALF * (this%rejinf0(n) + this%rejinf(n)) - pdrejinf = DZERO - if (avgrejinf > DZERO) then - pdrejinf = DHUNDRED * drejinf / avgrejinf - end if - drch = this%rch0(n) - this%rch(n) - avgrch = DHALF * (this%rch0(n) + this%rch(n)) - pdrch = DZERO - if (avgrch > DZERO) then - pdrch = DHUNDRED * drch / avgrch - end if - avgseep = DZERO - if (this%iseepflag == 1) then - dseep = this%gwd0(n) - this%gwd(n) - avgseep = DHALF * (this%gwd0(n) + this%gwd(n)) - end if - pdseep = DZERO - if (avgseep > DZERO) then - pdseep = DHUNDRED * dseep / avgseep - end if - if (ABS(pdrejinf) > this%pdmax .or. ABS(pdrch) > this%pdmax .or. ABS(pdseep) > this%pdmax) then - icnvg = 0 - ! write convergence check information if this is the last outer iteration - if (iend == 1) then - ! -- write header - if (ifirst == 1) then - ifirst = 0 - ! -- create first header line - iloc = 1 - line = '' - call UWWORD(line, iloc, 10, 1, 'uzf', n, r, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 15, 1, 'rej infil', n, r, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 15, 1, 'rej infil', n, r, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 15, 1, 'gwf recharge', n, r, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 15, 1, 'gwf recharge', n, r, CENTER=.TRUE., sep=' ') - if (this%iseepflag == 1) then - call UWWORD(line, iloc, 15, 1, 'gwf seepage', n, r, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 15, 1, 'gwf seepage', n, r, CENTER=.TRUE., sep=' ') - end if - call UWWORD(line, iloc, 15, 1, 'pct difference', n, r, CENTER=.TRUE.) - ! -- create line separator - linesep = repeat('-', iloc) - ! -- write first line - write(this%iout,'(/1X,A)') 'UZF PACKAGE FAILED CONVERGENCE CRITERIA' - write(this%iout,'(1X,A)') linesep(1:iloc) - write(this%iout,'(1X,A)') line(1:iloc) - ! -- create second header line - iloc = 1 - line = '' - call UWWORD(line, iloc, 10, 1, 'cell', n, r, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 15, 1, 'difference', n, r, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 15, 1, 'pct difference', n, r, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 15, 1, 'difference', n, r, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 15, 1, 'pct difference', n, r, CENTER=.TRUE., sep=' ') - if (this%iseepflag == 1) then - call UWWORD(line, iloc, 15, 1, 'difference', n, r, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 15, 1, 'pct difference', n, r, CENTER=.TRUE., sep=' ') - end if - call UWWORD(line, iloc, 15, 1, 'criteria', n, r, CENTER=.TRUE.) - ! -- write second line - write(this%iout,'(1X,A)') line(1:iloc) - write(this%iout,'(1X,A)') linesep(1:iloc) - end if - ! -- write data - iloc = 1 - line = '' - call UWWORD(line, iloc, 10, 2, text, n, r, sep=' ') - call UWWORD(line, iloc, 15, 3, text, n, drejinf, sep=' ') - call UWWORD(line, iloc, 15, 3, text, n, pdrejinf, sep=' ') - call UWWORD(line, iloc, 15, 3, text, n, drch, sep=' ') - call UWWORD(line, iloc, 15, 3, text, n, pdrch, sep=' ') - if (this%iseepflag == 1) then - call UWWORD(line, iloc, 15, 3, text, n, dseep, sep=' ') - call UWWORD(line, iloc, 15, 3, text, n, pdseep, sep=' ') - end if - call UWWORD(line, iloc, 15, 3, text, n, this%pdmax) - write(this%iout, '(1X,A)') line(1:iloc) - else - exit final_check - end if - end if - end do final_check - if (ifirst == 0) then - write(this%iout,'(1X,A)') linesep(1:iloc) - 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 - integer(I4B) :: i, node, ibinun - integer(I4B) :: ii - integer(I4B) :: n, m, ivertflag, ierr - integer(I4B) :: n1, n2 - integer(I4B) :: nlen - real(DP) :: rfinf - real(DP) :: rin,rout,rsto,ret,retgw,rgwseep,rvflux - real(DP) :: rstoin - real(DP) :: rstoout - 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 - integer(I4B) :: ibdlbl, 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)" - character(len=LENBUDTXT) :: aname(10) - ! -- for table - 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 - rstoin = DZERO - rstoout = 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 - ! - ! -- Budget for each UZF model (start by resetting) - call this%budget%reset() - ! - ! -- Go through and process each UZF cell - do i = 1, this%nodes - ! - ! -- Initialize variables - n = this%nodelist(i) - this%uzfobj => this%elements(i) - ivertflag = this%uzfobj%ivertcon - ! - ! Create pointer to object below - if ( ivertflag > 0 ) then - this%uzfobjbelow => this%elements(ivertflag) - else - ! -- point to i so not null. Does not use in this case. - this%uzfobjbelow => this%elements(i) - end if - ! - ! -- 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 - ! - ! -- 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(this%uzfobjbelow,i,this%totfluxtot, & - rfinf,rin,rout,rsto,ret,retgw,rgwseep,rvflux, & - this%ietflag,this%iseepflag,this%issflag,hgwf, & - hgwflm1,this%gwfhcond(m),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 NWAVSETS 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 + trhsgwet + (thcofgwet * hgwf) - retgw = retgw + this%gwet(i) - end if - ! - ! -- Calculate flows for cbc output and observations - if ( hgwf > this%uzfobj%celbot ) then - this%recharge(i) = this%uzfobj%totflux * this%uzfobj%uzfarea / delt - else - this%recharge(i) = this%uzfobjbelow%surflux * this%uzfobj%uzfarea - end if - - this%rch(i) = this%uzfobj%totflux * this%uzfobj%uzfarea / delt - - this%appliedinf(i) = this%uzfobj%sinf * this%uzfobj%uzfarea - this%infiltration(i) = this%uzfobj%surflux * this%uzfobj%uzfarea - - this%rejinf(i) = this%uzfobj%finf_rej * this%uzfobj%uzfarea - - qout = this%rejinf(i) + this%uzfobj%surfseep - 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 - 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 - this%uzet(i) = this%uzfobj%etact*this%uzfobj%uzfarea / delt - this%qsto(i) = this%uzfobj%delstor / delt - - ! -- accumulate groundwater et - qgwet = qgwet + this%gwet(i) - - if (this%qsto(i) < DZERO) then - rstoin = rstoin - this%qsto(i) - else - rstoout = rstoout + this%qsto(i) - end if - ! - ! -- 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 - - call this%budget%addentry(qfinf, DZERO, delt, aname(1), isuppress_output) - if (this%imover == 1) then - call this%budget%addentry(rfrommvr, DZERO, delt, aname(10), isuppress_output) - end if - call this%budget%addentry(DZERO, qrejinf, delt, aname(8), isuppress_output) - if (this%imover == 1) then - call this%budget%addentry(DZERO, qrejinftomvr, delt, aname(9), isuppress_output) - end if - call this%budget%addentry(DZERO, rout, delt, aname(2), isuppress_output) - if (this%ietflag /= 0) then - call this%budget%addentry(DZERO, ret, delt, aname(4), isuppress_output) - end if - ! - ! - rin = DZERO - rout = DZERO - if(rsto < DZERO) then - rin = -rsto - else - rout = rsto - endif - call this%budget%addentry(rstoin, rstoout, delt, aname(3), isuppress_output) - !if ( isuppress_output == 0 ) call this%budget%budget_ot(kstp, kper, this%iout) - - !call this%uzf_bdsav(icbcfl, icbcun) - - ! output saturation or other variables for each cell - call this%uzcelloutput(isuppress_output) - ! - ! -- 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 - ibdlbl = 0 - 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 - ! - ! -- 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 - if (ibdlbl == 0) write(this%iout,fmttkk) & - this%bdtxt(2) // ' (' // trim(this%name) // ')', kper, kstp - call this%dis%print_list_entry(i, node, rrate, this%iout, & - bname) - ibdlbl=1 - 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 - ibdlbl = 0 - 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 - ! - ! -- 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 - if (ibdlbl == 0) write(this%iout,fmttkk) & - this%bdtxt(3) // ' (' // trim(this%name) // ')', kper, kstp - call this%dis%print_list_entry(i, node, rrate, this%iout, & - bname) - ibdlbl=1 - 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 - ibdlbl = 0 - 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 - ! - ! -- 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 - if (ibdlbl == 0) write(this%iout,fmttkk) & - this%bdtxt(5) // ' (' // trim(this%name) // ')', kper, kstp - call this%dis%print_list_entry(i, node, rrate, this%iout, & - bname) - ibdlbl=1 - 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 - ibdlbl = 0 - 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 - ! - ! -- 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 - if (ibdlbl == 0) write(this%iout,fmttkk) & - this%bdtxt(4) // ' (' // trim(this%name) // ')', kper, kstp - call this%dis%print_list_entry(i, node, rrate, this%iout, & - bname) - ibdlbl=1 - 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 - ! - ! -- Set unit number for binary budget output - ibinun = 0 - if(this%ibudgetout /= 0) then - ibinun = this%ibudgetout - end if - if(icbcfl == 0) ibinun = 0 - if (isuppress_output /= 0) ibinun = 0 - ! - ! -- write uzf binary budget output - if (ibinun > 0) then - ! FLOW JA FACE - uzf to uzf connections using outlets - nlen = 0 - do n = 1, this%nodes - ! - ! -- Initialize variables - this%uzfobj => this%elements(n) - ivertflag = this%uzfobj%ivertcon - if ( ivertflag > 0 ) then - nlen = nlen + 1 - end if - end do - if (nlen > 0) then - naux = 0 - call ubdsv06(kstp, kper, ' FLOW-JA-FACE', this%name_model, this%name, & - this%name_model, this%name, & - ibinun, naux, this%cauxcbc, nlen*2, 1, 1, & - nlen*2, this%iout, delt, pertim, totim) - do n = 1, this%nodes - ! - ! -- Initialize variables - this%uzfobj => this%elements(n) - ivertflag = this%uzfobj%ivertcon - if ( ivertflag > 0 ) then - q = this%uzfobj%surfluxbelow * this%uzfobj%uzfarea - if (q > DZERO) then - q = -q - end if - n1 = n - n2 = ivertflag - call this%dis%record_mf6_list_entry(ibinun, n1, n2, q, naux, & - this%qauxcbc, & - olconv=.FALSE., & - olconv2=.FALSE.) - q = this%uzfobj%surfluxbelow * this%uzfobj%uzfarea - call this%dis%record_mf6_list_entry(ibinun, n2, n1, q, naux, & - this%qauxcbc, & - olconv=.FALSE., & - olconv2=.FALSE.) - - end if - end do - end if - ! GWF - naux = this%cbcauxitems - this%cauxcbc(1) = ' FLOW-AREA' - call ubdsv06(kstp, kper, aname(2), this%name_model, this%name, & - this%name_model, this%name_model, & - ibinun, naux, this%cauxcbc, this%nodes, 1, 1, & - this%nodes, this%iout, delt, pertim, totim) - do n = 1, this%nodes - ! - ! -- Initialize variables - this%uzfobj => this%elements(n) - this%qauxcbc(1) = this%uzfobj%uzfarea - n2 = this%mfcellid(n) - q = -this%rch(n) - call this%dis%record_mf6_list_entry(ibinun, n, n2, q, naux, & - this%qauxcbc, & - olconv=.FALSE.) - end do - ! SPECIFIED INFILTRATION - naux = 0 - call ubdsv06(kstp, kper, aname(1), this%name_model, this%name, & - this%name_model, this%name, & - ibinun, naux, this%cauxcbc, this%nodes, 1, 1, & - this%nodes, this%iout, delt, pertim, totim) - do n = 1, this%nodes - q = this%appliedinf(n) - call this%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%auxvar(:,n), & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - ! REJECTED INFILTRATION - naux = 0 - call ubdsv06(kstp, kper, aname(8), this%name_model, this%name, & - this%name_model, this%name, & - ibinun, naux, this%cauxcbc, this%nodes, 1, 1, & - this%nodes, this%iout, delt, pertim, totim) - do n = 1, this%nodes - q = this%rejinf(n) - if (q > DZERO) then - q = -q - end if - call this%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%auxvar(:,n), & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - ! UNSATURATED EVT - if (this%ietflag /= 0) then - naux = 0 - call ubdsv06(kstp, kper, aname(4), this%name_model, this%name, & - this%name_model, this%name, & - ibinun, naux, this%cauxcbc, this%nodes, 1, 1, & - this%nodes, this%iout, delt, pertim, totim) - do n = 1, this%nodes - q = this%uzet(n) - if (q > DZERO) then - q = -q - end if - call this%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%auxvar(:,n), & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - end if - ! STORAGE - naux = 0 - call ubdsv06(kstp, kper, aname(3), this%name_model, this%name, & - this%name_model, this%name, & - ibinun, naux, this%cauxcbc, this%nodes, 1, 1, & - this%nodes, this%iout, delt, pertim, totim) - do n = 1, this%nodes - q = -this%qsto(n) - call this%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%auxvar(:,n), & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - ! MOVER - if (this%imover == 1) then - ! FROM MOVER - naux = 0 - call ubdsv06(kstp, kper, aname(10), this%name_model, & - this%name, this%name_model, this%name, & - ibinun, naux, this%cauxcbc, & - this%nodes, 1, 1, & - this%nodes, this%iout, delt, pertim, totim) - do n = 1, this%nodes - q = this%pakmvrobj%get_qfrommvr(n) - call this%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%auxvar(:,n), & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - ! TO MOVER - naux = 0 - call ubdsv06(kstp, kper, aname(9), this%name_model, & - this%name, this%name_model, this%name, & - ibinun, naux, this%cauxcbc, & - this%nodes, 1, 1, & - this%nodes, this%iout, delt, pertim, totim) - do n = 1, this%nodes - q = this%rejinftomvr(n) - if (q > DZERO) then - q = -q - end if - call this%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%auxvar(:,n), & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - end if - ! AUXILIARY VARIABLES - naux = this%naux - if (naux > 0) then - call ubdsv06(kstp, kper, ' AUXILIARY', this%name_model, this%name,& - this%name_model, this%name, & - ibinun, naux, this%auxname, this%nodes, 1, 1, & - this%nodes, this%iout, delt, pertim, totim) - do n = 1, this%nodes - q = DZERO - ! fill auxvar - do i = 1, naux - ii = (n-1) * naux + i - this%auxvar(i,n) = this%lauxvar(ii)%value - end do - call this%dis%record_mf6_list_entry(ibinun, n, n, q, naux, & - this%auxvar(:,n), & - olconv=.FALSE., & - olconv2=.FALSE.) - end do - end if - end if - ! - ! -- return - return - end subroutine uzf_bd - - subroutine uzf_ot(this, kstp, kper, iout, ihedfl, ibudfl) -! ****************************************************************************** -! uzf_ot -- UZF package budget -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use InputOutputModule, only: UWWORD - ! -- 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 - character(len=LINELENGTH) :: line, linesep - character(len=16) :: text - integer(I4B) :: n - integer(I4B) :: iloc - integer(I4B) :: ivertflag - real(DP) :: q - real(DP) :: qin - real(DP) :: qout - real(DP) :: qerr - real(DP) :: qavg - real(DP) :: qpd - ! -- 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 - ! - ! -- write uzf rates - if (ibudfl /= 0 .and. this%iprflow /= 0) then - write (iout, 2000) 'UZF (', trim(this%name), ') FLOWS', kper, kstp - iloc = 1 - line = '' - if(this%inamedbound==1) then - call UWWORD(line, iloc, 16, 1, 'uzf', n, q, left=.TRUE.) - end if - call UWWORD(line, iloc, 6, 1, 'uzf', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'uzf', n, q, CENTER=.TRUE., sep=' ') - if (this%iuzf2uzf == 1) then - call UWWORD(line, iloc, 11, 1, 'uzf-uzf', n, q, CENTER=.TRUE., sep=' ') - end if - if (this%imover == 1) then - call UWWORD(line, iloc, 11, 1, 'uzf', n, q, CENTER=.TRUE., sep=' ') - end if - call UWWORD(line, iloc, 11, 1, 'uzf', n, q, CENTER=.TRUE., sep=' ') - if (this%imover == 1) then - call UWWORD(line, iloc, 11, 1, 'uzf rej-inf', n, q, CENTER=.TRUE., sep=' ') - end if - if (this%ietflag /= 0) then - call UWWORD(line, iloc, 11, 1, 'uzf', n, q, CENTER=.TRUE., sep=' ') - end if - call UWWORD(line, iloc, 11, 1, 'uzf', n, q, CENTER=.TRUE., sep=' ') - if (this%iuzf2uzf == 1) then - call UWWORD(line, iloc, 11, 1, 'uzf-uzf', n, q, CENTER=.TRUE., sep=' ') - end if - call UWWORD(line, iloc, 11, 1, 'uzf', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'uzf', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'percent', n, q, CENTER=.TRUE.) - ! -- 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, 1, 'name', n, q, left=.TRUE.) - end if - call UWWORD(line, iloc, 6, 1, 'no.', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'infilt.', n, q, CENTER=.TRUE., sep=' ') - if (this%iuzf2uzf == 1) then - call UWWORD(line, iloc, 11, 1, 'inflow', n, q, CENTER=.TRUE., sep=' ') - end if - if (this%imover == 1) then - call UWWORD(line, iloc, 11, 1, 'from mvr', n, q, CENTER=.TRUE., sep=' ') - end if - call UWWORD(line, iloc, 11, 1, 'rej-inf', n, q, CENTER=.TRUE., sep=' ') - if (this%imover == 1) then - call UWWORD(line, iloc, 11, 1, 'to mvr', n, q, CENTER=.TRUE., sep=' ') - end if - if (this%ietflag /= 0) then - call UWWORD(line, iloc, 11, 1, 'uzet', n, q, CENTER=.TRUE., sep=' ') - end if - call UWWORD(line, iloc, 11, 1, 'gwrch', n, q, CENTER=.TRUE., sep=' ') - if (this%iuzf2uzf == 1) then - call UWWORD(line, iloc, 11, 1, 'outflow', n, q, CENTER=.TRUE., sep=' ') - end if - call UWWORD(line, iloc, 11, 1, 'storage', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'in - out', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'difference', n, q, CENTER=.TRUE.) - ! -- write second line - write(iout,'(1X,A)') line(1:iloc) - write(iout,'(1X,A)') linesep(1:iloc) - ! write uzf rates for each uzf cell - do n = 1, this%maxbound - ! - ! -- reset accumulators - qin = DZERO - qout = DZERO - ! - ! -- fill line - iloc = 1 - line = '' - if (this%inamedbound==1) then - call UWWORD(line, iloc, 16, 1, this%boundname(n), n, q, left=.TRUE.) - end if - call UWWORD(line, iloc, 6, 2, text, n, q, CENTER=.TRUE., sep=' ') - ! - ! -- specified infiltration - q = this%appliedinf(n) - qin = qin + q - call UWWORD(line, iloc, 11, 3, text, n, q, sep=' ') - ! - ! -- infiltration from cell above - if (this%iuzf2uzf == 1) then - q = DZERO - this%uzfobj => this%elements(n) - if (this%uzfobj%landflag == 0) then - q = this%infiltration(n) - qin = qin + q - end if - call UWWORD(line, iloc, 11, 3, text, n, q, sep=' ') - end if - ! - ! -- from mover - if (this%imover == 1) then - q = this%pakmvrobj%get_qfrommvr(n) - qin = qin + q - call UWWORD(line, iloc, 11, 3, text, n, q, sep=' ') - end if - ! - ! -- rejected infiltration - q = this%rejinf(n) - if (q > DZERO) then - qout = qout + q - q = -q - end if - call UWWORD(line, iloc, 11, 3, text, n, q, sep=' ') - ! - ! -- rejected infiltration to mover - if (this%imover == 1) then - q = this%rejinftomvr(n) - if (q > DZERO) then - qout = qout + q - q = -q - end if - call UWWORD(line, iloc, 11, 3, text, n, q, sep=' ') - end if - ! - ! -- unsaturated evapotranspiration - if (this%ietflag /= 0) then - q = this%uzet(n) - if (q > DZERO) then - qout = qout + q - q = -q - end if - call UWWORD(line, iloc, 11, 3, text, n, q, sep=' ') - end if - ! - ! -- groundwater recharge - q = this%rch(n) - if (q > DZERO) then - qout = qout + q - q = -q - end if - call UWWORD(line, iloc, 11, 3, text, n, q, sep=' ') - ! - ! -- uzf below - if (this%iuzf2uzf == 1) then - q = DZERO - this%uzfobj => this%elements(n) - ivertflag = this%uzfobj%ivertcon - if ( ivertflag > 0 ) then - q = this%uzfobj%surfluxbelow * this%uzfobj%uzfarea - if (q > DZERO) then - qout = qout + q - q = -q - end if - end if - call UWWORD(line, iloc, 11, 3, text, n, q, sep=' ') - end if - ! - ! -- storage - q = this%qsto(n) - if (q > DZERO) then - qout = qout + q - else - qin = qin - q - end if - if (q /= DZERO) then - q = -q - end if - call UWWORD(line, iloc, 11, 3, text, n, q, sep=' ') - ! - ! -- calculate error - qerr = qin - qout - call UWWORD(line, iloc, 11, 3, text, n, qerr, sep=' ') - ! - ! -- calculate percent difference - qavg = DHALF * (qin + qout) - if (qavg > DZERO) then - end if - qpd = DZERO - if (qavg > DZERO) then - qpd = DHUNDRED * qerr / qavg - end if - call UWWORD(line, iloc, 11, 3, text, n, qpd) - ! - ! -- write line - write(iout, '(1X,A)') line(1:iloc) - end do - end if - ! - ! -- Output uzf budget - call this%budget%budget_ot(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 -! ------------------------------------------------------------------------------ - ! - ! -- Initialize - this%uzfobjwork => this%elements(this%nodes+1) - 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 - this%uzfobj => this%elements(i) - ivertflag = this%uzfobj%ivertcon - ! - ! Create pointer to object below - if ( ivertflag > 0 ) then - this%uzfobjbelow => this%elements(ivertflag) - else - ! -- point to i so not null. Does not use in this case. - this%uzfobjbelow => this%elements(i) - end if - ! - 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(this%uzfobjwork,this%uzfobjbelow,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 NWAVSETS 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 * this%uzfobj%uzfarea - this%rch(i) = this%uzfobj%totflux * this%uzfobj%uzfarea / delt - this%gwd(i) = this%uzfobj%surfseep - ! - ! -- 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 uzf_bdsav(this, icbcfl, icbcun) -!! ****************************************************************************** -!! uzf_bdsav -- Save budget terms -!! ****************************************************************************** -!! -!! SPECIFICATIONS: -!! ------------------------------------------------------------------------------ -! ! -- dummy -! class(UzfType) :: this -! integer(I4B), intent(in) :: icbcfl -! integer(I4B), intent(in) :: icbcun -! ! -- local -! integer(I4B) :: ibinun -! character(len=16), dimension(4) :: aname -! integer(I4B) :: iprint, nvaluesp, nwidthp -! character(len=1) :: cdatafmp=' ', editdesc=' ' -! real(DP) :: dinact -! ! -- data -! data aname(1) /'UZF INFILTRATION'/ -! data aname(2) /' UZF RECHARGE'/ -! data aname(3) /' UZF GWDISCHARGE'/ -! data aname(4) /' UZF GWET'/ -!! ------------------------------------------------------------------------------ -! ! -! ! -- 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 recharge/discharge rates if requested -! ! -- langevin: this doesn't work. We cannot use recordarray, because -! ! it assumes that the array is of size dis%nodes. In UZF, this%nodes -! ! does not equal dis%nodes. So we need to write each one of these -! ! arrays (recharge, discharge, gwet) as a list. For now, am commenting -! ! out this section by hardwiring ibinun = 0. -! ibinun = 0 -! if(ibinun /= 0) then -! iprint = 0 -! dinact = DZERO -! ! -! !! -- infiltration -! !call this%dis%record_array(this%infiltration, this%iout, iprint, & -! ! -ibinun, aname(1), cdatafmp, nvaluesp, & -! ! nwidthp, editdesc, dinact) -! !! -! !! -- recharge -! !call this%dis%record_array(this%recharge, this%iout, iprint, & -! ! -ibinun, aname(2), cdatafmp, nvaluesp, & -! ! nwidthp, editdesc, dinact) -! !! -! !! -- gw discharge -! !call this%dis%record_array(this%rejinf, this%iout, iprint, & -! ! -ibinun, aname(3), cdatafmp, nvaluesp, & -! ! nwidthp, editdesc, dinact) -! !! -! !! -- gw ET -! !call this%dis%record_array(this%gwet, this%iout, iprint, & -! ! -ibinun, aname(4), cdatafmp, nvaluesp, & -! ! nwidthp, editdesc, dinact) -! endif -! ! -! ! -- Return -! return -! end subroutine uzf_bdsav - - 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 -! UzfKinematic 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 mfcellid - call this%parser%GetCellid(this%dis%ndim, cellid) - ic = this%dis%noder_from_cellid(cellid, & - this%parser%iuactive, this%iout) - this%mfcellid(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%boundname(i)) - endif - n = this%mfcellid(i) - this%nodelist(i) = n - hgwf = this%xnew(n) - this%uzfobj => this%elements(i) - 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 - ! - ! --Initialize one more uzf object, which is used as a worker - i = this%nodes + 1 - this%uzfobj => this%elements(i) - n = this%mfcellid(i-1) - hgwf = this%xnew(n) - landflag = 0 - ivertcon = 0 - 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) - ! - ! -- 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%mfcellid(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 -! UzfKinematic type. -! ****************************************************************************** -! ------------------------------------------------------------------------------ - ! -- dummy - class(UzfType), intent(inout) :: this - ! -- local - character (len=20) :: cellids, cellid - character(len=LINELENGTH) :: line, linesep - character(len=16) :: text - integer(I4B) :: i - integer(I4B) :: n - integer(I4B) :: node - integer(I4B) :: iloc - real(DP) :: q -! ------------------------------------------------------------------------------ -! - ! - ! -- set cell id based on discretization - if (this%dis%ndim == 3) then - cellids = '(LAYER,ROW,COLUMN) ' - elseif (this%dis%ndim == 2) then - cellids = '(LAYER,CELL2D) ' - else - cellids = '(NODE) ' - end if - write (this%iout, '(//3a)') & - 'UZF PACKAGE (', trim(adjustl(this%name)), ') CELL DATA' - iloc = 1 - line = '' - if(this%inamedbound==1) then - call UWWORD(line, iloc, 16, 1, 'name', n, q, left=.TRUE.) - end if - call UWWORD(line, iloc, 6, 1, 'no.', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 20, 1, cellids, n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'landflag', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'ivertcon', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'surfdep', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'vks', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'thtr', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'thts', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'thti', n, q, CENTER=.TRUE., sep=' ') - call UWWORD(line, iloc, 11, 1, 'eps', n, q, CENTER=.TRUE.) - ! -- create line separator - linesep = repeat('-', iloc) - ! -- write header line and separator - write(this%iout,'(1X,A)') line(1:iloc) - write(this%iout,'(1X,A)') linesep(1:iloc) - ! - ! -- write data for each cell - do i = 1, this%nodes - ! - ! -- Initialize variables - this%uzfobj => this%elements(i) - ! - ! -- get cellid - node = this%mfcellid(i) - if (node > 0) then - call this%dis%noder_to_string(node, cellid) - else - cellid = 'none' - end if - ! - ! -- fill line - iloc = 1 - line = '' - if(this%inamedbound==1) then - call UWWORD(line, iloc, 16, 1, this%boundname(i), n, q, left=.TRUE.) - end if - call UWWORD(line, iloc, 6, 2, text, i, q, sep=' ') - call UWWORD(line, iloc, 20, 1, cellid, n, q, left=.TRUE.) - call UWWORD(line, iloc, 11, 2, text, this%uzfobj%landflag, q, sep=' ') - call UWWORD(line, iloc, 11, 2, text, this%uzfobj%ivertcon, q, sep=' ') - call UWWORD(line, iloc, 11, 3, text, i, this%uzfobj%surfdep, sep=' ') - call UWWORD(line, iloc, 11, 3, text, i, this%uzfobj%vks, sep=' ') - call UWWORD(line, iloc, 11, 3, text, i, this%uzfobj%thtr, sep=' ') - call UWWORD(line, iloc, 11, 3, text, i, this%uzfobj%thts, sep=' ') - call UWWORD(line, iloc, 11, 3, text, i, this%uzfobj%thti, sep=' ') - call UWWORD(line, iloc, 11, 3, text, i, this%uzfobj%eps) - ! -- write line - write(this%iout,'(1X,A)') line(1:iloc) - end do - ! - ! -- write separator - write(this%iout,'(1X,A)') linesep(1:iloc) - - ! - ! -- 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 - this%uzfobj => this%elements(i) - i2 = this%uzfobj%ivertcon - area = this%uzfobj%uzfarea - ! - ! Create pointer to object below - if ( i2 > 0 ) then - this%uzfobjbelow => this%elements(i2) - area2 = this%uzfobjbelow%uzfarea - 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)) - this%uzfobj => this%elements(i) - sumarea = sumarea + this%uzfobj%uzfarea - cellarea = this%uzfobj%cellarea - 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 - - subroutine uzcelloutput(this, isuppress_output) -! ****************************************************************************** -! write out cell by cell saturation. -! region beneath water table is considered 100% saturated. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(UzfType) :: this - type(UzfKinematicType), pointer :: uzfobj - integer(I4B), intent(in) :: isuppress_output - integer(I4B) :: i -! ------------------------------------------------------------------------------ - do i = 1, this%nodes - uzfobj => this%elements(i) - end do - end subroutine uzcelloutput - - ! -- 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') - this%uzfobj => this%elements(n) - 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) -70 format('Error: Invalid depth in OBS input: ',g15.7) - ! - 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 - this%uzfobj => this%elements(n) - dmax = this%uzfobj%celtop - this%uzfobj%celbot - ! -- 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 - ! -!300 continue -! call store_error(ermsg) -! call ustop() - 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%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) - call mem_allocate(this%pdmax, 'PDMAX', this%origin) - ! - ! -- initialize scalars - this%iprwcont = 0 - this%iwcontout = 0 - this%ibudgetout = 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 - this%pdmax = DEM1 - ! - ! -- 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 - integer (I4B) :: i - ! -- format -! ------------------------------------------------------------------------------ - ! - ! -- deallocate uzf objects - do i = 1, this%nodes+1 - this%uzfobj => this%elements(i) - call this%uzfobj%dealloc() - end do - nullify(this%uzfobj) - nullify(this%uzfobjwork) - nullify(this%uzfobjbelow) - deallocate(this%elements) - ! - ! -- budget object - call this%budget%budget_da() - deallocate(this%budget) - ! - ! -- character arrays - deallocate(this%bdtxt) - deallocate(this%cauxcbc) - ! - ! -- deallocate scalars - call mem_deallocate(this%iprwcont) - call mem_deallocate(this%iwcontout) - call mem_deallocate(this%ibudgetout) - 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) - call mem_deallocate(this%pdmax) - ! - ! -- deallocate arrays - call mem_deallocate(this%mfcellid) - 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 - -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 1fbb929e55d..c1df258b17f 100644 --- a/src/Model/GroundWaterFlow/gwf3wel8.f90 +++ b/src/Model/GroundWaterFlow/gwf3wel8.f90 @@ -1,445 +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 - ! - ! -- 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) -! ****************************************************************************** -! wel_cf -- Formulate the HCOF and RHS terms -! Subroutine: (1) skip in no wells -! (2) calculate hcof and rhs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(WelType) :: this - ! -- local - integer(I4B) :: i, node, ict - real(DP) :: qmult - real(DP) :: q - real(DP) :: tp - real(DP) :: bt - real(DP) :: thick -! ------------------------------------------------------------------------------ - ! - ! -- Return if no wells - if(this%nbound == 0) return - ! - ! -- pakmvrobj cf - if(this%imover == 1) 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/BndUzfKinematic.f90 b/src/Model/ModelUtilities/BndUzfKinematic.f90 index 919e702a08f..420a3a34c04 100644 --- a/src/Model/ModelUtilities/BndUzfKinematic.f90 +++ b/src/Model/ModelUtilities/BndUzfKinematic.f90 @@ -1,2165 +1,2165 @@ -module UzfKinematicModule - - 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 :: UzfKinematicType - - type :: UzfKinematicType - real(DP), pointer :: thtr => null() - real(DP), pointer :: thts => null() - real(DP), pointer :: thti => null() - real(DP), pointer :: eps => null() - real(DP), pointer :: extwc => null() - real(DP), pointer :: ha => null() - real(DP), pointer :: hroot => null() - real(DP), pointer :: rootact => null() - real(DP), pointer :: 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 :: nwavst => null() - real(DP), pointer :: uzolsflx => null() - real(DP), pointer :: uzstor => null() - real(DP), pointer :: delstor => null() - real(DP), pointer :: totflux => null() - real(DP), pointer :: vflow => null() - integer(I4B), pointer :: nwav, ntrail => null() - real(DP), pointer :: sinf => null() - real(DP), pointer :: finf => null() - real(DP), pointer :: pet => null() - real(DP), pointer :: petmax => null() - real(DP), pointer :: extdp => null() - real(DP), pointer :: extdpuz => null() - real(DP), pointer :: finf_rej => null() - real(DP), pointer :: gwet => null() - real(DP), pointer :: uzfarea => null() - real(DP), pointer :: cellarea => null() - real(DP), pointer :: celtop => null() - real(DP), pointer :: celbot => null() - real(DP), pointer :: landtop => null() - real(DP), pointer :: cvlm1 => null() - real(DP), pointer :: watab => null() - real(DP), pointer :: watabold => null() - real(DP), pointer :: vks => null() - real(DP), pointer :: surfdep => null() - real(DP), pointer :: surflux => null() - real(DP), pointer :: surfluxbelow => null() - real(DP), pointer :: surfseep => null() - real(DP), pointer :: gwpet => null() - integer(I4B), pointer :: landflag => null() - integer(I4B), pointer :: ivertcon => null() - contains - procedure :: init - procedure :: setdata - procedure :: setdatauzfarea - procedure :: setdatafinf - procedure :: setdataet - procedure :: setdataetwc - procedure :: setdataetha - procedure :: setwaves - procedure :: wave_shift - procedure :: routewaves - procedure :: uzflow - procedure :: addrech - procedure :: factors - procedure :: trailwav - procedure :: leadwav - procedure :: leadspeed - 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 :: etfunc_nlin - procedure :: etfunc_lin - procedure :: rejfinf - procedure :: gwseep - procedure :: setbelowpet - procedure :: dealloc - end type UzfKinematicType -! - contains -! -! ------------------------------------------------------------------------------ - - subroutine init(this, ipos, nwav) -! ****************************************************************************** -! init -- allocate and set uzf object variables -! -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - !modules - !arguments - class(UzfKinematicType) :: this - integer(I4B), intent(in) :: ipos - integer(I4B), intent(in) :: nwav -! ------------------------------------------------------------------------------ - allocate(this%uzdpst(nwav)) - allocate(this%uzthst(nwav)) - allocate(this%uzflst(nwav)) - allocate(this%uzspst(nwav)) - allocate(this%nwavst) - allocate(this%uzolsflx) - allocate(this%thtr) - allocate(this%thts) - allocate(this%thti) - allocate(this%eps) - allocate(this%ha) - allocate(this%hroot) - allocate(this%rootact) - allocate(this%extwc) - allocate(this%etact) - allocate(this%nwav) - allocate(this%ntrail) - allocate(this%uzstor) - allocate(this%delstor) - allocate(this%totflux) - allocate(this%vflow) - allocate(this%sinf) - allocate(this%finf) - allocate(this%finf_rej) - allocate(this%gwet) - allocate(this%uzfarea) - allocate(this%cellarea) - allocate(this%celtop) - allocate(this%celbot) - allocate(this%landtop) - allocate(this%cvlm1) - allocate(this%watab) - allocate(this%watabold) - allocate(this%surfdep) - allocate(this%vks) - allocate(this%surflux) - allocate(this%surfluxbelow) - allocate(this%surfseep) - allocate(this%gwpet) - allocate(this%pet) - allocate(this%petmax) - allocate(this%extdp) - allocate(this%extdpuz) - allocate(this%landflag) - allocate(this%ivertcon) - this%uzdpst = DZERO - this%uzthst = DZERO - this%uzflst = DZERO - this%uzspst = DZERO - this%nwavst = 1 - this%uzolsflx = DZERO - this%thtr = DZERO - this%thts = DZERO - this%thti = DZERO - this%eps = DZERO - this%ha = DZERO - this%hroot = DZERO - this%rootact = DZERO - this%extwc = DZERO - this%etact = DZERO - this%nwav = nwav - this%ntrail = 0 - this%uzstor = DZERO - this%delstor = DZERO - this%totflux = DZERO - this%vflow = DZERO - this%sinf = DZERO - this%finf = DZERO - this%finf_rej = DZERO - this%gwet = DZERO - this%uzfarea = DZERO - this%cellarea = DZERO - this%celtop = DZERO - this%celbot = DZERO - this%landtop = DZERO - this%cvlm1 = DZERO - this%watab = DZERO - this%watabold = DZERO - this%surfdep = DZERO - this%vks = DZERO - this%surflux = DZERO - this%surfluxbelow = DZERO - this%surfseep = DZERO - this%gwpet = DZERO - this%pet = DZERO - this%petmax = DZERO - this%extdp = DZERO - this%extdpuz = DZERO - this%landflag = 0 - this%ivertcon = 0 - end subroutine init - ! - ! - subroutine dealloc(this) -! ****************************************************************************** -! dealloc -- deallocate uzf object variables -! -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(UzfKinematicType) :: this - ! -- locals -! ------------------------------------------------------------------------------ - 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) - ! - ! -- return - return - end subroutine dealloc -! -! ------------------------------------------------------------------------------ - - subroutine setdata(this,ipos,area,top,bot,surfdep, & - vks,thtr,thts,thti,eps, & - ntrail,landflag,ivertcon,hgwf) -! ****************************************************************************** -! setdata -- set uzf object material properties -! -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - !modules - !arguments - class(UzfKinematicType) :: this - integer(I4B), intent(in) :: ipos, ntrail, landflag, ivertcon - 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 - real(DP), intent(in) :: hgwf -! ------------------------------------------------------------------------------ - this%landflag = landflag - this%ivertcon = ivertcon - this%surfdep = surfdep - this%uzfarea = area - this%cellarea = area - if ( this%landflag == 1 ) then - this%celtop = top - DHALF*this%surfdep - else - this%celtop = top - end if - this%celbot = bot - this%vks = vks - this%watab = this%celbot - if ( hgwf > this%celbot ) this%watab = hgwf - if ( this%watab > this%celtop ) this%watab = this%celtop - this%watabold = this%watab - this%thtr = thtr - this%thts = thts - this%thti = thti - this%eps = eps - this%ntrail = ntrail - this%pet = DZERO - this%extdp = DZERO - this%extwc = DZERO - this%ha = DZERO - this%hroot = DZERO - end subroutine setdata -! -! ------------------------------------------------------------------------------ - subroutine setdatafinf(this,finf) -! ****************************************************************************** -! setdatafinf -- set infiltration -! -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - !modules - !arguments - class(UzfKinematicType) :: this - real(DP), intent(in) :: finf -! ------------------------------------------------------------------------------ - if (this%landflag == 1) then - this%sinf = finf - this%finf = finf - else - this%sinf = DZERO - this%finf = DZERO - end if - this%finf_rej = DZERO - this%surflux = DZERO - this%surfluxbelow = DZERO - end subroutine setdatafinf -! ------------------------------------------------------------------------------ -! -! ------------------------------------------------------------------------------ - subroutine setdatauzfarea(this,areamult) -! ****************************************************************************** -! setdatauzfarea -- set uzfarea using cellarea and areamult -! -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! modules - ! -- dummy - class(UzfKinematicType) :: this - real(DP), intent(in) :: areamult -! ------------------------------------------------------------------------------ - this%uzfarea = this%cellarea * areamult - ! - ! -- return - return - end subroutine setdatauzfarea - -! ------------------------------------------------------------------------------ -! - subroutine setdataet(this,thisbelow,jbelow,pet,extdp) -! ****************************************************************************** -! setdataet -- set unsat. et variables -! -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - !modules - !arguments - class(UzfKinematicType) :: this - type(UzfKinematicType) :: thisbelow - integer(I4B), intent(in) :: jbelow - real(DP), intent(in) :: pet, extdp - ! -- dummy - real(DP) :: thick -! ------------------------------------------------------------------------------ - if (this%landflag == 1) then - this%pet = pet - this%gwpet = pet - else - this%pet = DZERO - this%gwpet = DZERO - end if - thick = this%celtop - this%celbot - this%extdp = extdp - if ( this%landflag > 0 ) then - this%landtop = this%celtop - this%petmax = this%pet - end if - ! - ! set uz extinction depth - if ( this%landtop - this%extdp < this%celbot ) then - this%extdpuz = thick - else - this%extdpuz = this%celtop - (this%landtop - this%extdp) - end if - if ( this%extdpuz < DZERO ) this%extdpuz = DZERO - if ( this%extdpuz > DEM7 .and. this%extdp < DEM7 ) this%extdp = this%extdpuz - ! - ! set pet for underlying cell - if ( jbelow > 0 ) then - thisbelow%landtop = this%landtop - thisbelow%petmax = this%petmax - end if - end subroutine setdataet -! -! ------------------------------------------------------------------------------ - - subroutine setbelowpet(this,thisbelow,aet) -! ****************************************************************************** -! setbelowpet -- subtract aet from pet to calculate residual et -! for deeper cells -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - !modules - !arguments - class(UzfKinematicType) :: this - type(UzfKinematicType) :: thisbelow - real(DP), intent(in) :: aet - ! -- dummy - real(DP) :: pet -! ------------------------------------------------------------------------------ - pet = DZERO - if ( thisbelow%extdpuz > DEM3 ) then - pet = this%petmax - aet - if ( pet < DZERO ) pet = DZERO - end if - thisbelow%pet = pet - end subroutine setbelowpet -! -! ------------------------------------------------------------------------------ - - subroutine setdataetwc(this,thisbelow,jbelow,extwc) -! ****************************************************************************** -! setdataetwc -- set extinction water content -! -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - !arguments - class(UzfKinematicType) :: this - type(UzfKinematicType) :: thisbelow - real(DP), intent(in) :: extwc - integer(I4B), intent(in) :: jbelow -! ------------------------------------------------------------------------------ - this%extwc = extwc - if ( jbelow > 0 ) thisbelow%extwc = extwc - end subroutine setdataetwc -! -! ------------------------------------------------------------------------------ - - subroutine setdataetha(this,thisbelow,jbelow,ha,hroot,rootact) -! ****************************************************************************** -! setdataetha -- set variables for head-based unsat. flow -! -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - !arguments - class(UzfKinematicType) :: this - type(UzfKinematicType) :: thisbelow - real(DP), intent(in) :: ha,hroot,rootact - integer(I4B), intent(in) :: jbelow -! ------------------------------------------------------------------------------ - this%ha = ha - this%hroot = hroot - this%rootact = rootact - if ( jbelow > 0 ) then - thisbelow%ha = ha - thisbelow%hroot = hroot - thisbelow%rootact = rootact - end if - end subroutine setdataetha -! -! ------------------------------------------------------------------------------ - - subroutine advance(this) -! ****************************************************************************** -! advance -- set variables to advance to new time step. nothing yet. -! -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(UzfKinematicType) :: this -! ------------------------------------------------------------------------------ - this%surfseep = DZERO - end subroutine advance -! -! ------------------------------------------------------------------------------ - - subroutine formulate(this,thiswork,thisbelow,ipos,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 - !arguments - class(UzfKinematicType) :: this - type(UzfKinematicType) :: thiswork - type(UzfKinematicType) :: thisbelow - integer(I4B), intent(in) :: ipos,ietflag,iseepflag,issflag,ivertflag - integer(I4B), intent(inout) :: ierr - real(DP), intent(in) :: hgwf,hgwfml1,cvv,qfrommvr - real(DP), intent(inout) :: trhs,thcof,qformvr,sumaet - real(DP), intent(inout) :: totfluxtot - real(DP), intent(inout) :: deriv - ! -- dummy - 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 = DZERO - this%surflux = this%finf + qfrommvr / this%uzfarea - this%surfseep = DZERO - seep = DZERO - finfact = DZERO - deriv1 = DZERO - deriv2 = DZERO - derivfinf = DZERO - this%watab = hgwf - this%etact = DZERO - this%surfluxbelow = DZERO - ! - ! set pet for gw when there is no UZ. - this%gwpet = this%pet - if( ivertflag > 0 ) then - thisbelow%finf = DZERO - end if - ! - ! save wave states for resetting after iteration. - this%watab = hgwf - call thiswork%wave_shift(this,0,1,this%nwavst,1) - if ( this%watab > this%celtop ) this%watab = this%celtop - ! - if ( this%ivertcon > 0 ) then - if ( this%watab < this%celbot ) this%watab = this%celbot - end if - ! - ! add water from mover to applied infiltration. - !this%surflux = this%surflux - if ( this%surflux > this%vks ) then - this%surflux = this%vks - end if - ! - ! saturation excess rejected infiltration - if ( this%landflag==1 ) then - call this%rejfinf(ipos,deriv1,hgwf,trhsfinf,thcoffinf,finfact) - this%surflux = finfact - end if - ! - ! calculate rejected infiltration - this%finf_rej = this%finf + (qfrommvr / this%uzfarea) - this%surflux - if ( iseepflag > 0 .and. this%landflag==1) then - ! - ! calculate groundwater discharge - call this%gwseep(ipos,deriv2,scale,hgwf,trhsseep,thcofseep,seep) - this%surfseep = seep - end if - ! - ! route water through unsat zone, calc. storage change and recharge - ! - test = this%watab - if ( this%watabold - test < -DEM15 ) test = this%watabold - if ( this%celtop - test > DEM15 ) then - if ( issflag == 0 ) then - call this%routewaves(totfluxtot,delt,ietflag,ipos,ierr) - if ( ierr > 0 ) return - call this%uz_rise(totfluxtot) - this%totflux = totfluxtot - if( ietflag > 0 .and. this%ivertcon > 0 ) then - thisbelow%pet = thisbelow%pet - this%etact - if ( thisbelow%pet < DEM15 ) thisbelow%pet = DEM15 - end if - if ( this%ivertcon > 0 ) then - call this%addrech(thisbelow,hgwf,trhsfinf,thcoffinf,derivfinf,delt,0) - end if - else - this%totflux = this%surflux*delt - totfluxtot = this%surflux*delt - end if - thcoffinf = DZERO - trhsfinf = this%totflux*this%uzfarea/delt - else - this%totflux = this%surflux*delt - totfluxtot = this%surflux*delt - end if - deriv = deriv1 + deriv2 + derivfinf - trhs = trhsfinf + trhsseep - thcof = thcoffinf + thcofseep - ! - ! add spring flow and rejected infiltration to mover - qformvr = this%surfseep + this%finf_rej*this%uzfarea - ! - ! reset waves to previous state for next iteration - call this%wave_shift(thiswork,0,1,thiswork%nwavst,1) - ! - ! distribute PET to deeper cells - sumaet = sumaet + this%etact - if( this%ivertcon > 0 ) then - if ( ietflag > 0 ) then - call this%setbelowpet(thisbelow,sumaet) - end if - end if - end subroutine formulate -! -! ------------------------------------------------------------------------------ - - subroutine budget(this,thisbelow,ipos,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 - !arguments - class(UzfKinematicType) :: this - type(UzfKinematicType) :: thisbelow - integer(I4B), intent(in) :: ipos,ietflag,iseepflag,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,hgwfml1,cvv,qfrommvr - real(DP), intent(inout) :: rfinf - real(DP), intent(inout) :: rin,qformvr,sumaet - real(DP), intent(inout) :: qgwformvr - real(DP), intent(inout) :: rout - real(DP), intent(inout) :: rsto - real(DP), intent(inout) :: ret,retgw,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 -! ------------------------------------------------------------------------------ - totfluxtot = DZERO - trhsfinf = DZERO - thcoffinf = DZERO - trhsseep = DZERO - thcofseep = DZERO - this%finf_rej = DZERO - this%surflux = this%finf + qfrommvr / this%uzfarea - this%watab = hgwf - this%vflow = DZERO - this%surfseep = DZERO - seep = DZERO - finfact = DZERO - this%etact = DZERO - this%surfluxbelow = DZERO - sumaet = DZERO - ! - ! set pet for gw when there is no UZ. - this%gwpet = this%pet - if ( this%ivertcon > 0 ) then - thisbelow%finf = dzero - if ( this%watab < this%celbot ) this%watab = this%celbot - end if - if ( this%watab > this%celtop ) this%watab = this%celtop - if ( this%surflux > this%vks ) then - this%surflux = this%vks - end if - ! - ! infiltration excess -- rejected infiltration - if ( this%landflag==1 ) then - call rejfinf(this,ipos,deriv,hgwf,trhsfinf,thcoffinf,finfact) - this%surflux = finfact - if (finfact 0 .and. this%landflag == 1 ) then - call this%gwseep(ipos,deriv,scale,hgwf,trhsseep,thcofseep,seep) - this%surfseep = seep - rgwseep = rgwseep + this%surfseep - 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 - if ( this%watabold - test < -DEM15 ) test = this%watabold - if ( this%celtop - test > DEM15 ) then - if ( issflag == 0 ) then - call this%routewaves(totfluxtot,delt,ietflag,ipos,ierr) - if ( ierr > 0 ) return - call this%uz_rise(totfluxtot) - this%totflux = totfluxtot - if ( this%ivertcon > 0 ) then - call this%addrech(thisbelow,hgwf,trhsfinf,thcoffinf,deriv,delt,1) - end if - else - this%totflux = this%surflux*delt - totfluxtot = this%surflux*delt - end if - thcoffinf = dzero - trhsfinf = this%totflux*this%uzfarea/delt - call this%update_wav(ipos,delt,rout,rsto,ret,ietflag,issflag,0) - else - call this%update_wav(ipos,delt,rout,rsto,ret,ietflag,issflag,1) - totfluxtot = this%surflux*delt - this%totflux = this%surflux*delt - end if - rfinf = rfinf + this%sinf * this%uzfarea - rin = rin + this%surflux*this%uzfarea - this%surfluxbelow*this%uzfarea - ! - ! add spring flow and rejected infiltration to mover - !qformvr = this%surfseep + this%finf_rej*this%uzfarea - qformvr = this%finf_rej*this%uzfarea - qgwformvr = this%surfseep - ! - ! process for observations - do i = 1, numobs - j = obs_num(i) - if (this%watab < this%celtop) then - if (this%celtop - obs_depth(j) > this%watab) then - d1 = obs_depth(j) - DEM3 - d2 = obs_depth(j) + DEM3 - f1 = unsat_stor(this, d1) - f2 = unsat_stor(this, d2) - obs_theta(j) = this%thtr + (f2 - f1)/(d2 - d1) - else - obs_theta(j) = this%thts - end if - else - obs_theta(j) = this%thts - end if - end do - ! - ! distribute residual PET to deeper cells - sumaet = sumaet + this%etact - if (this%ivertcon > 0) then - if (ietflag > 0) then - call this%setbelowpet(thisbelow, sumaet) - end if - end if - end subroutine budget -! -! ------------------------------------------------------------------------------ - - subroutine vertcellflow(this,ipos,trhs,hgwf,hgwfml1,cvv) -! ****************************************************************************** -! vertcellflow -- calculate exchange from sat. to unsat. zones -! subroutine not used until sat to unsat flow is supported -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - !modules - !arguments - class(UzfKinematicType) :: this - integer(I4B), intent(in) :: ipos - real(DP), intent(in) :: hgwf,hgwfml1,cvv - real(DP), intent(inout) :: trhs - ! -- dummy - real(DP) :: Qv,maxvflow,h1,h2,test -! ------------------------------------------------------------------------------ - this%vflow = DZERO - this%finf = DZERO -! UZfact(ic,ir,il) = 1.0 - trhs = DZERO - h1 = hgwfml1 - h2 = hgwf - test = this%watab - if ( this%watabold - test < -DEM30 ) test = this%watabold - if ( this%celtop - test > DEM30 ) then - ! - ! calc. downward flow using GWF heads and conductance - Qv = cvv*(h1-h2) - if ( Qv > DEM30 ) then - this%vflow = Qv - this%surflux = this%vflow/this%uzfarea -! UZfact(ic,ir,il) = dzero - maxvflow = this%vks*this%uzfarea - if ( this%vflow - maxvflow > DEM9 ) then - this%surflux = this%vks - trhs = this%vflow - maxvflow - this%vflow = maxvflow - end if - end if - end if - return - end subroutine vertcellflow -! -! ------------------------------------------------------------------------------ - - - subroutine addrech(this,thisbelow,hgwf,trhs,thcof,deriv,delt,it) -! ****************************************************************************** -! addrech -- add recharge or infiltration to cells -! -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - !modules - !arguments - class(UzfKinematicType) :: this - type(UzfKinematicType) :: thisbelow - integer(I4B), intent(in) :: it - real(DP), intent(inout) :: trhs,thcof,deriv - real(DP), intent(in) :: delt,hgwf - ! -- dummy - real(DP) :: fcheck - real(DP) :: x,scale,range -! ------------------------------------------------------------------------------ - range = DEM5 - deriv = DZERO - thcof = DZERO - trhs = this%uzfarea*this%totflux/delt - if ( this%totflux < DEM14 ) return - scale = DONE - ! - ! smoothly reduce flow between cells when head close to cell top - x = (hgwf-(this%celbot-range)) - call sSCurve(x,range,deriv,scale) - deriv = this%uzfarea*deriv*this%totflux/delt - thisbelow%finf = (DONE-scale)*this%totflux/delt - fcheck = thisbelow%finf - thisbelow%vks - ! - ! reduce flow between cells when vks is too small - if ( fcheck < DEM14 ) fcheck = DZERO - thisbelow%finf = thisbelow%finf - fcheck - this%surfluxbelow = thisbelow%finf - this%totflux = scale*this%totflux + fcheck*delt - trhs = this%uzfarea*this%totflux/delt - end subroutine addrech -! -! ------------------------------------------------------------------------------ - subroutine rejfinf(this,ipos,deriv,hgwf,trhs,thcof,finfact) -! ****************************************************************************** -! rejfinf -- reject applied infiltration due to low vks -! -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - !modules - !arguments - class(UzfKinematicType) :: this - integer(I4B), intent(in) :: ipos - real(DP), intent(inout) :: deriv,finfact,thcof,trhs - real(DP), intent(in) :: hgwf - ! -- dummy - real(DP) :: x,range,scale,q -! ------------------------------------------------------------------------------ - range = this%surfdep - q = (this%surflux) - finfact = q - trhs = finfact*this%uzfarea - x = (this%celtop-hgwf) - call sLinear(x,range,deriv,scale) - deriv = -q*deriv*this%uzfarea*scale - if ( scale < DONE ) then - finfact = q*scale - trhs = finfact*this%uzfarea*this%celtop/range - thcof = finfact*this%uzfarea/range - end if - end subroutine rejfinf -! -! ------------------------------------------------------------------------------ - - subroutine gwseep(this,ipos,deriv,scale,hgwf,trhs,thcof,seep) -! ****************************************************************************** -! gwseep -- calc. groudwater discharge to land surface -! -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - !modules - !argument - class(UzfKinematicType) :: this - integer(I4B), intent(in) :: ipos - real(DP), intent(inout) :: deriv,trhs,thcof,seep - real(DP), intent(out) :: scale - real(DP), intent(in) :: hgwf - ! -- dummy - real(DP) :: x,range,y,deriv1,d1,d2,Q -! ------------------------------------------------------------------------------ - seep = DZERO - deriv = DZERO - deriv1 = DZERO - d1 = DZERO - d2 = DZERO - scale = DZERO - Q = this%uzfarea*this%vks - range = this%surfdep - x = (hgwf-this%celtop) - call sCubicLinear(x,range,deriv1,y) - scale = y - seep = scale*Q*(hgwf-this%celtop)/range - trhs = scale*Q*this%celtop/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 - end subroutine gwseep -! -! ------------------------------------------------------------------------------ - - subroutine simgwet(this,igwetflag,ipos,hgwf,trhs,thcof,et,det) -! ****************************************************************************** -! simgwet -- calc. gwf et using residual uzf pet -! -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - !modules - !arguments - class(UzfKinematicType) :: this - integer(I4B), intent(in) :: igwetflag,ipos - real(DP), intent(in) :: hgwf - real(DP), intent(inout) :: trhs,thcof,det,et - ! -- dummy - real(DP) :: s,x,c - external :: etfunc_lin, etfunc_nlin - real(DP) :: etfunc_lin, etfunc_nlin -! ------------------------------------------------------------------------------ - this%gwet = DZERO - s = this%landtop - x = this%extdp - c = this%gwpet - if ( x < DEM6 ) return - if ( igwetflag==1 ) then - et = this%etfunc_lin(s,x,c,det,trhs,thcof,hgwf) - else if ( igwetflag==2 ) then - et = this%etfunc_nlin(s,x,c,det,trhs,thcof,hgwf) - end if - this%gwet = et*this%uzfarea - trhs = -trhs*this%uzfarea - thcof = thcof*this%uzfarea - return - end subroutine simgwet -! -! ------------------------------------------------------------------------------ - - function etfunc_lin(this,s,x,c,det,trhs,thcof,hgwf) -! ****************************************************************************** -! etfunc_lin -- calc. gwf et using linear ET function from mf-2005 -! -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - !modules - ! -- return - real(DP) :: etfunc_lin - ! -- dummy - class(UzfKinematicType) :: this - real(DP) :: etgw - real(DP) :: range - real(DP) :: depth,scale,thick - ! -- local - real(DP), intent(inout) :: det - real(DP), intent(in) :: s,x,c - real(DP), intent(inout) :: trhs,thcof - real(DP), intent(in) :: hgwf -! ------------------------------------------------------------------------------ - ! - ! 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 - depth = hgwf - (s - x) - thick = this%celtop-this%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 - end function etfunc_lin -! -! ------------------------------------------------------------------------------ - - function etfunc_nlin(this,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 - class(UzfKinematicType) :: this - real(DP), intent(inout) :: det - real(DP), intent(in) :: s,x,c,hgwf - ! -- local - real(DP), intent(inout) :: trhs,thcof - 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 - end function etfunc_nlin -! -! ------------------------------------------------------------------------------ - - subroutine uz_rise(this,totfluxtot) -! ****************************************************************************** -! uz_rise -- calculate recharge due to a rise in the gwf head -! -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ -! ------------------------------------------------------------------------------ - class(UzfKinematicType) :: this - real(DP), intent(inout) :: totfluxtot - real(DP) :: fm1,fm2,d1 -! ------------------------------------------------------------------------------ - ! - ! additional recharge from a rising water table - if ( this%watab-this%watabold > DEM30 ) then - d1 = this%celtop-this%watabold - fm1 = this%unsat_stor(d1) - d1 = this%celtop-this%watab - fm2 = this%unsat_stor(d1) - totfluxtot = totfluxtot + (fm1-fm2) - end if - end subroutine uz_rise -! -! ------------------------------------------------------------------------------ - - subroutine setwaves(this,ipos) -! ****************************************************************************** -! setwaves -- reset waves to default values at start of simulation -! -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ -! ------------------------------------------------------------------------------ - class(UzfKinematicType) :: this - integer(I4B), intent(in) :: ipos - real(DP) :: bottom, top - integer(I4B) :: jk - real(DP) :: thick -! ------------------------------------------------------------------------------ - this%uzstor = DZERO - this%delstor = DZERO - this%totflux = DZERO - this%nwavst = 1 - this%uzdpst = DZERO - thick = this%celtop - this%watab - do jk = 1, this%nwav - this%uzthst(jk) = this%thtr - end do - ! - ! initialize waves for first stress period - if ( thick > DZERO ) then - this%uzdpst(1) = thick - this%uzthst(1) = this%thti - top = this%uzthst(1) - this%thtr - if ( top < DZERO ) top = DZERO - bottom = this%thts - this%thtr - if ( bottom < DZERO ) bottom = DZERO - this%uzflst(1) = this%vks*(top/bottom)**this%eps - if ( this%uzthst(1) < this%thtr ) this%uzthst(1) = this%thtr - ! - ! calculate water stored in the unsaturated zone - if ( top > DZERO ) then - this%uzstor = this%uzdpst(1)*top*this%uzfarea - this%uzspst(1) = DZERO - this%uzolsflx = this%uzflst(1) - else - this%uzstor = DZERO - this%uzflst(1) = DZERO - this%uzspst(1) = DZERO - this%uzolsflx = DZERO - end if - ! - ! no unsaturated zone - else - this%uzflst(1) = DZERO - this%uzdpst(1) = DZERO - this%uzspst(1) = DZERO - this%uzthst(1) = this%thtr - this%uzstor = DZERO - this%uzolsflx = this%finf - end if - return - end subroutine -! -! ------------------------------------------------------------------------------ - - subroutine routewaves(this,totfluxtot,delt,ietflag,ipos,ierr) -! ****************************************************************************** -! routewaves -- prepare and route waves over time step -! -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ -! ------------------------------------------------------------------------------ - class(UzfKinematicType) :: this - real(DP), intent(inout) :: totfluxtot - real(DP), intent(in) :: delt - integer(I4B), intent(in) :: ietflag - integer(I4B), intent(in) :: ipos - integer(I4B), intent(inout) :: ierr - real(DP) :: thick, thickold - integer(I4B) :: idelt, iwav, ik -! ------------------------------------------------------------------------------ - this%totflux = DZERO - this%etact = DZERO - thick = this%celtop - this%watab - thickold = this%celtop - this%watabold - ! - ! no uz, clear waves - if ( thickold < DZERO ) then - do iwav = 1, 6 - this%uzthst(iwav) = this%thtr - this%uzdpst(iwav) = DZERO - this%uzspst(iwav) = DZERO - this%uzflst(iwav) = DZERO - this%nwavst = 1 - end do - end if - idelt = 1 - do ik = 1, idelt - call this%uzflow(thick,thickold,delt,ietflag,ipos,ierr) - if ( ierr > 0 ) return - totfluxtot = totfluxtot + this%totflux - end do - ! set residual pet after uz et - this%gwpet = this%pet - this%etact/delt - if ( this%gwpet < DZERO ) this%gwpet = DZERO - return - end subroutine routewaves -! -! ------------------------------------------------------------------------------ - - subroutine wave_shift(this1,this2,shft,strt,stp,cntr) -! ****************************************************************************** -! wave_shift -- copy waves or shift waves in arrays -! -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class (UzfKinematicType) :: this1 - type (UzfKinematicType) :: this2 - integer(I4B) :: j,shft,strt,stp,cntr -! ------------------------------------------------------------------------------ - do j = strt, stp, cntr - this1%uzthst(j) = this2%uzthst(j+shft) - this1%uzdpst(j) = this2%uzdpst(j+shft) - this1%uzflst(j) = this2%uzflst(j+shft) - this1%uzspst(j) = this2%uzspst(j+shft) - end do - this1%nwavst = this2%nwavst - return - end subroutine -! -! ------------------------------------------------------------------------------ - - subroutine uzflow(this,thick,thickold,delt,ietflag,ipos,ierr) -! ****************************************************************** -! uzflow----moc solution for kinematic wave equation -! ****************************************************************** -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - !modules - ! -- dummy - class (UzfKinematicType) :: 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) :: ipos - integer(I4B), intent(inout) :: ierr - real(DP) :: ffcheck,time,feps1,feps2 - real(DP) :: thetadif,thetab,fluxb,oldsflx - integer(I4B) :: itrailflg,itester -! ------------------------------------------------------------------ - time = DZERO - this%totflux = DZERO - itrailflg = 0 - oldsflx = this%uzflst(this%nwavst) - call this%factors(feps1,feps2) - !check for falling or rising water table - if ( (thick-thickold) > feps1 ) then - thetadif = abs(this%uzthst(1)-this%thtr) - if ( thetadif > DEM6 ) then - call this%wave_shift(this,-1,this%nwavst+1,2,-1) - if ( this%uzdpst(2) < DEM30 ) this%uzdpst(2) = (this%ntrail+DTWO)*DEM6 - if ( this%uzthst(2) > this%thtr ) then - this%uzspst(2) = this%uzflst(2)/(this%uzthst(2)-this%thtr) - else - this%uzspst(2) = DZERO - end if - this%uzthst(1) = this%thtr - this%uzflst(1) = DZERO - this%uzspst(1) = DZERO - this%uzdpst(1) = thick - this%nwavst = this%nwavst + 1 - if ( this%nwavst.GE.this%nwav ) then - !too many waves error - ierr = 1 - return - end if - else - this%uzdpst(1) = thick - end if - end if - thetab = this%uzthst(1) - fluxb = this%uzflst(1) - this%totflux = DZERO - itester = 0 - ffcheck = (this%surflux-this%uzflst(this%nwavst)) - ! - !crease new waves in infiltration changes - if ( ffcheck > feps2 .OR. ffcheck < -feps2 ) then - this%nwavst = this%nwavst + 1 - if ( this%nwavst.GE.this%nwav ) then - ! - !too many waves error - ierr = 1 - return - end if - else if ( this%nwavst.EQ.1 ) then - itester = 1 - end if - if ( this%nwavst > 1 ) then - IF ( ffcheck < -feps2) THEN - call this%trailwav(ierr) - if ( ierr > 0 ) return - itrailflg = 1 - end if - call this%leadwav(time,itester,itrailflg,thetab,fluxb,ffcheck,feps2,delt,ipos) - end if - if ( itester.EQ.1 ) then - this%totflux = this%totflux + (delt-time)*this%uzflst(1) - time = DZERO - itester = 0 - end if - ! - !simulate et - if ( ietflag > 0 ) call this%uzet(delt,ietflag,ierr) - if ( ierr > 0 ) return - return - end subroutine uzflow -! -! ------------------------------------------------------------------------------ - - subroutine factors(this,feps1,feps2) -! ****************************************************************************** -! factors----calculate unit specific tolerances -! ****************************************************************************** -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - !modules - ! -- dummy - class (UzfKinematicType) :: this - 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.EQ.1 ) then - factor1 = DONE/86400.D0 - else if ( ITMUNI.EQ.2 ) then - factor1 = DONE/1440.D0 - else if ( ITMUNI.EQ.3 ) then - factor1 = DONE/24.0D0 - else if ( ITMUNI.EQ.5 ) then - factor1 = 365.0D0 - end if - factor2 = DONE/0.3048 - feps1 = feps1*factor1*factor2 - feps2 = feps2*factor1*factor2 - end subroutine factors -! -! ------------------------------------------------------------------------------ - - subroutine trailwav(this,ierr) -! ****************************************************************************** -! trailwav----create and set trail waves -! ****************************************************************************** -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - !modules - !arguments - integer(I4B), intent(inout) :: ierr - ! -- dummy - class (UzfKinematicType) :: this - 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 -! ------------------------------------------------------------------ - eps_m1 = dble(this%eps) - DONE - thtsrinv = DONE/(this%thts-this%thtr) - nwavstm1 = this%nwavst - 1 - !initialize trailwaves - smoist = (((this%surflux/this%vks)**(DONE/this%eps))* & - (this%thts-this%thtr)) + this%thtr - if ( this%uzthst(nwavstm1)-smoist > DEM9 ) then - fnuminc = DZERO - do jk = 1, this%ntrail - fnuminc = fnuminc + float(jk) - end do - smoistinc = (this%uzthst(nwavstm1)-smoist)/(fnuminc-DONE) - jj = this%ntrail - ftrail = dble(this%ntrail) + DONE - do j = this%nwavst, this%nwavst + this%ntrail - 1 - if ( j > this%nwav ) then - ! too many waves error - ierr = 1 - return - end if - if( j > this%nwavst ) then - this%uzthst(j) = this%uzthst(j-1) & - - ((ftrail-float(jj))*smoistinc) - else - this%uzthst(j) = this%uzthst(j-1) - DEM9 - end if - jj = jj - 1 - if ( this%uzthst(j).LE.this%thtr+DEM9 ) this%uzthst(j) & - = this%thtr + DEM9 - this%uzflst(j) = this%vks*(((this%uzthst(j)-this%thtr) & - *thtsrinv)**this%eps) - theta2 = this%uzthst(j-1) - flux2 = this%uzflst(j-1) - flux1 = this%uzflst(j) - theta1 = this%uzthst(j) - this%uzspst(j) = this%leadspeed(theta1,theta2,flux1,flux2) - this%uzdpst(j) = DZERO - if ( j==this%nwavst ) then - this%uzdpst(j) = this%uzdpst(j) + (this%ntrail+1)*DEM9 - else - this%uzdpst(j) = this%uzdpst(j-1) - DEM9 - end if - end do - this%nwavst = this%nwavst + this%ntrail - 1 - if ( this%nwavst.GE.this%nwav ) then - !too many waves error - ierr = 1 - return - end if - else - this%uzdpst(this%nwavst) = DZERO - this%uzflst(this%nwavst) = this%vks*(((this%uzthst(this%nwavst)- & - this%thtr)*thtsrinv)**this%eps) - this%uzthst(this%nwavst) = smoist - theta2 = this%uzthst(this%nwavst-1) - flux2 = this%uzflst(this%nwavst-1) - flux1 = this%uzflst(this%nwavst) - theta1 = this%uzthst(this%nwavst) - this%uzspst(this%nwavst) = this%leadspeed(theta1,theta2,flux1,flux2) - end if - return - end subroutine trailwav - - - subroutine leadwav(this,time,itester,itrailflg,thetab,fluxb, & - ffcheck,feps2,delt,ipos) -! ****************************************************************** -! leadwav----create a lead wave and route over time step -! ****************************************************************** -! SPECIFICATIONS: -! ---------------------------------------------------------------------- - !modules - !arguments - class (UzfKinematicType) :: 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, Itrailflg - real(DP), intent(inout) :: ffcheck - real(DP), intent(in) :: delt - integer(I4B), intent(in) :: ipos - ! -- dummy - 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)) - allocate(more(this%nwavst)) - ftest = DZERO - eps_m1 = dble(this%eps) - DONE - thtsrinv = DONE/(this%thts-this%thtr) - ! - !initialize new wave - if ( Itrailflg.EQ.0 ) then - if ( ffcheck > feps2 ) then - this%uzflst(this%nwavst) = this%surflux - IF ( this%uzflst(this%nwavst) < DEM30 ) & - this%uzflst(this%nwavst) = DZERO - this%uzthst(this%nwavst) = & - (((this%uzflst(this%nwavst)/this%vks)** & - (DONE/this%eps))*(this%thts-this%thtr)) & - + this%thtr - theta2 = this%uzthst(this%nwavst) - flux2 = this%uzflst(this%nwavst) - flux1 = this%uzflst(this%nwavst-1) - theta1 = this%uzthst(this%nwavst-1) - this%uzspst(this%nwavst) = this%leadspeed(theta1,theta2,flux1,flux2) - this%uzdpst(this%nwavst) = 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) - if ( this%nwavst.EQ.0 ) Itester = 1 - if ( Itester.NE.1 ) then - do while ( diff > DEM6 ) - nwavp1 = this%nwavst + 1 - timedt = delt - Time - do j = 1, this%nwavst - checktime(j) = DEP20 - more(j) = 0 - end do - shortest = timedt - if ( this%nwavst > 2 ) then - j = 2 - ! - !calculate time until wave overtakes wave ahead - nwavp1 = this%nwavst + 1 - do while ( j < nwavp1 ) - ftest = this%uzspst(j-1)-this%uzspst(j) - if ( abs(ftest) > DEM30 ) then - checktime(j) = (this%uzdpst(j)-this%uzdpst(j-1))/(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 > 1 ) then - if ( this%uzspst(2) > DZERO ) then - bottom = this%uzspst(2) - if ( bottom < DEM15 ) bottom = DEM15 - bottomtime = (this%uzdpst(1)-this%uzdpst(2))/bottom - if ( bottomtime < DZERO ) bottomtime = DEM12 - end if - end if - ! - !calc time for wave interception - jshort = 0 - do j = this%nwavst, 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 - if ( shortest-checktime(j) < DEM9 ) then - if ( j.ne.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) = this%uzdpst(j) + this%uzspst(j) & - *bottomtime - j = j + 1 - end do - fluxb = this%uzflst(2) - thetab = this%uzthst(2) - iflx = 1 - call this%wave_shift(this,1,1,this%nwavst-1,1) - iremove = 1 - timenew = Time + bottomtime - this%uzspst(1) = DZERO - ! - !do waves intercept before end of time step - else if ( fcheck < DZERO .AND. this%nwavst > 2 ) then - j = 2 - do while ( j < nwavp1 ) - this%uzdpst(j) = this%uzdpst(j) + this%uzspst(j) & - *shortest - j = j + 1 - end do - ! - !combine waves that intercept, remove a wave - j = 3 - l = j - do while ( j < this%nwavst+1 ) - if ( more(j).EQ.1 ) then - l = j - theta2 = this%uzthst(j) - flux2 = this%uzflst(j) - if ( j.EQ.3 ) then - flux1 = fluxb - theta1 = thetab - else - flux1 = this%uzflst(j-2) - theta1 = this%uzthst(j-2) - end if - this%uzspst(j) = this%leadspeed(theta1,theta2,flux1,flux2) - ! - !update waves. - call this%wave_shift(this,1,l-1,this%nwavst-1,1) - l = this%nwavst + 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) = this%uzdpst(j) + this%uzspst(j) & - *timedt - j = j + 1 - end do - timenew = delt - end if - this%totflux = this%totflux + fluxhld2*(timenew-time) - if ( iflx.EQ.1 ) then - fluxhld2 = this%uzflst(1) - iflx = 0 - end if - ! - !remove dead waves - this%nwavst = this%nwavst - iremove - Time = timenew - diff = delt - Time - if ( this%nwavst.EQ.1 ) then - Itester = 1 - exit - end if - end do - end if - deallocate(checktime) - deallocate(more) - return - end subroutine leadwav -! - -! - function leadspeed(this,theta1,theta2,flux1,flux2) -! ****************************************************************** -! leadspeed----calculates waves speed from dflux/dtheta -! ****************************************************************** -! SPECIFICATIONS: -! ---------------------------------------------------------------------- - !modules - !arguments - class (UzfKinematicType) :: this - real(DP), intent(in) :: theta1 - real(DP), intent(in) :: theta2 - real(DP), intent(in) :: flux1 - real(DP), intent(inout) :: flux2 - ! -- dummy - real(DP) :: comp1, comp2, thsrinv, epsfksths - real(DP) :: eps_m1, fhold, comp3 - real(DP) :: leadspeed -! ---------------------------------------------------------------------- - eps_m1 = dble(this%eps) - DONE - thsrinv = DONE/(this%thts-this%thtr) - epsfksths = this%eps*this%vks*thsrinv - comp1 = theta2-theta1 - comp2 = abs(flux2-flux1) - comp3 = theta1 - this%thtr - if ( comp2 < DEM15 ) flux2 = flux1 + DEM15 - if ( abs(comp1) < DEM30 ) then - if ( comp3 > DEM30 ) fhold = ((comp3)*thsrinv)**this%eps - if ( fhold < DEM30 ) fhold = DEM30 - leadspeed = epsfksths * (fhold**eps_m1) - else - leadspeed = (flux2-flux1)/(theta2-theta1) - end if - if ( leadspeed < DEM30 ) leadspeed = DEM30 - end function leadspeed -! -! ---------------------------------------------------------------------- - - function unsat_stor(this,d1) -! ****************************************************************** -! unsat_stor---- sums up mobile water over depth interval -! ****************************************************************** -! SPECIFICATIONS: -! ---------------------------------------------------------------------- - !modules - !arguments - class (UzfKinematicType) :: this - real(DP), intent(inout) :: d1 - ! -- dummy - real(DP) :: fm, unsat_stor - integer(I4B) :: j, k,nwavm1,jj -! ---------------------------------------------------------------------- - fm = DZERO - j = this%nwavst + 1 - k = this%nwavst - nwavm1 = k-1 - if ( d1 > this%uzdpst(1) ) d1 = this%uzdpst(1) - ! - !find deepest wave above depth d1, counter held as j - do while ( k > 0 ) - if ( this%uzdpst(k) - d1 < -DEM30) j = k - k = k - 1 - end do - if ( j > this%nwavst ) then - fm = fm + (this%uzthst(this%nwavst)-this%thtr)*d1 - elseif ( this%nwavst > 1 ) then - if ( j > 1 ) then - fm = fm + (this%uzthst(j-1)-this%thtr) & - *(d1-this%uzdpst(j)) - end if - do jj = j, nwavm1 - fm = fm + (this%uzthst(jj)-this%thtr) & - *(this%uzdpst(jj) & - -this%uzdpst(jj+1)) - end do - fm = fm + (this%uzthst(this%nwavst)-this%thtr) & - *(this%uzdpst(this%nwavst)) - else - fm = fm + (this%uzthst(1)-this%thtr)*d1 - end if - unsat_stor = fm - end function unsat_stor -! -! ---------------------------------------------------------------------- - - subroutine update_wav(this,ipos,delt,rout,rsto,ret,etflg,iss,itest) -! ****************************************************************** -! update_wav---- update to new state of uz at end of time step -! ****************************************************************** -! SPECIFICATIONS: -! ---------------------------------------------------------------------- - !modules - !arguments - class (UzfKinematicType) :: this - integer(I4B), intent(in) :: ipos,etflg,itest,iss - real(DP), intent(in) :: delt - real(DP), intent(inout) :: rout - real(DP), intent(inout) :: rsto - real(DP), intent(inout) :: ret - ! -- dummy - real(DP) :: uzstorhold,bot,fm,depthsave,top - real(DP) :: thick,thtsrinv - integer(I4B) :: nwavhld, k,j -! ---------------------------------------------------------------------- -! - bot = this%watab - top = this%celtop - thick = top-bot - nwavhld = this%nwavst - if ( itest == 1 ) then -! this%uzflst(1) = this%surflux !rgn 5/25/17 - this%uzflst(1) = DZERO - this%uzthst(1) = this%thtr - this%delstor = - this%uzstor - this%uzstor = DZERO - uzstorhold = DZERO - rout = rout + this%totflux*this%uzfarea/delt - return - end if - if ( iss == 1 ) then - if ( this%thts-this%thtr < DEM7 ) then - thtsrinv = DONE/DEM7 - else - thtsrinv = DONE/(this%thts-this%thtr) - end if - this%totflux = this%surflux*delt - this%watabold = this%watab - this%uzthst(1) = this%thti - this%uzflst(1) = this%vks*(((this%uzthst(1)-this%thtr) & - *thtsrinv)**this%eps) - this%uzdpst(1) = thick - this%uzspst(1) = thick - this%nwavst = 1 - this%uzstor = thick*(this%thti-this%thtr)*this%uzfarea - this%delstor = DZERO - rout = rout + this%totflux*this%uzfarea/delt - else - ! - !water table rises through waves - if ( this%watab - this%watabold > DEM30 ) then - depthsave = this%uzdpst(1) - j = 0 - k = this%nwavst - do while ( k > 0 ) - if ( this%uzdpst(k) - thick < -DEM30) j = k - k = k - 1 - end do - this%uzdpst(1) = thick - if ( j > 1 ) then - this%uzspst(1) = dzero - this%nwavst = this%nwavst - j + 2 - this%uzthst(1) = this%uzthst(j-1) - this%uzflst(1) = this%uzflst(j-1) - if ( j > 2 ) call this%wave_shift(this,j-2,2,nwavhld-(j-2),1) - elseif ( j == 0 ) then - this%uzspst(1) = dzero - this%uzthst(1) = this%uzthst(this%nwavst) - this%uzflst(1) = this%uzflst(this%nwavst) - this%nwavst = 1 - end if - end if - ! - !calculate new unsat. storage - if ( thick > DZERO ) then - fm = this%unsat_stor(thick) - uzstorhold = this%uzstor - this%uzstor = fm*this%uzfarea - this%delstor = this%uzstor - uzstorhold - else - this%uzspst(1) = DZERO - this%nwavst = 1 - this%uzthst(1) = this%thtr - this%uzflst(1) = DZERO - this%delstor = - this%uzstor - this%uzstor = DZERO - uzstorhold = DZERO - end if - this%watabold = this%watab - rout = rout + this%totflux*this%uzfarea/delt - rsto = rsto + this%delstor/delt - if ( etflg > 0 ) ret = ret + this%etact*this%uzfarea/delt - end if - end subroutine - - subroutine uzet(this,delt,ietflag,ierr) -! ****************************************************************** -! uzet---- remove water from uz due to et -! ****************************************************************** -! SPECIFICATIONS: -! ---------------------------------------------------------------------- - !modules - ! -- dummy - class (UzfKinematicType) :: this - real(DP), intent(in) :: delt - integer(I4B), intent(in) :: ietflag - integer(I4B), intent(inout) :: ierr - ! -- local - type(UzfKinematicType), pointer :: 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 -! ------------------------------------------------------------------ - this%etact = DZERO - if ( this%extdpuz < DEM7 ) return - petsub = this%rootact*this%pet*this%extdpuz/this%extdp - thetaout = delt*petsub/this%extdp - if ( ietflag==1 ) thetaout = delt*this%pet/this%extdp - if ( thetaout < DEM10 ) return - depth = this%uzdpst(1) - st = this%Unsat_stor(depth) - if ( st < DEM4 ) return - ! - !allocate temporary wave storage. - allocate(uzfktemp) - allocate(uzfktemp%uzdpst(this%nwavst)) - allocate(uzfktemp%uzthst(this%nwavst)) - allocate(uzfktemp%uzflst(this%nwavst)) - allocate(uzfktemp%uzspst(this%nwavst)) - allocate(uzfktemp%nwavst) - ha = this%ha - nwv = this%nwavst - itest = 0 - ! - ! store original wave characteristics - call uzfktemp%wave_shift(this,0,1,Nwv,1) - factor = DONE - this%etact = DZERO - if ( this%thts-this%thtr < DEM7 ) then - thtsrinv = 1.0/DEM7 - else - thtsrinv = DONE/(this%thts-this%thtr) - end if - epsfksthts = this%eps*this%vks*thtsrinv - this%Etact = DZERO - fmp = DZERO - extwc1 = this%extwc - this%thtr - 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 == 1 .AND. this%uzdpst(1) <= this%extdpuz ) then - if ( ietflag == 2 ) then - tho = this%uzthst(1) - fktho = this%uzflst(1) - hcap = this%caph(tho) - thetaout = this%rate_et_z(factor,fktho,hcap) - end if - if ( (this%uzthst(1)-thetaout) > this%thtr+extwc1 ) then - this%uzthst(1) = this%uzthst(1) - thetaout - this%uzflst(1) = this%vks*(((this%uzthst(1)-this%thtr)*thtsrinv)**this%eps) - else if ( this%uzthst(1) > this%thtr+extwc1 ) then - this%uzthst(1) = this%thtr + extwc1 - this%uzflst(1) = this%vks*(((this%uzthst(1)-this%thtr)*thtsrinv)**this%eps) - end if - ! - !all waves shallower than extinction depth - else if ( this%nwavst > 1 .AND. this%uzdpst(this%nwavst) > this%extdpuz) then - if ( ietflag == 2 ) then - tho = this%uzthst(this%nwavst) - fktho = this%uzflst(this%nwavst) - hcap = this%caph(tho) - thetaout = this%rate_et_z(factor,fktho,hcap) - end if - if ( this%uzthst(this%nwavst)-thetaout > this%thtr+extwc1 ) then - this%uzthst(this%nwavst+1) = this%uzthst(this%nwavst) - thetaout - numadd = 1 - else if ( this%uzthst(this%nwavst) > this%thtr+extwc1 ) then - this%uzthst(this%nwavst+1) = this%thtr + extwc1 - numadd = 1 - end if - if ( numadd == 1 ) then - this%uzflst(this%nwavst+1) = this%vks* & - (((this%uzthst(this%nwavst+1)- & - this%thtr)*thtsrinv)**this%eps) - theta2 = this%uzthst(this%nwavst+1) - flux2 = this%uzflst(this%nwavst+1) - flux1 = this%uzflst(this%nwavst) - theta1 = this%uzthst(this%nwavst) - this%uzspst(this%nwavst+1) = this%leadspeed(theta1,theta2,flux1,flux2) - this%uzdpst(this%nwavst+1) = this%extdpuz - this%nwavst = this%nwavst + 1 - if ( this%nwavst > this%nwav ) 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 == 1 ) then - if ( ietflag == 2 ) then - tho = this%uzthst(1) - fktho = this%uzflst(1) - hcap = this%caph(tho) - thetaout = this%rate_et_z(factor,fktho,hcap) - end if - if ( (this%uzthst(1)-thetaout) > this%thtr+extwc1 ) then - if ( thetaout > DEM30 ) then - this%uzthst(2) = this%uzthst(1) - thetaout - this%uzflst(2) = this%vks*(((this%uzthst(2)-this%thtr)* & - thtsrinv)**this%eps) - this%uzdpst(2) = this%extdpuz - theta2 = this%uzthst(2) - flux2 = this%uzflst(2) - flux1 = this%uzflst(1) - theta1 = this%uzthst(1) - this%uzspst(2) = this%leadspeed(theta1,theta2,flux1,flux2) - this%nwavst = this%nwavst + 1 - if ( this%nwavst > this%nwav ) then - ! - !too many waves error - ierr = 1 - goto 500 - end if - end if - else if ( this%uzthst(1) > this%thtr+extwc1 ) then - if ( thetaout > DEM30 ) then - this%uzthst(2) = this%thtr + extwc1 - this%uzflst(2) = this%vks*(((this%uzthst(2)- & - this%thtr)*thtsrinv)**this%eps) - this%uzdpst(2) = this%extdpuz - theta2 = this%uzthst(2) - flux2 = this%uzflst(2) - flux1 = this%uzflst(1) - theta1 = this%uzthst(1) - this%uzspst(2) = this%leadspeed(theta1,theta2,flux1,flux2) - this%nwavst = this%nwavst + 1 - if ( this%nwavst > this%nwav ) then - !too many waves error - ierr = 1 - goto 500 - end if - end if - end if - else - ! - !extinction depth splits waves - if ( this%uzdpst(1)-this%extdpuz > DEM7 ) then - j = 2 - jk = 0 - ! - !locate extinction depth between waves - do while ( jk == 0 ) - diff = this%uzdpst(j) - this%extdpuz - if ( diff > dzero ) then - j = j + 1 - else - jk = 1 - end if - end do - kk = j - if ( this%uzthst(j) > this%thtr+extwc1 ) then - ! - !create a wave at extinction depth - if ( abs(diff) > DEM5 ) then - call this%wave_shift(this,-1,this%nwavst+1,j,-1) - this%uzdpst(j) = this%extdpuz - this%nwavst = this%nwavst + 1 - if ( this%nwavst > this%nwav ) then - ! - !too many waves error - ierr = 1 - goto 500 - end if - end if - kk = j - else - jhold = this%nwavst - i = j + 1 - do while ( i < this%nwavst ) - if ( this%uzthst(i) > this%thtr+extwc1 ) then - jhold = i - i = this%nwavst + 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.LE.this%nwavst) - if ( ietflag==2 ) then - tho = this%uzthst(kk) - fktho = this%uzflst(kk) - hcap = this%caph(tho) - thetaout = this%rate_et_z(factor,fktho,hcap) - end if - if ( this%uzthst(kk) > this%thtr+extwc1 ) then - if ( this%uzthst(kk)-thetaout > this%thtr+extwc1 ) then - this%uzthst(kk) = this%uzthst(kk) - thetaout - else if ( this%uzthst(kk) > this%thtr+extwc1 ) then - this%uzthst(kk) = this%thtr + extwc1 - end if - if ( kk.EQ.1 ) then - this%uzflst(kk) = this%vks*(((this%uzthst(kk)-this%thtr)*thtsrinv)**this%eps) - end if - if ( kk > 1 ) then - flux1 = this%vks*((this%uzthst(kk-1)-this%thtr)*thtsrinv)**this%eps - flux2 = this%vks*((this%uzthst(kk)-this%thtr)*thtsrinv)**this%eps - this%uzflst(kk) = flux2 - theta2 = this%uzthst(kk) - theta1 = this%uzthst(kk-1) - this%uzspst(kk) = this%leadspeed(theta1,theta2,flux1,flux2) - end if - end if - kk = kk + 1 - end do - end if - ! - !calculate aet - kj = 1 - do while ( kj.LE.this%nwavst-1 ) - if ( abs(this%uzthst(kj)-this%uzthst(kj+1)) < DEM6 ) then - call this%wave_shift(this,1,kj+1,this%nwavst-1,1) - kj = kj - 1 - this%nwavst = this%nwavst - 1 - end if - kj = kj + 1 - end do - depth = this%uzdpst(1) - fm = this%Unsat_stor(depth) - this%etact = st - fm - fm = this%Etact/delt - if ( this%Etact < dzero ) then - call this%wave_shift(uzfktemp,0,1,Nwv,1) - this%nwavst = Nwv - this%Etact = dzero - elseif ( petsub-fm < -DEM15 .AND. ietflag==2 ) then - ! aet greater than pet, reset and try again - call this%wave_shift(uzfktemp,0,1,Nwv,1) - this%nwavst = 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 deallocate(uzfktemp%uzdpst) - deallocate(uzfktemp%uzthst) - deallocate(uzfktemp%uzflst) - deallocate(uzfktemp%uzspst) - deallocate(uzfktemp%nwavst) - deallocate(uzfktemp) - return - end subroutine uzet -! -! ---------------------------------------------------------------------- - - function caph(this,tho) -! ****************************************************************** -! caph---- calculate capillary pressure head from B-C equation -! ****************************************************************** -! SPECIFICATIONS: -! ---------------------------------------------------------------------- - !modules - class (UzfKinematicType) :: this - real(DP), intent(in) :: tho - ! -- dummy - real(DP) :: caph,lambda,star -! ---------------------------------------------------------------------- - caph = -DEM6 - star = (tho-this%thtr)/(this%thts-this%thtr) - if ( star < DEM15 ) star = DEM15 - lambda = DTWO/(this%eps-DTHREE) - if ( star > DEM15 ) then - if ( tho-this%thts < DEM15 ) then - caph = this%ha*star**(-DONE/lambda) - else - caph = DZERO - end if - end if - end function caph - - function rate_et_z(this,factor,fktho,h) -! ****************************************************************** -! rate_et_z---- capillary pressure based uz et -! ****************************************************************** -! SPECIFICATIONS: -! ---------------------------------------------------------------------- - !modules - !arguments - class (UzfKinematicType) :: this - real(DP), intent(in) :: factor,fktho,h - ! -- dummy - real(DP) :: rate_et_z -! ---------------------------------------------------------------------- - rate_et_z = factor*fktho*(h-this%hroot) - if ( rate_et_z < DZERO ) rate_et_z = DZERO - end function rate_et_z -! -! ------------------------------------------------------------------------------ -! end of BndUzfKinematic object +module UzfKinematicModule + + 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 :: UzfKinematicType + + type :: UzfKinematicType + real(DP), pointer :: thtr => null() + real(DP), pointer :: thts => null() + real(DP), pointer :: thti => null() + real(DP), pointer :: eps => null() + real(DP), pointer :: extwc => null() + real(DP), pointer :: ha => null() + real(DP), pointer :: hroot => null() + real(DP), pointer :: rootact => null() + real(DP), pointer :: 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 :: nwavst => null() + real(DP), pointer :: uzolsflx => null() + real(DP), pointer :: uzstor => null() + real(DP), pointer :: delstor => null() + real(DP), pointer :: totflux => null() + real(DP), pointer :: vflow => null() + integer(I4B), pointer :: nwav, ntrail => null() + real(DP), pointer :: sinf => null() + real(DP), pointer :: finf => null() + real(DP), pointer :: pet => null() + real(DP), pointer :: petmax => null() + real(DP), pointer :: extdp => null() + real(DP), pointer :: extdpuz => null() + real(DP), pointer :: finf_rej => null() + real(DP), pointer :: gwet => null() + real(DP), pointer :: uzfarea => null() + real(DP), pointer :: cellarea => null() + real(DP), pointer :: celtop => null() + real(DP), pointer :: celbot => null() + real(DP), pointer :: landtop => null() + real(DP), pointer :: cvlm1 => null() + real(DP), pointer :: watab => null() + real(DP), pointer :: watabold => null() + real(DP), pointer :: vks => null() + real(DP), pointer :: surfdep => null() + real(DP), pointer :: surflux => null() + real(DP), pointer :: surfluxbelow => null() + real(DP), pointer :: surfseep => null() + real(DP), pointer :: gwpet => null() + integer(I4B), pointer :: landflag => null() + integer(I4B), pointer :: ivertcon => null() + contains + procedure :: init + procedure :: setdata + procedure :: setdatauzfarea + procedure :: setdatafinf + procedure :: setdataet + procedure :: setdataetwc + procedure :: setdataetha + procedure :: setwaves + procedure :: wave_shift + procedure :: routewaves + procedure :: uzflow + procedure :: addrech + procedure :: factors + procedure :: trailwav + procedure :: leadwav + procedure :: leadspeed + 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 :: etfunc_nlin + procedure :: etfunc_lin + procedure :: rejfinf + procedure :: gwseep + procedure :: setbelowpet + procedure :: dealloc + end type UzfKinematicType +! + contains +! +! ------------------------------------------------------------------------------ + + subroutine init(this, ipos, nwav) +! ****************************************************************************** +! init -- allocate and set uzf object variables +! +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + !modules + !arguments + class(UzfKinematicType) :: this + integer(I4B), intent(in) :: ipos + integer(I4B), intent(in) :: nwav +! ------------------------------------------------------------------------------ + allocate(this%uzdpst(nwav)) + allocate(this%uzthst(nwav)) + allocate(this%uzflst(nwav)) + allocate(this%uzspst(nwav)) + allocate(this%nwavst) + allocate(this%uzolsflx) + allocate(this%thtr) + allocate(this%thts) + allocate(this%thti) + allocate(this%eps) + allocate(this%ha) + allocate(this%hroot) + allocate(this%rootact) + allocate(this%extwc) + allocate(this%etact) + allocate(this%nwav) + allocate(this%ntrail) + allocate(this%uzstor) + allocate(this%delstor) + allocate(this%totflux) + allocate(this%vflow) + allocate(this%sinf) + allocate(this%finf) + allocate(this%finf_rej) + allocate(this%gwet) + allocate(this%uzfarea) + allocate(this%cellarea) + allocate(this%celtop) + allocate(this%celbot) + allocate(this%landtop) + allocate(this%cvlm1) + allocate(this%watab) + allocate(this%watabold) + allocate(this%surfdep) + allocate(this%vks) + allocate(this%surflux) + allocate(this%surfluxbelow) + allocate(this%surfseep) + allocate(this%gwpet) + allocate(this%pet) + allocate(this%petmax) + allocate(this%extdp) + allocate(this%extdpuz) + allocate(this%landflag) + allocate(this%ivertcon) + this%uzdpst = DZERO + this%uzthst = DZERO + this%uzflst = DZERO + this%uzspst = DZERO + this%nwavst = 1 + this%uzolsflx = DZERO + this%thtr = DZERO + this%thts = DZERO + this%thti = DZERO + this%eps = DZERO + this%ha = DZERO + this%hroot = DZERO + this%rootact = DZERO + this%extwc = DZERO + this%etact = DZERO + this%nwav = nwav + this%ntrail = 0 + this%uzstor = DZERO + this%delstor = DZERO + this%totflux = DZERO + this%vflow = DZERO + this%sinf = DZERO + this%finf = DZERO + this%finf_rej = DZERO + this%gwet = DZERO + this%uzfarea = DZERO + this%cellarea = DZERO + this%celtop = DZERO + this%celbot = DZERO + this%landtop = DZERO + this%cvlm1 = DZERO + this%watab = DZERO + this%watabold = DZERO + this%surfdep = DZERO + this%vks = DZERO + this%surflux = DZERO + this%surfluxbelow = DZERO + this%surfseep = DZERO + this%gwpet = DZERO + this%pet = DZERO + this%petmax = DZERO + this%extdp = DZERO + this%extdpuz = DZERO + this%landflag = 0 + this%ivertcon = 0 + end subroutine init + ! + ! + subroutine dealloc(this) +! ****************************************************************************** +! dealloc -- deallocate uzf object variables +! +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(UzfKinematicType) :: this + ! -- locals +! ------------------------------------------------------------------------------ + 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) + ! + ! -- return + return + end subroutine dealloc +! +! ------------------------------------------------------------------------------ + + subroutine setdata(this,ipos,area,top,bot,surfdep, & + vks,thtr,thts,thti,eps, & + ntrail,landflag,ivertcon,hgwf) +! ****************************************************************************** +! setdata -- set uzf object material properties +! +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + !modules + !arguments + class(UzfKinematicType) :: this + integer(I4B), intent(in) :: ipos, ntrail, landflag, ivertcon + 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 + real(DP), intent(in) :: hgwf +! ------------------------------------------------------------------------------ + this%landflag = landflag + this%ivertcon = ivertcon + this%surfdep = surfdep + this%uzfarea = area + this%cellarea = area + if ( this%landflag == 1 ) then + this%celtop = top - DHALF*this%surfdep + else + this%celtop = top + end if + this%celbot = bot + this%vks = vks + this%watab = this%celbot + if ( hgwf > this%celbot ) this%watab = hgwf + if ( this%watab > this%celtop ) this%watab = this%celtop + this%watabold = this%watab + this%thtr = thtr + this%thts = thts + this%thti = thti + this%eps = eps + this%ntrail = ntrail + this%pet = DZERO + this%extdp = DZERO + this%extwc = DZERO + this%ha = DZERO + this%hroot = DZERO + end subroutine setdata +! +! ------------------------------------------------------------------------------ + subroutine setdatafinf(this,finf) +! ****************************************************************************** +! setdatafinf -- set infiltration +! +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + !modules + !arguments + class(UzfKinematicType) :: this + real(DP), intent(in) :: finf +! ------------------------------------------------------------------------------ + if (this%landflag == 1) then + this%sinf = finf + this%finf = finf + else + this%sinf = DZERO + this%finf = DZERO + end if + this%finf_rej = DZERO + this%surflux = DZERO + this%surfluxbelow = DZERO + end subroutine setdatafinf +! ------------------------------------------------------------------------------ +! +! ------------------------------------------------------------------------------ + subroutine setdatauzfarea(this,areamult) +! ****************************************************************************** +! setdatauzfarea -- set uzfarea using cellarea and areamult +! +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! modules + ! -- dummy + class(UzfKinematicType) :: this + real(DP), intent(in) :: areamult +! ------------------------------------------------------------------------------ + this%uzfarea = this%cellarea * areamult + ! + ! -- return + return + end subroutine setdatauzfarea + +! ------------------------------------------------------------------------------ +! + subroutine setdataet(this,thisbelow,jbelow,pet,extdp) +! ****************************************************************************** +! setdataet -- set unsat. et variables +! +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + !modules + !arguments + class(UzfKinematicType) :: this + type(UzfKinematicType) :: thisbelow + integer(I4B), intent(in) :: jbelow + real(DP), intent(in) :: pet, extdp + ! -- dummy + real(DP) :: thick +! ------------------------------------------------------------------------------ + if (this%landflag == 1) then + this%pet = pet + this%gwpet = pet + else + this%pet = DZERO + this%gwpet = DZERO + end if + thick = this%celtop - this%celbot + this%extdp = extdp + if ( this%landflag > 0 ) then + this%landtop = this%celtop + this%petmax = this%pet + end if + ! + ! set uz extinction depth + if ( this%landtop - this%extdp < this%celbot ) then + this%extdpuz = thick + else + this%extdpuz = this%celtop - (this%landtop - this%extdp) + end if + if ( this%extdpuz < DZERO ) this%extdpuz = DZERO + if ( this%extdpuz > DEM7 .and. this%extdp < DEM7 ) this%extdp = this%extdpuz + ! + ! set pet for underlying cell + if ( jbelow > 0 ) then + thisbelow%landtop = this%landtop + thisbelow%petmax = this%petmax + end if + end subroutine setdataet +! +! ------------------------------------------------------------------------------ + + subroutine setbelowpet(this,thisbelow,aet) +! ****************************************************************************** +! setbelowpet -- subtract aet from pet to calculate residual et +! for deeper cells +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + !modules + !arguments + class(UzfKinematicType) :: this + type(UzfKinematicType) :: thisbelow + real(DP), intent(in) :: aet + ! -- dummy + real(DP) :: pet +! ------------------------------------------------------------------------------ + pet = DZERO + if ( thisbelow%extdpuz > DEM3 ) then + pet = this%petmax - aet + if ( pet < DZERO ) pet = DZERO + end if + thisbelow%pet = pet + end subroutine setbelowpet +! +! ------------------------------------------------------------------------------ + + subroutine setdataetwc(this,thisbelow,jbelow,extwc) +! ****************************************************************************** +! setdataetwc -- set extinction water content +! +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + !arguments + class(UzfKinematicType) :: this + type(UzfKinematicType) :: thisbelow + real(DP), intent(in) :: extwc + integer(I4B), intent(in) :: jbelow +! ------------------------------------------------------------------------------ + this%extwc = extwc + if ( jbelow > 0 ) thisbelow%extwc = extwc + end subroutine setdataetwc +! +! ------------------------------------------------------------------------------ + + subroutine setdataetha(this,thisbelow,jbelow,ha,hroot,rootact) +! ****************************************************************************** +! setdataetha -- set variables for head-based unsat. flow +! +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + !arguments + class(UzfKinematicType) :: this + type(UzfKinematicType) :: thisbelow + real(DP), intent(in) :: ha,hroot,rootact + integer(I4B), intent(in) :: jbelow +! ------------------------------------------------------------------------------ + this%ha = ha + this%hroot = hroot + this%rootact = rootact + if ( jbelow > 0 ) then + thisbelow%ha = ha + thisbelow%hroot = hroot + thisbelow%rootact = rootact + end if + end subroutine setdataetha +! +! ------------------------------------------------------------------------------ + + subroutine advance(this) +! ****************************************************************************** +! advance -- set variables to advance to new time step. nothing yet. +! +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(UzfKinematicType) :: this +! ------------------------------------------------------------------------------ + this%surfseep = DZERO + end subroutine advance +! +! ------------------------------------------------------------------------------ + + subroutine formulate(this,thiswork,thisbelow,ipos,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 + !arguments + class(UzfKinematicType) :: this + type(UzfKinematicType) :: thiswork + type(UzfKinematicType) :: thisbelow + integer(I4B), intent(in) :: ipos,ietflag,iseepflag,issflag,ivertflag + integer(I4B), intent(inout) :: ierr + real(DP), intent(in) :: hgwf,hgwfml1,cvv,qfrommvr + real(DP), intent(inout) :: trhs,thcof,qformvr,sumaet + real(DP), intent(inout) :: totfluxtot + real(DP), intent(inout) :: deriv + ! -- dummy + 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 = DZERO + this%surflux = this%finf + qfrommvr / this%uzfarea + this%surfseep = DZERO + seep = DZERO + finfact = DZERO + deriv1 = DZERO + deriv2 = DZERO + derivfinf = DZERO + this%watab = hgwf + this%etact = DZERO + this%surfluxbelow = DZERO + ! + ! set pet for gw when there is no UZ. + this%gwpet = this%pet + if( ivertflag > 0 ) then + thisbelow%finf = DZERO + end if + ! + ! save wave states for resetting after iteration. + this%watab = hgwf + call thiswork%wave_shift(this,0,1,this%nwavst,1) + if ( this%watab > this%celtop ) this%watab = this%celtop + ! + if ( this%ivertcon > 0 ) then + if ( this%watab < this%celbot ) this%watab = this%celbot + end if + ! + ! add water from mover to applied infiltration. + !this%surflux = this%surflux + if ( this%surflux > this%vks ) then + this%surflux = this%vks + end if + ! + ! saturation excess rejected infiltration + if ( this%landflag==1 ) then + call this%rejfinf(ipos,deriv1,hgwf,trhsfinf,thcoffinf,finfact) + this%surflux = finfact + end if + ! + ! calculate rejected infiltration + this%finf_rej = this%finf + (qfrommvr / this%uzfarea) - this%surflux + if ( iseepflag > 0 .and. this%landflag==1) then + ! + ! calculate groundwater discharge + call this%gwseep(ipos,deriv2,scale,hgwf,trhsseep,thcofseep,seep) + this%surfseep = seep + end if + ! + ! route water through unsat zone, calc. storage change and recharge + ! + test = this%watab + if ( this%watabold - test < -DEM15 ) test = this%watabold + if ( this%celtop - test > DEM15 ) then + if ( issflag == 0 ) then + call this%routewaves(totfluxtot,delt,ietflag,ipos,ierr) + if ( ierr > 0 ) return + call this%uz_rise(totfluxtot) + this%totflux = totfluxtot + if( ietflag > 0 .and. this%ivertcon > 0 ) then + thisbelow%pet = thisbelow%pet - this%etact + if ( thisbelow%pet < DEM15 ) thisbelow%pet = DEM15 + end if + if ( this%ivertcon > 0 ) then + call this%addrech(thisbelow,hgwf,trhsfinf,thcoffinf,derivfinf,delt,0) + end if + else + this%totflux = this%surflux*delt + totfluxtot = this%surflux*delt + end if + thcoffinf = DZERO + trhsfinf = this%totflux*this%uzfarea/delt + else + this%totflux = this%surflux*delt + totfluxtot = this%surflux*delt + end if + deriv = deriv1 + deriv2 + derivfinf + trhs = trhsfinf + trhsseep + thcof = thcoffinf + thcofseep + ! + ! add spring flow and rejected infiltration to mover + qformvr = this%surfseep + this%finf_rej*this%uzfarea + ! + ! reset waves to previous state for next iteration + call this%wave_shift(thiswork,0,1,thiswork%nwavst,1) + ! + ! distribute PET to deeper cells + sumaet = sumaet + this%etact + if( this%ivertcon > 0 ) then + if ( ietflag > 0 ) then + call this%setbelowpet(thisbelow,sumaet) + end if + end if + end subroutine formulate +! +! ------------------------------------------------------------------------------ + + subroutine budget(this,thisbelow,ipos,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 + !arguments + class(UzfKinematicType) :: this + type(UzfKinematicType) :: thisbelow + integer(I4B), intent(in) :: ipos,ietflag,iseepflag,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,hgwfml1,cvv,qfrommvr + real(DP), intent(inout) :: rfinf + real(DP), intent(inout) :: rin,qformvr,sumaet + real(DP), intent(inout) :: qgwformvr + real(DP), intent(inout) :: rout + real(DP), intent(inout) :: rsto + real(DP), intent(inout) :: ret,retgw,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 +! ------------------------------------------------------------------------------ + totfluxtot = DZERO + trhsfinf = DZERO + thcoffinf = DZERO + trhsseep = DZERO + thcofseep = DZERO + this%finf_rej = DZERO + this%surflux = this%finf + qfrommvr / this%uzfarea + this%watab = hgwf + this%vflow = DZERO + this%surfseep = DZERO + seep = DZERO + finfact = DZERO + this%etact = DZERO + this%surfluxbelow = DZERO + sumaet = DZERO + ! + ! set pet for gw when there is no UZ. + this%gwpet = this%pet + if ( this%ivertcon > 0 ) then + thisbelow%finf = dzero + if ( this%watab < this%celbot ) this%watab = this%celbot + end if + if ( this%watab > this%celtop ) this%watab = this%celtop + if ( this%surflux > this%vks ) then + this%surflux = this%vks + end if + ! + ! infiltration excess -- rejected infiltration + if ( this%landflag==1 ) then + call rejfinf(this,ipos,deriv,hgwf,trhsfinf,thcoffinf,finfact) + this%surflux = finfact + if (finfact 0 .and. this%landflag == 1 ) then + call this%gwseep(ipos,deriv,scale,hgwf,trhsseep,thcofseep,seep) + this%surfseep = seep + rgwseep = rgwseep + this%surfseep + 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 + if ( this%watabold - test < -DEM15 ) test = this%watabold + if ( this%celtop - test > DEM15 ) then + if ( issflag == 0 ) then + call this%routewaves(totfluxtot,delt,ietflag,ipos,ierr) + if ( ierr > 0 ) return + call this%uz_rise(totfluxtot) + this%totflux = totfluxtot + if ( this%ivertcon > 0 ) then + call this%addrech(thisbelow,hgwf,trhsfinf,thcoffinf,deriv,delt,1) + end if + else + this%totflux = this%surflux*delt + totfluxtot = this%surflux*delt + end if + thcoffinf = dzero + trhsfinf = this%totflux*this%uzfarea/delt + call this%update_wav(ipos,delt,rout,rsto,ret,ietflag,issflag,0) + else + call this%update_wav(ipos,delt,rout,rsto,ret,ietflag,issflag,1) + totfluxtot = this%surflux*delt + this%totflux = this%surflux*delt + end if + rfinf = rfinf + this%sinf * this%uzfarea + rin = rin + this%surflux*this%uzfarea - this%surfluxbelow*this%uzfarea + ! + ! add spring flow and rejected infiltration to mover + !qformvr = this%surfseep + this%finf_rej*this%uzfarea + qformvr = this%finf_rej*this%uzfarea + qgwformvr = this%surfseep + ! + ! process for observations + do i = 1, numobs + j = obs_num(i) + if (this%watab < this%celtop) then + if (this%celtop - obs_depth(j) > this%watab) then + d1 = obs_depth(j) - DEM3 + d2 = obs_depth(j) + DEM3 + f1 = unsat_stor(this, d1) + f2 = unsat_stor(this, d2) + obs_theta(j) = this%thtr + (f2 - f1)/(d2 - d1) + else + obs_theta(j) = this%thts + end if + else + obs_theta(j) = this%thts + end if + end do + ! + ! distribute residual PET to deeper cells + sumaet = sumaet + this%etact + if (this%ivertcon > 0) then + if (ietflag > 0) then + call this%setbelowpet(thisbelow, sumaet) + end if + end if + end subroutine budget +! +! ------------------------------------------------------------------------------ + + subroutine vertcellflow(this,ipos,trhs,hgwf,hgwfml1,cvv) +! ****************************************************************************** +! vertcellflow -- calculate exchange from sat. to unsat. zones +! subroutine not used until sat to unsat flow is supported +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + !modules + !arguments + class(UzfKinematicType) :: this + integer(I4B), intent(in) :: ipos + real(DP), intent(in) :: hgwf,hgwfml1,cvv + real(DP), intent(inout) :: trhs + ! -- dummy + real(DP) :: Qv,maxvflow,h1,h2,test +! ------------------------------------------------------------------------------ + this%vflow = DZERO + this%finf = DZERO +! UZfact(ic,ir,il) = 1.0 + trhs = DZERO + h1 = hgwfml1 + h2 = hgwf + test = this%watab + if ( this%watabold - test < -DEM30 ) test = this%watabold + if ( this%celtop - test > DEM30 ) then + ! + ! calc. downward flow using GWF heads and conductance + Qv = cvv*(h1-h2) + if ( Qv > DEM30 ) then + this%vflow = Qv + this%surflux = this%vflow/this%uzfarea +! UZfact(ic,ir,il) = dzero + maxvflow = this%vks*this%uzfarea + if ( this%vflow - maxvflow > DEM9 ) then + this%surflux = this%vks + trhs = this%vflow - maxvflow + this%vflow = maxvflow + end if + end if + end if + return + end subroutine vertcellflow +! +! ------------------------------------------------------------------------------ + + + subroutine addrech(this,thisbelow,hgwf,trhs,thcof,deriv,delt,it) +! ****************************************************************************** +! addrech -- add recharge or infiltration to cells +! +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + !modules + !arguments + class(UzfKinematicType) :: this + type(UzfKinematicType) :: thisbelow + integer(I4B), intent(in) :: it + real(DP), intent(inout) :: trhs,thcof,deriv + real(DP), intent(in) :: delt,hgwf + ! -- dummy + real(DP) :: fcheck + real(DP) :: x,scale,range +! ------------------------------------------------------------------------------ + range = DEM5 + deriv = DZERO + thcof = DZERO + trhs = this%uzfarea*this%totflux/delt + if ( this%totflux < DEM14 ) return + scale = DONE + ! + ! smoothly reduce flow between cells when head close to cell top + x = (hgwf-(this%celbot-range)) + call sSCurve(x,range,deriv,scale) + deriv = this%uzfarea*deriv*this%totflux/delt + thisbelow%finf = (DONE-scale)*this%totflux/delt + fcheck = thisbelow%finf - thisbelow%vks + ! + ! reduce flow between cells when vks is too small + if ( fcheck < DEM14 ) fcheck = DZERO + thisbelow%finf = thisbelow%finf - fcheck + this%surfluxbelow = thisbelow%finf + this%totflux = scale*this%totflux + fcheck*delt + trhs = this%uzfarea*this%totflux/delt + end subroutine addrech +! +! ------------------------------------------------------------------------------ + subroutine rejfinf(this,ipos,deriv,hgwf,trhs,thcof,finfact) +! ****************************************************************************** +! rejfinf -- reject applied infiltration due to low vks +! +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + !modules + !arguments + class(UzfKinematicType) :: this + integer(I4B), intent(in) :: ipos + real(DP), intent(inout) :: deriv,finfact,thcof,trhs + real(DP), intent(in) :: hgwf + ! -- dummy + real(DP) :: x,range,scale,q +! ------------------------------------------------------------------------------ + range = this%surfdep + q = (this%surflux) + finfact = q + trhs = finfact*this%uzfarea + x = (this%celtop-hgwf) + call sLinear(x,range,deriv,scale) + deriv = -q*deriv*this%uzfarea*scale + if ( scale < DONE ) then + finfact = q*scale + trhs = finfact*this%uzfarea*this%celtop/range + thcof = finfact*this%uzfarea/range + end if + end subroutine rejfinf +! +! ------------------------------------------------------------------------------ + + subroutine gwseep(this,ipos,deriv,scale,hgwf,trhs,thcof,seep) +! ****************************************************************************** +! gwseep -- calc. groudwater discharge to land surface +! +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + !modules + !argument + class(UzfKinematicType) :: this + integer(I4B), intent(in) :: ipos + real(DP), intent(inout) :: deriv,trhs,thcof,seep + real(DP), intent(out) :: scale + real(DP), intent(in) :: hgwf + ! -- dummy + real(DP) :: x,range,y,deriv1,d1,d2,Q +! ------------------------------------------------------------------------------ + seep = DZERO + deriv = DZERO + deriv1 = DZERO + d1 = DZERO + d2 = DZERO + scale = DZERO + Q = this%uzfarea*this%vks + range = this%surfdep + x = (hgwf-this%celtop) + call sCubicLinear(x,range,deriv1,y) + scale = y + seep = scale*Q*(hgwf-this%celtop)/range + trhs = scale*Q*this%celtop/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 + end subroutine gwseep +! +! ------------------------------------------------------------------------------ + + subroutine simgwet(this,igwetflag,ipos,hgwf,trhs,thcof,et,det) +! ****************************************************************************** +! simgwet -- calc. gwf et using residual uzf pet +! +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + !modules + !arguments + class(UzfKinematicType) :: this + integer(I4B), intent(in) :: igwetflag,ipos + real(DP), intent(in) :: hgwf + real(DP), intent(inout) :: trhs,thcof,det,et + ! -- dummy + real(DP) :: s,x,c + external :: etfunc_lin, etfunc_nlin + real(DP) :: etfunc_lin, etfunc_nlin +! ------------------------------------------------------------------------------ + this%gwet = DZERO + s = this%landtop + x = this%extdp + c = this%gwpet + if ( x < DEM6 ) return + if ( igwetflag==1 ) then + et = this%etfunc_lin(s,x,c,det,trhs,thcof,hgwf) + else if ( igwetflag==2 ) then + et = this%etfunc_nlin(s,x,c,det,trhs,thcof,hgwf) + end if + this%gwet = et*this%uzfarea + trhs = -trhs*this%uzfarea + thcof = thcof*this%uzfarea + return + end subroutine simgwet +! +! ------------------------------------------------------------------------------ + + function etfunc_lin(this,s,x,c,det,trhs,thcof,hgwf) +! ****************************************************************************** +! etfunc_lin -- calc. gwf et using linear ET function from mf-2005 +! +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + !modules + ! -- return + real(DP) :: etfunc_lin + ! -- dummy + class(UzfKinematicType) :: this + real(DP) :: etgw + real(DP) :: range + real(DP) :: depth,scale,thick + ! -- local + real(DP), intent(inout) :: det + real(DP), intent(in) :: s,x,c + real(DP), intent(inout) :: trhs,thcof + real(DP), intent(in) :: hgwf +! ------------------------------------------------------------------------------ + ! + ! 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 + depth = hgwf - (s - x) + thick = this%celtop-this%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 + end function etfunc_lin +! +! ------------------------------------------------------------------------------ + + function etfunc_nlin(this,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 + class(UzfKinematicType) :: this + real(DP), intent(inout) :: det + real(DP), intent(in) :: s,x,c,hgwf + ! -- local + real(DP), intent(inout) :: trhs,thcof + 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 + end function etfunc_nlin +! +! ------------------------------------------------------------------------------ + + subroutine uz_rise(this,totfluxtot) +! ****************************************************************************** +! uz_rise -- calculate recharge due to a rise in the gwf head +! +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ +! ------------------------------------------------------------------------------ + class(UzfKinematicType) :: this + real(DP), intent(inout) :: totfluxtot + real(DP) :: fm1,fm2,d1 +! ------------------------------------------------------------------------------ + ! + ! additional recharge from a rising water table + if ( this%watab-this%watabold > DEM30 ) then + d1 = this%celtop-this%watabold + fm1 = this%unsat_stor(d1) + d1 = this%celtop-this%watab + fm2 = this%unsat_stor(d1) + totfluxtot = totfluxtot + (fm1-fm2) + end if + end subroutine uz_rise +! +! ------------------------------------------------------------------------------ + + subroutine setwaves(this,ipos) +! ****************************************************************************** +! setwaves -- reset waves to default values at start of simulation +! +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ +! ------------------------------------------------------------------------------ + class(UzfKinematicType) :: this + integer(I4B), intent(in) :: ipos + real(DP) :: bottom, top + integer(I4B) :: jk + real(DP) :: thick +! ------------------------------------------------------------------------------ + this%uzstor = DZERO + this%delstor = DZERO + this%totflux = DZERO + this%nwavst = 1 + this%uzdpst = DZERO + thick = this%celtop - this%watab + do jk = 1, this%nwav + this%uzthst(jk) = this%thtr + end do + ! + ! initialize waves for first stress period + if ( thick > DZERO ) then + this%uzdpst(1) = thick + this%uzthst(1) = this%thti + top = this%uzthst(1) - this%thtr + if ( top < DZERO ) top = DZERO + bottom = this%thts - this%thtr + if ( bottom < DZERO ) bottom = DZERO + this%uzflst(1) = this%vks*(top/bottom)**this%eps + if ( this%uzthst(1) < this%thtr ) this%uzthst(1) = this%thtr + ! + ! calculate water stored in the unsaturated zone + if ( top > DZERO ) then + this%uzstor = this%uzdpst(1)*top*this%uzfarea + this%uzspst(1) = DZERO + this%uzolsflx = this%uzflst(1) + else + this%uzstor = DZERO + this%uzflst(1) = DZERO + this%uzspst(1) = DZERO + this%uzolsflx = DZERO + end if + ! + ! no unsaturated zone + else + this%uzflst(1) = DZERO + this%uzdpst(1) = DZERO + this%uzspst(1) = DZERO + this%uzthst(1) = this%thtr + this%uzstor = DZERO + this%uzolsflx = this%finf + end if + return + end subroutine +! +! ------------------------------------------------------------------------------ + + subroutine routewaves(this,totfluxtot,delt,ietflag,ipos,ierr) +! ****************************************************************************** +! routewaves -- prepare and route waves over time step +! +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ +! ------------------------------------------------------------------------------ + class(UzfKinematicType) :: this + real(DP), intent(inout) :: totfluxtot + real(DP), intent(in) :: delt + integer(I4B), intent(in) :: ietflag + integer(I4B), intent(in) :: ipos + integer(I4B), intent(inout) :: ierr + real(DP) :: thick, thickold + integer(I4B) :: idelt, iwav, ik +! ------------------------------------------------------------------------------ + this%totflux = DZERO + this%etact = DZERO + thick = this%celtop - this%watab + thickold = this%celtop - this%watabold + ! + ! no uz, clear waves + if ( thickold < DZERO ) then + do iwav = 1, 6 + this%uzthst(iwav) = this%thtr + this%uzdpst(iwav) = DZERO + this%uzspst(iwav) = DZERO + this%uzflst(iwav) = DZERO + this%nwavst = 1 + end do + end if + idelt = 1 + do ik = 1, idelt + call this%uzflow(thick,thickold,delt,ietflag,ipos,ierr) + if ( ierr > 0 ) return + totfluxtot = totfluxtot + this%totflux + end do + ! set residual pet after uz et + this%gwpet = this%pet - this%etact/delt + if ( this%gwpet < DZERO ) this%gwpet = DZERO + return + end subroutine routewaves +! +! ------------------------------------------------------------------------------ + + subroutine wave_shift(this1,this2,shft,strt,stp,cntr) +! ****************************************************************************** +! wave_shift -- copy waves or shift waves in arrays +! +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class (UzfKinematicType) :: this1 + type (UzfKinematicType) :: this2 + integer(I4B) :: j,shft,strt,stp,cntr +! ------------------------------------------------------------------------------ + do j = strt, stp, cntr + this1%uzthst(j) = this2%uzthst(j+shft) + this1%uzdpst(j) = this2%uzdpst(j+shft) + this1%uzflst(j) = this2%uzflst(j+shft) + this1%uzspst(j) = this2%uzspst(j+shft) + end do + this1%nwavst = this2%nwavst + return + end subroutine +! +! ------------------------------------------------------------------------------ + + subroutine uzflow(this,thick,thickold,delt,ietflag,ipos,ierr) +! ****************************************************************** +! uzflow----moc solution for kinematic wave equation +! ****************************************************************** +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + !modules + ! -- dummy + class (UzfKinematicType) :: 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) :: ipos + integer(I4B), intent(inout) :: ierr + real(DP) :: ffcheck,time,feps1,feps2 + real(DP) :: thetadif,thetab,fluxb,oldsflx + integer(I4B) :: itrailflg,itester +! ------------------------------------------------------------------ + time = DZERO + this%totflux = DZERO + itrailflg = 0 + oldsflx = this%uzflst(this%nwavst) + call this%factors(feps1,feps2) + !check for falling or rising water table + if ( (thick-thickold) > feps1 ) then + thetadif = abs(this%uzthst(1)-this%thtr) + if ( thetadif > DEM6 ) then + call this%wave_shift(this,-1,this%nwavst+1,2,-1) + if ( this%uzdpst(2) < DEM30 ) this%uzdpst(2) = (this%ntrail+DTWO)*DEM6 + if ( this%uzthst(2) > this%thtr ) then + this%uzspst(2) = this%uzflst(2)/(this%uzthst(2)-this%thtr) + else + this%uzspst(2) = DZERO + end if + this%uzthst(1) = this%thtr + this%uzflst(1) = DZERO + this%uzspst(1) = DZERO + this%uzdpst(1) = thick + this%nwavst = this%nwavst + 1 + if ( this%nwavst.GE.this%nwav ) then + !too many waves error + ierr = 1 + return + end if + else + this%uzdpst(1) = thick + end if + end if + thetab = this%uzthst(1) + fluxb = this%uzflst(1) + this%totflux = DZERO + itester = 0 + ffcheck = (this%surflux-this%uzflst(this%nwavst)) + ! + !crease new waves in infiltration changes + if ( ffcheck > feps2 .OR. ffcheck < -feps2 ) then + this%nwavst = this%nwavst + 1 + if ( this%nwavst.GE.this%nwav ) then + ! + !too many waves error + ierr = 1 + return + end if + else if ( this%nwavst.EQ.1 ) then + itester = 1 + end if + if ( this%nwavst > 1 ) then + IF ( ffcheck < -feps2) THEN + call this%trailwav(ierr) + if ( ierr > 0 ) return + itrailflg = 1 + end if + call this%leadwav(time,itester,itrailflg,thetab,fluxb,ffcheck,feps2,delt,ipos) + end if + if ( itester.EQ.1 ) then + this%totflux = this%totflux + (delt-time)*this%uzflst(1) + time = DZERO + itester = 0 + end if + ! + !simulate et + if ( ietflag > 0 ) call this%uzet(delt,ietflag,ierr) + if ( ierr > 0 ) return + return + end subroutine uzflow +! +! ------------------------------------------------------------------------------ + + subroutine factors(this,feps1,feps2) +! ****************************************************************************** +! factors----calculate unit specific tolerances +! ****************************************************************************** +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + !modules + ! -- dummy + class (UzfKinematicType) :: this + 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.EQ.1 ) then + factor1 = DONE/86400.D0 + else if ( ITMUNI.EQ.2 ) then + factor1 = DONE/1440.D0 + else if ( ITMUNI.EQ.3 ) then + factor1 = DONE/24.0D0 + else if ( ITMUNI.EQ.5 ) then + factor1 = 365.0D0 + end if + factor2 = DONE/0.3048 + feps1 = feps1*factor1*factor2 + feps2 = feps2*factor1*factor2 + end subroutine factors +! +! ------------------------------------------------------------------------------ + + subroutine trailwav(this,ierr) +! ****************************************************************************** +! trailwav----create and set trail waves +! ****************************************************************************** +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + !modules + !arguments + integer(I4B), intent(inout) :: ierr + ! -- dummy + class (UzfKinematicType) :: this + 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 +! ------------------------------------------------------------------ + eps_m1 = dble(this%eps) - DONE + thtsrinv = DONE/(this%thts-this%thtr) + nwavstm1 = this%nwavst - 1 + !initialize trailwaves + smoist = (((this%surflux/this%vks)**(DONE/this%eps))* & + (this%thts-this%thtr)) + this%thtr + if ( this%uzthst(nwavstm1)-smoist > DEM9 ) then + fnuminc = DZERO + do jk = 1, this%ntrail + fnuminc = fnuminc + float(jk) + end do + smoistinc = (this%uzthst(nwavstm1)-smoist)/(fnuminc-DONE) + jj = this%ntrail + ftrail = dble(this%ntrail) + DONE + do j = this%nwavst, this%nwavst + this%ntrail - 1 + if ( j > this%nwav ) then + ! too many waves error + ierr = 1 + return + end if + if( j > this%nwavst ) then + this%uzthst(j) = this%uzthst(j-1) & + - ((ftrail-float(jj))*smoistinc) + else + this%uzthst(j) = this%uzthst(j-1) - DEM9 + end if + jj = jj - 1 + if ( this%uzthst(j).LE.this%thtr+DEM9 ) this%uzthst(j) & + = this%thtr + DEM9 + this%uzflst(j) = this%vks*(((this%uzthst(j)-this%thtr) & + *thtsrinv)**this%eps) + theta2 = this%uzthst(j-1) + flux2 = this%uzflst(j-1) + flux1 = this%uzflst(j) + theta1 = this%uzthst(j) + this%uzspst(j) = this%leadspeed(theta1,theta2,flux1,flux2) + this%uzdpst(j) = DZERO + if ( j==this%nwavst ) then + this%uzdpst(j) = this%uzdpst(j) + (this%ntrail+1)*DEM9 + else + this%uzdpst(j) = this%uzdpst(j-1) - DEM9 + end if + end do + this%nwavst = this%nwavst + this%ntrail - 1 + if ( this%nwavst.GE.this%nwav ) then + !too many waves error + ierr = 1 + return + end if + else + this%uzdpst(this%nwavst) = DZERO + this%uzflst(this%nwavst) = this%vks*(((this%uzthst(this%nwavst)- & + this%thtr)*thtsrinv)**this%eps) + this%uzthst(this%nwavst) = smoist + theta2 = this%uzthst(this%nwavst-1) + flux2 = this%uzflst(this%nwavst-1) + flux1 = this%uzflst(this%nwavst) + theta1 = this%uzthst(this%nwavst) + this%uzspst(this%nwavst) = this%leadspeed(theta1,theta2,flux1,flux2) + end if + return + end subroutine trailwav + + + subroutine leadwav(this,time,itester,itrailflg,thetab,fluxb, & + ffcheck,feps2,delt,ipos) +! ****************************************************************** +! leadwav----create a lead wave and route over time step +! ****************************************************************** +! SPECIFICATIONS: +! ---------------------------------------------------------------------- + !modules + !arguments + class (UzfKinematicType) :: 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, Itrailflg + real(DP), intent(inout) :: ffcheck + real(DP), intent(in) :: delt + integer(I4B), intent(in) :: ipos + ! -- dummy + 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)) + allocate(more(this%nwavst)) + ftest = DZERO + eps_m1 = dble(this%eps) - DONE + thtsrinv = DONE/(this%thts-this%thtr) + ! + !initialize new wave + if ( Itrailflg.EQ.0 ) then + if ( ffcheck > feps2 ) then + this%uzflst(this%nwavst) = this%surflux + IF ( this%uzflst(this%nwavst) < DEM30 ) & + this%uzflst(this%nwavst) = DZERO + this%uzthst(this%nwavst) = & + (((this%uzflst(this%nwavst)/this%vks)** & + (DONE/this%eps))*(this%thts-this%thtr)) & + + this%thtr + theta2 = this%uzthst(this%nwavst) + flux2 = this%uzflst(this%nwavst) + flux1 = this%uzflst(this%nwavst-1) + theta1 = this%uzthst(this%nwavst-1) + this%uzspst(this%nwavst) = this%leadspeed(theta1,theta2,flux1,flux2) + this%uzdpst(this%nwavst) = 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) + if ( this%nwavst.EQ.0 ) Itester = 1 + if ( Itester.NE.1 ) then + do while ( diff > DEM6 ) + nwavp1 = this%nwavst + 1 + timedt = delt - Time + do j = 1, this%nwavst + checktime(j) = DEP20 + more(j) = 0 + end do + shortest = timedt + if ( this%nwavst > 2 ) then + j = 2 + ! + !calculate time until wave overtakes wave ahead + nwavp1 = this%nwavst + 1 + do while ( j < nwavp1 ) + ftest = this%uzspst(j-1)-this%uzspst(j) + if ( abs(ftest) > DEM30 ) then + checktime(j) = (this%uzdpst(j)-this%uzdpst(j-1))/(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 > 1 ) then + if ( this%uzspst(2) > DZERO ) then + bottom = this%uzspst(2) + if ( bottom < DEM15 ) bottom = DEM15 + bottomtime = (this%uzdpst(1)-this%uzdpst(2))/bottom + if ( bottomtime < DZERO ) bottomtime = DEM12 + end if + end if + ! + !calc time for wave interception + jshort = 0 + do j = this%nwavst, 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 + if ( shortest-checktime(j) < DEM9 ) then + if ( j.ne.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) = this%uzdpst(j) + this%uzspst(j) & + *bottomtime + j = j + 1 + end do + fluxb = this%uzflst(2) + thetab = this%uzthst(2) + iflx = 1 + call this%wave_shift(this,1,1,this%nwavst-1,1) + iremove = 1 + timenew = Time + bottomtime + this%uzspst(1) = DZERO + ! + !do waves intercept before end of time step + else if ( fcheck < DZERO .AND. this%nwavst > 2 ) then + j = 2 + do while ( j < nwavp1 ) + this%uzdpst(j) = this%uzdpst(j) + this%uzspst(j) & + *shortest + j = j + 1 + end do + ! + !combine waves that intercept, remove a wave + j = 3 + l = j + do while ( j < this%nwavst+1 ) + if ( more(j).EQ.1 ) then + l = j + theta2 = this%uzthst(j) + flux2 = this%uzflst(j) + if ( j.EQ.3 ) then + flux1 = fluxb + theta1 = thetab + else + flux1 = this%uzflst(j-2) + theta1 = this%uzthst(j-2) + end if + this%uzspst(j) = this%leadspeed(theta1,theta2,flux1,flux2) + ! + !update waves. + call this%wave_shift(this,1,l-1,this%nwavst-1,1) + l = this%nwavst + 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) = this%uzdpst(j) + this%uzspst(j) & + *timedt + j = j + 1 + end do + timenew = delt + end if + this%totflux = this%totflux + fluxhld2*(timenew-time) + if ( iflx.EQ.1 ) then + fluxhld2 = this%uzflst(1) + iflx = 0 + end if + ! + !remove dead waves + this%nwavst = this%nwavst - iremove + Time = timenew + diff = delt - Time + if ( this%nwavst.EQ.1 ) then + Itester = 1 + exit + end if + end do + end if + deallocate(checktime) + deallocate(more) + return + end subroutine leadwav +! + +! + function leadspeed(this,theta1,theta2,flux1,flux2) +! ****************************************************************** +! leadspeed----calculates waves speed from dflux/dtheta +! ****************************************************************** +! SPECIFICATIONS: +! ---------------------------------------------------------------------- + !modules + !arguments + class (UzfKinematicType) :: this + real(DP), intent(in) :: theta1 + real(DP), intent(in) :: theta2 + real(DP), intent(in) :: flux1 + real(DP), intent(inout) :: flux2 + ! -- dummy + real(DP) :: comp1, comp2, thsrinv, epsfksths + real(DP) :: eps_m1, fhold, comp3 + real(DP) :: leadspeed +! ---------------------------------------------------------------------- + eps_m1 = dble(this%eps) - DONE + thsrinv = DONE/(this%thts-this%thtr) + epsfksths = this%eps*this%vks*thsrinv + comp1 = theta2-theta1 + comp2 = abs(flux2-flux1) + comp3 = theta1 - this%thtr + if ( comp2 < DEM15 ) flux2 = flux1 + DEM15 + if ( abs(comp1) < DEM30 ) then + if ( comp3 > DEM30 ) fhold = ((comp3)*thsrinv)**this%eps + if ( fhold < DEM30 ) fhold = DEM30 + leadspeed = epsfksths * (fhold**eps_m1) + else + leadspeed = (flux2-flux1)/(theta2-theta1) + end if + if ( leadspeed < DEM30 ) leadspeed = DEM30 + end function leadspeed +! +! ---------------------------------------------------------------------- + + function unsat_stor(this,d1) +! ****************************************************************** +! unsat_stor---- sums up mobile water over depth interval +! ****************************************************************** +! SPECIFICATIONS: +! ---------------------------------------------------------------------- + !modules + !arguments + class (UzfKinematicType) :: this + real(DP), intent(inout) :: d1 + ! -- dummy + real(DP) :: fm, unsat_stor + integer(I4B) :: j, k,nwavm1,jj +! ---------------------------------------------------------------------- + fm = DZERO + j = this%nwavst + 1 + k = this%nwavst + nwavm1 = k-1 + if ( d1 > this%uzdpst(1) ) d1 = this%uzdpst(1) + ! + !find deepest wave above depth d1, counter held as j + do while ( k > 0 ) + if ( this%uzdpst(k) - d1 < -DEM30) j = k + k = k - 1 + end do + if ( j > this%nwavst ) then + fm = fm + (this%uzthst(this%nwavst)-this%thtr)*d1 + elseif ( this%nwavst > 1 ) then + if ( j > 1 ) then + fm = fm + (this%uzthst(j-1)-this%thtr) & + *(d1-this%uzdpst(j)) + end if + do jj = j, nwavm1 + fm = fm + (this%uzthst(jj)-this%thtr) & + *(this%uzdpst(jj) & + -this%uzdpst(jj+1)) + end do + fm = fm + (this%uzthst(this%nwavst)-this%thtr) & + *(this%uzdpst(this%nwavst)) + else + fm = fm + (this%uzthst(1)-this%thtr)*d1 + end if + unsat_stor = fm + end function unsat_stor +! +! ---------------------------------------------------------------------- + + subroutine update_wav(this,ipos,delt,rout,rsto,ret,etflg,iss,itest) +! ****************************************************************** +! update_wav---- update to new state of uz at end of time step +! ****************************************************************** +! SPECIFICATIONS: +! ---------------------------------------------------------------------- + !modules + !arguments + class (UzfKinematicType) :: this + integer(I4B), intent(in) :: ipos,etflg,itest,iss + real(DP), intent(in) :: delt + real(DP), intent(inout) :: rout + real(DP), intent(inout) :: rsto + real(DP), intent(inout) :: ret + ! -- dummy + real(DP) :: uzstorhold,bot,fm,depthsave,top + real(DP) :: thick,thtsrinv + integer(I4B) :: nwavhld, k,j +! ---------------------------------------------------------------------- +! + bot = this%watab + top = this%celtop + thick = top-bot + nwavhld = this%nwavst + if ( itest == 1 ) then +! this%uzflst(1) = this%surflux !rgn 5/25/17 + this%uzflst(1) = DZERO + this%uzthst(1) = this%thtr + this%delstor = - this%uzstor + this%uzstor = DZERO + uzstorhold = DZERO + rout = rout + this%totflux*this%uzfarea/delt + return + end if + if ( iss == 1 ) then + if ( this%thts-this%thtr < DEM7 ) then + thtsrinv = DONE/DEM7 + else + thtsrinv = DONE/(this%thts-this%thtr) + end if + this%totflux = this%surflux*delt + this%watabold = this%watab + this%uzthst(1) = this%thti + this%uzflst(1) = this%vks*(((this%uzthst(1)-this%thtr) & + *thtsrinv)**this%eps) + this%uzdpst(1) = thick + this%uzspst(1) = thick + this%nwavst = 1 + this%uzstor = thick*(this%thti-this%thtr)*this%uzfarea + this%delstor = DZERO + rout = rout + this%totflux*this%uzfarea/delt + else + ! + !water table rises through waves + if ( this%watab - this%watabold > DEM30 ) then + depthsave = this%uzdpst(1) + j = 0 + k = this%nwavst + do while ( k > 0 ) + if ( this%uzdpst(k) - thick < -DEM30) j = k + k = k - 1 + end do + this%uzdpst(1) = thick + if ( j > 1 ) then + this%uzspst(1) = dzero + this%nwavst = this%nwavst - j + 2 + this%uzthst(1) = this%uzthst(j-1) + this%uzflst(1) = this%uzflst(j-1) + if ( j > 2 ) call this%wave_shift(this,j-2,2,nwavhld-(j-2),1) + elseif ( j == 0 ) then + this%uzspst(1) = dzero + this%uzthst(1) = this%uzthst(this%nwavst) + this%uzflst(1) = this%uzflst(this%nwavst) + this%nwavst = 1 + end if + end if + ! + !calculate new unsat. storage + if ( thick > DZERO ) then + fm = this%unsat_stor(thick) + uzstorhold = this%uzstor + this%uzstor = fm*this%uzfarea + this%delstor = this%uzstor - uzstorhold + else + this%uzspst(1) = DZERO + this%nwavst = 1 + this%uzthst(1) = this%thtr + this%uzflst(1) = DZERO + this%delstor = - this%uzstor + this%uzstor = DZERO + uzstorhold = DZERO + end if + this%watabold = this%watab + rout = rout + this%totflux*this%uzfarea/delt + rsto = rsto + this%delstor/delt + if ( etflg > 0 ) ret = ret + this%etact*this%uzfarea/delt + end if + end subroutine + + subroutine uzet(this,delt,ietflag,ierr) +! ****************************************************************** +! uzet---- remove water from uz due to et +! ****************************************************************** +! SPECIFICATIONS: +! ---------------------------------------------------------------------- + !modules + ! -- dummy + class (UzfKinematicType) :: this + real(DP), intent(in) :: delt + integer(I4B), intent(in) :: ietflag + integer(I4B), intent(inout) :: ierr + ! -- local + type(UzfKinematicType), pointer :: 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 +! ------------------------------------------------------------------ + this%etact = DZERO + if ( this%extdpuz < DEM7 ) return + petsub = this%rootact*this%pet*this%extdpuz/this%extdp + thetaout = delt*petsub/this%extdp + if ( ietflag==1 ) thetaout = delt*this%pet/this%extdp + if ( thetaout < DEM10 ) return + depth = this%uzdpst(1) + st = this%Unsat_stor(depth) + if ( st < DEM4 ) return + ! + !allocate temporary wave storage. + allocate(uzfktemp) + allocate(uzfktemp%uzdpst(this%nwavst)) + allocate(uzfktemp%uzthst(this%nwavst)) + allocate(uzfktemp%uzflst(this%nwavst)) + allocate(uzfktemp%uzspst(this%nwavst)) + allocate(uzfktemp%nwavst) + ha = this%ha + nwv = this%nwavst + itest = 0 + ! + ! store original wave characteristics + call uzfktemp%wave_shift(this,0,1,Nwv,1) + factor = DONE + this%etact = DZERO + if ( this%thts-this%thtr < DEM7 ) then + thtsrinv = 1.0/DEM7 + else + thtsrinv = DONE/(this%thts-this%thtr) + end if + epsfksthts = this%eps*this%vks*thtsrinv + this%Etact = DZERO + fmp = DZERO + extwc1 = this%extwc - this%thtr + 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 == 1 .AND. this%uzdpst(1) <= this%extdpuz ) then + if ( ietflag == 2 ) then + tho = this%uzthst(1) + fktho = this%uzflst(1) + hcap = this%caph(tho) + thetaout = this%rate_et_z(factor,fktho,hcap) + end if + if ( (this%uzthst(1)-thetaout) > this%thtr+extwc1 ) then + this%uzthst(1) = this%uzthst(1) - thetaout + this%uzflst(1) = this%vks*(((this%uzthst(1)-this%thtr)*thtsrinv)**this%eps) + else if ( this%uzthst(1) > this%thtr+extwc1 ) then + this%uzthst(1) = this%thtr + extwc1 + this%uzflst(1) = this%vks*(((this%uzthst(1)-this%thtr)*thtsrinv)**this%eps) + end if + ! + !all waves shallower than extinction depth + else if ( this%nwavst > 1 .AND. this%uzdpst(this%nwavst) > this%extdpuz) then + if ( ietflag == 2 ) then + tho = this%uzthst(this%nwavst) + fktho = this%uzflst(this%nwavst) + hcap = this%caph(tho) + thetaout = this%rate_et_z(factor,fktho,hcap) + end if + if ( this%uzthst(this%nwavst)-thetaout > this%thtr+extwc1 ) then + this%uzthst(this%nwavst+1) = this%uzthst(this%nwavst) - thetaout + numadd = 1 + else if ( this%uzthst(this%nwavst) > this%thtr+extwc1 ) then + this%uzthst(this%nwavst+1) = this%thtr + extwc1 + numadd = 1 + end if + if ( numadd == 1 ) then + this%uzflst(this%nwavst+1) = this%vks* & + (((this%uzthst(this%nwavst+1)- & + this%thtr)*thtsrinv)**this%eps) + theta2 = this%uzthst(this%nwavst+1) + flux2 = this%uzflst(this%nwavst+1) + flux1 = this%uzflst(this%nwavst) + theta1 = this%uzthst(this%nwavst) + this%uzspst(this%nwavst+1) = this%leadspeed(theta1,theta2,flux1,flux2) + this%uzdpst(this%nwavst+1) = this%extdpuz + this%nwavst = this%nwavst + 1 + if ( this%nwavst > this%nwav ) 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 == 1 ) then + if ( ietflag == 2 ) then + tho = this%uzthst(1) + fktho = this%uzflst(1) + hcap = this%caph(tho) + thetaout = this%rate_et_z(factor,fktho,hcap) + end if + if ( (this%uzthst(1)-thetaout) > this%thtr+extwc1 ) then + if ( thetaout > DEM30 ) then + this%uzthst(2) = this%uzthst(1) - thetaout + this%uzflst(2) = this%vks*(((this%uzthst(2)-this%thtr)* & + thtsrinv)**this%eps) + this%uzdpst(2) = this%extdpuz + theta2 = this%uzthst(2) + flux2 = this%uzflst(2) + flux1 = this%uzflst(1) + theta1 = this%uzthst(1) + this%uzspst(2) = this%leadspeed(theta1,theta2,flux1,flux2) + this%nwavst = this%nwavst + 1 + if ( this%nwavst > this%nwav ) then + ! + !too many waves error + ierr = 1 + goto 500 + end if + end if + else if ( this%uzthst(1) > this%thtr+extwc1 ) then + if ( thetaout > DEM30 ) then + this%uzthst(2) = this%thtr + extwc1 + this%uzflst(2) = this%vks*(((this%uzthst(2)- & + this%thtr)*thtsrinv)**this%eps) + this%uzdpst(2) = this%extdpuz + theta2 = this%uzthst(2) + flux2 = this%uzflst(2) + flux1 = this%uzflst(1) + theta1 = this%uzthst(1) + this%uzspst(2) = this%leadspeed(theta1,theta2,flux1,flux2) + this%nwavst = this%nwavst + 1 + if ( this%nwavst > this%nwav ) then + !too many waves error + ierr = 1 + goto 500 + end if + end if + end if + else + ! + !extinction depth splits waves + if ( this%uzdpst(1)-this%extdpuz > DEM7 ) then + j = 2 + jk = 0 + ! + !locate extinction depth between waves + do while ( jk == 0 ) + diff = this%uzdpst(j) - this%extdpuz + if ( diff > dzero ) then + j = j + 1 + else + jk = 1 + end if + end do + kk = j + if ( this%uzthst(j) > this%thtr+extwc1 ) then + ! + !create a wave at extinction depth + if ( abs(diff) > DEM5 ) then + call this%wave_shift(this,-1,this%nwavst+1,j,-1) + this%uzdpst(j) = this%extdpuz + this%nwavst = this%nwavst + 1 + if ( this%nwavst > this%nwav ) then + ! + !too many waves error + ierr = 1 + goto 500 + end if + end if + kk = j + else + jhold = this%nwavst + i = j + 1 + do while ( i < this%nwavst ) + if ( this%uzthst(i) > this%thtr+extwc1 ) then + jhold = i + i = this%nwavst + 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.LE.this%nwavst) + if ( ietflag==2 ) then + tho = this%uzthst(kk) + fktho = this%uzflst(kk) + hcap = this%caph(tho) + thetaout = this%rate_et_z(factor,fktho,hcap) + end if + if ( this%uzthst(kk) > this%thtr+extwc1 ) then + if ( this%uzthst(kk)-thetaout > this%thtr+extwc1 ) then + this%uzthst(kk) = this%uzthst(kk) - thetaout + else if ( this%uzthst(kk) > this%thtr+extwc1 ) then + this%uzthst(kk) = this%thtr + extwc1 + end if + if ( kk.EQ.1 ) then + this%uzflst(kk) = this%vks*(((this%uzthst(kk)-this%thtr)*thtsrinv)**this%eps) + end if + if ( kk > 1 ) then + flux1 = this%vks*((this%uzthst(kk-1)-this%thtr)*thtsrinv)**this%eps + flux2 = this%vks*((this%uzthst(kk)-this%thtr)*thtsrinv)**this%eps + this%uzflst(kk) = flux2 + theta2 = this%uzthst(kk) + theta1 = this%uzthst(kk-1) + this%uzspst(kk) = this%leadspeed(theta1,theta2,flux1,flux2) + end if + end if + kk = kk + 1 + end do + end if + ! + !calculate aet + kj = 1 + do while ( kj.LE.this%nwavst-1 ) + if ( abs(this%uzthst(kj)-this%uzthst(kj+1)) < DEM6 ) then + call this%wave_shift(this,1,kj+1,this%nwavst-1,1) + kj = kj - 1 + this%nwavst = this%nwavst - 1 + end if + kj = kj + 1 + end do + depth = this%uzdpst(1) + fm = this%Unsat_stor(depth) + this%etact = st - fm + fm = this%Etact/delt + if ( this%Etact < dzero ) then + call this%wave_shift(uzfktemp,0,1,Nwv,1) + this%nwavst = Nwv + this%Etact = dzero + elseif ( petsub-fm < -DEM15 .AND. ietflag==2 ) then + ! aet greater than pet, reset and try again + call this%wave_shift(uzfktemp,0,1,Nwv,1) + this%nwavst = 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 deallocate(uzfktemp%uzdpst) + deallocate(uzfktemp%uzthst) + deallocate(uzfktemp%uzflst) + deallocate(uzfktemp%uzspst) + deallocate(uzfktemp%nwavst) + deallocate(uzfktemp) + return + end subroutine uzet +! +! ---------------------------------------------------------------------- + + function caph(this,tho) +! ****************************************************************** +! caph---- calculate capillary pressure head from B-C equation +! ****************************************************************** +! SPECIFICATIONS: +! ---------------------------------------------------------------------- + !modules + class (UzfKinematicType) :: this + real(DP), intent(in) :: tho + ! -- dummy + real(DP) :: caph,lambda,star +! ---------------------------------------------------------------------- + caph = -DEM6 + star = (tho-this%thtr)/(this%thts-this%thtr) + if ( star < DEM15 ) star = DEM15 + lambda = DTWO/(this%eps-DTHREE) + if ( star > DEM15 ) then + if ( tho-this%thts < DEM15 ) then + caph = this%ha*star**(-DONE/lambda) + else + caph = DZERO + end if + end if + end function caph + + function rate_et_z(this,factor,fktho,h) +! ****************************************************************** +! rate_et_z---- capillary pressure based uz et +! ****************************************************************** +! SPECIFICATIONS: +! ---------------------------------------------------------------------- + !modules + !arguments + class (UzfKinematicType) :: this + real(DP), intent(in) :: factor,fktho,h + ! -- dummy + real(DP) :: rate_et_z +! ---------------------------------------------------------------------- + rate_et_z = factor*fktho*(h-this%hroot) + if ( rate_et_z < DZERO ) rate_et_z = DZERO + end function rate_et_z +! +! ------------------------------------------------------------------------------ +! end of BndUzfKinematic object end module UzfKinematicModule \ No newline at end of file diff --git a/src/Model/ModelUtilities/BoundaryPackage.f90 b/src/Model/ModelUtilities/BoundaryPackage.f90 index 79a384eb4bb..ad2e4434441 100644 --- a/src/Model/ModelUtilities/BoundaryPackage.f90 +++ b/src/Model/ModelUtilities/BoundaryPackage.f90 @@ -1,1584 +1,1705 @@ -module BndModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: LENAUXNAME, LENBOUNDNAME, LENFTYPE, & - DZERO, LENMODELNAME, LENPACKAGENAME, & - LENORIGIN, MAXCHARLEN, LINELENGTH, & - DNODATA - 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 - - implicit none - - private - public :: BndType, AddBndToList, GetBndFromList - private :: CastAsBndClass - - type, extends(NumericalPackageType) :: BndType - ! -- characters - character(len=500) :: 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 - - 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 - ! - ! -- 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) :: i, ierr, nlinks, nlist, node - logical :: isfound, endOfBlock - character(len=LINELENGTH) :: line, errmsg - type(TimeSeriesLinkType), pointer :: tsLink => null() - ! -- 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) -! ****************************************************************************** -! 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 -! ------------------------------------------------------------------------------ - ! -- 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) -! ****************************************************************************** -! 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 - ! -- local -! ------------------------------------------------------------------------------ - - ! - ! -- Newton-Raphson under-relaxation - ! - ! -- return - return - end subroutine bnd_nur - - subroutine bnd_cc(this, iend, icnvg) -! ****************************************************************************** -! bnd_cc -- additional convergence check for advanced packages -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(BndType), intent(inout) :: this - integer(I4B), intent(in) :: iend - integer(I4B), intent(inout) :: icnvg - ! -- 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: kstp, kper, 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=LENPACKAGENAME) :: text - integer(I4B) :: imover - integer(I4B) :: i, node, n2, ibinun - real(DP) :: q - real(DP) :: qtomvr - real(DP) :: ratin, ratout, rrate - integer(I4B) :: ibdlbl, naux - ! -- for observations - character(len=LENBOUNDNAME) :: bname - ! -- formats - character(len=*), parameter :: fmttkk = & - "(1X,/1X,A,' PERIOD ',I0,' STEP ',I0)" -! ------------------------------------------------------------------------------ - ! - ! -- 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 - ! - ! -- Clear accumulators and set flags - ratin = DZERO - ratout = DZERO - ibdlbl = 0 - ! - ! -- 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 - if(ibdlbl == 0) write(this%iout,fmttkk) & - this%text // ' (' // trim(this%name) // ')', kper, kstp - call this%dis%print_list_entry(i, node, rrate, this%iout, & - bname) - ibdlbl=1 - 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%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 - ibdlbl = 0 - text = trim(adjustl(this%text)) // '-TO-MVR' - text = adjustr(text) - ! - ! -- 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 - if(ibdlbl == 0) write(this%iout,fmttkk) text, kper, kstp - call this%dis%print_list_entry(i, node, rrate, this%iout, & - bname) - ibdlbl=1 - 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 - ! - ! -- 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 - call mem_setptr(this%icelltype, 'ICELLTYPE', & - trim(adjustl(this%name_model))//' NPF') - ! - ! -- 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) = '' - ! - ! -- 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 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 - - 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 47e3c3749bf..b327c18df3a 100644 --- a/src/Model/ModelUtilities/Connections.f90 +++ b/src/Model/ModelUtilities/Connections.f90 @@ -1,1253 +1,1356 @@ -module ConnectionsModule - - use ArrayReadersModule, only: ReadArray - use KindModule, only: DP, I4B - use ConstantsModule, only: LENMODELNAME, LENORIGIN - use BlockParserModule, only: BlockParserType - - implicit none - private - public :: ConnectionsType - - 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 - 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 :: read_from_block - procedure :: read_connectivity_from_block - procedure :: set_cl1_cl2_from_fleng - procedure :: disconnections - procedure :: disvconnections - procedure :: iajausr - procedure :: getjaindex - 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 - ! - ! -- 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) - ! - ! -- Return - return - end subroutine allocate_arrays - - subroutine read_from_block(this, name_model, nodes, nja, inunit, iout) -! ****************************************************************************** -! read_from_block -- Read connection information from input block -! ****************************************************************************** -! -! 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 - character(len=*), intent(in) :: name_model - integer(I4B), intent(in) :: nodes - integer(I4B), intent(in) :: nja - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: iout - ! -- local - character(len=LINELENGTH) :: errmsg, keyword - integer(I4B) :: ii,n,m - integer(I4B) :: ierr - logical :: isfound, endOfBlock - integer(I4B),dimension(:),allocatable :: ihctemp - real(DP),dimension(:),allocatable :: cl12temp - real(DP),dimension(:),allocatable :: hwvatemp - real(DP),dimension(:),allocatable :: angldegx - integer(I4B), parameter :: nname = 6 - 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: ',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'/ -! ------------------------------------------------------------------------------ - ! - ! -- Allocate and initialize dimensions - call this%allocate_scalars(name_model) - this%nodes = nodes - this%nja = nja - this%njas = (this%nja - this%nodes) / 2 - ! - call this%allocate_arrays() - ! - ! -- allocate temporary arrays for reading - allocate(ihctemp(this%nja)) - allocate(cl12temp(this%nja)) - allocate(hwvatemp(this%nja)) - ! - ! -- Initialize block parser - call this%parser%Initialize(inunit, iout) - ! - ! -- 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 ('IHC') - call ReadArray(this%parser%iuactive, ihctemp, aname(3), 1, & - this%nja, iout, 0) - lname(3) = .true. - case ('CL12') - call ReadArray(this%parser%iuactive, cl12temp, aname(4), 1, & - this%nja, iout, 0) - lname(4) = .true. - case ('HWVA') - call ReadArray(this%parser%iuactive, hwvatemp, aname(5), 1, & - this%nja, iout, 0) - lname(5) = .true. - case ('ANGLDEGX') - allocate(angldegx(this%nja)) - call ReadArray(this%parser%iuactive, angldegx, aname(6), 1, & - this%nja, iout, 0) - lname(6) = .true. - this%ianglex = 1 - 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(aname(n) == aname(6)) cycle - if(.not. lname(n)) then - write(ermsg,'(1x,a,a)') & - 'ERROR. REQUIRED INPUT WAS NOT SPECIFIED: ', aname(n) - call this%parser%StoreErrorUnit() - 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 - ! - ! -- 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 - deallocate(angldegx) - else - do n = 1, size(this%anglex) - this%anglex(n) = DNODATA - enddo - write(iout, '(1x,a)') 'ANGLDEGX NOT FOUND IN CONNECTIONDATA BLOCK. ' // & - 'SOME CAPABILITIES MAY BE LIMITED.' - endif - ! - ! -- deallocate temp arrays - deallocate(ihctemp) - deallocate(cl12temp) - deallocate(hwvatemp) - ! - ! -- Return - return - end subroutine read_from_block - - 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) :: 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(*, fmtsymerr) aname(2), ii, this%isym(ii) - 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, area, & - 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) :: area - 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 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) - !this%iausr => this%ia - !this%jausr => this%ja - 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 - - -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 857b0956743..1beac64c251 100644 --- a/src/Model/ModelUtilities/DiscretizationBase.f90 +++ b/src/Model/ModelUtilities/DiscretizationBase.f90 @@ -1,1411 +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() - integer(I4B), dimension(:), pointer, contiguous :: ibuff => null() - 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_from_string - procedure :: nodeu_from_cellid - procedure :: noder_from_string - procedure :: noder_from_cellid - procedure :: connection_normal - procedure :: connection_vector - 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, public :: read_list - ! - procedure, public :: record_array - procedure, public :: record_connection_array - procedure, public :: noder_to_string - procedure, public :: record_srcdst_list_header - procedure, private :: record_srcdst_list_entry - generic, public :: record_mf6_list_entry => record_srcdst_list_entry - 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) -! ****************************************************************************** -! noder_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 - - 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 -! ------------------------------------------------------------------------------ - ! - nodenumber = 0 - call store_error('Program error: DisBaseType method get_nodeuser not & - &implemented.') - call ustop() - ! - ! -- 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 - - 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 - integer(I4B) :: ival - 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 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 TdisModule, only: totimsav, perlen - 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=500), 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 the same as this column, 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 - integer(I4B) :: il, ir, ic, ncol, nrow, nlay, nval, nodeu - logical :: found - 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 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 - - 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 f587fd5174d..d2801e67afc 100644 --- a/src/Model/ModelUtilities/Mover.f90 +++ b/src/Model/ModelUtilities/Mover.f90 @@ -1,388 +1,405 @@ -module MvrModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: LENMODELNAME, LENPACKAGENAME, LINELENGTH, & - LENBUDTXT, LENAUXNAME, DZERO, DONE - - 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 - character(len=20) :: mvrtype = '' !FACTOR, THRESHOLD, UPTO, EXCESS - real(DP) :: value = DZERO !factor or rate depending on mvrtype - real(DP) :: qpold = DZERO !provider rate from last time step - real(DP) :: qpnew = DZERO !new provider rate - 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 being 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) -! ****************************************************************************** -! set -- Setup mvr object -! If mname == '', then read mname out of line -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use InputOutputModule, only: urword - use SimModule, only: ustop, store_error, store_error_unit - use MemoryManagerModule, only: mem_setptr - ! -- 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 - ! -- local - character(len=LENMODELNAME+LENPACKAGENAME+1) :: origin - integer(I4B) :: lloc, istart, istop, ival, i - real(DP) :: rval - real(DP), dimension(:), pointer, contiguous :: temp_ptr => null() - logical :: valid - character(len=LINELENGTH) :: errmsg - logical :: mnamel -! ------------------------------------------------------------------------------ - ! - ! -- 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 urword(line, lloc, istart, istop, 2, ival, rval, iout, inunit) - 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 urword(line, lloc, istart, istop, 2, ival, rval, iout, inunit) - this%irch2 = ival - ! - ! -- Read type and value - call urword(line, lloc, istart, istop, 1, ival, rval, iout, inunit) - this%mvrtype = line(istart:istop) - call urword(line, lloc, istart, istop, 3, ival, rval, iout, inunit) - this%value = rval - ! - ! -- Ensure mvrtype is valid - valid = .false. - do i = 1, size(mvrtypes) - if(this%mvrtype == mvrtypes(i)) then - valid = .true. - exit - endif - enddo - if(.not. valid) then - call store_error('ERROR. INVALID MOVER TYPE: '//trim(this%mvrtype) ) - call store_error_unit(inunit) - call ustop() - endif - ! - ! -- 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 AND THE SAME: '// & - trim(line)) - call store_error_unit(inunit) - call ustop() - endif - ! - ! -- Set pointer to provider position in array - origin = trim(this%pname1) - call mem_setptr(temp_ptr, 'QTOMVR', origin) - if(.not. associated(temp_ptr)) then - call store_error('VALID PROVIDER COULD NOT BE FOUND: '//origin) - call store_error_unit(inunit) - call ustop() - endif - if(size(temp_ptr) == 0) then - call store_error('MOVER CAPABILITY NOT ACTIVATED IN '//origin) - call store_error('ADD "MOVER" KEYWORD TO PACKAGE OPTIONS BLOCK.') - call store_error_unit(inunit) - call ustop() - endif - 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 available position in array - temp_ptr => null() - call mem_setptr(temp_ptr, 'QFORMVR', origin) - this%qformvr_ptr => temp_ptr(this%irch1) - ! - ! -- Set pointer to total available position in array - temp_ptr => null() - call mem_setptr(temp_ptr, 'QTFORMVR', origin) - this%qtformvr_ptr => temp_ptr(this%irch1) - ! - ! -- Set pointer to receiver position in array - temp_ptr => null() - origin = trim(this%pname2) - call mem_setptr(temp_ptr, 'QFROMMVR', origin) - if(.not. associated(temp_ptr)) then - call store_error('VALID RECEIVER COULD NOT BE FOUND: '//origin) - call store_error_unit(inunit) - call ustop() - endif - if(size(temp_ptr) == 0) then - call store_error('MOVER CAPABILITY NOT ACTIVATED IN '//origin) - call store_error('ADD "MOVER" KEYWORD TO PACKAGE OPTIONS BLOCK.') - call store_error_unit(inunit) - call ustop() - endif - if(this%irch2 < 1 .or. this%irch2 > size(temp_ptr)) then - call store_error('ERROR. PROVIDER 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(this%mvrtype),& - ' ', 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%mvrtype) - case('FACTOR') - ! -- 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('EXCESS') - if(qa > this%value) then - qr = qa - this%value - else - qr = DZERO - endif - case('THRESHOLD') - if(this%value > qa) then - qr = DZERO - else - qr = this%value - endif - case('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 19d86b24499..f3d1dc51f2a 100644 --- a/src/Model/ModelUtilities/PackageMover.f90 +++ b/src/Model/ModelUtilities/PackageMover.f90 @@ -1,174 +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 - - 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 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 new file mode 100644 index 00000000000..5b74088251d --- /dev/null +++ b/src/Model/ModelUtilities/UzfCellGroup.f90 @@ -0,0 +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 + +end module UzfCellGroupModule \ No newline at end of file diff --git a/src/Model/ModelUtilities/Xt3dAlgorithm.f90 b/src/Model/ModelUtilities/Xt3dAlgorithm.f90 index 0eaf4437441..d31a60ec689 100644 --- a/src/Model/ModelUtilities/Xt3dAlgorithm.f90 +++ b/src/Model/ModelUtilities/Xt3dAlgorithm.f90 @@ -1,416 +1,539 @@ -module Xt3dAlgorithmModule -! -! -- Mathematical core of the XT3D method. -! - 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) - use KindModule, only: DP, I4B - implicit real(DP) (a-h,o-z) - implicit integer(I4B) (i-n) - logical allhc0,allhc1 - dimension inbr0(nnbrmx) - dimension vc0(nnbrmx,3),vn0(nnbrmx,3) - dimension dl0(nnbrmx),dl0n(nnbrmx) - dimension ck0(3,3) - dimension inbr1(nnbrmx) - dimension vc1(nnbrmx,3),vn1(nnbrmx,3) - dimension dl1(nnbrmx),dl1n(nnbrmx) - dimension ck1(3,3) - dimension bhat0(nnbrmx),bhat1(nnbrmx) - dimension chati0(nnbrmx),chat1j(nnbrmx) -! -!.....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.) -! -!.....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) - use KindModule, only: DP, I4B - implicit real(DP) (a-h,o-z) - implicit integer(I4B) (i-n) - logical allhc,iscomp - dimension vc(nnbrmx,3),vccde(nnbrmx,3),vn(nnbrmx,3) - dimension dl0(nnbrmx),dln(nnbrmx) - dimension inbr(nnbrmx),ck(3,3) - dimension rmat(3,3),sigma(3),bhat(nnbrmx) - dimension bd(nnbrmx),be(nnbrmx),betad(nnbrmx),betae(nnbrmx) -! -!.....Compute "ahat" and "bhat" coefficients for one side of an -! interface. -! -!.....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 ! kluge note - does not handle the case of a x-sec model (old comment?) - ace = 0d0 - aee = 1d0 - ade = 0d0 - be = 0d0 - else - iscomp = .false. - do 200 il=1,nnbr - if ((il.eq.il01).or.(inbr(il).eq.0)) then - cycle - else if (dabs(vccde(il,3)).gt.1d-10) then - iscomp = .true. - exit - end if - 200 continue - 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 300 il=1,nnbr -!...........If this is connection (0,1) or inactive, skip. - if ((il.eq.il01).or.(inbr(il).eq.0)) cycle - betad(il) = (bd(il)*aee - be(il)*aed)*oodet - betae(il) = (be(il)*add - bd(il)*ade)*oodet - 300 continue -! -!........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 400 il=1,nnbr -!...........If this is connection (0,1) or inactive, skip. - if ((il.eq.il01).or.(inbr(il).eq.0)) cycle - dl0il = dl0(il) + dln(il) - bhat(il) = (sigma(2)*betad(il) + sigma(3)*betae(il))/dl0il - 400 continue -!........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) - use KindModule, only: DP, I4B - implicit real(DP) (a-h,o-z) - implicit integer(I4B) (i-n) - dimension inbr(nnbrmx) - dimension vc(nnbrmx,3),vcc(3),vcd(3),vce(3),vcmax(3),rmat(3,3) -! -!.....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. -! -!.....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 200 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 - 200 continue - if (iml0.eq.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) - use KindModule, only: DP, I4B - implicit real(DP) (a-h,o-z) - implicit integer(I4B) (i-n) - dimension rmat(3,3) - dimension vc(nnbrmx,3),vccde(nnbrmx,3) -! -!.....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. -! -!.....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 200 il=1,nnbrs - vccde(il,:) = matmul(transpose(rmat), vc(il,:)) - 200 continue -! - return - end subroutine tranvc - - subroutine abwts(nnbrmx,nnbr,inbr,il01,nde1,vccde, & - vcthresh,dl0,dln,acd,add,aed,bd) - use KindModule, only: DP, I4B - implicit real(DP) (a-h,o-z) - implicit integer(I4B) (i-n) - dimension inbr(nnbrmx) - dimension vccde(nnbrmx,3) - dimension dl0(nnbrmx), dln(nnbrmx) - dimension omwt(nnbrmx), bd(nnbrmx) -! -!.....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. -! -!.....Set the perpendicular direction of secondary interest. - nde2 = 5 - nde1 -! -!.....Begin computing "omega" weights. - omwt = 0d0 - dsum = 0d0 - vcmx = 0d0 - do 200 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) - 200 continue -! -!.....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 250 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)) - 250 continue -! -!.....Compute "b" weights. - bd = 0d0 - dsum = 0d0 - do 300 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)) - 300 continue - oodsum = 1d0/dsum - do 350 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 - 350 continue -! -!.....Compute "a" weights. - add = 1d0 - acd = 0d0 - aed = 0d0 - do 400 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) - 400 continue -! -!.....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 -! - 999 return - end subroutine abwts -! -end module Xt3dAlgorithmModule +! +! -- Mathematical core of the XT3D method. +! +module Xt3dAlgorithmModule + + use KindModule, only: DP, I4B + use ConstantsModule, only: DPREC, DONE + 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 + real(DP) :: denom +! ------------------------------------------------------------------------------ +! +!.....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. + denom = (ahat0 + ahat1) + if (abs(denom) > DPREC) then + wght1 = ahat0/(ahat0 + ahat1) + else + wght1 = DONE + end if + 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 053239ff7f9..5df97f2cae0 100644 --- a/src/Model/ModelUtilities/Xt3dInterface.f90 +++ b/src/Model/ModelUtilities/Xt3dInterface.f90 @@ -1,1746 +1,1783 @@ -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 - real(DP), pointer :: min_satthk => null() !min saturated thickness - 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_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_ac(this, moffset, sparse, nodes, ia, ja) -! ****************************************************************************** -! xt3d_ac -- Add connections for extended neighbors to the sparse matrix -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SparseModule, only: sparsematrix - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(Xt3dType) :: this - integer(I4B), intent(in) :: moffset, nodes - integer(I4B), dimension(:), intent(in) :: ia - integer(I4B), dimension(:), intent(in) :: ja - 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, nodes - iglo = i + moffset - ! -- loop over neighbors - do jj = ia(i), ia(i+1) - 1 - j = ja(jj) - ! -- loop over neighbors of neighbors - do kk = ia(j), ia(j+1) - 1 - k = 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, nodes, ia, ja, 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), intent(in) :: nodes - integer(I4B), dimension(:), intent(in) :: ia - integer(I4B), dimension(:), intent(in) :: ja - 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 + nodes - ! - ! -- allocate iax, jax, and idxglox - niax = 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, 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 = ia(i), ia(i+1) - 1 - j = 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, dis, ibound, k11, ik33, k33, sat, ik22, k22, & - inewton, min_satthk, icelltype, iangle1, iangle2, iangle3, angle1, angle2, & - angle3) -! ****************************************************************************** -! xt3d_ar -- Allocate and Read -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimModule, only: store_error, ustop - ! -- dummy - class(Xt3dType) :: this - class(DisBaseType),pointer,intent(inout) :: dis - 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 - real(DP), intent(in), pointer :: min_satthk - 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%dis => dis - 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%min_satthk => min_satthk - 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, nodes, nja, 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) :: 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 - ! - 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 - ! - if (this%lamatsaved) then - do i = 1, 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 - 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 - ! - 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 - 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 - ! - 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 - 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, nodes, nja, hnew, flowja) -! ****************************************************************************** -! xt3d_flowja -- Budget -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use Xt3dAlgorithmModule, only: qconds - ! -- dummy - class(Xt3dType) :: this - integer(I4B),intent(in) :: nodes - integer(I4B),intent(in) :: nja - real(DP),intent(inout),dimension(nodes) :: hnew - real(DP),intent(inout),dimension(nja) :: flowja - ! -- local - integer(I4B) :: n,ipos,m - 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 - 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) = qnm - flowja(this%dis%con%isym(ipos)) = -qnm - enddo - enddo - ! - ! -- Return - return - end subroutine xt3d_flowja - - subroutine xt3d_flowjahfb(this, nodes, n, m, nja, 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),intent(in) :: nodes - integer(I4B),intent(in) :: nja - integer(I4B) :: n, m - real(DP),intent(inout),dimension(nodes) :: hnew - real(DP),intent(inout),dimension(nja) :: flowja - real(DP) :: condhfb - ! -- local - ! - 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 - ! - 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 .and. .not. this%ldispersion) & + 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 +! ------------------------------------------------------------------------------ + ! + ! -- Initialize amatpc and amatpcx to zero + do n = 1, size(this%amatpc) + this%amatpc(n) = DZERO + enddo + do n = 1, size(this%amatpcx) + this%amatpcx(n) = DZERO + enddo + ! + ! -- 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 + ! + if (this%ldispersion) then + ! + ! -- xt3d is being used for dispersion + this%lamatsaved = .true. + call mem_allocate(this%iallpc, this%dis%nodes, 'IALLPC', this%origin) + this%iallpc = 1 + else + ! + ! -- xt3d is being used for flow so find where connections are + ! permanently confined + call this%xt3d_iallpc() + endif + + ! + 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) 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 (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) + 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 1634362f827..3741e042aa5 100644 --- a/src/Model/NumericalModel.f90 +++ b/src/Model/NumericalModel.f90 @@ -1,423 +1,433 @@ -module NumericalModelModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: LINELENGTH, LENBUDTXT, LENPACKAGENAME - 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 - real(DP),dimension(njasln),intent(inout) :: amatsln - integer(I4B),intent(in) :: njasln - 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 - real(DP),dimension(njasln),intent(inout) :: amatsln - integer(I4B),intent(in) :: njasln - integer(I4B), intent(in) :: inwtflag - end subroutine model_nr - - subroutine model_cc(this, kiter, iend, icnvg) - class(NumericalModelType) :: this - integer(I4B),intent(in) :: kiter - integer(I4B),intent(in) :: iend - integer(I4B),intent(inout) :: icnvg - end subroutine model_cc - - subroutine model_nur(this, neqmod, x, xtemp, dx, inewtonur) - 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 - 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 <= 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 - integer(I4B) :: ip, ipaknode, istart, istop - class(BndType), pointer :: packobj - - 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 ConstantsModule, only: DZERO + use MemoryManagerModule, only: mem_allocate + class(NumericalModelType) :: this + integer(I4B) :: i + ! + 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)) + ! + ! -- initialize + do i = 1, size(this%flowja) + this%flowja(i) = DZERO + end do + ! + ! -- 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 d138fe7ffc2..b05d89d3c2e 100644 --- a/src/Model/NumericalPackage.f90 +++ b/src/Model/NumericalPackage.f90 @@ -1,215 +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 - 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 - -end module NumericalPackageModule - + 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 + diff --git a/src/SimulationCreate.f90 b/src/SimulationCreate.f90 index 3576fffce4c..aa25514ab14 100644 --- a/src/SimulationCreate.f90 +++ b/src/SimulationCreate.f90 @@ -1,670 +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 SimModule, only: ustop, store_error, count_errors, & - store_error_unit - 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) :: simfile - !character(len=LINELENGTH) :: simlstfile -! ------------------------------------------------------------------------------ - !! - !! -- set default simfile and simlstfile - !simfile = 'mfsim.nam' - !simlstfile = 'mfsim.lst' - ! - ! -- initialize iout - iout = 0 - ! - ! -- Open simulation list file - iout = getunit() - call openfile(iout, 0, simlstfile, 'LIST', filstat_opt='REPLACE') - write(*,'(A,A)') ' Writing simulation list file: ', & - trim(adjustl(simlstfile)) - 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 InputOutputModule, 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, iout, 80) - call write_centered(MFTITLE, iout, 80) - call write_centered('VERSION '//VERSION, iout, 80) - ! - ! -- Write if develop mode - if (IDEVELOPMODE == 1) call write_centered('***DEVELOP MODE***', iout, 80) - ! - ! -- Write compiler version +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(' ', iout, 80) - call write_centered(trim(adjustl(compiler)), iout, 80) - ! - ! -- 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) :: 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(*,'(A,A)') ' Using Simulation name file: ', simfile - ! - ! -- 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, 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 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) - 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) - 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) - 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) - 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 + 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/BaseSolution.f90 b/src/Solution/BaseSolution.f90 index 63deb1fe8c0..4d4621ec1c9 100644 --- a/src/Solution/BaseSolution.f90 +++ b/src/Solution/BaseSolution.f90 @@ -53,12 +53,11 @@ subroutine sln_ot(this) class(BaseSolutionType) :: this end subroutine - subroutine sln_ca(this, kstp, kper, kpicard, isgcnvg, & - isuppress_output) + subroutine sln_ca(this, kpicard, isgcnvg, isuppress_output) use KindModule, only: DP, I4B import BaseSolutionType class(BaseSolutionType) :: this - integer(I4B),intent(in) :: kstp, kper, kpicard, isuppress_output + integer(I4B),intent(in) :: kpicard, isuppress_output integer(I4B), intent(inout) :: isgcnvg end subroutine diff --git a/src/Solution/NumericalSolution.f90 b/src/Solution/NumericalSolution.f90 index 41e702145bf..118cf984518 100644 --- a/src/Solution/NumericalSolution.f90 +++ b/src/Solution/NumericalSolution.f90 @@ -1,2603 +1,3007 @@ -! This is the numerical solution module. - -module NumericalSolutionModule - use KindModule, only: DP, I4B - use TimerModule, only: code_timer - use ConstantsModule, only: LINELENGTH, LENSOLUTIONNAME, & - DPREC, DZERO, DEM20, DEM15, DEM6, DEM4, & - DEM3, DEM2, DEM1, DHALF, & - DONE, DTHREE, DEP6, DEP20 - 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 - - 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 :: 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 - - 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 - - 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%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%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 - 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, 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 - ! - ! -- 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_NO_PTC') - call this%parser%DevOpt() - this%iallowptc = 0 - write(IOUT,'(1x,A)') 'PSEUDO-TRANSIENT CONTINUATION DISABLED' - 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 - -00020 FORMAT(1X,'SPECIFIED OPTION:',/, & - & 1X,'SOLVER INPUT VALUES WILL BE USER-SPECIFIED') -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) - ! - ! -- 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.LT.DEM3 ) this%theta = DEM3 - ! - ! -- backtracking should only be used if this%nonmeth > 0 - if (this%nonmeth < 1) then - this%ibflag = 0 - end if - ! - !-------ECHO INPUT OF NONLINEAR ITERATION PARAMETERS AND LINEAR SOLVER INDEX - WRITE(IOUT,9002) this%hclose,this%mxiter,this%iprims,this%nonmeth,this%linmeth - ! -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.NE.0)THEN - WRITE(IOUT,9003) this%theta, this%akappa, this%gamma, this%amomentum, & - this%numtrack - IF(THIS%NUMTRACK.NE.0) WRITE(IOUT,9004) this%btol,this%breduc,this%res_lim - ENDIF - -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) -9004 FORMAT(1X,'BACKTRACKING TOLERANCE FACTOR (BTOL) = ', E15.6, & - & /1X,'BACKTRACKING REDUCTION FACTOR (BREDUC) = ', E15.6, & - & /1X,'BACKTRACKING RESIDUAL LIMIT (RES_LIM) = ', E15.6) - - if(this%mxiter.le.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.gt.0 )then - WRITE(IOUT,*) '**UNDER-RELAXATION WILL BE USED***' - WRITE(IOUT,*) - isymflg = 0 - elseif ( this%nonmeth.eq.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 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) - ! - ! -- 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%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, kstp, kper, 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 SimVariablesModule, only:iout - use TdisModule, only: subtiming_begin, subtiming_end, perlen, totimsav - ! -- dummy - class(NumericalSolutionType) :: this - integer(I4B), intent(in) :: kstp - integer(I4B), intent(in) :: kper - 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 - character(len=16) :: cval - character(len=34) :: strh - integer(I4B) :: im, ic - integer(I4B) :: kiter - integer(I4B) :: iter - integer(I4B) :: nsubtimes, nstm, isubtime - integer(I4B) :: itertot - integer(I4B) :: inewtonur - integer(I4B) :: itestmat, n - integer(I4B) :: i0, i1 - integer(I4B) :: iend - integer(I4B) :: iptc - integer(I4B) :: nodeu - real(DP) :: ptcf - real(DP) :: dt - real(DP) :: totim - real(DP) :: ttform - real(DP) :: ttsoln - real(DP) :: dxmax - ! -- formats - character(len=*), parameter :: fmtnocnvg = & - "(1X,'Solution ', i0, ' did not converge for stress period ', i0, & - ' and time step ', i0)" - 11 FORMAT(//1X,'OUTER ITERATION SUMMARY',/,1x,139('-'),/, & - 18x,' OUTER INNER BACKTRACK BACKTRACK INCOMING ',& - 'OUTGOING MAXIMUM MAXIMUM CHANGE',/, & - 18x,' ITERATION ITERATION FLAG NUMBER RESIDUAL ',& - 'RESIDUAL CHANGE MODEL-(CELLID)',/, & - 1x,139('-')) - 12 FORMAT(//1X,'OUTER ITERATION SUMMARY',/,1x,87('-'),/, & - 18x,' OUTER INNER MAXIMUM ', & - 'MAXIMUM CHANGE',/, & - 18x,' ITERATION ITERATION CHANGE ', & - 'MODEL-(CELLID)',/, & - 1x,87('-')) -! ------------------------------------------------------------------------------ - ! - ! -- write header for csv output - if (kper == 1 .and. kstp == 1) then - 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 if - ! - ! -- 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 - ! - itertot = 0 - 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) - ! - ! -- 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 - ! - ! -- 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) - iptc = iptc * this%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 - - ! - ! -- Nonlinear iteration loop for this solution - this%icnvg = 0 - outerloop: do kiter = 1, this%mxiter - ! - ! --backtracking - if (this%numtrack > 0) then - if (kiter == 1) then - ! -- write header for solver output - if (this%iprims > 0) then - write (iout,11) - end if - end if - ! - ! -- call backtracking - call this%sln_backtracking(mp, cp, kiter) - else - if (kiter == 1) then - ! -- write header for solver output - if (this%iprims > 0) then - write (iout,12) - end if - end if - 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,itertot,iptc,ptcf) - call code_timer(1, ttsoln, this%ttsoln) - ! - !------------------------------------------------------- - itestmat = 0 - if(itestmat.eq.1)then - open(99,file='sol_MF6.TXT') - WRITE(99,*)'MATRIX SOLUTION FOLLOWS' - WRITE(99,67)(n,this%x(N),N=1,this%NEQ) -67 FORMAT(10(I8,G15.4)) - close(99) - stop - endif - !------------------------------------------------------- - ! -- 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) this%icnvg = 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 - if (kiter == this%mxiter) then - write(*,*) 'pseudo-transient continuation caused convergence failure' - end if - end if - end if - end if - ! - ! -- Additional convergence check for exchanges - do ic=1,this%exchangelist%Count() - cp => GetNumericalExchangeFromList(this%exchangelist, ic) - call cp%exg_cc(this%icnvg) - enddo - ! - ! -- additional convergence check for model packages - if (this%icnvg == 1) then - iend = 0 - if (kiter == this%mxiter) then - iend = 1 - end if - do im=1,this%modellist%Count() - mp => GetNumericalModelFromList(this%modellist, im) - call mp%model_cc(kiter, iend, this%icnvg) - enddo - end if - ! - !--write maximum head change from linear solver to list file - itertot = itertot + iter - if (this%iprims > 0) then - cval = 'Linear Solver ' - call this%sln_get_loc(this%lrch(1,kiter), strh) - if (this%numtrack > 0) then - WRITE(IOUT,22) cval, kiter, iter, this%hncg(kiter), & - adjustr(trim(strh)) - else - WRITE(IOUT,23) cval, kiter, iter, this%hncg(kiter), & - adjustr(trim(strh)) - end if - end if - ! - ! -- dampening - 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 if necessary - inewtonur = 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) - end do - ! - ! --update maximum head change - call this%sln_outer_check(this%hncg(kiter), this%lrch(1,kiter)) - if (inewtonur /= 0) then - call this%sln_maxval(this%neq, this%dxold, dxmax) - if (abs(dxmax) <= this%hclose .and. & - abs(this%hncg(kiter)) <= this%hclose) then - this%icnvg = 1 - end if - end if - ! - !--write maximum head change after under relaxation to list file - !itertot = itertot + iter - if (this%iprims > 0) then - cval = 'Under-relaxation' - call this%sln_get_loc(this%lrch(1,kiter), strh) - if (this%numtrack > 0) then - WRITE(IOUT,24) cval, kiter, this%hncg(kiter), adjustr(trim(strh)) - else - WRITE(IOUT,25) cval, kiter, this%hncg(kiter), adjustr(trim(strh)) - end if - end if - end if -22 FORMAT(1X,A16,1X,I10,I10,53X,1PG15.6,A34) -23 FORMAT(1X,A16,1X,I10,I10,1X,1PG15.6,A34) -24 FORMAT(1X,A16,1X,I10,10X,53X,1PG15.6,A34) -25 FORMAT(1X,A16,1X,I10,10X,1X,1PG15.6,A34) - ! - ! -- Write a message if convergence was not achieved - if (kiter == this%mxiter) then - write(iout, fmtnocnvg) this%id, kper, kstp - end if - ! - ! -- Exit outer iteration loop if converged - if (this%icnvg == 1) then - if (this%iprims > 0) then - write(iout,1010) kiter, kstp, kper, itertot - end if - exit outerloop - end if - ! - ! -- End of outer iteration loop - end do outerloop - -01010 format(/1X,I0,' CALLS TO NUMERICAL SOLUTION ','IN TIME STEP ',I0, & - ' STRESS PERIOD ',I0,/1X,I0,' TOTAL ITERATIONS') - ! - ! -- 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, itertot) - end do - ! - ! -- write summary for entire solution - call this%convergence_summary(iout, this%convnmod+1, 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 + 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, itertot, & - this%hncg(kiter), im, nodeu - else - call this%csv_convergence_summary(this%icsvout, totim, kper, kstp, & - isubtime, 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 of the sub-timestep loop - enddo - ! - ! -- end the subtiming - call subtiming_end() - ! - ! - ! -- Check if convergence for the exchange packages - 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 - - 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, itersum, 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(in) :: itersum - integer(I4B), intent(inout) :: iptc - real(DP), intent(in) :: ptcf - ! -- local - integer(I4B) :: n - integer(I4B) :: itestmat,i,i1,i2 - integer(I4B) :: iptct - 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 - iptct = iptc * this%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 - end if - end if - iptct = iptc * this%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 - 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 - - - !------------------------------------------------------- - 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) - ENDDO -66 FORMAT(I9,1X,G15.6,2X,100G15.6) - close(99) - !stop - endif - !------------------------------------------------------- - ! - ! 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=16) :: cval - integer(I4B) :: ic - integer(I4B) :: im - integer(I4B) :: nb - integer(I4B) :: btflag - integer(I4B) :: ibflag - integer(I4B) :: ibtcnt - real(DP) :: resin -! ------------------------------------------------------------------------------ - ! - 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 - 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 backtracking results -66 FORMAT(1X,A16,1X,I10,10X,I10,I10,1X,1PG15.6,1X,1PG15.6) - WRITE(IOUT,66) 'Backtracking ', kiter, ibflag, ibtcnt, & - resin, this%res_prev - ! - ! -- 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_l2norm -! ****************************************************************************** -! -! 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_l2norm -! ****************************************************************************** -! -! 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 - 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 - -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', '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, 25, 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) + ! + ! -- increment the counter storing the total number of linear iterations + this%itertot = this%itertot + iter + ! + ! -- 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(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 + ! + ! -- 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 + ! + ! -- write revised head change data after + ! newton under-relaxation + if (this%iprims > 0) then + cval = 'Newton under-relaxation' + cmsg = '*' + 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 + 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 + ! + ! -- convergence was achieved + if (this%icnvg /= 0) then + if (this%iprims > 0) then + write(iout, fmtcnvg) kiter, kstp, kper, this%itertot + end if + ! + ! -- convergence was not achieved + else + 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, kiter, this%itertot, & + this%hncg(kiter), im, nodeu + else + call this%csv_convergence_summary(this%icsvout, totim, kper, kstp, & + 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=LINELENGTH) :: title + character(len=LINELENGTH) :: tag + character(len=LENPAKLOC) :: strh + character(len=LENPAKLOC) :: strr + integer(I4B) :: ntabrows + integer(I4B) :: ntabcols + 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 +! ------------------------------------------------------------------------------ + ! + ! -- initialize local variables + iouter = 1 + ! + ! -- initialize inner iteration summary table + if (.not. associated(this%innertab)) then + ! + ! -- create outer iteration table + ! -- table dimensions + ntabrows = itertot + ntabcols = 7 + ! + ! -- initialize table and define columns + title = 'INNER ITERATION SUMMARY' + call table_cr(this%innertab, this%name, title) + call this%innertab%table_df(ntabrows, ntabcols, iu) + tag = 'TOTAL ITERATION' + call this%innertab%initialize_column(tag, 10, alignment=TABRIGHT) + tag = 'OUTER ITERATION' + call this%innertab%initialize_column(tag, 10, alignment=TABRIGHT) + tag = 'INNER ITERATION' + call this%innertab%initialize_column(tag, 10, alignment=TABRIGHT) + tag = 'MAXIMUM CHANGE' + call this%innertab%initialize_column(tag, 15, alignment=TABRIGHT) + tag = 'MAXIMUM CHANGE MODEL-(CELLID)' + call this%innertab%initialize_column(tag, LENPAKLOC, alignment=TABRIGHT) + tag = 'MAXIMUM RESIDUAL' + call this%innertab%initialize_column(tag, 15, alignment=TABRIGHT) + tag = 'MAXIMUM RESIDUAL MODEL-(CELLID)' + call this%innertab%initialize_column(tag, LENPAKLOC, alignment=TABRIGHT) + ! + ! -- reset the output unit + else + call this%innertab%set_iout(iu) + end if + ! + ! -- write the inner iteration summary to unit iu + 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) + ! + ! -- add data to innertab + call this%innertab%add_term(k) + call this%innertab%add_term(iouter) + call this%innertab%add_term(i) + call this%innertab%add_term(dv) + call this%innertab%add_term(adjustr(trim(strh))) + call this%innertab%add_term(dr) + call this%innertab%add_term(adjustr(trim(strr))) + ! + ! -- update i0 + i0 = i + end do + ! + ! -- return + return + end subroutine convergence_summary + + + subroutine csv_convergence_summary(this, iu, totim, kper, kstp, 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) :: 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, 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 42fb9ee103d..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(kstp, kper, 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(kstp, kper, 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 4a8f295aa97..2aaecfc0a28 100644 --- a/src/Solution/SparseMatrixSolver/ims8linear.f90 +++ b/src/Solution/SparseMatrixSolver/ims8linear.f90 @@ -1,2887 +1,2894 @@ - 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 - 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_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 - 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, cdroptol - 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 + + + -! 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,//) -02020 FORMAT (///,1X,'IMSLINEAR DATA INPUT ERROR:', & - & /,2X,'SCALING MUST BE USED (ISCL.GT.0) IF USING', & - & /,2X,'THE ILU0 OR MILU0 PRECONDITIONERS (IPC.EQ.2 OR', & - & /,2X,'IPC.EQ.3) WITH MATRIX REORDERING (IORD.GT.0)') -2030 FORMAT(1X,A20,1X,6(I6,1X)) -2040 FORMAT(1X,20('-'),1X,6(6('-'),1X)) -2050 FORMAT(1X,62('-'),/) -!------------------------------------------------------------------ -! -!-------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) - 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 = 3 - 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 -! -!-------PRINT MXITER,ITER1,IPC,ISCL,IORD,HCLOSE,RCLOSE - WRITE (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 .OR. THIS%DROPTOL > DZERO) THEN - WRITE (IOUT,2015) trim(adjustl(clevel)), & - & trim(adjustl(cdroptol)) - ELSE - WRITE (IOUT,'(//)') - END IF -! -!-------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 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 - integer(I4B) :: i,j -! + + + PARAMETERS + + + -! + + + FUNCTIONS + + + -! + + + FORMATS + + + - 2030 FORMAT(1X,A20,1X,6(I6,1X)) - 2040 FORMAT(1X,20('-'),1X,6(6('-'),1X)) - 2050 FORMAT(1X,62('-'),/) -! + + + 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 -! -! WRITE SUMMARY OF REORDERING INFORMATION -! TO LIST FILE - IF (IPRIMS == 2) THEN - DO i = 1, NEQ, 6 - WRITE (IOUT,2030) 'ORIGINAL NODE :', & - & (j,j=i,MIN(i+5,NEQ)) - WRITE (IOUT,2040) - WRITE (IOUT,2030) 'REORDERED INDEX :', & - & (LORDER(j),j=i,MIN(i+5,NEQ)) - WRITE (IOUT,2030) 'REORDERED NODE :', & - & (IORDER(j),j=i,MIN(i+5,NEQ)) - WRITE (IOUT,2050) - END DO - END IF -! 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 - character(len=31) :: cval - integer(I4B) :: n - integer(I4B) :: iiter - integer(I4B) :: isame - 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 - isame = IMSLINEARSUB_SAME(rho, rho0) - IF (isame.NE.0) 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 - character(len=15) :: cval1, cval2 - integer(I4B) :: n - integer(I4B) :: iiter - integer(I4B) :: isame - 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 - isame = IMSLINEARSUB_SAME(rho, rho0) - IF (isame.NE.0) THEN - EXIT INNER - END IF - isame = IMSLINEARSUB_SAME(alpha, alpha0) - IF (isame.NE.0) THEN - EXIT INNER - END IF - isame = IMSLINEARSUB_SAME(omega, omega0) - IF (isame.NE.0) 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 - - FUNCTION IMSLINEARSUB_SAME(a, b) RESULT(ivalue) -! + + + return - integer(I4B) :: ivalue -! + + + dummy arguments + + + - real(DP), intent(in) :: a - real(DP), intent(in) :: b -! + + + local definitions + + + - real(DP) :: denom - real(DP) :: rdiff -! + + + parameters + + + -! + + + functions + + + -! + + + code + + + - ivalue = 0 - if (a == b) then - ivalue = 1 - 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 <= DEM5) then - if (rdiff <= DSAME) then - ivalue = 1 - end if - end if - !---------return - return - END FUNCTION IMSLINEARSUB_SAME -! -! -!-------BEGINNING OF SUBROUTINES FROM OTHER LIBRARIES - - ! SUBSET OF SPARSKIT VERSION 2 SOURCE CODE - ! - ! SPARSKIT VERSION 2 SUBROUTINES INCLUDED INCLUDE: - ! - ! 1 - ilut - ! 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 - 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 - 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 (*,'(//1x,2i10)') ju0, iwk - 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 (*,'(//1x,2i10)') (ilen + ju0), iwk - 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 +! +!-----------CHECK FOR STANDARD CONVERGENCE + 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 +! +!-----------CHECK FOR STANDARD CONVERGENCE + 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) THEN + IF (iiter == 1) THEN + Icnvg = 1 + ELSE + Icnvg = -1 + END IF + 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 27d40d10cd3..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 - ! -2 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) -2 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 -1 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 fb7e913cc28..d6f2ea6d9b3 100644 --- a/src/Timing/tdis.f90 +++ b/src/Timing/tdis.f90 @@ -1,646 +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: LENDATETIME - ! - 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, ISTDOUT - ! -- local - ! -- 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(ISTDOUT, fmtspts) kper, kstp - ! - ! -- 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) endofsimulation = .true. - ! - ! -- 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, 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) - ! - ! -- 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)" - character(len=*), parameter :: fmtpwarn = & - "(1X,/1X, & - &'WARNING: PERLEN MUST NOT BE 0.0 FOR TRANSIENT STRESS PERIODS')" - !data -! ------------------------------------------------------------------------------ - ! - ! -- get PERIODDATA block - call parser%GetBlock('PERIODDATA', isfound, ierr) - ! - ! -- 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) - ! - !-----stop if nstp le 0, perlen eq 0 for transient stress periods, - !-----tsmult le 0, or perlen lt 0.. - if(nstp(n) <= 0) then - call store_error( & - 'THERE MUST BE AT LEAST ONE TIME STEP IN EVERY STRESS PERIOD') - end if - if(perlen(n) == dzero) then - write(iout, fmtpwarn) - end if - if(tsmult(n) <= dzero) then - call store_error( & - 'TSMULT MUST BE GREATER THAN 0.0') - end if - if(perlen(n).lt.dzero) then - call store_error( & - 'PERLEN CANNOT BE LESS THAN 0.0 FOR ANY STRESS PERIOD') - end if - totalsimtime = totalsimtime + perlen(n) - enddo - 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 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 3c5a6a0f580..38bb5cf96ea 100644 --- a/src/Utilities/ArrayHandlers.f90 +++ b/src/Utilities/ArrayHandlers.f90 @@ -1,370 +1,374 @@ -module ArrayHandlersModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: MAXCHARLEN - use SimVariablesModule, only: iout - 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_real(array, increment) - implicit none - ! -- dummy - real, allocatable, intent(inout) :: array(:) - integer(I4B), optional, intent(in) :: increment - ! -- local - integer(I4B) :: inclocal, isize, newsize - real, 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_real - - subroutine expand_character(array, increment) - implicit none - ! -- dummy - character(len=*), allocatable, intent(inout) :: array(:) - integer(I4B), optional, intent(in) :: increment - ! -- local - integer(I4B) :: i, inclocal, isize, lenc, newsize - character(len=MAXCHARLEN), allocatable, dimension(:) :: array_temp - ! - ! -- check character length - lenc = len(array) - if (lenc>MAXCHARLEN) then - ! Can't use store_error or ustop here because SimModule - ! is dependent on ArrayHandlersModule. - write(iout,*)'Error in ArrayHandlersModule: Need to increase MAXCHARLEN' - write(*,*)'Error in ArrayHandlersModule: Need to increase MAXCHARLEN' - write(iout,*)'Stopping...' - write(*,*)'Stopping...' - stop - endif - ! - ! -- 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 - integer(I4B) :: i, inclocal, isize, istat, newsize - real(DP), dimension(:), pointer, contiguous :: array_temp => null() - character(len=100) :: ermsg - ! - ! -- 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 - ! - return ! normal return - ! - ! -- Error reporting - 99 continue - ! Can't use store_error or ustop here because SimModule - ! is dependent on ArrayHandlersModule. - write(iout,*)'Error encountered while trying to increase array size:' - write(iout,'(a)')trim(ermsg) - write(iout,*)'Stopping...' - write(*,*)'Error encountered while trying to increase array size:' - write(iout,'(a)')trim(ermsg) - write(*,*)'Stopping...' - stop - 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 - integer(I4B) :: i, inclocal, isize, istat, newsize - integer(I4B), dimension(:), pointer, contiguous :: array_temp => null() - character(len=100) :: ermsg - ! - ! -- 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 - ! - return - ! - ! -- Error reporting - 99 continue - ! Can't use store_error or ustop here because SimModule - ! is dependent on ArrayHandlersModule. - write(iout,*)'Error encountered while trying to increase array size:' - write(iout,'(a)')trim(ermsg) - write(iout,*)'Stopping...' - write(*,*)'Error encountered while trying to increase array size:' - write(iout,'(a)')trim(ermsg) - write(*,*)'Stopping...' - stop - 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 - integer(I4B) :: i, isize, lenc, newsize, inew - character(len=MAXCHARLEN), allocatable, dimension(:) :: array_temp - ! - ! -- check character length - lenc = len(array) - if (lenc>MAXCHARLEN) then - ! Can't use store_error or ustop here because SimModule - ! is dependent on ArrayHandlersModule. - write(iout,*)'Error in ArrayHandlersModule: Need to increase MAXCHARLEN' - write(*,*)'Error in ArrayHandlersModule: Need to increase MAXCHARLEN' - write(iout,*)'Stopping...' - write(*,*)'Stopping...' - stop - 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 7f7ed2ee0c1..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 @@ -195,8 +195,8 @@ subroutine read_array_int2d(iu, iarr, aname, ndim, jj, ii, iout, k) else ! -- Read data as binary locat = -locat - do i=1,ii - call read_binary_header(locat, iout, aname, nval) + call read_binary_header(locat, iout, aname, nval) + 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 @@ -453,8 +453,8 @@ subroutine read_array_dbl2d(iu, darr, aname, ndim, jj, ii, iout, k) else ! -- Read data as binary locat = -locat - do i = 1, ii - call read_binary_header(locat, iout, aname, nval) + call read_binary_header(locat, iout, aname, nval) + 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/Budget.f90 b/src/Utilities/Budget.f90 index 5933254ba89..fc43b9a8e5b 100644 --- a/src/Utilities/Budget.f90 +++ b/src/Utilities/Budget.f90 @@ -80,7 +80,7 @@ subroutine budget_df(this, maxsize, bdtype, bddim, labeltitle, bdzone) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ class(BudgetType) :: this - integer(I4B),intent(in) :: maxsize + integer(I4B), intent(in) :: maxsize character(len=*), optional :: bdtype character(len=*), optional :: bddim character(len=*), optional :: labeltitle diff --git a/src/Utilities/BudgetFileReader.f90 b/src/Utilities/BudgetFileReader.f90 new file mode 100644 index 00000000000..c7cdbc4c3e5 --- /dev/null +++ b/src/Utilities/BudgetFileReader.f90 @@ -0,0 +1,263 @@ +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 diff --git a/src/Utilities/BudgetObject.f90 b/src/Utilities/BudgetObject.f90 new file mode 100644 index 00000000000..766f25ceaba --- /dev/null +++ b/src/Utilities/BudgetObject.f90 @@ -0,0 +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 + +end module BudgetObjectModule \ No newline at end of file diff --git a/src/Utilities/BudgetTerm.f90 b/src/Utilities/BudgetTerm.f90 new file mode 100644 index 00000000000..9405225ffc0 --- /dev/null +++ b/src/Utilities/BudgetTerm.f90 @@ -0,0 +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 + +end module BudgetTermModule \ No newline at end of file diff --git a/src/Utilities/Constants.f90 b/src/Utilities/Constants.f90 index 600b6ef8473..d00f96f9f97 100644 --- a/src/Utilities/Constants.f90 +++ b/src/Utilities/Constants.f90 @@ -1,102 +1,127 @@ -module ConstantsModule - use, intrinsic :: iso_fortran_env, only: output_unit - use KindModule - public - ! -- constants - integer(I4B), parameter :: ISTDOUT = output_unit - 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 = 20 - integer(I4B), parameter :: LENTIMESERIESNAME = LENOBSNAME - integer(I4B), parameter :: LENTIMESERIESTEXT = 12 - integer(I4B), parameter :: LENDATETIME = 30 - integer(I4B), parameter :: LINELENGTH = 300 - integer(I4B), parameter :: MAXCHARLEN = 1000 - integer(I4B), parameter :: MAXOBSTYPES = 100 - integer(I4B), parameter :: NAMEDBOUNDFLAG = -9 - integer(I4B), parameter :: IZERO = 0 - - 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 :: 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 - - -end module ConstantsModule +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 diff --git a/src/Utilities/DeferredStringObject.f90 b/src/Utilities/DeferredStringObject.f90 new file mode 100644 index 00000000000..6889c6d77d9 --- /dev/null +++ b/src/Utilities/DeferredStringObject.f90 @@ -0,0 +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 diff --git a/src/Utilities/InputOutput.f90 b/src/Utilities/InputOutput.f90 index 61daad0e099..cce5b5e738f 100644 --- a/src/Utilities/InputOutput.f90 +++ b/src/Utilities/InputOutput.f90 @@ -1,2147 +1,2216 @@ -! -- MODFLOW 6 utility routines. -! -module InputOutputModule - - use KindModule, only: DP, I4B - use SimModule, only: store_error, ustop, store_error_unit, & - store_error_filename - use ConstantsModule, only: LINELENGTH, LENBIGLINE, LENBOUNDNAME, & - NAMEDBOUNDFLAG, LINELENGTH, MAXCHARLEN - private - public :: dclosetest, 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, write_centered, 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 - - contains - - logical function dclosetest(a,b,eps) -! ****************************************************************************** -! Check and see if two doubles are close enough to be considered equal -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - ! -- dummy - real(DP), intent(in) :: a - real(DP), intent(in) :: b - real(DP), intent(in), optional :: eps - ! -- local - real(DP) :: epslocal, absval -! ------------------------------------------------------------------------------ - ! - if (present(eps)) then - epslocal = eps - else - epslocal = 1.2d-7 - endif - dclosetest=.true. - if(a.gt.b) then - absval = abs(a) - if((a-b) .le. absval*epslocal) return - else - absval = abs(b) - if((b-a) .le. absval*epslocal) return - end if - dclosetest=.false. - ! - ! -- Return - return - end function dclosetest - - 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) :: lastunitnumber - parameter(lastunitnumber=10000) - integer(I4B), save :: nextunitnumber=1000 - integer(I4B) :: i - logical :: opened -! ------------------------------------------------------------------------------ - ! - do i = nextunitnumber, lastunitnumber - inquire(unit=i, opened=opened) - if(.not. opened) exit - enddo - iu = i - nextunitnumber = 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 ConstantsModule, only: LINELENGTH - 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) +! -- 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) + 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,CENTER,LEFT,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 - logical, optional, intent(in) :: CENTER - logical, optional, intent(in) :: LEFT - character (len=*), optional, intent(in) :: SEP - ! -- local - character (len=16) :: cfmt - character (len=ILEN) :: cval - logical :: lcenter - logical :: lleft - integer(I4B) :: i - integer(I4B) :: ispace - integer(I4B) :: istop - ! -- code - if (present(FMT)) then - CFMT = FMT - else - select case(NCODE) - case(0, 1) - write(cfmt, '(A,I0,A)') '(A', ILEN, ')' - case(2) - write(cfmt, '(A,I0,A)') '(I', ILEN, ')' - case(3) - i = ILEN - 7 - write(cfmt, '(A,I0,A,I0,A)') '(G', ILEN, '.', i, ')' - end select - end if - - if (present(CENTER)) then - lcenter = CENTER - else - lcenter = .FALSE. - end if - - if (present(LEFT)) then - lleft = LEFT - else - lleft = .FALSE. - end if - - if (NCODE == 0 .or. NCODE == 1) then - if (len_trim(adjustl(C)) > ILEN) then - cval = adjustl(C) - else - cval = trim(adjustl(C)) - end if - if (lcenter) then - i = len_trim(cval) - ispace = (ILEN - i) / 2 - cval = repeat(' ', ispace) // trim(cval) - else if (lleft) then - cval = trim(adjustl(cval)) - else - cval = adjustr(cval) - end if - if (NCODE == 1) then - call UPCASE(cval) - end if - end if - - istop = ICOL + ILEN - - select case(NCODE) - case(0, 1) - write(LINE(ICOL:istop), cfmt) cval - case(2) - write(LINE(ICOL:istop), cfmt) N - case(3) - write(LINE(ICOL:istop), cfmt) R - end select - - ICOL = istop - - 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 -!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(IOUT,201) IN,LINE(ISTART:ISTOP),STRING(1:L),LINE - ELSE - WRITE(IOUT,202) LINE(ISTART:ISTOP),STRING(1:L),LINE - END IF -201 FORMAT(1X,/1X,'FILE UNIT ',I4,' : ERROR CONVERTING "',A, & - & '" TO ',A,' IN LINE:',/1X,A) -202 FORMAT(1X,/1X,'KEYBOARD INPUT : ERROR CONVERTING "',A, & - & '" TO ',A,' IN LINE:',/1X,A) -!C -!C7C-----If output unit is 0; write a message to default output. - ELSE - IF(IN.GT.0) THEN - WRITE(*,201) IN,LINE(ISTART:ISTOP),STRING(1:L),LINE - ELSE - WRITE(*,202) LINE(ISTART:ISTOP),STRING(1:L),LINE - END IF - 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 - 1 FORMAT(1X,'UBDSV4 SAVING "',A16,'" ON UNIT',I4, & - & ' AT TIME STEP',I3,', STRESS PERIOD',I4) - 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. - 5 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 1000 I=1,NROW - GO TO(10,20,30,40,50,60,70,80,90,100,110,120,130,140,150,160,170, & - & 180,190,200,210), IP -!C -!C------------ FORMAT 11G10.3 - 10 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))) - GO TO 1000 -!C -!C------------ FORMAT 9G13.6 - 20 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))) - GO TO 1000 -!C -!C------------ FORMAT 15F7.1 - 30 WRITE(IOUT,31) I,(BUF(J,I),J=1,NCOL) - 31 FORMAT(1X,I3,1X,15(1X,F7.1):/(5X,15(1X,F7.1))) - GO TO 1000 -!C -!C------------ FORMAT 15F7.2 - 40 WRITE(IOUT,41) I,(BUF(J,I),J=1,NCOL) - 41 FORMAT(1X,I3,1X,15(1X,F7.2):/(5X,15(1X,F7.2))) - GO TO 1000 -!C -!C------------ FORMAT 15F7.3 - 50 WRITE(IOUT,51) I,(BUF(J,I),J=1,NCOL) - 51 FORMAT(1X,I3,1X,15(1X,F7.3):/(5X,15(1X,F7.3))) - GO TO 1000 -!C -!C------------ FORMAT 15F7.4 - 60 WRITE(IOUT,61) I,(BUF(J,I),J=1,NCOL) - 61 FORMAT(1X,I3,1X,15(1X,F7.4):/(5X,15(1X,F7.4))) - GO TO 1000 -!C -!C------------ FORMAT 20F5.0 - 70 WRITE(IOUT,71) I,(BUF(J,I),J=1,NCOL) - 71 FORMAT(1X,I3,1X,20(1X,F5.0):/(5X,20(1X,F5.0))) - GO TO 1000 -!C -!C------------ FORMAT 20F5.1 - 80 WRITE(IOUT,81) I,(BUF(J,I),J=1,NCOL) - 81 FORMAT(1X,I3,1X,20(1X,F5.1):/(5X,20(1X,F5.1))) - GO TO 1000 -!C -!C------------ FORMAT 20F5.2 - 90 WRITE(IOUT,91) I,(BUF(J,I),J=1,NCOL) - 91 FORMAT(1X,I3,1X,20(1X,F5.2):/(5X,20(1X,F5.2))) - GO TO 1000 -!C -!C------------ FORMAT 20F5.3 - 100 WRITE(IOUT,101) I,(BUF(J,I),J=1,NCOL) - 101 FORMAT(1X,I3,1X,20(1X,F5.3):/(5X,20(1X,F5.3))) - GO TO 1000 -!C -!C------------ FORMAT 20F5.4 - 110 WRITE(IOUT,111) I,(BUF(J,I),J=1,NCOL) - 111 FORMAT(1X,I3,1X,20(1X,F5.4):/(5X,20(1X,F5.4))) - GO TO 1000 -!C -!C------------ FORMAT 10G11.4 - 120 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))) - GO TO 1000 -!C -!C------------ FORMAT 10F6.0 - 130 WRITE(IOUT,131) I,(BUF(J,I),J=1,NCOL) - 131 FORMAT(1X,I3,1X,10(1X,F6.0):/(5X,10(1X,F6.0))) - GO TO 1000 -!C -!C------------ FORMAT 10F6.1 - 140 WRITE(IOUT,141) I,(BUF(J,I),J=1,NCOL) - 141 FORMAT(1X,I3,1X,10(1X,F6.1):/(5X,10(1X,F6.1))) - GO TO 1000 -!C -!C------------ FORMAT 10F6.2 - 150 WRITE(IOUT,151) I,(BUF(J,I),J=1,NCOL) - 151 FORMAT(1X,I3,1X,10(1X,F6.2):/(5X,10(1X,F6.2))) - GO TO 1000 -!C -!C------------ FORMAT 10F6.3 - 160 WRITE(IOUT,161) I,(BUF(J,I),J=1,NCOL) - 161 FORMAT(1X,I3,1X,10(1X,F6.3):/(5X,10(1X,F6.3))) - GO TO 1000 -!C -!C------------ FORMAT 10F6.4 - 170 WRITE(IOUT,171) I,(BUF(J,I),J=1,NCOL) - 171 FORMAT(1X,I3,1X,10(1X,F6.4):/(5X,10(1X,F6.4))) - GO TO 1000 -!C -!C------------ FORMAT 10F6.5 - 180 WRITE(IOUT,181) I,(BUF(J,I),J=1,NCOL) - 181 FORMAT(1X,I3,1X,10(1X,F6.5):/(5X,10(1X,F6.5))) - GO TO 1000 -!C -!C------------FORMAT 5G12.5 - 190 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))) - GO TO 1000 -!C -!C------------FORMAT 6G11.4 - 200 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))) - GO TO 1000 -!C -!C------------FORMAT 7G9.2 - 210 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))) -!C - 1000 CONTINUE -!C -!C5------RETURN - 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) - integer(I4B) :: iu - character(len=100) :: fname,ac,act,fm,frm,seq,unf - inquire(unit=iu,name=fname,access=ac,action=act,formatted=fm, & - sequential=seq,unformatted=unf,form=frm) - - 10 format('unit:',i4,' name:',a,' access:',a,' action:',a,/, & - ' formatted:',a, & - ' sequential:',a,' unformatted:',a,' form:',a) - - write(*,10)iu,trim(fname),trim(ac),trim(act),trim(fm),trim(seq), & - trim(unf),trim(frm) - 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) - ! - ! -- 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 - nwords = nwords + 1 - enddo - 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) - enddo - 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 - - subroutine write_centered(text, iout, linelen) - ! Write text to unit iout centered in width defined by linelen - ! Left-pad with blanks as needed. - use ConstantsModule, only: LINELENGTH - implicit none - ! -- dummy - character(len=*), intent(in) :: text - integer(I4B), intent(in) :: iout - integer(I4B), intent(in) :: linelen - ! -- local - integer(I4B) :: loc1, loc2, lentext, nspaces - character(len=LINELENGTH) :: newline, textleft - ! - if (iout<=0) return - textleft = adjustl(text) - lentext = len_trim(textleft) - nspaces = linelen - lentext - loc1 = (nspaces / 2) + 1 - loc2 = loc1 + lentext - 1 - newline = ' ' - newline(loc1:loc2) = textleft - write(iout,'(a)')trim(newline) - ! - return - end subroutine write_centered - - 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 (dclosetest(t0, t1) .or. dclosetest(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)) - 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 - read(words(2), *, iostat=ierr) nvaluesp - 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) - 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 Output Control: Unrecognized option: ' // words(i) - 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 - -END MODULE InputOutputModule + 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 4af0c75ea70..961b934155c 100644 --- a/src/Utilities/List.f90 +++ b/src/Utilities/List.f90 @@ -1,6 +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 private public :: ListType, ListNodeType @@ -210,7 +212,8 @@ subroutine InsertAfter(this, objptr, indx) class(*), pointer, intent(inout) :: objptr integer(I4B), intent(in) :: indx ! -- local - integer :: numnodes + character(len=LINELENGTH) :: line + integer(I4B) :: numnodes type(ListNodeType), pointer :: precedingNode => null() type(ListNodeType), pointer :: followingNode => null() type(ListNodeType), pointer :: newNode => null() @@ -230,8 +233,9 @@ subroutine InsertAfter(this, objptr, indx) followingNode%prevNode => newNode this%nodeCount = this%nodeCount + 1 else - write(*,*)'Programming error in ListType%insert_after' - stop + write(line,'(a)') 'Programming error in ListType%insert_after' + call sim_message(line) + call stop_with_error(1) endif endif ! diff --git a/src/Utilities/ListReader.f90 b/src/Utilities/ListReader.f90 index f11b0e46dc8..c8b80426d7b 100644 --- a/src/Utilities/ListReader.f90 +++ b/src/Utilities/ListReader.f90 @@ -1,708 +1,773 @@ -! -- Generic List Reader Module -module ListReaderModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: LINELENGTH, LENBOUNDNAME, LENTIMESERIESNAME, DONE - use SimModule, only: store_error_unit - implicit none - private - public ListReaderType - - type :: ListReaderType - integer(I4B) :: in ! unit number of file containing control record - integer(I4B) :: inlist ! unit number of file from which list will be read - integer(I4B) :: iout ! unit number to output messages - integer(I4B) :: inamedbound ! flag indicating boundary names are to be read - integer(I4B) :: ierr ! error flag - integer(I4B) :: nlist ! number of entries in list. -1 indicates number will be automatically determined - integer(I4B) :: ibinary ! flag indicating to read binary list - integer(I4B) :: istart ! string starting location - integer(I4B) :: istop ! string ending location - integer(I4B) :: lloc ! entry number in line - integer(I4B) :: iclose ! flag indicating whether or not to close file - integer(I4B) :: ndim ! number of dimensions in model - integer(I4B) :: ntxtrlist ! number of text entries found in rlist - integer(I4B) :: ntxtauxvar ! number of text entries found in auxvar - character(len=LINELENGTH) :: 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 exit')" - 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 exit') - 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) -! ****************************************************************************** -! init -- Initialize the reader -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH, LENBOUNDNAME - use InputOutputModule, only: ulstlb, get_ijk - ! -- dummy - class(ListReaderType) :: this - ! -- local - integer(I4B) :: ii, jj, i, j, k, nod - integer(I4B) :: ldim - integer(I4B) :: naux - ! -- formats - character(len=LINELENGTH) :: fmtlstbn -! ------------------------------------------------------------------------------ - ! - ! -- Determine sizes - ldim = size(this%rlist, 1) - naux = size(this%auxvar, 1) - ! - ! -- Build list-label output format - if(size(this%mshape) == 3) then - ! -- Grid is structured; start with fields for - ! sequence number, layer, row, and column. - fmtlstbn = '(1X,I6,I7,I7,I7' - elseif(size(this%mshape) == 2) then - ! -- Disv grid; start with fields for - ! sequence number, layer, and cell2d. - fmtlstbn = '(1X,I6,I7,I7' - else - ! -- Grid is unstructured, start with fields for - ! sequence number and node. - fmtlstbn = '(1X,I6,I7' - endif - ! -- Add fields for non-optional real values - do i = 1, ldim - fmtlstbn = trim(fmtlstbn) // ',G16.4' - enddo - ! -- Add field for boundary name - if(this%inamedbound == 1) fmtlstbn = trim(fmtlstbn) // ',2X,A' - ! -- Add fields for auxiliary variables - fmtlstbn = trim(fmtlstbn) // ',25G16.4)' - ! - ! -- Write the label - write(this%iout, '(1x)') - call ulstlb(this%iout, trim(this%label), this%auxname, naux, naux) - ! - ! -- Write the table - do ii = 1, this%nlist - ! - ! -- Structured, disv, or unstructured write - 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) - if (this%inamedbound == 0) then - write(this%iout, fmtlstbn) ii, k, i, j, & - (this%rlist(jj, ii), jj = 1, ldim), & - (this%auxvar(jj, ii), jj = 1, naux) - else - write(this%iout, fmtlstbn) ii, k, i, j, & - (this%rlist(jj, ii), jj = 1, ldim), & - this%boundname(ii), & - (this%auxvar(jj, ii), jj = 1, naux) - endif - elseif (size(this%mshape) == 2) then - nod = this%nodelist(ii) - call get_ijk(nod, 1, this%mshape(2), this%mshape(1), i, j, k) - if (this%inamedbound == 0) then - write(this%iout, fmtlstbn) ii, k, j, & - (this%rlist(jj, ii), jj = 1, ldim), & - (this%auxvar(jj, ii), jj = 1, naux) - else - write(this%iout, fmtlstbn) ii, k, j, & - (this%rlist(jj, ii), jj = 1, ldim), & - this%boundname(ii), & - (this%auxvar(jj, ii), jj = 1, naux) - endif - else - nod = this%nodelist(ii) - if (this%inamedbound == 0) then - write(this%iout, fmtlstbn) ii, nod, & - (this%rlist(jj,ii), jj = 1, ldim), & - (this%auxvar(jj, ii), jj = 1, naux) - else - write(this%iout, fmtlstbn) ii, nod, & - (this%rlist(jj, ii), jj = 1, ldim), & - this%boundname(ii), & - (this%auxvar(jj, ii), jj = 1, naux) - endif - endif - ! - enddo - ! - ! -- 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 471ed9e9bc3..16c67b79fad 100644 --- a/src/Utilities/Memory/Memory.f90 +++ b/src/Utilities/Memory/Memory.f90 @@ -1,7 +1,8 @@ module MemoryTypeModule use KindModule, only: DP, I4B - use ConstantsModule, only: LENORIGIN, LENTIMESERIESNAME, LENVARNAME + use ConstantsModule, only: LENORIGIN, LENTIMESERIESNAME, LENVARNAME, & + MAXMEMRANK, LENMEMTYPE implicit none private public :: MemoryTSType, MemoryType @@ -10,26 +11,28 @@ module MemoryTypeModule character (len=LENTIMESERIESNAME), pointer :: name => null() real(DP), pointer :: value => null() end type MemoryTSType - - + type MemoryType character(len=LENVARNAME) :: name !name of the array character(len=LENORIGIN) :: origin !name of origin - character(len=50) :: memtype !type (INTEGER or DOUBLE) + 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 + 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 real(DP), pointer :: dblsclr => null() !pointer to the double integer(I4B), dimension(:), pointer, contiguous :: aint1d => null() !pointer to 1d integer array integer(I4B), dimension(:, :), pointer, contiguous :: aint2d => null() !pointer to 2d integer array + integer(I4B), dimension(:, :, :), pointer, contiguous :: aint3d => null() !pointer to 3d integer array real(DP), dimension(:), pointer, contiguous :: adbl1d => null() !pointer to 1d double array real(DP), dimension(:, :), pointer, contiguous :: adbl2d => null() !pointer to 2d double array + real(DP), dimension(:, :, :), pointer, contiguous :: adbl3d => null() !pointer to 3d double array 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 @@ -37,14 +40,18 @@ module MemoryTypeModule subroutine table_entry(this, msg) class(MemoryType) :: this character(len=*), intent(inout) :: msg - character(len=*), parameter :: fmt = "(1x, a40, a20, a20, i10, i10, a2)" + 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 = '' + if (.not. this%master) cptr = 'T' dastr = '' if (this%mt_associated() .and. this%isize > 0) dastr='*' write(msg, fmt) this%origin, this%name, this%memtype, this%isize, & - this%nrealloc, dastr + this%nrealloc, cptr, dastr end subroutine table_entry function mt_associated(this) result(al) @@ -56,8 +63,10 @@ function mt_associated(this) result(al) if(associated(this%dblsclr)) al = .true. if(associated(this%aint1d)) al = .true. if(associated(this%aint2d)) al = .true. + if(associated(this%aint3d)) al = .true. if(associated(this%adbl1d)) al = .true. if(associated(this%adbl2d)) al = .true. + if(associated(this%adbl3d)) al = .true. if(associated(this%ats1d)) al = .true. end function mt_associated 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 0a629d5d3e1..203accc6391 100644 --- a/src/Utilities/Memory/MemoryManager.f90 +++ b/src/Utilities/Memory/MemoryManager.f90 @@ -1,10 +1,11 @@ module MemoryManagerModule use KindModule, only: DP, I4B, I8B - use ConstantsModule, only: DZERO, LENORIGIN, LENVARNAME + 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 @@ -12,11 +13,19 @@ module MemoryManagerModule public :: mem_reallocate public :: mem_setptr public :: mem_copyptr + public :: mem_reassignptr public :: mem_deallocate - public :: mem_usage - public :: mem_da + 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 :: copy_dbl1d + type(MemoryListType) :: memorylist integer(I8B) :: nvalues_alogical = 0 integer(I8B) :: nvalues_achr = 0 @@ -28,7 +37,9 @@ module MemoryManagerModule interface mem_allocate module procedure allocate_logical, & allocate_int, allocate_int1d, allocate_int2d, & + allocate_int3d, & allocate_dbl, allocate_dbl1d, allocate_dbl2d, & + allocate_dbl3d, & allocate_ts1d end interface mem_allocate @@ -48,14 +59,164 @@ module MemoryManagerModule copyptr_dbl1d, copyptr_dbl2d end interface mem_copyptr + interface mem_reassignptr + module procedure reassignptr_int1d, reassignptr_int2d, & + reassignptr_dbl1d, reassignptr_dbl2d + end interface mem_reassignptr + interface mem_deallocate module procedure deallocate_logical, & deallocate_int, deallocate_int1d, deallocate_int2d, & + deallocate_int3d, & deallocate_dbl, deallocate_dbl1d, deallocate_dbl2d, & + deallocate_dbl3d, & deallocate_ts1d end interface mem_deallocate -contains + 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 + if(associated(mt%aint1d)) rank = 1 + if(associated(mt%aint2d)) rank = 2 + if(associated(mt%aint3d)) rank = 3 + 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%logicalsclr)) mem_shape = shape(mt%logicalsclr) + if(associated(mt%intsclr)) mem_shape = shape(mt%logicalsclr) + if(associated(mt%dblsclr)) mem_shape = shape(mt%dblsclr) + if(associated(mt%aint1d)) mem_shape = shape(mt%aint1d) + if(associated(mt%aint2d)) mem_shape = shape(mt%aint2d) + 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 + 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() + found = .false. + do ipos = 1, memorylist%count() + mt => memorylist%Get(ipos) + if(mt%name == name .and. mt%origin == origin) then + 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 + end if + return + end subroutine get_from_memorylist subroutine allocate_error(varname, origin, istat, errmsg, isize) use SimModule, only: store_error, ustop @@ -64,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) @@ -76,6 +237,18 @@ subroutine allocate_error(varname, origin, istat, errmsg, isize) call store_error(' Status code: ' // cint) call ustop() 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 + end subroutine check_varname subroutine allocate_logical(logicalsclr, name, origin) logical, pointer, intent(inout) :: logicalsclr @@ -103,13 +276,7 @@ subroutine allocate_int(intsclr, name, origin) integer(I4B) :: istat type(MemoryType), pointer :: mt character(len=100) :: ermsg - if(len(name) > LENVARNAME) then - write(ermsg, '(*(G0))') & - 'Programming error. Variable ', name, ' must be ', LENVARNAME, & - ' characters or less.' - call store_error(ermsg) - call ustop() - endif + call check_varname(name) allocate(intsclr, stat=istat, errmsg=ermsg) if(istat /= 0) call allocate_error(name, origin, istat, ermsg, 1) nvalues_aint = nvalues_aint + 1 @@ -130,13 +297,7 @@ subroutine allocate_int1d(aint, isize, name, origin) integer(I4B) :: istat type(MemoryType), pointer :: mt character(len=100) :: ermsg - if(len(name) > LENVARNAME) then - write(ermsg, '(*(G0))') & - 'Programming error. Variable ', name, ' must be ', LENVARNAME, & - ' characters or less.' - call store_error(ermsg) - call ustop() - endif + call check_varname(name) allocate(aint(isize), stat=istat, errmsg=ermsg) if(istat /= 0) call allocate_error(name, origin, istat, ermsg, isize) nvalues_aint = nvalues_aint + isize @@ -159,13 +320,7 @@ subroutine allocate_int2d(aint, ncol, nrow, name, origin) integer(I4B) :: isize type(MemoryType), pointer :: mt character(len=100) :: ermsg - if(len(name) > LENVARNAME) then - write(ermsg, '(*(G0))') & - 'Programming error. Variable ', name, ' must be ', LENVARNAME, & - ' characters or less.' - call store_error(ermsg) - call ustop() - endif + call check_varname(name) isize = ncol * nrow allocate(aint(ncol, nrow), stat=istat, errmsg=ermsg) if(istat /= 0) call allocate_error(name, origin, istat, ermsg, isize) @@ -178,7 +333,33 @@ subroutine allocate_int2d(aint, ncol, nrow, name, origin) write(mt%memtype, "(a,' (',i0,',',i0,')')") 'INTEGER', ncol, nrow call memorylist%add(mt) end subroutine allocate_int2d - + + subroutine allocate_int3d(aint, ncol, nrow, nlay, name, origin) + integer(I4B), dimension(:, :, :), pointer, contiguous, intent(inout) :: aint + integer(I4B), intent(in) :: ncol + integer(I4B), intent(in) :: nrow + integer(I4B), intent(in) :: nlay + character(len=*), intent(in) :: name + character(len=*), intent(in) :: origin + integer(I4B) :: istat + integer(I4B) :: isize + type(MemoryType), pointer :: mt + character(len=100) :: ermsg + call check_varname(name) + isize = ncol * nrow * nlay + allocate(aint(ncol, nrow, nlay), stat=istat, errmsg=ermsg) + if(istat /= 0) call allocate_error(name, origin, istat, ermsg, isize) + nvalues_aint = nvalues_aint + isize + allocate(mt) + mt%aint3d => aint + mt%isize = isize + mt%name = name + mt%origin = origin + write(mt%memtype, "(a,' (',i0,',',i0,',',i0,')')") 'INTEGER', ncol, & + nrow, nlay + call memorylist%add(mt) + end subroutine allocate_int3d + subroutine allocate_dbl(dblsclr, name, origin) real(DP), pointer, intent(inout) :: dblsclr character(len=*), intent(in) :: name @@ -186,13 +367,7 @@ subroutine allocate_dbl(dblsclr, name, origin) integer(I4B) :: istat type(MemoryType), pointer :: mt character(len=100) :: ermsg - if(len(name) > LENVARNAME) then - write(ermsg, '(*(G0))') & - 'Programming error. Variable ', name, ' must be ', LENVARNAME, & - ' characters or less.' - call store_error(ermsg) - call ustop() - endif + call check_varname(name) allocate(dblsclr, stat=istat, errmsg=ermsg) if(istat /= 0) call allocate_error(name, origin, istat, ermsg, 1) nvalues_aint = nvalues_aint + 1 @@ -213,13 +388,7 @@ subroutine allocate_dbl1d(adbl, isize, name, origin) integer(I4B) :: istat type(MemoryType), pointer :: mt character(len=100) :: ermsg - if(len(name) > LENVARNAME) then - write(ermsg, '(*(G0))') & - 'Programming error. Variable ', name, ' must be ', LENVARNAME, & - ' characters or less.' - call store_error(ermsg) - call ustop() - endif + call check_varname(name) allocate(adbl(isize), stat=istat, errmsg=ermsg) if(istat /= 0) call allocate_error(name, origin, istat, ermsg, isize) nvalues_adbl = nvalues_adbl + isize @@ -242,13 +411,7 @@ subroutine allocate_dbl2d(adbl, ncol, nrow, name, origin) integer(I4B) :: isize type(MemoryType), pointer :: mt character(len=100) :: ermsg - if(len(name) > LENVARNAME) then - write(ermsg, '(*(G0))') & - 'Programming error. Variable ', name, ' must be ', LENVARNAME, & - ' characters or less.' - call store_error(ermsg) - call ustop() - endif + call check_varname(name) isize = ncol * nrow allocate(adbl(ncol, nrow), stat=istat, errmsg=ermsg) if(istat /= 0) call allocate_error(name, origin, istat, ermsg, isize) @@ -261,6 +424,32 @@ subroutine allocate_dbl2d(adbl, ncol, nrow, name, origin) write(mt%memtype, "(a,' (',i0,',',i0,')')") 'DOUBLE', ncol, nrow call memorylist%add(mt) end subroutine allocate_dbl2d + + subroutine allocate_dbl3d(adbl, ncol, nrow, nlay, name, origin) + real(DP), dimension(:, :, :), pointer, contiguous, intent(inout) :: adbl + integer(I4B), intent(in) :: ncol + integer(I4B), intent(in) :: nrow + integer(I4B), intent(in) :: nlay + character(len=*), intent(in) :: name + character(len=*), intent(in) :: origin + integer(I4B) :: istat + integer(I4B) :: isize + type(MemoryType), pointer :: mt + character(len=100) :: ermsg + call check_varname(name) + isize = ncol * nrow * nlay + allocate(adbl(ncol, nrow, nlay), stat=istat, errmsg=ermsg) + if(istat /= 0) call allocate_error(name, origin, istat, ermsg, isize) + nvalues_adbl = nvalues_adbl + isize + allocate(mt) + mt%adbl3d => adbl + mt%isize = isize + mt%name = name + mt%origin = origin + write(mt%memtype, "(a,' (',i0,',',i0,',',i0,')')") 'DOUBLE', ncol, & + nrow, nlay + call memorylist%add(mt) + end subroutine allocate_dbl3d subroutine allocate_ts1d(ats, isize, name, origin) type (MemoryTSType), dimension(:), pointer, contiguous, intent(inout) :: ats @@ -271,13 +460,7 @@ subroutine allocate_ts1d(ats, isize, name, origin) integer(I4B) :: i type(MemoryType), pointer :: mt character(len=100) :: ermsg - if(len(name) > LENVARNAME) then - write(ermsg, '(*(G0))') & - 'Programming error. Variable ', name, ' must be ', LENVARNAME, & - ' characters or less.' - call store_error(ermsg) - call ustop() - endif + call check_varname(name) allocate(ats(isize), stat=istat, errmsg=ermsg) if(istat /= 0) call allocate_error(name, origin, istat, ermsg, isize) do i = 1, isize @@ -305,29 +488,20 @@ subroutine reallocate_int1d(aint, isize, name, origin) character(len=*), intent(in) :: origin integer(I4B) :: istat type(MemoryType), pointer :: mt - integer(I4B) :: ipos, i, isizeold + integer(I4B) :: i, isizeold + integer(I4B) :: ifill character(len=100) :: ermsg logical :: found ! ! -- Find and assign mt - mt => null() - found = .false. - do ipos = 1, memorylist%count() - mt => memorylist%Get(ipos) - if(mt%name == name .and. mt%origin == origin) then - found = .true. - exit - endif - enddo - ! - if(.not. found) call allocate_error(name, origin, 0, & - 'Variable not found in MemoryManager', isize) + call get_from_memorylist(name, origin, mt, found) ! ! -- Allocate aint and then refill 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) - do i = 1, isizeold + do i = 1, ifill aint(i) = mt%aint1d(i) enddo ! @@ -336,6 +510,7 @@ subroutine reallocate_int1d(aint, isize, name, origin) mt%aint1d => aint mt%isize = isize mt%nrealloc = mt%nrealloc + 1 + mt%master = .true. nvalues_aint = nvalues_aint + isize - isizeold ! ! -- return @@ -351,23 +526,12 @@ subroutine reallocate_int2d(aint, ncol, nrow, name, origin) integer(I4B) :: istat type(MemoryType), pointer :: mt integer(I4B), dimension(2) :: ishape - integer(I4B) :: ipos, i, j, isize, isizeold + integer(I4B) :: i, j, isize, isizeold character(len=100) :: ermsg logical :: found ! ! -- Find and assign mt - mt => null() - found = .false. - do ipos = 1, memorylist%count() - mt => memorylist%Get(ipos) - if(mt%name == name .and. mt%origin == origin) then - found = .true. - exit - endif - enddo - ! - if(.not. found) call allocate_error(name, origin, 0, & - 'Variable not found in MemoryManager', isize) + call get_from_memorylist(name, origin, mt, found) ! ! -- Allocate aint and then refill ishape = shape(mt%aint2d) @@ -386,6 +550,7 @@ subroutine reallocate_int2d(aint, ncol, nrow, name, origin) mt%aint2d => aint mt%isize = isize mt%nrealloc = mt%nrealloc + 1 + mt%master = .true. nvalues_aint = nvalues_aint + isize - isizeold write(mt%memtype, "(a,' (',i0,',',i0,')')") 'INTEGER', ncol, nrow ! @@ -400,29 +565,20 @@ subroutine reallocate_dbl1d(adbl, isize, name, origin) character(len=*), intent(in) :: origin integer(I4B) :: istat type(MemoryType), pointer :: mt - integer(I4B) :: ipos, i, isizeold + integer(I4B) :: i, isizeold + integer(I4B) :: ifill character(len=100) :: ermsg logical :: found ! ! -- Find and assign mt - mt => null() - found = .false. - do ipos = 1, memorylist%count() - mt => memorylist%Get(ipos) - if(mt%name == name .and. mt%origin == origin) then - found = .true. - exit - endif - enddo - ! - if(.not. found) call allocate_error(name, origin, 0, & - 'Variable not found in MemoryManager', isize) + call get_from_memorylist(name, origin, mt, found) ! ! -- Allocate adbl and then refill 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) - do i = 1, isizeold + do i = 1, ifill adbl(i) = mt%adbl1d(i) enddo ! @@ -431,6 +587,7 @@ subroutine reallocate_dbl1d(adbl, isize, name, origin) mt%adbl1d => adbl mt%isize = isize mt%nrealloc = mt%nrealloc + 1 + mt%master = .true. nvalues_adbl = nvalues_adbl + isize - isizeold write(mt%memtype, "(a,' (',i0,')')") 'DOUBLE', isize ! @@ -447,23 +604,12 @@ subroutine reallocate_dbl2d(adbl, ncol, nrow, name, origin) integer(I4B) :: istat type(MemoryType), pointer :: mt integer(I4B), dimension(2) :: ishape - integer(I4B) :: ipos, i, j, isize, isizeold + integer(I4B) :: i, j, isize, isizeold character(len=100) :: ermsg logical :: found ! ! -- Find and assign mt - mt => null() - found = .false. - do ipos = 1, memorylist%count() - mt => memorylist%Get(ipos) - if(mt%name == name .and. mt%origin == origin) then - found = .true. - exit - endif - enddo - ! - if(.not. found) call allocate_error(name, origin, 0, & - 'Variable not found in MemoryManager', isize) + call get_from_memorylist(name, origin, mt, found) ! ! -- Allocate adbl and then refill ishape = shape(mt%adbl2d) @@ -482,6 +628,7 @@ subroutine reallocate_dbl2d(adbl, ncol, nrow, name, origin) mt%adbl2d => adbl mt%isize = isize mt%nrealloc = mt%nrealloc + 1 + mt%master = .true. nvalues_adbl = nvalues_adbl + isize - isizeold write(mt%memtype, "(a,' (',i0,',',i0,')')") 'DOUBLE', ncol, nrow ! @@ -493,140 +640,92 @@ subroutine setptr_logical(logicalsclr, name, origin) logical, pointer, intent(inout) :: logicalsclr character(len=*), intent(in) :: name character(len=*), intent(in) :: origin - class(MemoryType), pointer :: mt - integer(I4B) :: ipos - logicalsclr => null() - do ipos = 1, memorylist%count() - mt => memorylist%Get(ipos) - if(mt%name == name .and. mt%origin == origin) then - logicalsclr => mt%logicalsclr - exit - endif - enddo + type(MemoryType), pointer :: mt + logical :: found + call get_from_memorylist(name, origin, mt, found) + logicalsclr => mt%logicalsclr end subroutine setptr_logical subroutine setptr_int(intsclr, name, origin) integer(I4B), pointer, intent(inout) :: intsclr character(len=*), intent(in) :: name character(len=*), intent(in) :: origin - class(MemoryType), pointer :: mt - integer(I4B) :: ipos - intsclr => null() - do ipos = 1, memorylist%count() - mt => memorylist%Get(ipos) - if(mt%name == name .and. mt%origin == origin) then - intsclr => mt%intsclr - exit - endif - enddo + type(MemoryType), pointer :: mt + logical :: found + call get_from_memorylist(name, origin, mt, found) + intsclr => mt%intsclr end subroutine setptr_int subroutine setptr_int1d(aint, name, origin) integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint character(len=*), intent(in) :: name character(len=*), intent(in) :: origin - class(MemoryType), pointer :: mt - integer(I4B) :: ipos - aint => null() - do ipos = 1, memorylist%count() - mt => memorylist%Get(ipos) - if(mt%name == name .and. mt%origin == origin) then - aint => mt%aint1d - exit - endif - enddo + type(MemoryType), pointer :: mt + logical :: found + call get_from_memorylist(name, origin, mt, found) + aint => mt%aint1d end subroutine setptr_int1d subroutine setptr_int2d(aint, name, origin) integer(I4B), dimension(:, :), pointer, contiguous, intent(inout) :: aint character(len=*), intent(in) :: name character(len=*), intent(in) :: origin - class(MemoryType), pointer :: mt - integer(I4B) :: ipos - aint => null() - do ipos = 1, memorylist%count() - mt => memorylist%Get(ipos) - if(mt%name == name .and. mt%origin == origin) then - aint => mt%aint2d - exit - endif - enddo + type(MemoryType), pointer :: mt + logical :: found + call get_from_memorylist(name, origin, mt, found) + aint => mt%aint2d end subroutine setptr_int2d subroutine setptr_dbl(dblsclr, name, origin) real(DP), pointer, intent(inout) :: dblsclr character(len=*), intent(in) :: name character(len=*), intent(in) :: origin - class(MemoryType), pointer :: mt - integer(I4B) :: ipos - dblsclr => null() - do ipos = 1, memorylist%count() - mt => memorylist%Get(ipos) - if(mt%name == name .and. mt%origin == origin) then - dblsclr => mt%dblsclr - exit - endif - enddo + type(MemoryType), pointer :: mt + logical :: found + call get_from_memorylist(name, origin, mt, found) + dblsclr => mt%dblsclr end subroutine setptr_dbl subroutine setptr_dbl1d(adbl, name, origin) real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl character(len=*), intent(in) :: name character(len=*), intent(in) :: origin - class(MemoryType), pointer :: mt - integer(I4B) :: ipos - adbl => null() - do ipos = 1, memorylist%count() - mt => memorylist%Get(ipos) - if(mt%name == name .and. mt%origin == origin) then - adbl => mt%adbl1d - exit - endif - enddo + type(MemoryType), pointer :: mt + logical :: found + call get_from_memorylist(name, origin, mt, found) + adbl => mt%adbl1d end subroutine setptr_dbl1d subroutine setptr_dbl2d(adbl, name, origin) real(DP), dimension(:, :), pointer, contiguous, intent(inout) :: adbl character(len=*), intent(in) :: name character(len=*), intent(in) :: origin - class(MemoryType), pointer :: mt - integer(I4B) :: ipos - adbl => null() - do ipos = 1, memorylist%count() - mt => memorylist%Get(ipos) - if(mt%name == name .and. mt%origin == origin) then - adbl => mt%adbl2d - exit - endif - enddo + type(MemoryType), pointer :: mt + logical :: found + call get_from_memorylist(name, origin, mt, found) + adbl => mt%adbl2d end subroutine setptr_dbl2d - subroutine copyptr_int1d(aint, name, origin, origin2) integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint character(len=*), intent(in) :: name character(len=*), intent(in) :: origin character(len=*), intent(in), optional :: origin2 - class(MemoryType), pointer :: mt - integer(I4B) :: ipos + type(MemoryType), pointer :: mt integer(I4B) :: n + logical :: found + call get_from_memorylist(name, origin, mt, found) aint => null() - do ipos = 1, memorylist%count() - mt => memorylist%Get(ipos) - if(mt%name == name .and. mt%origin == origin) then - ! -- check the copy into the memory manager - if (present(origin2)) then - call allocate_int1d(aint, size(mt%aint1d), mt%name, origin2) - ! -- create a local copy - else - allocate(aint(size(mt%aint1d))) - end if - do n = 1, size(mt%aint1d) - aint(n) = mt%aint1d(n) - end do - exit - endif - enddo + ! -- check the copy into the memory manager + if (present(origin2)) then + call allocate_int1d(aint, size(mt%aint1d), mt%name, origin2) + ! -- create a local copy + else + allocate(aint(size(mt%aint1d))) + end if + do n = 1, size(mt%aint1d) + aint(n) = mt%aint1d(n) + end do end subroutine copyptr_int1d subroutine copyptr_int2d(aint, name, origin, origin2) @@ -634,31 +733,26 @@ subroutine copyptr_int2d(aint, name, origin, origin2) character(len=*), intent(in) :: name character(len=*), intent(in) :: origin character(len=*), intent(in), optional :: origin2 - class(MemoryType), pointer :: mt - integer(I4B) :: ipos + type(MemoryType), pointer :: mt integer(I4B) :: i, j integer(I4B) :: ncol, nrow + logical :: found + call get_from_memorylist(name, origin, mt, found) aint => null() - do ipos = 1, memorylist%count() - mt => memorylist%Get(ipos) - if(mt%name == name .and. mt%origin == origin) then - ncol = size(mt%aint2d, dim=1) - nrow = size(mt%aint2d, dim=2) - ! -- check the copy into the memory manager - if (present(origin2)) then - call allocate_int2d(aint, ncol, nrow, mt%name, origin2) - ! -- create a local copy - else - allocate(aint(ncol,nrow)) - end if - do i = 1, nrow - do j = 1, ncol - aint(j,i) = mt%aint2d(j,i) - end do - end do - exit - endif - enddo + ncol = size(mt%aint2d, dim=1) + nrow = size(mt%aint2d, dim=2) + ! -- check the copy into the memory manager + if (present(origin2)) then + call allocate_int2d(aint, ncol, nrow, mt%name, origin2) + ! -- create a local copy + else + allocate(aint(ncol,nrow)) + end if + do i = 1, nrow + do j = 1, ncol + aint(j,i) = mt%aint2d(j,i) + end do + end do end subroutine copyptr_int2d subroutine copyptr_dbl1d(adbl, name, origin, origin2) @@ -666,26 +760,21 @@ subroutine copyptr_dbl1d(adbl, name, origin, origin2) character(len=*), intent(in) :: name character(len=*), intent(in) :: origin character(len=*), intent(in), optional :: origin2 - class(MemoryType), pointer :: mt - integer(I4B) :: ipos + type(MemoryType), pointer :: mt integer(I4B) :: n + logical :: found + call get_from_memorylist(name, origin, mt, found) adbl => null() - do ipos = 1, memorylist%count() - mt => memorylist%Get(ipos) - if(mt%name == name .and. mt%origin == origin) then - ! -- check the copy into the memory manager - if (present(origin2)) then - call allocate_dbl1d(adbl, size(mt%adbl1d), mt%name, origin2) - ! -- create a local copy - else - allocate(adbl(size(mt%adbl1d))) - end if - do n = 1, size(mt%adbl1d) - adbl(n) = mt%adbl1d(n) - end do - exit - endif - enddo + ! -- check the copy into the memory manager + if (present(origin2)) then + call allocate_dbl1d(adbl, size(mt%adbl1d), mt%name, origin2) + ! -- create a local copy + else + allocate(adbl(size(mt%adbl1d))) + end if + do n = 1, size(mt%adbl1d) + adbl(n) = mt%adbl1d(n) + end do end subroutine copyptr_dbl1d subroutine copyptr_dbl2d(adbl, name, origin, origin2) @@ -693,52 +782,160 @@ subroutine copyptr_dbl2d(adbl, name, origin, origin2) character(len=*), intent(in) :: name character(len=*), intent(in) :: origin character(len=*), intent(in), optional :: origin2 - class(MemoryType), pointer :: mt - integer(I4B) :: ipos + type(MemoryType), pointer :: mt integer(I4B) :: i, j integer(I4B) :: ncol, nrow + logical :: found + call get_from_memorylist(name, origin, mt, found) adbl => null() - do ipos = 1, memorylist%count() - mt => memorylist%Get(ipos) - if(mt%name == name .and. mt%origin == origin) then - ncol = size(mt%adbl2d, dim=1) - nrow = size(mt%adbl2d, dim=2) - ! -- check the copy into the memory manager - if (present(origin2)) then - call allocate_dbl2d(adbl, ncol, nrow, mt%name, origin2) - ! -- create a local copy - else - allocate(adbl(ncol,nrow)) - end if - do i = 1, nrow - do j = 1, ncol - adbl(j,i) = mt%adbl2d(j,i) - end do - end do - exit - endif - enddo + ncol = size(mt%adbl2d, dim=1) + nrow = size(mt%adbl2d, dim=2) + ! -- check the copy into the memory manager + if (present(origin2)) then + call allocate_dbl2d(adbl, ncol, nrow, mt%name, origin2) + ! -- create a local copy + else + allocate(adbl(ncol,nrow)) + end if + do i = 1, nrow + do j = 1, ncol + adbl(j,i) = mt%adbl2d(j,i) + 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 + + call get_from_memorylist(name, origin, mt, found) + do n = 1, size(mt%adbl1d) + adbl(n) = mt%adbl1d(n) + end do + + end subroutine copy_dbl1d + + subroutine reassignptr_int1d(aint1d, name, origin, name2, origin2) + integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint1d + character(len=*), intent(in) :: name + character(len=*), intent(in) :: origin + character(len=*), intent(in) :: name2 + character(len=*), intent(in) :: origin2 + type(MemoryType), pointer :: mt, mt2 + logical :: 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. + return + end subroutine reassignptr_int1d + + subroutine reassignptr_int2d(aint2d, name, origin, name2, origin2) + integer(I4B), dimension(:,:), pointer, contiguous, intent(inout) :: aint2d + character(len=*), intent(in) :: name + character(len=*), intent(in) :: origin + character(len=*), intent(in) :: name2 + 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(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) + ncol = size(aint2d, dim=1) + nrow = size(aint2d, dim=2) + write(mt%memtype, "(a,' (',i0,',',i0,')')") 'INTEGER', ncol, nrow + mt%master = .false. + return + end subroutine reassignptr_int2d + + subroutine reassignptr_dbl1d(adbl1d, name, origin, name2, origin2) + real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl1d + character(len=*), intent(in) :: name + character(len=*), intent(in) :: origin + character(len=*), intent(in) :: name2 + character(len=*), intent(in) :: origin2 + type(MemoryType), pointer :: mt, mt2 + logical :: 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. + return + end subroutine reassignptr_dbl1d + + subroutine reassignptr_dbl2d(adbl2d, name, origin, name2, origin2) + real(DP), dimension(:,:), pointer, contiguous, intent(inout) :: adbl2d + character(len=*), intent(in) :: name + character(len=*), intent(in) :: origin + character(len=*), intent(in) :: name2 + 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(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) + ncol = size(adbl2d, dim=1) + nrow = size(adbl2d, dim=2) + 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 - deallocate(logicalsclr) + if (mt%master) then + deallocate(logicalsclr) + else + nullify(logicalsclr) + end if endif end subroutine deallocate_logical @@ -746,21 +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 - deallocate(intsclr) + if (mt%master) then + deallocate(intsclr) + else + nullify(intsclr) + end if endif end subroutine deallocate_int @@ -768,164 +969,282 @@ 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 - deallocate(dblsclr) + if (mt%master) then + deallocate(dblsclr) + else + nullify (dblsclr) + end if endif end subroutine deallocate_dbl - subroutine deallocate_int1d(aint1d) + subroutine deallocate_int1d(aint1d, name, origin) integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint1d - class(MemoryType), pointer :: mt - integer(I4B) :: ipos - logical :: found - found = .false. - do ipos = 1, memorylist%count() - mt => memorylist%Get(ipos) - if(associated(mt%aint1d, aint1d)) then - nullify(mt%aint1d) - found = .true. - exit - endif - enddo - if (.not. found .and. size(aint1d) > 0 ) then - call store_error('programming error in deallocate_int1d') - call ustop() + 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 + found = .false. + do ipos = 1, memorylist%count() + mt => memorylist%Get(ipos) + if(associated(mt%aint1d, aint1d)) then + nullify(mt%aint1d) + found = .true. + exit + endif + enddo + end if + if (.not. found .and. size(aint1d) > 0 ) then + call store_error('programming error in deallocate_int1d') + call ustop() else - deallocate(aint1d) + if (mt%master) then + deallocate(aint1d) + else + nullify(aint1d) + end if endif end subroutine deallocate_int1d - subroutine deallocate_int2d(aint2d) + subroutine deallocate_int2d(aint2d, name, origin) integer(I4B), dimension(:, :), pointer, contiguous, intent(inout) :: aint2d - class(MemoryType), pointer :: mt + character(len=*), optional :: name + character(len=*), optional :: origin + type(MemoryType), pointer :: mt integer(I4B) :: ipos - logical :: found - found = .false. - do ipos = 1, memorylist%count() - mt => memorylist%Get(ipos) - if(associated(mt%aint2d, aint2d)) then - nullify(mt%aint2d) - found = .true. - exit - endif - enddo - if (.not. found .and. size(aint2d) > 0 ) then - call store_error('programming error in deallocate_int2d') - call ustop() + 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 + endif + enddo + end if + if (.not. found .and. size(aint2d) > 0 ) then + call store_error('programming error in deallocate_int2d') + call ustop() else - deallocate(aint2d) + if (mt%master) then + deallocate(aint2d) + else + nullify(aint2d) + end if endif end subroutine deallocate_int2d - subroutine deallocate_dbl1d(adbl1d) + subroutine deallocate_int3d(aint3d, name, origin) + integer(I4B), dimension(:, :, :), pointer, contiguous, intent(inout) :: aint3d + 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%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 + endif + enddo + end if + 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 + endif + end subroutine deallocate_int3d + + subroutine deallocate_dbl1d(adbl1d, name, origin) real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl1d - class(MemoryType), pointer :: mt + character(len=*), optional :: name + character(len=*), optional :: origin + type(MemoryType), pointer :: mt integer(I4B) :: ipos - logical :: found - 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 - if (.not. found .and. size(adbl1d) > 0 ) then - call store_error('programming error in deallocate_dbl1d') - call ustop() + logical :: found + if (present(name) .and. present(origin)) then + call get_from_memorylist(name, origin, mt, found) + nullify(mt%adbl1d) else - deallocate(adbl1d) + 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) + subroutine deallocate_dbl2d(adbl2d, name, origin) real(DP), dimension(:, :), pointer, contiguous, intent(inout) :: adbl2d - class(MemoryType), pointer :: mt + character(len=*), optional :: name + character(len=*), optional :: origin + type(MemoryType), pointer :: mt integer(I4B) :: ipos - logical :: found - found = .false. - do ipos = 1, memorylist%count() - mt => memorylist%Get(ipos) - if(associated(mt%adbl2d, adbl2d)) then - nullify(mt%adbl2d) - found = .true. - exit - endif - enddo - if (.not. found .and. size(adbl2d) > 0 ) then - call store_error('programming error in deallocate_dbl2d') - call ustop() + logical :: found + if (present(name) .and. present(origin)) then + call get_from_memorylist(name, origin, mt, found) + nullify(mt%adbl2d) else - deallocate(adbl2d) + found = .false. + do ipos = 1, memorylist%count() + mt => memorylist%Get(ipos) + if(associated(mt%adbl2d, adbl2d)) then + nullify(mt%adbl2d) + found = .true. + exit + endif + enddo + end if + 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 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 + found = .false. + do ipos = 1, memorylist%count() + mt => memorylist%Get(ipos) + if(associated(mt%adbl3d, adbl3d)) then + nullify(mt%adbl3d) + found = .true. + exit + endif + enddo + end if + 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 + endif + end subroutine deallocate_dbl3d + 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 - deallocate(ats1d) - 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 @@ -933,99 +1252,112 @@ subroutine mem_usage(iout) character(len=*), parameter :: fmtd = "(1x, a, 1(1pg15.6))" character(len=*), parameter :: fmttitle = "(/, 1x, a)" character(len=*), parameter :: fmtheader = & - "(1x, a40, a20, a20, a10, a10, /, 1x, 100('-'))" - character(len=200) :: msg + "(1x, a40, a20, a20, a10, a10, a10, /, 1x, 110('-'))" + 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 (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() - class(MemoryType), pointer :: mt + 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) + 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() - 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)) + 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 ff65d57cfae..370f9d4511b 100644 --- a/src/Utilities/NameFile.f90 +++ b/src/Utilities/NameFile.f90 @@ -1,382 +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, 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) - 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) - 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 e74f2c786d3..55edc48b638 100644 --- a/src/Utilities/Observation/Obs3.f90 +++ b/src/Utilities/Observation/Obs3.f90 @@ -1,1197 +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, & - LINELENGTH, NAMEDBOUNDFLAG, MAXCHARLEN, & - MAXOBSTYPES, LENHUGELINE, DNODATA - 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=20), 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 - 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 - ! formats - 30 format(i10) - ! - ! -- 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) - ! - ! -- 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.') -20 format('Error reading begin/end block: ',a) -30 format('Binary output precision set to: ',a) -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, 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) -! Remove PRECISION option at least temporarily. -! Let precision default to DOUBLE. -! case ('PRECISION') -! ! -- Specifies SINGLE or DOUBLE precision for writing simulated values -! ! to a binary file. Default is DOUBLE. -! ! -- get the word following the keyword (the key value) -! call this%parser%GetStringCaps(keyvalue) -! if (localprecision==0) then -! if (keyvalue=='SINGLE') then -! localprecision = 1 -! write(this%iout,30)'SINGLE' -! elseif (keyvalue=='DOUBLE') then -! localprecision = 2 -! write(this%iout,30)'DOUBLE' -! else -! errormessage = 'Error in OBS input: "'//trim(keyvalue)// & -! '" is not a valid option for PRECISION' -! call store_error(errormessage) -! exit readblockoptions -! endif -! else -! errormessage = 'Error in OBS input: PRECISION has already been defined' -! call store_error(errormessage) -! exit readblockoptions -! endif - 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=LENBIGLINE) :: oldheader, newheader - character(len=LENBIGLINE), 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 - oldheader = headr - nam = obsrv%Name - call ExpandArray(obsOutput%obsnames) - idx = size(obsOutput%obsnames) - obsOutput%obsnames(idx) = nam - newheader = trim(oldheader) // ',' // trim(nam) - headr = newheader - 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 - iu = obsOutput%nunit - write(iu,'(a)')trim(headr) - 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=20) :: accarg, bin, fmtarg - type(ObserveType), pointer :: obsrv => null() - type(ObsOutputType), pointer :: obsOutput => null() - ! formats - 40 format(a) - 50 format(/,'Observations read from file "',a,'":',/, & - 'Name',38x,'Type',29x,'Time',9x,'Location data',/, & - '---------------------------------------- -------------------------------', & - ' ----------- --------------------------' ) - 60 format('(Output to file: ',a,')') - ! - numspec = -1 - ermsg = '' - ! - inquire(unit=this%parser%iuactive, name=pnamein) - call GetFileFromPath(pnamein, fnamein) - ! - if (this%echo) write(this%iout,50)trim(fnamein) - ! - found = .true. - readblocks: do - if (.not. found) exit - ! - call this%parser%GetBlock('*', found, ierr, .true., .false., btagfound) - if (.not. found) then - exit readblocks - endif - this%blockTypeFound = btagfound - ! - ! Get keyword, which should be FILEOUT - call this%parser%GetStringCaps(word) - ! - ! -- 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) - call this%parser%StoreErrorUnit() - call ustop() - elseif (this%obsOutputList%ContainsFile(fname)) then - ermsg = 'OBS outfile "' // trim(fname) // & - '" is provided more than once.' - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- 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') - if (word /= 'FILEOUT') then - call store_error('CONTINUOUS keyword must be followed by ' // & - '"FILEOUT" then by filename.') - call this%parser%StoreErrorUnit() - call ustop() - endif - ! -- 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) - if (this%echo) then - call obsrv%WriteTo(this%iout) - endif - enddo readblockcontinuous - case default - ermsg = 'Error: Observation type not recognized: '// & - trim(btagfound) - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - end select - enddo readblocks - ! - 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 6c9b808569d..86f510d2fe1 100644 --- a/src/Utilities/Observation/ObsOutput.f90 +++ b/src/Utilities/Observation/ObsOutput.f90 @@ -25,8 +25,8 @@ module ObsOutputModule integer(I4B), public :: nunit = 0 character(len=500), public :: filename = '' character(len=LENOBSNAME), allocatable, dimension(:), public :: obsnames - character(len=LENBIGLINE), public :: header = '' - character(len=LENBIGLINE), public :: lineout = '' + character(len=LENOBSNAME), public :: header = '' + character(len=LENOBSNAME), public :: lineout = '' logical, public :: FormattedOutput = .true. contains ! -- Public procedures @@ -64,8 +64,9 @@ subroutine WriteLineout(this) implicit none ! -- dummy class(ObsOutputType), intent(inout) :: this - ! - write(this%nunit,'(a)')trim(this%lineout) + ! -- write a line return to end of observation output line + ! for this totim + write(this%nunit,'(a)', advance='YES') '' ! return end subroutine WriteLineout diff --git a/src/Utilities/Observation/ObsUtility.f90 b/src/Utilities/Observation/ObsUtility.f90 index 73c1e77d704..324804117d6 100644 --- a/src/Utilities/Observation/ObsUtility.f90 +++ b/src/Utilities/Observation/ObsUtility.f90 @@ -38,22 +38,27 @@ subroutine write_fmtd_cont(fmtc, obsrv, obsOutputList, value) real(DP), intent(in) :: value ! -- local integer(I4B) :: indx + integer(I4B) :: nunit character(len=50) :: cval - character(len=LENBIGLINE), pointer :: linout => null() + character(len=LENOBSNAME), pointer :: linout => null() type(ObsOutputType), pointer :: ObsOutput => null() !--------------------------------------------------------------------------- ! -- format 10 format(G20.13) + ! -- output unit + nunit = obsrv%UnitNumber ! indx = obsrv%indxObsOutput ObsOutput => obsOutputList%Get(indx) linout => obsOutput%lineout if (linout == '') then - write(linout,10)totim + write(linout,10) totim + write(cval,10) totim + write(nunit, '(a)', advance='NO') trim(adjustl(cval)) endif ! -- append value to output line write(cval,fmtc)value - linout = trim(linout) // ',' // cval + write(nunit, '(a,a)', advance='NO') ',', trim(adjustl(cval)) return end subroutine write_fmtd_cont @@ -74,20 +79,20 @@ subroutine write_unfmtd_cont(obsrv, iprec, obsOutputList, value) use iso_fortran_env, only: real32, real64 implicit none ! -- dummy - type(ObserveType), intent(inout) :: obsrv - integer(I4B), intent(in) :: iprec + type(ObserveType), intent(inout) :: obsrv + integer(I4B), intent(in) :: iprec type(ObsOutputListType), pointer, intent(inout) :: obsOutputList - real(DP), intent(in) :: value + real(DP), intent(in) :: value ! -- local integer(I4B) :: indx, nunit - character(len=LENBIGLINE), pointer :: linout => null() + character(len=LENOBSNAME), pointer :: linout => null() real(real32) :: totimsngl, valsngl real(real64) :: totimdbl, valdbl type(ObsOutputType), pointer :: obsOutput => null() !--------------------------------------------------------------------------- ! -- formats 10 format(G20.13) - ! + ! -- output unit nunit = obsrv%UnitNumber ! -- continuous observation indx = obsrv%indxObsOutput diff --git a/src/Utilities/Observation/Observe.f90 b/src/Utilities/Observation/Observe.f90 index 90d34ff6eea..f57e2b88380 100644 --- a/src/Utilities/Observation/Observe.f90 +++ b/src/Utilities/Observation/Observe.f90 @@ -15,7 +15,8 @@ module ObserveModule use BaseDisModule, only: DisBaseType use ConstantsModule, only: LENBOUNDNAME, LENOBSNAME, LENOBSTYPE, & MAXOBSTYPES, DNODATA, DZERO - use InputOutputModule, only: dclosetest, urword + use TableModule, only: TableType + use InputOutputModule, only: urword use ListModule, only: ListType use SimModule, only: store_warning, store_error, & store_error_unit, ustop @@ -29,7 +30,7 @@ module ObserveModule type :: ObserveType ! -- Public members - ! + ! ! -- For all observations integer(I4B), public :: NodeNumber = 0 integer(I4B), public :: UnitNumber = 0 @@ -38,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 @@ -117,7 +118,7 @@ subroutine ResetCurrent(this) return end subroutine ResetCurrent - subroutine WriteTo(this, iout) + subroutine WriteTo(this, obstab, btagfound, fnamein) ! ************************************************************************** ! WriteTo -- Write information about this observation to table in list file. ! ************************************************************************** @@ -127,12 +128,36 @@ subroutine WriteTo(this, iout) implicit none ! -- dummy class(ObserveType), intent(inout) :: this - integer(I4B), intent(in) :: iout - ! formats - 20 format(a,2x,a,a,t76,'All times',t89,'"',a,'"') + 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(iout,20)this%Name, 'Continuous ', this%ObsTypeId, & - trim(this%IDstring) + ! -- 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 df95a2e659a..b844e4fbf06 100644 --- a/src/Utilities/OutputControl/OutputControl.f90 +++ b/src/Utilities/OutputControl/OutputControl.f90 @@ -1,480 +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=5) :: 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, 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: ', & - 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 dc831c02024..242ed1000ea 100644 --- a/src/Utilities/OutputControl/OutputControlData.f90 +++ b/src/Utilities/OutputControl/OutputControlData.f90 @@ -1,320 +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) -! ****************************************************************************** -! 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 - ! -- local - integer(I4B) :: iprint - integer(I4B) :: idataun -! ------------------------------------------------------------------------------ - ! - iprint = 0 - if(this%psmobj%kstp_to_print(kstp, nstp)) then - iprint = 1 - ipflg = 1 - endif - idataun = 0 - if(this%psmobj%kstp_to_save(kstp, nstp)) idataun = this%idataun - ! - ! -- 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(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 3958bc4135b..cab7172181c 100644 --- a/src/Utilities/Sim.f90 +++ b/src/Utilities/Sim.f90 @@ -1,587 +1,704 @@ -module SimModule - use KindModule, only: DP, I4B - use ConstantsModule, only: MAXCHARLEN,LINELENGTH, ISTDOUT - use SimVariablesModule, only: iout, ireturnerr - implicit none - private - public :: count_errors, iverbose, sim_message, store_error, ustop, & - converge_reset, converge_check, final_message, store_warning, & - store_note, count_warnings, count_notes, store_error_unit, & - store_error_filename, print_notes - integer(I4B) :: iverbose=0 !0: print nothing - !1: print first level subroutine information - 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) :: 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() - implicit none - integer(I4B) :: count_errors - if (allocated(sim_errors)) then - !count_errors = size(sim_errors) - count_errors = nerrors - else - count_errors = 0 - endif - return -end function count_errors - -function count_warnings() - implicit none - integer(I4B) :: count_warnings - if (allocated(sim_warnings)) then - !count_warnings = size(sim_warnings) - count_warnings = nwarnings - else - count_warnings = 0 - endif - return -end function count_warnings - -function count_notes() - implicit none - integer(I4B) :: count_notes - if (allocated(sim_notes)) then - !count_notes = size(sim_notes) - 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: - ! -------------------------------------------------------------------------- - use ArrayHandlersModule, only: ExpandArray - implicit none - ! -- dummy - character(len=*), intent(in) :: errmsg - ! -- local - logical :: inc_array - integer(I4B) :: i - ! - inc_array = .TRUE. - if (allocated(sim_errors)) then - if (count_errors() < size(sim_errors)) then - inc_array = .FALSE. - end if - end if - if (inc_array) then - call ExpandArray(sim_errors, increment=inc_errors) - inc_errors = inc_errors * 1.1 - end if - i = count_errors() + 1 - nerrors = i - sim_errors(i) = errmsg - ! - return -end subroutine store_error - -subroutine store_error_unit(iunit) - ! ************************************************************************** - ! Convert iunit to file name and indicate error reading from this file - ! ************************************************************************** - ! - ! SPECIFICATIONS: - ! -------------------------------------------------------------------------- - implicit none - ! -- 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: - ! -------------------------------------------------------------------------- - implicit none - ! -- 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: - ! -------------------------------------------------------------------------- - use ArrayHandlersModule, only: ExpandArray - implicit none - ! -- 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: - ! -------------------------------------------------------------------------- - use ArrayHandlersModule, only: ExpandArray - implicit none - ! -- 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: - ! -------------------------------------------------------------------------- - implicit none - ! -- local - integer(I4B) :: i, isize - ! -- formats -10 format(/,'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,10) - write(*,10) - do i=1,isize - call write_message(sim_errors(i)) - if (iout > 0) call write_message(sim_errors(i),iout) - enddo - endif - endif - ! - return -end function print_errors - -subroutine print_warnings() - ! ************************************************************************** - ! Print all warning messages that have been stored - ! ************************************************************************** - ! - ! SPECIFICATIONS: - ! -------------------------------------------------------------------------- - implicit none - ! -- local - integer(I4B) :: i, isize - ! -- formats -10 format(/,'WARNINGS:',/) - ! - if (allocated(sim_warnings)) then - isize = count_warnings() - if (isize>0) then - if (iout>0) write(iout,10) - write(*,10) - do i=1,isize - call write_message(sim_warnings(i)) - if (iout>0) call write_message(sim_warnings(i),iout) - enddo - endif - write(*,'()') - if (iout>0) write(iout,'()') - endif - ! - return -end subroutine print_warnings - -subroutine print_notes(numberlist) - ! ************************************************************************** - ! Print all notes that have been stored - ! ************************************************************************** - ! - ! SPECIFICATIONS: - ! -------------------------------------------------------------------------- - implicit none - ! -- dummy - logical, intent(in), optional :: numberlist - ! -- local - integer(I4B) :: i, isize - character(len=MAXCHARLEN+10) :: noteplus - logical :: numlist - ! -- formats -10 format(/,'NOTES:') -20 format(i0,'. ',a) -30 format(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) write(iout,10) - write(*,10) - do i=1,isize - if (numlist) then - write(noteplus,20)i,trim(sim_notes(i)) - else - write(noteplus,30)trim(sim_notes(i)) - endif - call write_message(noteplus) - if (iout>0) call write_message(noteplus,iout) - enddo - endif - endif - ! - return -end subroutine print_notes - -subroutine write_message(message,iunit,error,leadspace,endspace) - ! -- 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" - ! LEADSPACE : if true precede message with blank line - ! ENDSPACE : if true follow message by blank line - ! - implicit none - ! -- dummy - character (len=*), intent(in) :: message - integer(I4B), intent(in), optional :: iunit - logical, intent(in), optional :: error - logical, intent(in), optional :: leadspace - logical, intent(in), optional :: endspace - ! -- 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) - ablank=' ' - itake=0 - j=0 - if(present(iunit))then - junit = iunit - else - junit = ISTDOUT - end if - if(present(leadspace))then - if(leadspace) then - if (junit>0) then - write(junit,*) - else - write(*,*) - endif - endif - 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.ge.nblc) go to 100 - do i=jend,j+1,-1 - if(amessage(i:i).eq.' ') then - if(itake.eq.0) then - if (junit>0) then - write(junit,'(a)',err=200) amessage(j+1:i) - else - write(*,'(a)',err=200) amessage(j+1:i) - endif - itake=2+leadblank - else - if (junit>0) then - write(junit,'(a)',err=200) ablank(1:leadblank+2)//amessage(j+1:i) - else - write(*,'(a)',err=200) ablank(1:leadblank+2)//amessage(j+1:i) - endif - end if - j=i - go to 5 - end if - end do - if(itake.eq.0)then - if (junit>0) then - write(junit,'(a)',err=200) amessage(j+1:jend) - else - write(*,'(a)',err=200) amessage(j+1:jend) - endif - itake=2+leadblank - else - if (junit>0) then - write(junit,'(a)',err=200) ablank(1:leadblank+2)//amessage(j+1:jend) - else - write(*,'(a)',err=200) ablank(1:leadblank+2)//amessage(j+1:jend) - endif - end if - j=jend - go to 5 - ! -100 continue - jend=nblc - if(itake.eq.0)then - if (junit>0) then - write(junit,'(a)',err=200) amessage(j+1:jend) - else - write(*,'(a)',err=200) amessage(j+1:jend) - endif - else - if (junit>0) then - write(junit,'(a)',err=200) ablank(1:leadblank+2)//amessage(j+1:jend) - else - write(*,'(a)',err=200) ablank(1:leadblank+2)//amessage(j+1:jend) - endif - end if - ! - if(present(endspace))then - if(endspace) then - if (junit>0) then - write(junit,*) - else - write(*,*) - endif - endif - end if - return - ! -200 continue - call ustop() - ! -end subroutine write_message - -subroutine sim_message(iv,message) -! -- iv is the verbosity level of this message -! -- (1) means primary subroutine for simulation, exchange, model, -! -- solution, package, etc. -! -- message is a character string message to write - implicit none - integer(I4B),intent(in) :: iv - character(len=*),intent(in) :: message - if(iv<=iverbose) then - write(iout,'(a)') message - endif -end subroutine sim_message - -subroutine ustop(stopmess,ioutlocal) - ! ************************************************************************** - ! Stop program, with option to print message before stopping. - ! ************************************************************************** - ! - ! SPECIFICATIONS: - ! -------------------------------------------------------------------------- - ! -- dummy - implicit none - 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 - write(*,fmt) stopmess - write(iout,fmt) stopmess - 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 - write(*,fmt) msg - if (iout > 0) write(iout,fmt) msg - if (present(ioutlocal)) then - if (ioutlocal > 0 .and. ioutlocal /= iout) write(ioutlocal,fmt) msg - endif - endif - ! - ! -- close iout file - close(iout) - ! - ! -- return appropriate error codes when terminating the program - if (ireturnerr == 0) then - stop - elseif (ireturnerr == 1) then - stop 1 - elseif (ireturnerr == 2) then - stop 2 - else - stop 999 - end if -end subroutine ustop - - subroutine converge_reset() -! ****************************************************************************** -! converge_reset -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use SimVariablesModule, only: isimcnvg -! ------------------------------------------------------------------------------ - ! - isimcnvg = 1 - ! - ! -- Return - return - end subroutine converge_reset - - subroutine converge_check(exit_tsloop) -! ****************************************************************************** -! converge_check -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimVariablesModule, only: isimcnvg, numnoconverge, isimcontinue - ! -- dummy - logical, intent(inout) :: exit_tsloop - ! -- format - character(len=*), parameter :: fmtfail = & - "(1x, 'Simulation convergence failure.', & - ' Simulation will terminate after output and deallocation.')" -! ------------------------------------------------------------------------------ - ! - ! -- Initialize - exit_tsloop = .false. - ! - ! -- Count number of failures - if(isimcnvg == 0) numnoconverge = numnoconverge + 1 - ! - ! -- 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) - exit_tsloop = .true. - endif - ! - ! -- Return - return - end subroutine converge_check - - subroutine final_message() -! ****************************************************************************** -! final_message -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimVariablesModule, only: isimcnvg, numnoconverge, ireturnerr - ! -- formats - character(len=*), parameter :: fmtnocnvg = & - "(1x, 'Simulation convergence failure occurred ', i0, ' time(s).')" -! ------------------------------------------------------------------------------ - ! - ! -- Write message if any nonconvergence - if(numnoconverge > 0) then - write(*, fmtnocnvg) numnoconverge - write(iout, fmtnocnvg) numnoconverge - endif - ! - if(isimcnvg == 0) then - ireturnerr = 1 - call ustop('Premature termination of simulation.', iout) - else - call ustop('Normal termination of simulation.', iout) - endif - ! - ! -- Return - return - end subroutine final_message - -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/SimVariables.f90 b/src/Utilities/SimVariables.f90 index 51e87f94d03..0ff2446eb68 100644 --- a/src/Utilities/SimVariables.f90 +++ b/src/Utilities/SimVariables.f90 @@ -1,12 +1,19 @@ module SimVariablesModule - use KindModule, only: DP, I4B + use, intrinsic :: iso_fortran_env, only: output_unit + use KindModule, only: DP, I4B + use ConstantsModule, only: LINELENGTH, IUSTART, VALL public - character(len=9), parameter :: simfile = 'mfsim.nam' - character(len=9), parameter :: simlstfile = 'mfsim.lst' + character(len=LINELENGTH) :: simfile = 'mfsim.nam' + character(len=LINELENGTH) :: simlstfile = 'mfsim.lst' + character(len=LINELENGTH) :: simstdout = 'mfsim.stdout' + integer(I4B) :: istdout = output_unit ! -- unit number for stdout + integer(I4B) :: isim_level = VALL ! -- unit number for stdout integer(I4B) :: iout ! -- unit number for simulation output integer(I4B) :: isimcnvg ! -- 1 if all objects have converged, 0 otherwise integer(I4B) :: isimcontinue = 0 ! -- 1 to continue if isimcnvg = 0, 0 to terminate integer(I4B) :: isimcheck = 1 ! -- 1 to check input, 0 to ignore checks - integer(I4B) :: numnoconverge = 0 ! -- number of times there were convergence problems + integer(I4B) :: numnoconverge = 0 ! -- number of times there were convergence problems integer(I4B) :: ireturnerr = 0 ! -- return code for program (0 successful, 1 non-convergence, 2 error) + integer(I4B) :: iforcestop = 1 ! -- 1 forces a call to ustop(..) when the simulation has ended, 0 doesn't + integer(I4B) :: iunext = iustart end module SimVariablesModule diff --git a/src/Utilities/SmoothingFunctions.f90 b/src/Utilities/SmoothingFunctions.f90 old mode 100755 new mode 100644 index 1b8ac7a2c31..911dd50c584 --- a/src/Utilities/SmoothingFunctions.f90 +++ b/src/Utilities/SmoothingFunctions.f90 @@ -1,7 +1,7 @@ module SmoothingModule use KindModule, only: DP, I4B - use ConstantsModule, only: DZERO, DHALF, DONE, DTWO, DTHREE, DFOUR, & - & DSIX, DPREC, DEM2, DEM4, DEM5, DEM6, DEM14 + use ConstantsModule, only: DZERO, DHALF, DONE, DTWO, DTHREE, DFOUR, & + & DSIX, DPREC, DEM2, DEM4, DEM5, DEM6, DEM8, DEM14 implicit none contains @@ -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 @@ -373,7 +373,6 @@ function sQuadraticSaturation(top, bot, x, eps, bmin) result(y) return end function sQuadraticSaturation - function svanGenuchtenSaturation(top, bot, x, alpha, beta, sr) result(y) ! ****************************************************************************** @@ -463,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 @@ -558,8 +557,308 @@ function sQSaturationDerivative(top, bot, x) result(y) return 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 +! x-values greater than xi, where dx = x - xi. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return + real(DP) :: y + ! -- dummy variables + real(DP), intent(in) :: x + real(DP), intent(in) :: xi + real(DP), intent(in) :: yi + real(DP), intent(in) :: sm + real(DP), intent(in) :: sp + real(DP), optional, intent(in) :: ta + ! -- local + real(DP) :: a + real(DP) :: b + real(DP) :: dx + real(DP) :: xm + real(DP) :: xp + real(DP) :: ym + real(DP) :: yp +! ------------------------------------------------------------------------------ + ! + ! -- 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 + ! + ! -- 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 +! greater than xi, where dx = x - xi. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return + real(DP) :: y + ! -- dummy variables + real(DP), intent(in) :: x + real(DP), intent(in) :: xi + real(DP), intent(in) :: sm + real(DP), intent(in) :: sp + real(DP), optional, intent(in) :: ta + ! -- local + real(DP) :: a + real(DP) :: b + real(DP) :: dx + real(DP) :: mu + real(DP) :: rho +! ------------------------------------------------------------------------------ + ! + ! -- 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) + ! + ! -- 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. +! From Panday et al. (2013) - eq. 35 - https://dx.doi.org/10.5066/F7R20ZFJ +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return + real(DP) :: y + ! -- dummy variables + real(DP), intent(in) :: x + real(DP), intent(in) :: xi + real(DP), optional, intent(in) :: tomega + ! -- local + real(DP) :: omega + real(DP) :: epsilon + real(DP) :: dx +! ------------------------------------------------------------------------------ + ! + ! -- 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 + ! + ! -- 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. +! From Panday et al. (2013) - eq. 35 - https://dx.doi.org/10.5066/F7R20ZFJ +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return + real(DP) :: y + ! -- dummy variables + real(DP), intent(in) :: x + real(DP), intent(in) :: xi + real(DP), optional, intent(in) :: tomega + ! -- local + real(DP) :: omega + real(DP) :: epsilon + real(DP) :: dx +! ------------------------------------------------------------------------------ + ! + ! -- 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 + ! + ! -- return + return + 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 +! x-values greater than xi, where dx = x - xi. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return + real(DP) :: y + ! -- dummy variables + real(DP), intent(in) :: x + real(DP), intent(in) :: xi + real(DP), intent(in) :: yi + real(DP), intent(in) :: sm + real(DP), intent(in) :: sp + real(DP), optional, intent(in) :: tomega + ! -- local + real(DP) :: omega + real(DP) :: epsilon + real(DP) :: dx + real(DP) :: c +! ------------------------------------------------------------------------------ + ! + ! -- 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 + ! + ! -- return + return + 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 +! yi + (sp * dx) for x-values greater than xi, where dx = x - xi. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return + real(DP) :: y + ! -- dummy variables + real(DP), intent(in) :: x + real(DP), intent(in) :: xi + real(DP), intent(in) :: sm + real(DP), intent(in) :: sp + real(DP), optional, intent(in) :: tomega + ! -- local + real(DP) :: omega + real(DP) :: epsilon + real(DP) :: dx + real(DP) :: c +! ------------------------------------------------------------------------------ + ! + ! -- 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 + ! + ! -- return + return + end function sQuadraticSlopeDerivative - end module SmoothingModule \ No newline at end of file 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 new file mode 100644 index 00000000000..ab86ea241f0 --- /dev/null +++ b/src/Utilities/Table.f90 @@ -0,0 +1,957 @@ +! 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 :: set_iout + 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 set_iout(this, iout) +! ****************************************************************************** +! set_iout -- reset iout +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(TableType) :: this + integer(I4B), intent(in) :: iout + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- set iout + this%iout = iout + ! + ! -- return + return + end subroutine set_iout + + 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 new file mode 100644 index 00000000000..f00d1cc7cd1 --- /dev/null +++ b/src/Utilities/TableTerm.f90 @@ -0,0 +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 + +end module TableTermModule \ No newline at end of file diff --git a/src/Utilities/TimeSeries/TimeArraySeries.f90 b/src/Utilities/TimeSeries/TimeArraySeries.f90 index 8e7985abc11..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 InputOutputModule, only: dclosetest, 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 - private :: epsil - - real(DP), parameter :: epsil = 1.0d-10 - - 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) - 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 (dclosetest(taEarlier%taTime, time, epsil)) 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 (dclosetest(taLater%taTime, time, epsil)) 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. dclosetest(ta%taTime, time, epsil)) 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 72fb8cb33a9..508253baf81 100644 --- a/src/Utilities/TimeSeries/TimeArraySeriesManager.f90 +++ b/src/Utilities/TimeSeries/TimeArraySeriesManager.f90 @@ -1,450 +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 - 5 format(/,'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,5)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 9a05be114a7..2b11a0d15e7 100644 --- a/src/Utilities/TimeSeries/TimeSeries.f90 +++ b/src/Utilities/TimeSeries/TimeSeries.f90 @@ -1,1466 +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 InputOutputModule, only: GetUnit, openfile, ParseLine, upcase, & - dclosetest - 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 - - real(DP), parameter :: epsil = 1.0d-10 - - 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. dclosetest(tsr%tsrTime, time, epsil)) 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. dclosetest(time1,time,epsil)) - 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. dclosetest(time0,time,epsil)) tsrecEarlier => tsrec0 - if (time1 > time .or. dclosetest(time1,time,epsil)) 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. dclosetest(tsr%tsrTime, time, epsil)) 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. dclosetest(time1,time,epsil)) - 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. dclosetest(time0,time,epsil)) then - tsrecEarlier => tsrec0 - nodeEarlier => tsNode0 - endif - if (time1 > time .or. dclosetest(time1,time,epsil)) 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 (dclosetest(tsrEarlier%tsrTime, time, epsil)) 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 (dclosetest(tsrLater%tsrTime, time, epsil)) 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 (dclosetest(currTime, time1, epsil)) 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. dclosetest(currTime,time0,epsil)) then - t0 = currTime - else - t0 = time0 - endif - if (nextTime < time1 .or. dclosetest(nextTime,time1,epsil)) 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 (dclosetest(t1, time1, epsil)) 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. dclosetest(tsr%tsrTime, time, epsil)) 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. dclosetest(time0,time,epsil)) 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 (dclosetest(tsr%tsrTime,time,epsi)) 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) - 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 e0e24b4871e..0879d5d471a 100644 --- a/src/Utilities/TimeSeries/TimeSeriesManager.f90 +++ b/src/Utilities/TimeSeries/TimeSeriesManager.f90 @@ -1,741 +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 - 5 format(/,'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 - ! - ! -- Iterate through boundtslinks and replace specified - ! elements of bound with average value obtained from - ! appropriate time series. (For list-type packages) - nlinks = this%boundtslinks%Count() - nauxlinks = this%auxvartslinks%Count() - do i = 1, nlinks - tsLink => GetTimeSeriesLinkFromList(this%boundTsLinks, i) - if (i == 1) then - if (tsLink%Iprpak == 1) then - write(this%iout,5)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 - if (associated(tsLink%RMultiplier)) then - tsLink%BndElement = tsLink%BndElement * tsLink%RMultiplier - endif -! ! Ned TODO: Need a flag to control output of values generated from time series -! ! Also need to format as a table? Otherwise, just remove this if block. - 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 - !if (i==nlinks) then - ! write(this%iout,'()') - !endif - enddo - ! - ! -- Iterate through auxvartslinks and replace specified - ! elements of auxvar with average value obtained from - ! appropriate time series. - do i=1,nauxlinks - tsLink => GetTimeSeriesLinkFromList(this%auxvarTsLinks, i) - timeseries => tsLink%timeSeries - if (i==1 .and. nlinks==0) then - if (tsLink%Iprpak == 1) then - write(this%iout,5)kper,kstp - endif - endif - tsLink%BndElement = timeseries%GetValue(begintime, endtime) -! ! Ned TODO: Need a flag to control output of values generated from time series -! ! Also need to format as a table? Otherwise, just remove this if block. - 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 - 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 1ac5dbf9ca0..5e4d33dc44c 100644 --- a/src/Utilities/Timer.f90 +++ b/src/Utilities/Timer.f90 @@ -1,180 +1,194 @@ -module TimerModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: DZERO - 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: -! ------------------------------------------------------------------------------ - integer(I4B) :: i - 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(*, fmtdt) (ibdt(i), i = 1, 3), (ibdt(i), i = 5, 7) - ! - ! -- 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 - 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 -! ------------------------------------------------------------------------------ -! -! Get current date and time, assign to IEDT, and write. - CALL DATE_AND_TIME(VALUES=IEDT) - WRITE(*,1000) (IEDT(I),I=1,3),(IEDT(I),I=5,7) - 1000 FORMAT(1X,'Run end date and time (yyyy/mm/dd hh:mm:ss): ', & - I4,'/',I2.2,'/',I2.2,1X,I2,':',I2.2,':',I2.2) - IF(IPRTIM.GT.0) THEN - WRITE(IOUT,'(1X)') - WRITE(IOUT,1000) (IEDT(I),I=1,3),(IEDT(I),I=5,7) - 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(*,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(*,1020) NHOURS,NMINS,NRSECS - 1020 FORMAT(1X,'Elapsed run time: ',I2,' Hours, ',I2, & - ' Minutes, ',I2,' Seconds',/) - ELSEIF (NMINS.GT.0) THEN - WRITE(*,1030) NMINS,NSECS,MSECS - 1030 FORMAT(1X,'Elapsed run time: ',I2,' Minutes, ', & - I2,'.',I3.3,' Seconds',/) - ELSE - WRITE(*,1040) NSECS,MSECS - 1040 FORMAT(1X,'Elapsed run time: ',I2,'.',I3.3,' Seconds',/) - ENDIF -! -! 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 5581d093c8c..12313aea901 100644 --- a/src/Utilities/comarg.f90 +++ b/src/Utilities/comarg.f90 @@ -1,167 +1,258 @@ -module CommandArguments +module CommandArguments use KindModule - use ConstantsModule, only: ISTDOUT, LINELENGTH, LENHUGELINE - use VersionModule, only: VERSION, MFVNAM, IDEVELOPMODE - use CompilerVersion - use SimVariablesModule, only: simfile - use SimModule, only: store_error, ustop, store_error_unit, & - store_error_filename - use InputOutputModule, only: urword - ! - implicit none - ! - private - public :: GetCommandLineArguments - ! - contains - - subroutine GetCommandLineArguments() - ! -- dummy - ! -- local - character(len=LENHUGELINE) :: line - 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 - 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 - integer(I4B) :: ipos - integer(I4B) :: iarg - integer(I4B) :: iterm - real(DP) :: rval -! ------------------------------------------------------------------------------ - ! - ! -- Get the command line string - call GET_COMMAND(line, ilen, istat) - ! - ! -- This will read mf6 executable - lloc = 1 - call urword(line, lloc, istart, istop, 0, ival, rval, 0, inunit) - ! - ! -- remove quotes around the mf6 executable - do i = istart, istop - if (line(i:i) == '"' .or. line(i:i) == "'") then - line(i:i) = ' ' - end if - end do - ! - ! -- find name of executable without path - ipos = index(line(istart:istop), '/', back=.TRUE.) - if (ipos == 0) then - ipos = index(line(istart:istop), '\', back=.TRUE.) - end if - if (ipos /= 0) then - istart = ipos + 1 - end if - ! - ! -- set mf6 executable name - cexe = adjustl(line(istart:istop)) - ! - ! -- 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 - ! - ! -- Read remaining arguments - iarg = 0 - iterm = 0 - do - call urword(line, lloc, istart, istop, 1, ival, rval, 0, inunit) - if (line(istart:istop) == ' ') exit - iarg = iarg + 1 - iterm = 1 - select case(line(istart:istop)) - case('-H', '-?', '--HELP') - call write_usage(trim(adjustl(header)), trim(adjustl(cexe))) - case('-V', '--VERSION') - write(ISTDOUT,'(2a,2(1x,a))') & - trim(adjustl(cexe)), ':', trim(adjustl(VERSION)), ctyp - case('-DEV', '--DEVELOP') - write(ISTDOUT,'(2a,l)') & - trim(adjustl(cexe)), ': develop version', ltyp - case('-C', '--COMPILER') - call get_compiler(compiler) - write(ISTDOUT,'(2a,1x,a)') & - trim(adjustl(cexe)), ':', trim(adjustl(compiler)) - case default - call write_usage(trim(adjustl(header)), trim(adjustl(cexe))) - write(errmsg, '(2a,1x,a)') & - trim(adjustl(cexe)), ': illegal option -', line(istart:istop) - call store_error(errmsg) - end select - end do - ! - ! -- no command line arguments - check if mfsim.nam exists - if (iarg == 0) then - inquire(file=simfile, exist=lexist) - if (.NOT. lexist) then - iterm = 1 - write(errmsg, '(2a,2(1x,a))') & - trim(adjustl(cexe)), ':', simfile, 'is not present in working directory.' - call store_error(errmsg) - end if - end if - ! - ! -- command line arguments present or mfsim.nam file does not exist - if (iterm > 0) then - call USTOP() - 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=*), 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.',/, & - &' ',/,& - &'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(ISTDOUT,'(a,/,a,1x,a,15x,a,2(1x,a),2a,/,a,1x,a,1x,a,5x,a)') & - trim(adjustl(header)), & - 'usage:', cexe, 'run MODFLOW', trim(adjustl(MFVNAM)), & - 'using "', trim(adjustl(simfile)), '"', & - ' or:', cexe, '[options]', & - 'retrieve program information' - write(ISTDOUT, 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 new file mode 100644 index 00000000000..78a99e7fb43 --- /dev/null +++ b/src/Utilities/genericutils.f90 @@ -0,0 +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 + + 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/Utilities/version.f90 b/src/Utilities/version.f90 index 76022a43633..6d080cd80af 100644 --- a/src/Utilities/version.f90 +++ b/src/Utilities/version.f90 @@ -3,7 +3,7 @@ module VersionModule public ! -- modflow 6 version integer(I4B), parameter :: IDEVELOPMODE = 1 - character(len=40), parameter :: VERSION = '6.0.3.8 09/06/2018' + character(len=40), parameter :: VERSION = '6.1.1 12/12/2019' character(len=10), parameter :: MFVNAM = ' 6' character(len=*), parameter :: MFTITLE = & 'U.S. GEOLOGICAL SURVEY MODULAR HYDROLOGIC MODEL' diff --git a/src/mf6.f90 b/src/mf6.f90 index 1ba0a39bf30..814ba3975e9 100644 --- a/src/mf6.f90 +++ b/src/mf6.f90 @@ -1,232 +1,8 @@ -! -program mf6 -! ****************************************************************************** -! Main MODFLOW Version 6 program. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use KindModule, only: DP, I4B - use ConstantsModule, only: ISTDOUT - use VersionModule, only: VERSION, MFVNAM, MFTITLE, FMTDISCLAIMER, & - IDEVELOPMODE - use CompilerVersion - use CommandArguments, only: GetCommandLineArguments - use InputOutputModule, only: write_centered - use SimulationCreateModule, only: simulation_cr, simulation_da - use TimerModule, only: start_time, elapsed_time - use MemoryManagerModule, only: mem_usage, mem_da - use BaseModelModule, only: BaseModelType, GetBaseModelFromList - use BaseExchangeModule, only: BaseExchangeType, GetBaseExchangeFromList - use BaseSolutionModule, only: BaseSolutionType, GetBaseSolutionFromList - use SolutionGroupModule, only: SolutionGroupType, GetSolutionGroupFromList - use ListsModule, only: basesolutionlist, solutiongrouplist, & - basemodellist, baseexchangelist, & - lists_da - use SimVariablesModule, only: iout - use SimModule, only: converge_reset, converge_check, & - final_message - use TdisModule, only: tdis_tu, tdis_da, & - endofsimulation - implicit none - ! -- local - class(SolutionGroupType), pointer :: sgp => null() - class(BaseSolutionType), pointer :: sp => null() - class(BaseModelType), pointer :: mp => null() - class(BaseExchangeType), pointer :: ep => null() - integer(I4B) :: im, ic, is, isg - logical :: exit_tsloop - character(len=80) :: compiler - ! -- formats -! ------------------------------------------------------------------------------ - ! - ! -- parse any command line arguments - call GetCommandLineArguments() - ! - ! -- Write banner to screen (unit 6) and start timer - call write_centered('MODFLOW'//MFVNAM, ISTDOUT, 80) - call write_centered(MFTITLE, ISTDOUT, 80) - call write_centered('VERSION '//VERSION, ISTDOUT, 80) - ! - ! -- Write if develop mode - if (IDEVELOPMODE == 1) call write_centered('***DEVELOP MODE***', ISTDOUT, 80) - ! - ! -- Write compiler version - call get_compiler(compiler) - call write_centered(' ', ISTDOUT, 80) - call write_centered(trim(adjustl(compiler)), ISTDOUT, 80) - ! - ! -- Write disclaimer - write(ISTDOUT, FMTDISCLAIMER) - ! -- get start time - call start_time() - ! - ! - ! -- CREATE (CR) - call simulation_cr() - ! - ! - ! -- DEFINE (DF) - ! -- 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 - ! - ! - ! -- ALLOCATE AND READ (AR) - ! -- 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 - ! - ! - ! -- TIME STEP LOOP - tsloop: do - ! - ! -- TIME UPDATE (TU) - call tdis_tu() - ! - ! - ! -- READ AND PREPARE (RP) - ! -- 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 - ! - ! - ! -- CALCULATE (CA) - call converge_reset() - do isg = 1, solutiongrouplist%Count() - sgp => GetSolutionGroupFromList(solutiongrouplist, isg) - call sgp%sgp_ca() - enddo - ! - ! - ! -- OUTPUT (OT) - ! -- 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 - ! - ! -- Time step exit conditions - call converge_check(exit_tsloop) - if(exit_tsloop) exit tsloop - if(endofsimulation) exit tsloop - ! - enddo tsloop - ! - ! - ! -- 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 program mf6 - +! this is the main entry point for the mf6 program +program mf6 + use Mf6CoreModule + + call Mf6Run() + +end program + \ No newline at end of file diff --git a/src/mf6core.f90 b/src/mf6core.f90 new file mode 100644 index 00000000000..df9ae4e0074 --- /dev/null +++ b/src/mf6core.f90 @@ -0,0 +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 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/bmi.f90 b/srcbmi/bmi.f90 new file mode 100644 index 00000000000..2698f99ab8d --- /dev/null +++ b/srcbmi/bmi.f90 @@ -0,0 +1,469 @@ +module bmif + + implicit none + + integer, parameter :: BMI_MAX_COMPONENT_NAME = 2048 + integer, parameter :: BMI_MAX_VAR_NAME = 2048 + integer, parameter :: BMI_MAX_TYPE_NAME = 2048 + integer, parameter :: BMI_MAX_UNITS_NAME = 2048 + + integer, parameter :: BMI_FAILURE = 1 + integer, parameter :: BMI_SUCCESS = 0 + + type, abstract :: bmi + contains + procedure (bmif_get_component_name), deferred :: get_component_name + procedure (bmif_get_input_var_names), deferred :: get_input_var_names + procedure (bmif_get_output_var_names), deferred :: get_output_var_names + procedure (bmif_initialize), deferred :: initialize + procedure (bmif_finalize), deferred :: finalize + procedure (bmif_get_start_time), deferred :: get_start_time + procedure (bmif_get_end_time), deferred :: get_end_time + procedure (bmif_get_current_time), deferred :: get_current_time + procedure (bmif_get_time_step), deferred :: get_time_step + procedure (bmif_get_time_units), deferred :: get_time_units + procedure (bmif_update), deferred :: update + procedure (bmif_update_frac), deferred :: update_frac + procedure (bmif_update_until), deferred :: update_until + procedure (bmif_get_var_grid), deferred :: get_var_grid + procedure (bmif_get_grid_type), deferred :: get_grid_type + procedure (bmif_get_grid_rank), deferred :: get_grid_rank + procedure (bmif_get_grid_shape), deferred :: get_grid_shape + procedure (bmif_get_grid_size), deferred :: get_grid_size + procedure (bmif_get_grid_spacing), deferred :: get_grid_spacing + procedure (bmif_get_grid_origin), deferred :: get_grid_origin + procedure (bmif_get_grid_x), deferred :: get_grid_x + procedure (bmif_get_grid_y), deferred :: get_grid_y + procedure (bmif_get_grid_z), deferred :: get_grid_z + procedure (bmif_get_grid_connectivity), deferred :: get_grid_connectivity + procedure (bmif_get_grid_offset), deferred :: get_grid_offset + procedure (bmif_get_var_type), deferred :: get_var_type + procedure (bmif_get_var_units), deferred :: get_var_units + procedure (bmif_get_var_itemsize), deferred :: get_var_itemsize + procedure (bmif_get_var_nbytes), deferred :: get_var_nbytes + procedure (bmif_get_value_int), deferred :: get_value_int + procedure (bmif_get_value_float), deferred :: get_value_float + procedure (bmif_get_value_double), deferred :: get_value_double + procedure (bmif_get_value_ptr_int), deferred :: get_value_ptr_int + procedure (bmif_get_value_ptr_float), deferred :: get_value_ptr_float + procedure (bmif_get_value_ptr_double), deferred :: get_value_ptr_double + procedure (bmif_get_value_at_indices_int), deferred :: & + get_value_at_indices_int + procedure (bmif_get_value_at_indices_float), deferred :: & + get_value_at_indices_float + procedure (bmif_get_value_at_indices_double), deferred :: & + get_value_at_indices_double + procedure (bmif_set_value_int), deferred :: set_value_int + procedure (bmif_set_value_float), deferred :: set_value_float + procedure (bmif_set_value_double), deferred :: set_value_double + procedure (bmif_set_value_at_indices_int), deferred :: & + set_value_at_indices_int + procedure (bmif_set_value_at_indices_float), deferred :: & + set_value_at_indices_float + procedure (bmif_set_value_at_indices_double), deferred :: & + set_value_at_indices_double + end type bmi + + abstract interface + + ! Get the name of the model. + function bmif_get_component_name(this, name) result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + character (len=*), pointer, intent(out) :: name + integer :: bmi_status + end function bmif_get_component_name + + ! List a model's input variables. + function bmif_get_input_var_names(this, names) result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + character (len=*), pointer, intent(out) :: names(:) + integer :: bmi_status + end function bmif_get_input_var_names + + ! List a model's output variables. + function bmif_get_output_var_names(this, names) result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + character (len=*), pointer, intent(out) :: names(:) + integer :: bmi_status + end function bmif_get_output_var_names + + ! Perform startup tasks for the model. + function bmif_initialize(this, config_file) result(bmi_status) + import :: bmi + class (bmi), intent(out) :: this + character (len=*), intent(in) :: config_file + integer :: bmi_status + end function bmif_initialize + + ! Perform teardown tasks for the model. + function bmif_finalize(this) result(bmi_status) + import :: bmi + class (bmi), intent(inout) :: this + integer :: bmi_status + end function bmif_finalize + + ! Start time of the model. + function bmif_get_start_time(this, time) result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + double precision, intent(out) :: time + integer :: bmi_status + end function bmif_get_start_time + + ! End time of the model. + function bmif_get_end_time(this, time) result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + double precision, intent(out) :: time + integer :: bmi_status + end function bmif_get_end_time + + ! Current time of the model. + function bmif_get_current_time(this, time) result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + double precision, intent(out) :: time + integer :: bmi_status + end function bmif_get_current_time + + ! Time step of the model. + function bmif_get_time_step(this, time_step) result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + double precision, intent(out) :: time_step + integer :: bmi_status + end function bmif_get_time_step + + ! Time units of the model. + function bmif_get_time_units(this, time_units) result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + character (len=*), intent(out) :: time_units + integer :: bmi_status + end function bmif_get_time_units + + ! Advance the model one time step. + function bmif_update(this) result(bmi_status) + import :: bmi + class (bmi), intent(inout) :: this + integer :: bmi_status + end function bmif_update + + ! Advance the model by a fraction of a time step. + function bmif_update_frac(this, time_frac) result(bmi_status) + import :: bmi + class (bmi), intent(inout) :: this + double precision, intent(in) :: time_frac + integer :: bmi_status + end function bmif_update_frac + + ! Advance the model until the given time. + function bmif_update_until(this, time) result(bmi_status) + import :: bmi + class (bmi), intent(inout) :: this + double precision, intent(in) :: time + integer :: bmi_status + end function bmif_update_until + + ! Get the grid identifier for the given variable. + function bmif_get_var_grid(this, var_name, grid_id) result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + character (len=*), intent(in) :: var_name + integer, intent(out) :: grid_id + integer :: bmi_status + end function bmif_get_var_grid + + ! Get the grid type as a string. + function bmif_get_grid_type(this, grid_id, grid_type) result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + integer, intent(in) :: grid_id + character (len=*), intent(out) :: grid_type + integer :: bmi_status + end function bmif_get_grid_type + + ! Get number of dimensions of the computational grid. + function bmif_get_grid_rank(this, grid_id, grid_rank) result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + integer, intent(in) :: grid_id + integer, intent(out) :: grid_rank + integer :: bmi_status + end function bmif_get_grid_rank + + ! Get the dimensions of the computational grid. + function bmif_get_grid_shape(this, grid_id, grid_shape) result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + integer, intent(in) :: grid_id + integer, dimension(:), intent(out) :: grid_shape + integer :: bmi_status + end function bmif_get_grid_shape + + ! Get the total number of elements in the computational grid. + function bmif_get_grid_size(this, grid_id, grid_size) result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + integer, intent(in) :: grid_id + integer, intent(out) :: grid_size + integer :: bmi_status + end function bmif_get_grid_size + + ! Get distance between nodes of the computational grid. + function bmif_get_grid_spacing(this, grid_id, grid_spacing) result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + integer, intent(in) :: grid_id + double precision, dimension(:), intent(out) :: grid_spacing + integer :: bmi_status + end function bmif_get_grid_spacing + + ! Get coordinates of the origin of the computational grid. + function bmif_get_grid_origin(this, grid_id, grid_origin) result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + integer, intent(in) :: grid_id + double precision, dimension(:), intent(out) :: grid_origin + integer :: bmi_status + end function bmif_get_grid_origin + + ! Get the x-coordinates of the nodes of a computational grid. + function bmif_get_grid_x(this, grid_id, grid_x) result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + integer, intent(in) :: grid_id + double precision, dimension(:), intent(out) :: grid_x + integer :: bmi_status + end function bmif_get_grid_x + + ! Get the y-coordinates of the nodes of a computational grid. + function bmif_get_grid_y(this, grid_id, grid_y) result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + integer, intent(in) :: grid_id + double precision, dimension(:), intent(out) :: grid_y + integer :: bmi_status + end function bmif_get_grid_y + + ! Get the z-coordinates of the nodes of a computational grid. + function bmif_get_grid_z(this, grid_id, grid_z) result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + integer, intent(in) :: grid_id + double precision, dimension(:), intent(out) :: grid_z + integer :: bmi_status + end function bmif_get_grid_z + + ! Get the connectivity array of the nodes of an unstructured grid. + function bmif_get_grid_connectivity(this, grid_id, grid_conn) & + result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + integer, intent(in) :: grid_id + integer, dimension(:), intent(out) :: grid_conn + integer :: bmi_status + end function bmif_get_grid_connectivity + + ! Get the offsets of the nodes of an unstructured grid. + function bmif_get_grid_offset(this, grid_id, grid_offset) & + result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + integer, intent(in) :: grid_id + integer, dimension(:), intent(out) :: grid_offset + integer :: bmi_status + end function bmif_get_grid_offset + + ! Get the data type of the given variable as a string. + function bmif_get_var_type(this, var_name, var_type) result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + character (len=*), intent(in) :: var_name + character (len=*), intent(out) :: var_type + integer :: bmi_status + end function bmif_get_var_type + + ! Get the units of the given variable. + function bmif_get_var_units(this, var_name, var_units) result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + character (len=*), intent(in) :: var_name + character (len=*), intent(out) :: var_units + integer :: bmi_status + end function bmif_get_var_units + + ! Get memory use per array element, in bytes. + function bmif_get_var_itemsize(this, var_name, var_size) result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + character (len=*), intent(in) :: var_name + integer, intent(out) :: var_size + integer :: bmi_status + end function bmif_get_var_itemsize + + ! Get size of the given variable, in bytes. + function bmif_get_var_nbytes(this, var_name, var_nbytes) result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + character (len=*), intent(in) :: var_name + integer, intent(out) :: var_nbytes + integer :: bmi_status + end function bmif_get_var_nbytes + + ! Get a copy of values (flattened!) of the given integer variable. + function bmif_get_value_int(this, var_name, dest) result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + character (len=*), intent(in) :: var_name + integer, intent(inout) :: dest(:) + integer :: bmi_status + end function bmif_get_value_int + + ! Get a copy of values (flattened!) of the given real variable. + function bmif_get_value_float(this, var_name, dest) result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + character (len=*), intent(in) :: var_name + real, intent(inout) :: dest(:) + integer :: bmi_status + end function bmif_get_value_float + + ! Get a copy of values (flattened!) of the given double variable. + function bmif_get_value_double(this, var_name, dest) result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + character (len=*), intent(in) :: var_name + double precision, intent(inout) :: dest(:) + integer :: bmi_status + end function bmif_get_value_double + + ! Get a reference to the given integer variable. + function bmif_get_value_ptr_int(this, var_name, dest) & + result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + character (len=*), intent(in) :: var_name + integer, pointer, intent(inout) :: dest(:) + integer :: bmi_status + end function bmif_get_value_ptr_int + + ! Get a reference to the given real variable. + function bmif_get_value_ptr_float(this, var_name, dest) & + result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + character (len=*), intent(in) :: var_name + real, pointer, intent(inout) :: dest(:) + integer :: bmi_status + end function bmif_get_value_ptr_float + + ! Get a reference to the given double variable. + function bmif_get_value_ptr_double(this, var_name, dest) & + result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + character (len=*), intent(in) :: var_name + double precision, pointer, intent(inout) :: dest(:) + integer :: bmi_status + end function bmif_get_value_ptr_double + + ! Get integer values at particular (one-dimensional) indices. + function bmif_get_value_at_indices_int(this, var_name, dest, indices) & + result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + character (len=*), intent(in) :: var_name + integer, intent(inout) :: dest(:) + integer, intent(in) :: indices(:) + integer :: bmi_status + end function bmif_get_value_at_indices_int + + ! Get real values at particular (one-dimensional) indices. + function bmif_get_value_at_indices_float(this, var_name, dest, indices) & + result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + character (len=*), intent(in) :: var_name + real, intent(inout) :: dest(:) + integer, intent(in) :: indices(:) + integer :: bmi_status + end function bmif_get_value_at_indices_float + + ! Get double values at particular (one-dimensional) indices. + function bmif_get_value_at_indices_double(this, var_name, dest, indices) & + result(bmi_status) + import :: bmi + class (bmi), intent(in) :: this + character (len=*), intent(in) :: var_name + double precision, intent(inout) :: dest(:) + integer, intent(in) :: indices(:) + integer :: bmi_status + end function bmif_get_value_at_indices_double + + ! Set new values for an integer model variable. + function bmif_set_value_int(this, var_name, src) result(bmi_status) + import :: bmi + class (bmi), intent(inout) :: this + character (len=*), intent(in) :: var_name + integer, intent(in) :: src(:) + integer :: bmi_status + end function bmif_set_value_int + + ! Set new values for a real model variable. + function bmif_set_value_float(this, var_name, src) result(bmi_status) + import :: bmi + class (bmi), intent(inout) :: this + character (len=*), intent(in) :: var_name + real, intent(in) :: src(:) + integer :: bmi_status + end function bmif_set_value_float + + ! Set new values for a double model variable. + function bmif_set_value_double(this, var_name, src) result(bmi_status) + import :: bmi + class (bmi), intent(inout) :: this + character (len=*), intent(in) :: var_name + double precision, intent(in) :: src(:) + integer :: bmi_status + end function bmif_set_value_double + + ! Set integer values at particular (one-dimensional) indices. + function bmif_set_value_at_indices_int(this, var_name, indices, src) & + result(bmi_status) + import :: bmi + class (bmi), intent(inout) :: this + character (len=*), intent(in) :: var_name + integer, intent(in) :: indices(:) + integer, intent(in) :: src(:) + integer :: bmi_status + end function bmif_set_value_at_indices_int + + ! Set real values at particular (one-dimensional) indices. + function bmif_set_value_at_indices_float(this, var_name, indices, src) & + result(bmi_status) + import :: bmi + class (bmi), intent(inout) :: this + character (len=*), intent(in) :: var_name + integer, intent(in) :: indices(:) + real, intent(in) :: src(:) + integer :: bmi_status + end function bmif_set_value_at_indices_float + + ! Set double values at particular (one-dimensional) indices. + function bmif_set_value_at_indices_double(this, var_name, indices, src) & + result(bmi_status) + import :: bmi + class (bmi), intent(inout) :: this + character (len=*), intent(in) :: var_name + integer, intent(in) :: indices(:) + double precision, intent(in) :: src(:) + integer :: bmi_status + end function bmif_set_value_at_indices_double + + end interface + +end module bmif diff --git a/srcbmi/mf6ami.f90 b/srcbmi/mf6ami.f90 new file mode 100644 index 00000000000..ffca68ded80 --- /dev/null +++ b/srcbmi/mf6ami.f90 @@ -0,0 +1,170 @@ +! this module contains entry points for the mf6 dll to expose functionality +! that is _beyond_ the basic model interface: https://bmi-spec.readthedocs.io/en/latest/ +module mf6ami + use Mf6CoreModule + use KindModule + use bmif, only: BMI_SUCCESS, BMI_FAILURE + use iso_c_binding, only: c_int + implicit none + + ! this is the counter for the outer iteration loop, + ! it is initialized in prepare_iteration + integer(I4B), pointer :: iterationCounter => null() + + contains + + function ami_prepare_timestep() result(bmi_status) bind(C, name="prepare_timestep") + !DEC$ ATTRIBUTES DLLEXPORT :: ami_prepare_timestep + integer(kind=c_int) :: bmi_status + + call Mf6PrepareTimestep() + bmi_status = BMI_SUCCESS + + end function ami_prepare_timestep + + function ami_finalize_timestep() result(bmi_status) bind(C, name="finalize_timestep") + !DEC$ ATTRIBUTES DLLEXPORT :: ami_finalize_timestep + integer(kind=c_int) :: bmi_status + ! local + logical :: hasConverged + + hasConverged = Mf6FinalizeTimestep() + if (hasConverged) then + bmi_status = BMI_SUCCESS + else + bmi_status = BMI_FAILURE + end if + + end function ami_finalize_timestep + + ! returns the number of NumericalSolutions in the simulation. + ! It works if there is only one SolutionGroup used. + function ami_get_subcomponent_count(count) result(bmi_status) bind(C, name="get_subcomponent_count") + !DEC$ ATTRIBUTES DLLEXPORT :: ami_get_subcomponent_count + use ListsModule, only: solutiongrouplist + use SimVariablesModule, only: iout + integer(kind=c_int) :: bmi_status + integer(kind=c_int), intent(out) :: count + ! local + class(SolutionGroupType), pointer :: sgp + + ! TODO_MJR: this goes for all calls, move to init I guess... + if (solutiongrouplist%Count() /= 1) then + write(iout,*) 'multiple solution groups not supported' + count = -1 + bmi_status = BMI_FAILURE + return + end if + + sgp => GetSolutionGroupFromList(solutiongrouplist, 1) + count = sgp%nsolutions + bmi_status = BMI_SUCCESS + + end function ami_get_subcomponent_count + + ! this prepares for running a single outer iteration on the + ! specific subcomponent (=NumericalSolution) + function ami_prepare_iteration(subcomponent_idx) result(bmi_status) bind(C, name="prepare_iteration") + !DEC$ ATTRIBUTES DLLEXPORT :: ami_prepare_iteration + use NumericalSolutionModule + integer(kind=c_int) :: subcomponent_idx ! 1,2,...,ami_get_subcomponent_count() + integer(kind=c_int) :: bmi_status + ! local + class(NumericalSolutionType), pointer :: ns + + ! get the numerical solution we are running + ns => getSolution(subcomponent_idx) + + ! prepare with defaults, i.e. no subtiming and picard + call ns%prepareIteration(1, 1) + + ! reset counter + allocate(iterationCounter) + iterationCounter = 0 + + bmi_status = BMI_SUCCESS + + end function ami_prepare_iteration + + ! execute a single outer iteration on the specified + ! subcomponent (=NumericalSolution) + function ami_do_iteration(subcomponent_idx, has_converged) result(bmi_status) bind(C, name="do_iteration") + !DEC$ ATTRIBUTES DLLEXPORT :: ami_do_iteration + use NumericalSolutionModule + integer(kind=c_int), intent(in) :: subcomponent_idx ! 1,2,...,ami_get_subcomponent_count() + integer(kind=c_int), intent(out) :: has_converged + integer(kind=c_int) :: bmi_status + ! local + class(NumericalSolutionType), pointer :: ns + + ! get the numerical solution we are running + ns => getSolution(subcomponent_idx) + + ! execute the nth iteration + iterationCounter = iterationCounter + 1 + call ns%doIteration(iterationCounter) + + ! the following check is equivalent to that in NumericalSolution%sln_ca + if (ns%icnvg == 1) then + has_converged = 1 + else + has_converged = 0 + end if + + bmi_status = BMI_SUCCESS + + end function ami_do_iteration + + ! after the convergence loop on the subcomponent is done, + ! call this to report, clean up, etc. + function ami_finalize_iteration(subcomponent_idx) result(bmi_status) bind(C, name="finalize_iteration") + !DEC$ ATTRIBUTES DLLEXPORT :: ami_finalize_iteration + use NumericalSolutionModule + integer(kind=c_int), intent(in) :: subcomponent_idx ! 1,2,...,ami_get_subcomponent_count() + integer(kind=c_int) :: bmi_status + ! local + class(NumericalSolutionType), pointer :: ns + integer(I4B) :: hasConverged + + ! get the numerical solution we are running + ns => getSolution(subcomponent_idx) + + ! hasConverged is equivalent to the isgcnvg variable which is initialized to 1, + ! see the body of the picard loop in SolutionGroupType%sgp_ca + hasConverged = 1 + + ! finish up + call ns%finalizeIteration(iterationCounter, hasConverged, 1, 0) + + ! check convergence on solution + if (hasConverged == 1) then + bmi_status = BMI_SUCCESS + else + bmi_status = BMI_FAILURE + end if + + ! clear this for safety + deallocate(iterationCounter) + + end function ami_finalize_iteration + + ! the subcomponent_idx runs from 1 to the nr of + ! solutions in the solution group + function getSolution(subcomponent_idx) result(solution) + use SolutionGroupModule + use NumericalSolutionModule + use ListsModule, only: basesolutionlist, solutiongrouplist + integer(I4B), intent(in) :: subcomponent_idx + class(NumericalSolutionType), pointer :: solution + ! local + class(SolutionGroupType), pointer :: sgp + integer(I4B) :: solutionIdx + + ! this is equivalent to how it's done in sgp_ca + sgp => GetSolutionGroupFromList(solutiongrouplist, 1) + solutionIdx = sgp%idsolutions(subcomponent_idx) + solution => GetNumericalSolutionFromList(basesolutionlist, solutionIdx) + + end function getSolution + +end module mf6ami \ No newline at end of file diff --git a/srcbmi/mf6bmi.f90 b/srcbmi/mf6bmi.f90 new file mode 100644 index 00000000000..f410e26bb3b --- /dev/null +++ b/srcbmi/mf6bmi.f90 @@ -0,0 +1,843 @@ +! Module description: +! TODO_MJR +! +! Note on style: BMI apparently uses underscores, we use underscores in some +! places but camelcase in other. Since this is a dedicated BMI interface module, +! we'll use underscores here as well. +module mf6bmi + use Mf6CoreModule + 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 + implicit none + + ! Define global constants + integer(c_int), BIND(C, name="MAXSTRLEN") :: MAXSTRLEN = MAXCHARLEN + !DEC$ ATTRIBUTES DLLEXPORT :: MAXSTRLEN + + contains + + ! initialize the computational core, assuming to have the configuration + ! file 'mfsim.nam' in the working directory + ! NOTE: initialize should be matched with a call to finalize, but there + ! is currently no reason to believe that we can reinitialize a model in + ! the same memory space... currently you would have to create a new process + ! for that. + 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() + ! + ! -- open stdout file mfsim.stdout + open(unit=istdout, file=simstdout) + ! + ! -- initialize MODFLOW 6 + call Mf6Initialize() + bmi_status = BMI_SUCCESS + + end function bmi_initialize + + ! perform a computational time step, it will prepare the timestep and + ! then call sgp_ca (calculate) on all the solution groups in the simulation + function bmi_update() result(bmi_status) bind(C, name="update") + !DEC$ ATTRIBUTES DLLEXPORT :: bmi_update + integer(kind=c_int) :: bmi_status + ! local + logical :: hasConverged + + hasConverged = Mf6Update() + + ! TODO_MJR: not sure about this. Should bmi_status only represent the + ! state of the BMI, or does it include the state of the simulation? + if (hasConverged) then + bmi_status = BMI_SUCCESS + else + bmi_status = BMI_FAILURE + end if + + end function bmi_update + + ! Perform teardown tasks for the model. + function bmi_finalize() result(bmi_status) bind(C, name="finalize") + !DEC$ ATTRIBUTES DLLEXPORT :: bmi_finalize + use SimVariablesModule, only: iforcestop, ireturnerr + integer(kind=c_int) :: bmi_status + + ! we don't want a full stop() here, this disables it: + iforcestop = 0 + call Mf6Finalize() + + bmi_status = BMI_SUCCESS + + end function bmi_finalize + + ! Start time of the model, as MODFLOW does not have internal time, + ! this will currently be returning 0.0 + function get_start_time(time) result(bmi_status) bind(C, name="get_start_time") + !DEC$ ATTRIBUTES DLLEXPORT :: get_start_time + double precision, intent(out) :: time + integer(kind=c_int) :: bmi_status + + time = 0.0_DP + bmi_status = BMI_SUCCESS + + end function get_start_time + + ! End time of the model. + function get_end_time(time) result(bmi_status) bind(C, name="get_end_time") + !DEC$ ATTRIBUTES DLLEXPORT :: get_end_time + use TdisModule, only: totalsimtime + double precision, intent(out) :: time + integer(kind=c_int) :: bmi_status + + time = totalsimtime + bmi_status = BMI_SUCCESS + + end function get_end_time + + ! Current time of the model. + function get_current_time(time) result(bmi_status) bind(C, name="get_current_time") + !DEC$ ATTRIBUTES DLLEXPORT :: get_current_time + use TdisModule, only: totim + double precision, intent(out) :: time + integer(kind=c_int) :: bmi_status + + time = totim + bmi_status = BMI_SUCCESS + + end function get_current_time + + ! Get memory use per array element, in bytes. + function get_var_itemsize(c_var_name, var_size) result(bmi_status) bind(C, name="get_var_itemsize") + !DEC$ ATTRIBUTES DLLEXPORT :: get_var_itemsize + use MemoryManagerModule, only: get_mem_size + character (kind=c_char), intent(in) :: c_var_name(*) + integer, intent(out) :: var_size + integer(kind=c_int) :: bmi_status + ! local + character(len=LENORIGIN) :: origin + character(len=LENVARNAME) :: var_name_only + + call split_c_var_name(c_var_name, origin, var_name_only) + + bmi_status = BMI_SUCCESS + call get_mem_size(var_name_only, origin, var_size) + if (var_size == -1) bmi_status = BMI_FAILURE + + end function get_var_itemsize + + ! Get size of the given variable, in bytes. + function get_var_nbytes(c_var_name, var_nbytes) result(bmi_status) bind(C, name="get_var_nbytes") + !DEC$ ATTRIBUTES DLLEXPORT :: get_var_nbytes + use MemoryManagerModule, only: get_mem_size, get_isize + character (kind=c_char), intent(in) :: c_var_name(*) + integer, intent(out) :: var_nbytes + integer(kind=c_int) :: bmi_status + ! local + integer :: var_size, isize + character(len=LENORIGIN) :: origin + character(len=LENVARNAME) :: var_name_only + + call split_c_var_name(c_var_name, origin, var_name_only) + + bmi_status = BMI_SUCCESS + call get_mem_size(var_name_only, origin, var_size) + if (var_size == -1) bmi_status = BMI_FAILURE + call get_isize(var_name_only, origin, isize) + if (isize == -1) bmi_status = BMI_FAILURE + + var_nbytes = var_size*isize + + end function get_var_nbytes + + + ! set the pointer to the array of the given double variable, there + ! is no copying of data involved!! + function get_value_ptr_double(c_var_name, x) result(bmi_status) bind(C, name="get_value_ptr_double") + !DEC$ ATTRIBUTES DLLEXPORT :: get_value_ptr_double + use MemoryManagerModule, only: mem_setptr, get_mem_rank + character (kind=c_char), intent(in) :: c_var_name(*) + type(c_ptr), intent(inout) :: x + integer(kind=c_int) :: bmi_status + ! local + integer :: i + character(len=LENORIGIN) :: origin + character(len=LENVARNAME) :: var_name_only + real(DP), pointer :: dblptr + real(DP), dimension(:), pointer, contiguous :: arrayptr + real(DP), dimension(:,:), pointer, contiguous :: arrayptr2D + integer(I4B) :: rank + + call split_c_var_name(c_var_name, origin, var_name_only) + + rank = -1 + call get_mem_rank(var_name_only, origin, rank) + if (rank == 0) then + call mem_setptr(dblptr, var_name_only, origin) + x = c_loc(dblptr) + else if (rank == 1) then + call mem_setptr(arrayptr, var_name_only, origin) + x = c_loc(arrayptr) + else if (rank == 2) then + call mem_setptr(arrayptr2D, var_name_only, origin) + x = c_loc(arrayptr2D) + else + bmi_status = BMI_FAILURE + return + end if + bmi_status = BMI_SUCCESS + + end function get_value_ptr_double + + ! set the pointer to the array of the given integer variable, there + ! is no copying of data involved!! + ! + ! NB: in the future this might merge with get_value_ptr_double, we could + ! dispatch on the type ourselves and the c_ptr will work for both... + function get_value_ptr_int(c_var_name, x) result(bmi_status) bind(C, name="get_value_ptr_int") + !DEC$ ATTRIBUTES DLLEXPORT :: get_value_ptr_int + use MemoryManagerModule, only: mem_setptr, get_mem_rank + character (kind=c_char), intent(in) :: c_var_name(*) + type(c_ptr), intent(inout) :: x + integer(kind=c_int) :: bmi_status + ! local + integer :: i + character(len=LENORIGIN) :: origin + character(len=LENVARNAME) :: var_name_only + integer(I4B) :: rank + integer(I4B), pointer :: scalarptr + integer(I4B), dimension(:), pointer, contiguous :: arrayptr + integer(I4B), dimension(:,:), pointer, contiguous :: arrayptr2D + + call split_c_var_name(c_var_name, origin, var_name_only) + + rank = -1 + call get_mem_rank(var_name_only, origin, rank) + + if (rank == 0) then + call mem_setptr(scalarptr, var_name_only, origin) + x = c_loc(scalarptr) + else if (rank == 1) then + call mem_setptr(arrayptr, var_name_only, origin) + x = c_loc(arrayptr) + else if (rank == 2) then + call mem_setptr(arrayptr, var_name_only, origin) + x = c_loc(arrayptr2D) + else + bmi_status = BMI_FAILURE + return + end if + + bmi_status = BMI_SUCCESS + + end function get_value_ptr_int + + function get_var_type(c_var_name, c_var_type) result(bmi_status) bind(C, name="get_var_type") + !DEC$ ATTRIBUTES DLLEXPORT :: get_var_type + use MemoryManagerModule, only: get_mem_type + use ConstantsModule, only: LENMEMTYPE + character (kind=c_char), intent(in) :: c_var_name(*) + character (kind=c_char), intent(out) :: c_var_type(MAXSTRLEN) + integer(kind=c_int) :: bmi_status + ! local + character(len=LENORIGIN) :: origin + character(len=LENVARNAME) :: var_name_only + character(len=LENMEMTYPE) :: mem_type + + call split_c_var_name(c_var_name, origin, var_name_only) + + bmi_status = BMI_SUCCESS + call get_mem_type(var_name_only, origin, mem_type) + c_var_type(1:len(trim(mem_type))+1) = string_to_char_array(trim(mem_type), len(trim(mem_type))) + end function get_var_type + + ! TODO_MJR: this isn't BMI, move? + function get_var_rank(c_var_name, c_var_rank) result(bmi_status) bind(C, name="get_var_rank") + !DEC$ ATTRIBUTES DLLEXPORT :: get_var_rank + use MemoryManagerModule, only: get_mem_rank + character (kind=c_char), intent(in) :: c_var_name(*) + integer(kind=c_int), intent(out) :: c_var_rank + integer(kind=c_int) :: bmi_status + ! local + character(len=LENORIGIN) :: origin + character(len=LENVARNAME) :: var_name_only + + call split_c_var_name(c_var_name, origin, var_name_only) + + call get_mem_rank(var_name_only, origin, c_var_rank) + if (c_var_rank == -1) then + bmi_status = BMI_FAILURE + return + end if + + bmi_status = BMI_SUCCESS + + end function get_var_rank + + ! TODO_MJR: this isn't BMI, move? + function get_var_shape(c_var_name, c_var_shape) result(bmi_status) bind(C, name="get_var_shape") + !DEC$ ATTRIBUTES DLLEXPORT :: get_var_shape + use ConstantsModule, only: MAXMEMRANK + use MemoryManagerModule, only: get_mem_shape, get_mem_rank + character (kind=c_char), intent(in) :: c_var_name(*) + integer(c_int), intent(inout) :: c_var_shape(*) + integer(kind=c_int) :: bmi_status + ! local + integer(I4B), dimension(MAXMEMRANK) :: var_shape + integer :: var_rank + character(len=LENORIGIN) :: origin + character(len=LENVARNAME) :: var_name_only + + call split_c_var_name(c_var_name, origin, var_name_only) + + var_shape = 0 + var_rank = 0 + call get_mem_rank(var_name_only, origin, var_rank) + call get_mem_shape(var_name_only, origin, var_shape) + if (var_shape(1) == -1 .or. var_rank == -1) then + bmi_status = BMI_FAILURE + return + end if + + ! The user of the BMI is assumed C style, so if the internal shape + ! is (100,1) we get (100,1,undef) from the call get_mem_shape + ! This we need to revert to C-style which should be (1,100) + ! hence, we reverse the array and drop undef + c_var_shape(1:var_rank) = var_shape(var_rank:1:-1) + bmi_status = BMI_SUCCESS + + end function get_var_shape + + + ! Get the grid identifier for the given variable. + function get_var_grid(c_var_name, var_grid) result(bmi_status) bind(C, name="get_var_grid") + !DEC$ ATTRIBUTES DLLEXPORT :: get_var_grid + use ListsModule, only: basemodellist + use BaseModelModule, only: BaseModelType, GetBaseModelFromList + character (kind=c_char), intent(in) :: c_var_name(*) + integer(kind=c_int), intent(out) :: var_grid + integer(kind=c_int) :: bmi_status + ! local + character(len=LENMODELNAME) :: model_name + character(len=LENORIGIN) :: var_name + integer :: i + class(BaseModelType), pointer :: baseModel + + var_name = char_array_to_string(c_var_name, strlen(c_var_name)) + model_name = extract_model_name(var_name) + + var_grid = 0 + do i = 1,basemodellist%Count() + baseModel => GetBaseModelFromList(basemodellist, i) + if (baseModel%name == model_name) then + var_grid = baseModel%id + bmi_status = BMI_SUCCESS + return + end if + end do + + ! TODO_MJR: some variables will not have a model associated, + ! but maybe a numerical solution instead, e.g. head "X", and then + ! even have multiple grids (from multiple models) + ! How should this work? + + bmi_status = BMI_FAILURE + end function get_var_grid + + ! Get the grid type as a string. + function get_grid_type(grid_id, grid_type) result(bmi_status) bind(C, name="get_grid_type") + !DEC$ ATTRIBUTES DLLEXPORT :: get_grid_type + integer(kind=c_int), intent(in) :: grid_id + character(kind=c_char), intent(out) :: grid_type(MAXSTRLEN) + integer(kind=c_int) :: bmi_status + ! local + character(len=MAXSTRLEN) :: grid_type_f + character(len=LENMODELNAME) :: model_name + + model_name = get_model_name(grid_id) + bmi_status = get_grid_type_model(model_name, grid_type_f) + if (bmi_status == BMI_FAILURE) return + + grid_type(1:len(trim(grid_type_f))+1) = string_to_char_array(trim(grid_type_f), len(trim(grid_type_f))) + + end function get_grid_type + + ! internal helper function to return the grid type for a + ! named model as a fortran string following BMI convention + function get_grid_type_model(model_name, grid_type_f) result(bmi_status) + use ListsModule, only: basemodellist + use NumericalModelModule, only: NumericalModelType, GetNumericalModelFromList + character(len=LENMODELNAME) :: model_name + character(len=MAXSTRLEN) :: grid_type_f + integer(kind=c_int) :: bmi_status + ! local + integer :: i + class(NumericalModelType), pointer :: numericalModel + + do i = 1,basemodellist%Count() + numericalModel => GetNumericalModelFromList(basemodellist, i) + if (numericalModel%name == model_name) then + call numericalModel%dis%get_dis_type(grid_type_f) + end if + end do + + if (grid_type_f == "DIS") then + grid_type_f = "rectilinear" + else if ((grid_type_f == "DISV") .or. (grid_type_f == "DISU")) then + grid_type_f = "unstructured" + else + bmi_status = BMI_FAILURE + return + end if + bmi_status = BMI_SUCCESS + + end function get_grid_type_model + + !TODO_JH: Currently only works for rectilinear grids + ! Get number of dimensions of the computational grid. + function get_grid_rank(grid_id, grid_rank) result(bmi_status) bind(C, name="get_grid_rank") + !DEC$ ATTRIBUTES DLLEXPORT :: get_grid_rank + use MemoryManagerModule, only: mem_setptr + integer(kind=c_int), intent(in) :: grid_id + integer(kind=c_int), intent(out) :: grid_rank + integer(kind=c_int) :: bmi_status + ! local + character(len=LENMODELNAME) :: model_name + integer(I4B), dimension(:), pointer, contiguous :: grid_shape + character(kind=c_char) :: grid_type(MAXSTRLEN) + + ! make sure function is only used for implemented grid_types + if (get_grid_type(grid_id, grid_type) /= BMI_SUCCESS) then + bmi_status = BMI_FAILURE + return + end if + + ! get shape array + model_name = get_model_name(grid_id) + call mem_setptr(grid_shape, "MSHAPE", trim(model_name) // " DIS") + + if (grid_shape(1) == 1) then + grid_rank = 2 + else + grid_rank = 3 + end if + + bmi_status = BMI_SUCCESS + end function get_grid_rank + + ! Get the total number of elements in the computational grid. + function get_grid_size(grid_id, grid_size) result(bmi_status) bind(C, name="get_grid_size") + !DEC$ ATTRIBUTES DLLEXPORT :: get_grid_size + use MemoryManagerModule, only: mem_setptr + integer(kind=c_int), intent(in) :: grid_id + integer(kind=c_int), intent(out) :: grid_size + integer(kind=c_int) :: bmi_status + ! local + character(len=LENMODELNAME) :: model_name + integer(I4B), dimension(:), pointer, contiguous :: grid_shape + character(kind=c_char) :: grid_type(MAXSTRLEN) + character(len=MAXSTRLEN) :: grid_type_f + integer :: status + + ! make sure function is only used for implemented grid_types + if (get_grid_type(grid_id, grid_type) /= BMI_SUCCESS) then + bmi_status = BMI_FAILURE + return + end if + grid_type_f = char_array_to_string(grid_type, strlen(grid_type)) + + model_name = get_model_name(grid_id) + + if (grid_type_f == "rectilinear") then + call mem_setptr(grid_shape, "MSHAPE", trim(model_name) // " DIS") + grid_size = grid_shape(1) * grid_shape(2) * grid_shape(3) + bmi_status = BMI_SUCCESS + else if (grid_type_f == "unstructured") then + status = get_grid_node_count(grid_id, grid_size) + bmi_status = BMI_SUCCESS + else + bmi_status = BMI_FAILURE + end if + end function get_grid_size + + ! TODO_MJR: refactor this, grid_shape should be copied into an externally + ! allocated array (same for get_grid_x and get_grid_y) + ! + ! Get the dimensions of the computational grid. + function get_grid_shape(grid_id, grid_shape) result(bmi_status) bind(C, name="get_grid_shape") + !DEC$ ATTRIBUTES DLLEXPORT :: get_grid_shape + use MemoryManagerModule, only: mem_setptr + integer(kind=c_int), intent(in) :: grid_id + type(c_ptr), intent(out) :: grid_shape + integer(kind=c_int) :: bmi_status + ! local + integer, dimension(:), pointer, contiguous :: grid_shape_ptr + integer, dimension(:), target, allocatable, save :: array + character(len=LENMODELNAME) :: model_name + character(kind=c_char) :: grid_type(MAXSTRLEN) + + ! make sure function is only used for implemented grid_types + if (get_grid_type(grid_id, grid_type) /= BMI_SUCCESS) then + bmi_status = BMI_FAILURE + return + end if + + ! get shape array + model_name = get_model_name(grid_id) + call mem_setptr(grid_shape_ptr, "MSHAPE", trim(model_name) // " DIS") + + ! TODO_MJR: review this! + if (grid_shape_ptr(1) == 1) then + array = grid_shape_ptr(2:3) + grid_shape_ptr => array + end if + + grid_shape = c_loc(grid_shape_ptr) + bmi_status = BMI_SUCCESS + end function get_grid_shape + + + ! Provides an array (whose length is the number of rows) that gives the x-coordinate for each row. + function get_grid_x(grid_id, grid_x) result(bmi_status) bind(C, name="get_grid_x") + !DEC$ ATTRIBUTES DLLEXPORT :: get_grid_x + use MemoryManagerModule, only: mem_setptr + integer(kind=c_int), intent(in) :: grid_id + type(c_ptr), intent(out) :: grid_x + integer(kind=c_int) :: bmi_status + ! local + integer :: i + integer, dimension(:), pointer, contiguous :: grid_shape_ptr + real(DP), dimension(:), pointer, contiguous :: array_ptr + real(DP), dimension(:), target, allocatable, save :: array + character(len=LENMODELNAME) :: model_name + character(kind=c_char) :: grid_type(MAXSTRLEN) + real(DP), dimension(:,:), pointer, contiguous :: vertices_ptr + character(len=MAXSTRLEN) :: grid_type_f + + ! make sure function is only used for implemented grid_types + if (get_grid_type(grid_id, grid_type) /= BMI_SUCCESS) then + bmi_status = BMI_FAILURE + return + end if + grid_type_f = char_array_to_string(grid_type, strlen(grid_type)) + + model_name = get_model_name(grid_id) + if (grid_type_f == "rectilinear") then + call mem_setptr(grid_shape_ptr, "MSHAPE", trim(model_name) // " DIS") + array = [ (i, i=0,grid_shape_ptr(size(grid_shape_ptr))) ] + else if (grid_type_f == "unstructured") then + call mem_setptr(vertices_ptr, "VERTICES", trim(model_name) // " DIS") + array = vertices_ptr(1, :) + else + bmi_status = BMI_FAILURE + return + end if + + array_ptr => array + grid_x = c_loc(array_ptr) + bmi_status = BMI_SUCCESS + + end function get_grid_x + + ! Provides an array (whose length is the number of rows) that gives the y-coordinate for each row. + function get_grid_y(grid_id, grid_y) result(bmi_status) bind(C, name="get_grid_y") + !DEC$ ATTRIBUTES DLLEXPORT :: get_grid_y + use MemoryManagerModule, only: mem_setptr + integer(kind=c_int), intent(in) :: grid_id + type(c_ptr), intent(out) :: grid_y + integer(kind=c_int) :: bmi_status + ! local + integer :: i + integer, dimension(:), pointer, contiguous :: grid_shape_ptr + real(DP), dimension(:), pointer, contiguous :: array_ptr + real(DP), dimension(:), target, allocatable, save :: array + character(len=LENMODELNAME) :: model_name + character(kind=c_char) :: grid_type(MAXSTRLEN) + real(DP), dimension(:,:), pointer, contiguous :: vertices_ptr + character(len=MAXSTRLEN) :: grid_type_f + + ! make sure function is only used for implemented grid_types + if (get_grid_type(grid_id, grid_type) /= BMI_SUCCESS) then + bmi_status = BMI_FAILURE + return + end if + grid_type_f = char_array_to_string(grid_type, strlen(grid_type)) + + model_name = get_model_name(grid_id) + if (grid_type_f == "rectilinear") then + call mem_setptr(grid_shape_ptr, "MSHAPE", trim(model_name) // " DIS") + array = [ (i, i=grid_shape_ptr(size(grid_shape_ptr)-1),0,-1) ] + else if (grid_type_f == "unstructured") then + call mem_setptr(vertices_ptr, "VERTICES", trim(model_name) // " DIS") + array = vertices_ptr(2, :) + else + bmi_status = BMI_FAILURE + return + end if + + array_ptr => array + grid_y = c_loc(array_ptr) + bmi_status = BMI_SUCCESS + end function get_grid_y + + + ! Get a copy of values (flattened!) of the given double variable. + function get_value_double(c_var_name, x, nx) result(bmi_status) bind(C, name="get_value_double") + !DEC$ ATTRIBUTES DLLEXPORT :: get_value_double + use MemoryManagerModule, only: copy_dbl1d + character (kind=c_char), intent(in) :: c_var_name(*) + integer, intent(in) :: nx + real(DP), dimension(nx), intent(inout) :: x + integer :: bmi_status + ! local + integer :: idx, i + character(len=LENORIGIN) :: origin, var_name + character(len=LENVARNAME) :: var_name_only + + var_name = char_array_to_string(c_var_name, strlen(c_var_name)) + + idx = index(var_name, '/', back=.true.) + origin = var_name(:idx-1) + var_name_only = var_name(idx+1:) + + call copy_dbl1d(x, var_name_only, origin) + bmi_status = BMI_SUCCESS + + end function get_value_double + + ! NOTE: node in BMI-terms is a vertex in Modflow terms + ! Get the number of nodes in an unstructured grid. + function get_grid_node_count(grid_id, count) result(bmi_status) bind(C, name="get_grid_node_count") + !DEC$ ATTRIBUTES DLLEXPORT :: get_grid_node_count + use MemoryManagerModule, only: mem_setptr + integer(kind=c_int), intent(in) :: grid_id + integer(kind=c_int), intent(out) :: count + integer(kind=c_int) :: bmi_status + ! local + character(len=LENMODELNAME) :: model_name + integer :: status + integer(I4B), pointer :: nvert_ptr + + ! make sure function is only used for unstructured grids + bmi_status = BMI_FAILURE + if (.not. confirm_grid_type(grid_id, "unstructured")) return + + model_name = get_model_name(grid_id) + call mem_setptr(nvert_ptr, "NVERT", trim(model_name) // " DIS") + count = nvert_ptr + bmi_status = BMI_SUCCESS + end function get_grid_node_count + + ! TODO_JH: This is a simplified implementation which ignores vertical face + ! Get the number of faces in an unstructured grid. + function get_grid_face_count(grid_id, count) result(bmi_status) bind(C, name="get_grid_face_count") + !DEC$ ATTRIBUTES DLLEXPORT :: get_grid_face_count + use ListsModule, only: basemodellist + use NumericalModelModule, only: NumericalModelType, GetNumericalModelFromList + integer(kind=c_int), intent(in) :: grid_id + integer(kind=c_int), intent(out) :: count + integer(kind=c_int) :: bmi_status + ! local + character(len=LENMODELNAME) :: model_name + integer :: i + integer :: status + class(NumericalModelType), pointer :: numericalModel + + ! make sure function is only used for unstructured grids + bmi_status = BMI_FAILURE + if (.not. confirm_grid_type(grid_id, "unstructured")) return + + model_name = get_model_name(grid_id) + do i = 1,basemodellist%Count() + numericalModel => GetNumericalModelFromList(basemodellist, i) + if (numericalModel%name == model_name) then + count = numericalModel%dis%nodes + end if + end do + bmi_status = BMI_SUCCESS + end function get_grid_face_count + + ! Get the face-node connectivity. + function get_grid_face_nodes(grid_id, face_nodes) result(bmi_status) bind(C, name="get_grid_face_nodes") + !DEC$ ATTRIBUTES DLLEXPORT :: get_grid_face_nodes + use MemoryManagerModule, only: mem_setptr + integer(kind=c_int), intent(in) :: grid_id + type(c_ptr), intent(out) :: face_nodes + integer(kind=c_int) :: bmi_status + ! local + integer :: status + character(len=LENMODELNAME) :: model_name + integer, dimension(:), pointer, contiguous :: javert_ptr + + ! make sure function is only used for unstructured grids + bmi_status = BMI_FAILURE + if (.not. confirm_grid_type(grid_id, "unstructured")) return + + model_name = get_model_name(grid_id) + call mem_setptr(javert_ptr, "JAVERT", trim(model_name) // " DIS") + face_nodes = c_loc(javert_ptr) + bmi_status = BMI_SUCCESS + end function get_grid_face_nodes + + ! Get the number of nodes for each face. + function get_grid_nodes_per_face(grid_id, nodes_per_face) result(bmi_status) bind(C, name="get_grid_nodes_per_face") + !DEC$ ATTRIBUTES DLLEXPORT :: get_grid_nodes_per_face + use MemoryManagerModule, only: mem_setptr + integer(kind=c_int), intent(in) :: grid_id + type(c_ptr), intent(out) :: nodes_per_face + integer(kind=c_int) :: bmi_status + ! local + integer :: i + integer :: status + character(len=LENMODELNAME) :: model_name + integer, dimension(:), pointer, contiguous :: iavert_ptr + integer, dimension(:), pointer, contiguous :: array_ptr + ! TODO_MJR: this array will not work for multiple models, or multiple calls, + ! should we let the outside manage the memory? + integer, dimension(:), target, allocatable, save :: array + + ! make sure function is only used for unstructured grids + bmi_status = BMI_FAILURE + if (.not. confirm_grid_type(grid_id, "unstructured")) return + + model_name = get_model_name(grid_id) + call mem_setptr(iavert_ptr, "IAVERT", trim(model_name) // " DIS") + + if (allocated(array)) deallocate(array) + allocate(array(size(iavert_ptr) - 1)) + do i = 2, size(iavert_ptr) + array(i-1) = iavert_ptr(i) - iavert_ptr(i-1) - 1 + end do + + array_ptr => array + nodes_per_face = c_loc(array_ptr) + bmi_status = BMI_SUCCESS + end function get_grid_nodes_per_face + + ! ----------------------------------------------------------------------- + ! convenience functions follow here, TODO_MJR: move to dedicated module? + ! ----------------------------------------------------------------------- + + ! Helper function to check the grid, not all bmi routines are implemented + ! for all types of discretizations + function confirm_grid_type(grid_id, expected_type) result(is_match) + integer(kind=c_int), intent(in) :: grid_id + character(kind=c_char), intent(in) :: expected_type(MAXSTRLEN) ! this is a C-style string + logical :: is_match + ! local + integer :: status + character(len=LENMODELNAME) :: model_name + character(len=MAXSTRLEN) :: expected_type_f ! this is a fortran style string + character(len=MAXSTRLEN) :: grid_type_f + + is_match = .false. + + model_name = get_model_name(grid_id) + status = get_grid_type_model(model_name, grid_type_f) + + ! careful comparison: + expected_type_f = char_array_to_string(expected_type, strlen(expected_type)) + if (expected_type_f == grid_type_f) is_match = .true. + + end function confirm_grid_type + + ! splits the variable name from the full address string into + ! an origin and name as used by the memory manager + subroutine split_c_var_name(c_var_name, origin, var_name_only) + character (kind=c_char), intent(in) :: c_var_name(*) + character(len=LENORIGIN), intent(out) :: origin + character(len=LENVARNAME), intent(out) :: var_name_only + ! local + integer :: idx + character(len=LENORIGIN) :: var_name + + var_name = char_array_to_string(c_var_name, strlen(c_var_name)) + idx = index(var_name, '/', back=.true.) + origin = var_name(:idx-1) + var_name_only = var_name(idx+1:) + + end subroutine split_c_var_name + + integer(c_int) pure function strlen(char_array) + character(c_char), intent(in) :: char_array(LENORIGIN) + integer :: inull, i + + strlen = 0 + do i = 1, size(char_array) + if (char_array(i) .eq. C_NULL_CHAR) then + strlen = i-1 + exit + end if + end do + + end function strlen + + pure function char_array_to_string(char_array, length) + integer(c_int), intent(in) :: length + character(c_char),intent(in) :: char_array(length) + character(len=length) :: char_array_to_string + integer :: i + + do i = 1, length + char_array_to_string(i:i) = char_array(i) + enddo + + end function char_array_to_string + + pure function string_to_char_array(string, length) + integer(c_int),intent(in) :: length + character(len=length), intent(in) :: string + character(kind=c_char,len=1) :: string_to_char_array(length+1) + integer :: i + + do i = 1, length + string_to_char_array(i) = string(i:i) + enddo + string_to_char_array(length+1) = C_NULL_CHAR + + end function string_to_char_array + + ! get the model name from the string, assuming that it is + ! the substring in front of the first space + pure function extract_model_name(var_name) + character(len=*), intent(in) :: var_name + character(len=LENMODELNAME) :: extract_model_name + integer :: idx + + idx = index(var_name, ' ') + extract_model_name = var_name(:idx-1) + + end function extract_model_name + + function get_model_name(grid_id) result(model_name) + use ListsModule, only: basemodellist + use BaseModelModule, only: BaseModelType, GetBaseModelFromList + integer(kind=c_int), intent(in) :: grid_id + character(len=LENMODELNAME) :: model_name + ! local + integer :: i + class(BaseModelType), pointer :: baseModel + + model_name = '' + + do i = 1,basemodellist%Count() + baseModel => GetBaseModelFromList(basemodellist, i) + if (baseModel%id == grid_id) then + model_name = baseModel%name + return + end if + end do + + ! TODO_MJR: error message, should never get here... + + end function get_model_name + + + + +end module mf6bmi diff --git a/utils/mf5to6/make/makefile b/utils/mf5to6/make/makefile index 72f3df4d480..08e58d3ef02 100644 --- a/utils/mf5to6/make/makefile +++ b/utils/mf5to6/make/makefile @@ -1,4 +1,4 @@ -# makefile created on 2018-08-09 13:41:31.725160 +# makefile created on 2019-12-12 13:31:13.926505 # by pymake (version 1.1.0) # using the gfortran fortran and gcc c/c++ compilers. @@ -35,155 +35,156 @@ FFLAGS = -O2 -fbacktrace # Define the C compile flags CC = gcc -CFLAGS = -O3 -D_UF +CFLAGS = -O2 -D_UF # Define the libraries SYSLIBS = OBJECTS = \ -$(OBJDIR)/GlobalPHMF.o \ -$(OBJDIR)/mach_mod.o \ -$(OBJDIR)/GwfLpfModule.o \ -$(OBJDIR)/GwfEvtModule.o \ -$(OBJDIR)/gwf2hfb7_NWT.o \ -$(OBJDIR)/GwfResModule.o \ -$(OBJDIR)/GwfDrnModule.o \ -$(OBJDIR)/ConstantsPHMF.o \ -$(OBJDIR)/GwfEtsModule.o \ -$(OBJDIR)/GwfGhbModule.o \ -$(OBJDIR)/GwfLakModule.o \ -$(OBJDIR)/NWT1_module.o \ -$(OBJDIR)/kind.o \ $(OBJDIR)/GwfUpwModule.o \ -$(OBJDIR)/NWT1_xmdlib.o \ -$(OBJDIR)/OpenSpec.o \ -$(OBJDIR)/GwfMnwModule.o \ $(OBJDIR)/GwfChdModule.o \ +$(OBJDIR)/ConstantsPHMF.o \ +$(OBJDIR)/StressPeriod.o \ +$(OBJDIR)/GwfGhbModule.o \ $(OBJDIR)/GwfRchModule.o \ $(OBJDIR)/GwfUzfModule_NWT.o \ -$(OBJDIR)/GwfBcfModule.o \ +$(OBJDIR)/GwfLpfModule.o \ +$(OBJDIR)/ParamModule.o \ +$(OBJDIR)/mach_mod.o \ +$(OBJDIR)/OpenSpec.o \ +$(OBJDIR)/GlobalPHMF.o \ +$(OBJDIR)/GwfRivModule.o \ $(OBJDIR)/ConverterCommon.o \ +$(OBJDIR)/GwfBcfModule.o \ +$(OBJDIR)/GwfEvtModule.o \ $(OBJDIR)/GwfFhbModule.o \ -$(OBJDIR)/ParamModule.o \ $(OBJDIR)/GwfWelModule.o \ +$(OBJDIR)/GwfDrnModule.o \ +$(OBJDIR)/GwfEtsModule.o \ +$(OBJDIR)/GwfResModule.o \ $(OBJDIR)/GwfLgrModule.o \ -$(OBJDIR)/GwfRivModule.o \ -$(OBJDIR)/StressPeriod.o \ +$(OBJDIR)/GwfLakModule.o \ +$(OBJDIR)/gwf2hfb7_NWT.o \ +$(OBJDIR)/NWT1_xmdlib.o \ +$(OBJDIR)/kind.o \ +$(OBJDIR)/GwfMnwModule.o \ $(OBJDIR)/GlobalVariablesPHMF.o \ -$(OBJDIR)/version.o \ $(OBJDIR)/List.o \ +$(OBJDIR)/NWT1_module.o \ $(OBJDIR)/Constants.o \ $(OBJDIR)/Connection.o \ -$(OBJDIR)/TimeSeriesRecord.o \ -$(OBJDIR)/CharacterContainer.o \ +$(OBJDIR)/genericutils.o \ $(OBJDIR)/LakeOutlet.o \ -$(OBJDIR)/LakeTributary.o \ -$(OBJDIR)/Global.o \ -$(OBJDIR)/GwfSfrModule.o \ -$(OBJDIR)/LakeConnection.o \ $(OBJDIR)/Auxiliary.o \ -$(OBJDIR)/GlobalVariables.o \ +$(OBJDIR)/version.o \ $(OBJDIR)/SfrDiversion.o \ -$(OBJDIR)/ArrayHandlers.o \ +$(OBJDIR)/TimeSeriesRecord.o \ $(OBJDIR)/Memory.o \ -$(OBJDIR)/SimVariables.o \ +$(OBJDIR)/GwfSfrModule.o \ +$(OBJDIR)/CharacterContainer.o \ +$(OBJDIR)/Global.o \ +$(OBJDIR)/LakeTributary.o \ +$(OBJDIR)/GlobalVariables.o \ +$(OBJDIR)/GwfBasModule.o \ +$(OBJDIR)/pcgn2.o \ $(OBJDIR)/MemoryList.o \ -$(OBJDIR)/NWT1_ilupc_mod.o \ +$(OBJDIR)/SimVariables.o \ +$(OBJDIR)/ArrayHandlers.o \ $(OBJDIR)/SfrReach.o \ -$(OBJDIR)/pcgn2.o \ -$(OBJDIR)/GwfBasModule.o \ +$(OBJDIR)/LakeConnection.o \ +$(OBJDIR)/NWT1_ilupc_mod.o \ +$(OBJDIR)/ModelPackage.o \ $(OBJDIR)/SimPHMF.o \ -$(OBJDIR)/SimVariablesPHMF.o \ $(OBJDIR)/SfrSegment.o \ -$(OBJDIR)/GwfSfrCheck.o \ +$(OBJDIR)/MultiLayerObsModule.o \ $(OBJDIR)/InputOutput.o \ -$(OBJDIR)/ModelPackage.o \ -$(OBJDIR)/ArrayReadersMF5.o \ -$(OBJDIR)/Utilities.o \ -$(OBJDIR)/precutls.o \ $(OBJDIR)/GwfFhbSubs.o \ -$(OBJDIR)/MemoryManager.o \ -$(OBJDIR)/MultiLayerObsModule.o \ +$(OBJDIR)/SimVariablesPHMF.o \ +$(OBJDIR)/Utilities.o \ +$(OBJDIR)/LineList.o \ $(OBJDIR)/Lake.o \ +$(OBJDIR)/MemoryManager.o \ +$(OBJDIR)/GwfSfrCheck.o \ +$(OBJDIR)/BlockParser.o \ +$(OBJDIR)/precutls.o \ $(OBJDIR)/ObservePHMF.o \ +$(OBJDIR)/ArrayReadersMF5.o \ $(OBJDIR)/File.o \ $(OBJDIR)/GwfResSubs.o \ -$(OBJDIR)/LineList.o \ -$(OBJDIR)/BlockParser.o \ $(OBJDIR)/FileWriter.o \ -$(OBJDIR)/DiscretizationBasePHMF.o \ -$(OBJDIR)/IcWriter.o \ $(OBJDIR)/FileList.o \ -$(OBJDIR)/StoWriter.o \ $(OBJDIR)/TimeSeries.o \ +$(OBJDIR)/DisWriter.o \ +$(OBJDIR)/DiscretizationBasePHMF.o \ $(OBJDIR)/Discretization3D.o \ -$(OBJDIR)/utl7.o \ $(OBJDIR)/TdisWriter.o \ +$(OBJDIR)/NpfWriter.o \ +$(OBJDIR)/utl7.o \ +$(OBJDIR)/gmg7.o \ +$(OBJDIR)/StoWriter.o \ $(OBJDIR)/GwfEvtSubs.o \ -$(OBJDIR)/ObsBlock.o \ -$(OBJDIR)/GwfRchSubs.o \ -$(OBJDIR)/gwf2wel7_NWT.o \ -$(OBJDIR)/GwfChdSubs.o \ -$(OBJDIR)/GwfGhbSubs.o \ -$(OBJDIR)/GwfLakSubs.o \ -$(OBJDIR)/DisWriter.o \ -$(OBJDIR)/obs2ghb7.o \ -$(OBJDIR)/Mover.o \ -$(OBJDIR)/obs2bas7.o \ -$(OBJDIR)/GwfSfrSubs.o \ +$(OBJDIR)/obs2drn7.o \ +$(OBJDIR)/IcWriter.o \ +$(OBJDIR)/obs2riv7.o \ $(OBJDIR)/NWT1_gmres.o \ -$(OBJDIR)/ChdType.o \ -$(OBJDIR)/sip7.o \ +$(OBJDIR)/GwfRchSubs.o \ $(OBJDIR)/TdisVariables.o \ -$(OBJDIR)/NpfWriter.o \ -$(OBJDIR)/pcg7.o \ -$(OBJDIR)/NWT1_xmd.o \ +$(OBJDIR)/GwfBasOcSubs.o \ +$(OBJDIR)/de47.o \ +$(OBJDIR)/ChdType.o \ $(OBJDIR)/obs2chd7.o \ -$(OBJDIR)/GwfUzfSubs_NWT.o \ +$(OBJDIR)/Mover.o \ +$(OBJDIR)/gwf2wel7_NWT.o \ +$(OBJDIR)/pcg7.o \ $(OBJDIR)/GwfEtsSubs.o \ +$(OBJDIR)/GwfGhbSubs.o \ $(OBJDIR)/parutl7.o \ +$(OBJDIR)/GwfDrnSubs.o \ +$(OBJDIR)/ObsBlock.o \ +$(OBJDIR)/GwfLakSubs.o \ +$(OBJDIR)/sip7.o \ $(OBJDIR)/GwfRivSubs.o \ -$(OBJDIR)/Preproc.o \ -$(OBJDIR)/obs2riv7.o \ -$(OBJDIR)/GwfHfbSubs_NWT.o \ $(OBJDIR)/GwfLgrSubs.o \ +$(OBJDIR)/GwfHfbSubs_NWT.o \ +$(OBJDIR)/GwfUzfSubs_NWT.o \ $(OBJDIR)/GwfMnwSubs.o \ -$(OBJDIR)/NWT1_solver.o \ -$(OBJDIR)/GwfDrnSubs.o \ -$(OBJDIR)/gmg7.o \ -$(OBJDIR)/de47.o \ -$(OBJDIR)/GwfBasOcSubs.o \ -$(OBJDIR)/obs2drn7.o \ +$(OBJDIR)/GwfSfrSubs.o \ +$(OBJDIR)/NWT1_xmd.o \ +$(OBJDIR)/Preproc.o \ $(OBJDIR)/gwf2mnw17.o \ +$(OBJDIR)/GwfChdSubs.o \ +$(OBJDIR)/obs2bas7.o \ +$(OBJDIR)/NWT1_solver.o \ +$(OBJDIR)/obs2ghb7.o \ $(OBJDIR)/gwf2mnw2i7.o \ $(OBJDIR)/ObsWriter.o \ $(OBJDIR)/ChdObsWriter.o \ -$(OBJDIR)/RivObsWriter.o \ $(OBJDIR)/DrnObsWriter.o \ -$(OBJDIR)/GhbObsWriter.o \ +$(OBJDIR)/RivObsWriter.o \ $(OBJDIR)/PackageWriter.o \ -$(OBJDIR)/WelPackageWriter.o \ -$(OBJDIR)/ChdPackageWriter.o \ -$(OBJDIR)/HfbPackageWriter.o \ -$(OBJDIR)/DrnPackageWriter.o \ -$(OBJDIR)/MvrPackageWriter.o \ $(OBJDIR)/MawPackageWriter.o \ -$(OBJDIR)/FhbPackageWriter.o \ -$(OBJDIR)/OutputControlWriter.o \ $(OBJDIR)/EvtPackageWriter.o \ +$(OBJDIR)/GhbPackageWriter.o \ $(OBJDIR)/RchPackageWriter.o \ +$(OBJDIR)/DrnPackageWriter.o \ +$(OBJDIR)/GhbObsWriter.o \ $(OBJDIR)/RivPackageWriter.o \ -$(OBJDIR)/GhbPackageWriter.o \ +$(OBJDIR)/ChdPackageWriter.o \ $(OBJDIR)/ImsPackageWriter.o \ +$(OBJDIR)/WelPackageWriter.o \ +$(OBJDIR)/HfbPackageWriter.o \ +$(OBJDIR)/OutputControlWriter.o \ +$(OBJDIR)/MvrPackageWriter.o \ +$(OBJDIR)/FhbPackageWriter.o \ $(OBJDIR)/LakPackageWriter.o \ $(OBJDIR)/SfrPackageWriter.o \ $(OBJDIR)/UzfPackageWriter.o \ $(OBJDIR)/Model.o \ -$(OBJDIR)/GwfUpwSubs.o \ -$(OBJDIR)/GwfBasSubs.o \ -$(OBJDIR)/GwfBcfSubs.o \ $(OBJDIR)/Exchange.o \ +$(OBJDIR)/GwfBasSubs.o \ $(OBJDIR)/GwfLpfSubs.o \ +$(OBJDIR)/GwfUpwSubs.o \ +$(OBJDIR)/GwfBcfSubs.o \ $(OBJDIR)/ModelConverter.o \ $(OBJDIR)/ExchangeWriter.o \ $(OBJDIR)/SimFileWriter.o \ 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 3d9cd15f474..5dc7976b665 100644 --- a/utils/mf5to6/msvs/mf5to6.vfproj +++ b/utils/mf5to6/msvs/mf5to6.vfproj @@ -1,185 +1,187 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/utils/mf5to6/pymake/extrafiles.txt b/utils/mf5to6/pymake/extrafiles.txt index f6af26b129c..a5f14a7e5bd 100644 --- a/utils/mf5to6/pymake/extrafiles.txt +++ b/utils/mf5to6/pymake/extrafiles.txt @@ -5,6 +5,8 @@ ../../../src/Utilities/TimeSeries/TimeSeriesRecord.f90 ../../../src/Utilities/BlockParser.f90 ../../../src/Utilities/Constants.f90 +../../../src/Utilities/SimVariables.f90 +../../../src/Utilities/genericutils.f90 ../../../src/Utilities/InputOutput.f90 ../../../src/Utilities/kind.f90 ../../../src/Utilities/List.f90 diff --git a/utils/mf5to6/src/EvtPackageWriter.f90 b/utils/mf5to6/src/EvtPackageWriter.f90 index 80afb7ab97e..cdd4cb38c23 100755 --- a/utils/mf5to6/src/EvtPackageWriter.f90 +++ b/utils/mf5to6/src/EvtPackageWriter.f90 @@ -422,7 +422,7 @@ subroutine WriteStressPeriodListData(this, lineList) ! format 10 format(a,' boundary removed at (',i0,',',i0,',',i0,')') ! - ! Write stress-period data for MF6 + ! Write stress period data for MF6 ! Loop through rows and columns to generate list of EVT input rowloop: do i=1,NROW colloop: do j=1,NCOL 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/GwfBasSubs.f b/utils/mf5to6/src/MF2005/GwfBasSubs.f index 23fd980f4d9..01b15a2e4da 100644 --- a/utils/mf5to6/src/MF2005/GwfBasSubs.f +++ b/utils/mf5to6/src/MF2005/GwfBasSubs.f @@ -11,7 +11,7 @@ module GwfBasSubs use global, only: iout use GlobalVariablesModule, only: echo use GwfBasModule, only: SGWF2BAS7PNT, SGWF2BAS7PSV - use InputOutputModule, only: write_centered + use GenericUtilitiesModule, only: write_centered use ModelModule, only: ModelType use ObsWriterModule, only: ObsWriterType use OpenSpecModule, only: ACCESS, ACTION, FORM @@ -1051,9 +1051,9 @@ SUBROUTINE SGWF2BAS7OPEN(INUNIT,IUNIT,CUNIT,NIUNIT, model%iulist = iu OPEN(UNIT=IU,FILE=FNAME(1:IFLEN),STATUS='REPLACE', 1 FORM='FORMATTED',ACCESS='SEQUENTIAL') - call write_centered(PROGNAM, iout, 80) + call write_centered(PROGNAM, 80, iunit=iout) msg = 'Conversion Report' - call write_centered(msg, iout, 80) + call write_centered(msg, 80, iunit=iout) write(iout,1)trim(model%NameFile2005) write(iout,2)trim(model%BaseName) if (.not. model%ConversionDone) then 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/MawPackageWriter.f90 b/utils/mf5to6/src/MawPackageWriter.f90 old mode 100755 new mode 100644 index 1dcda5b865f..dc782ce1a05 --- a/utils/mf5to6/src/MawPackageWriter.f90 +++ b/utils/mf5to6/src/MawPackageWriter.f90 @@ -481,8 +481,8 @@ subroutine WriteWellConnections(this) else ! Intervals are specified in MNW2 input ! Get first and last interval for this well - firstint = nint(mnwnod(12, iw)) - lastint = nint(mnwnod(13, iw)) + firstint = nint(mnwnod(12, firstnode)) + lastint = nint(mnwnod(13, lastnode)) nintvl = lastint - firstint + 1 ! loop through intervals do ii=firstint,lastint @@ -510,8 +510,8 @@ subroutine WriteWellConnections(this) do nn = firstnode,lastnode ! Get layer il = nint(mnwnod(1, nn)) - write(iu,30)iw, nn, il, ir, ic, scrn_top, scrn_bot, hk_skin, & - radius_skin + write(iu,30) iw, nn - firstnode + 1, il, ir, ic, scrn_top, & + scrn_bot, hk_skin, radius_skin enddo enddo endif 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 1b2d4f710e4..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: write_centered, GetUnit, openfile + use InputOutputModule, only: GetUnit, openfile use ListModule, only: ListType use ModelModule, only: ModelType use ModelPackageModule, only: ModelPackageType, ConstructModelPackageType @@ -36,7 +36,7 @@ module ModelConverterModule use GlobalVariablesModule, only: echo use SimModule, only: store_error, store_note, store_warning, ustop, & write_message - use SimVariablesModule, only: SimMovers + use SimListVariablesModule, only: SimMovers use UpwSubsModule, only: GWF2UPW1AR use UtilitiesModule, only: GetArgs diff --git a/utils/mf5to6/src/ModelPackage.f90 b/utils/mf5to6/src/ModelPackage.f90 index 88c0193890b..82e7eeaf115 100644 --- a/utils/mf5to6/src/ModelPackage.f90 +++ b/utils/mf5to6/src/ModelPackage.f90 @@ -2,7 +2,7 @@ module ModelPackageModule use ConstantsModule, only: LENMODELNAME, LENPACKAGENAME use ListModule, only: ListType - use SimVariablesModule, only: ModelPacks + use SimListVariablesModule, only: ModelPacks implicit none diff --git a/utils/mf5to6/src/MultiLayerObsModule.f90 b/utils/mf5to6/src/MultiLayerObsModule.f90 index dcae3f2ff14..5ea57812af2 100644 --- a/utils/mf5to6/src/MultiLayerObsModule.f90 +++ b/utils/mf5to6/src/MultiLayerObsModule.f90 @@ -1,8 +1,8 @@ module MultiLayerObs - use ConstantsModule, only: DONE, MAXCHARLEN - use ConstantsPHMFModule, only: LENOBSNAMENEW - use InputOutputModule, only: dclosetest + use ConstantsModule, only: DONE, MAXCHARLEN + use ConstantsPHMFModule, only: LENOBSNAMENEW + use GenericUtilitiesModule, only: IS_SAME use ListModule, only: ListType use SimModule, only: store_error, ustop @@ -153,7 +153,7 @@ subroutine CheckWeightSum(this) weightsum = weightsum + layobs%weight enddo ! - if (.not. dclosetest(weightsum, DONE, 1.0d-7)) then + if (.not. IS_SAME(weightsum, DONE)) then write(ermsg,10)trim(this%mlobsname) call store_error(ermsg) call ustop() diff --git a/utils/mf5to6/src/MvrPackageWriter.f90 b/utils/mf5to6/src/MvrPackageWriter.f90 index 1b20731db7c..e6a2062905e 100644 --- a/utils/mf5to6/src/MvrPackageWriter.f90 +++ b/utils/mf5to6/src/MvrPackageWriter.f90 @@ -6,7 +6,7 @@ module MvrPackageWriterModule use ListModule, only: ListType use MoverModule, only: MoverType, AddMoverToList, GetMoverFromList use PackageWriterModule, only: PackageWriterType - use SimVariablesModule, only: SimMovers + use SimListVariablesModule, only: SimMovers implicit none 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/OutputControlWriter.f90 b/utils/mf5to6/src/OutputControlWriter.f90 index b4a1c01dd1c..184411391bb 100644 --- a/utils/mf5to6/src/OutputControlWriter.f90 +++ b/utils/mf5to6/src/OutputControlWriter.f90 @@ -151,7 +151,7 @@ subroutine WriteFile(this, Mf6FileList, igrid) call this%process_options(Mf6FileList) ! Write the Options block call this%write_options() - ! Generate stress-period input + ! Generate stress period input call this%ProcessStressLoop(igrid) else ! Ned todo: There probably should be something in an OC file @@ -494,7 +494,7 @@ subroutine process_stress_loop(this, igrid) end subroutine process_stress_loop subroutine WriteStressPeriodListData(this, lineList) - ! Write stress-period data for MF6 Output Control + ! Write stress period data for MF6 Output Control implicit none ! dummy class(OutputControlWriterType) :: this diff --git a/utils/mf5to6/src/PackageWriter.f90 b/utils/mf5to6/src/PackageWriter.f90 index b95ee73644f..2a89be96dcb 100644 --- a/utils/mf5to6/src/PackageWriter.f90 +++ b/utils/mf5to6/src/PackageWriter.f90 @@ -14,7 +14,7 @@ module PackageWriterModule use MoverModule, only: MoverType, AddMoverToList use ObsWriterModule, only: ObsWriterType use SimModule, only: store_error, store_note, ustop - use SimVariablesModule, only: SimMovers + use SimListVariablesModule, only: SimMovers use UtilitiesModule, only: ConstantReal2D implicit none @@ -311,7 +311,7 @@ subroutine WriteBlockIfNeeded(this, kper, option, forceWrite) endif ! if (needToWrite) then - ! write block of stress-period input for MF6 + ! write block of stress period input for MF6 iu = this%fileobj%IUnit write(iu,5) if (present(option)) then @@ -341,7 +341,7 @@ subroutine WriteStressPeriodListData(this, lineList) ! format 10 format(a,' boundary removed at (',i0,',',i0,',',i0,')') ! - ! Write stress-period data for MF6 + ! Write stress period data for MF6 do ii=1,this%NBndPeriod kold = nint(this%rlist(1,ii)) k = this%Layptr(kold) diff --git a/utils/mf5to6/src/Preproc/Discretization3D.f90 b/utils/mf5to6/src/Preproc/Discretization3D.f90 index 0ced3976332..1d940145dad 100644 --- a/utils/mf5to6/src/Preproc/Discretization3D.f90 +++ b/utils/mf5to6/src/Preproc/Discretization3D.f90 @@ -5,7 +5,7 @@ module DnmDis3dModule use ConstantsPHMFModule, only: PI use DnmDisBaseModule, only: DisBaseType use GlobalVariablesPHMFModule, only: verbose - use InputOutputModule, only: get_ijk, get_node, URWORD, dclosetest + use InputOutputModule, only: get_ijk, get_node, URWORD use SimModule, only: count_errors, store_error, & store_error_unit, ustop implicit none diff --git a/utils/mf5to6/src/Preproc/Global.f90 b/utils/mf5to6/src/Preproc/Global.f90 index ee5aa0f6a12..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, ISTDOUT + 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 64de44bd4d9..fd16060af5b 100644 --- a/utils/mf5to6/src/Preproc/ObsBlock.f90 +++ b/utils/mf5to6/src/Preproc/ObsBlock.f90 @@ -3,11 +3,11 @@ module ObsBlockModule use BlockParserModule, only: BlockParserType use ConstantsModule, only: DONE, DZERO, & LINELENGTH, MAXCHARLEN + use GenericUtilitiesModule, only: IS_SAME use ConstantsPHMFModule, only: CONTINUOUS, SINGLE, LENOBSNAMENEW use DnmDis3dModule, only: Dis3dType use GlobalVariablesPHMFModule, only: verbose - use InputOutputModule, only: dclosetest, UPCASE, URWORD, & - uterminate_block + use InputOutputModule, only: UPCASE, URWORD, uterminate_block use ListModule, only: ListType use ObserveModule, only: ObserveType, AddObserveToList, & GetObserveFromList, ConstructObservation @@ -184,7 +184,7 @@ subroutine process_block(this, insertLine, WriteBeginEnd, parser) iadjrow = 0 jadjcol = 0 ! - if (.not. dclosetest(xoff, DZERO)) then + if (.not. IS_SAME(xoff, DZERO)) then if (xoff > DZERO) then if (jcol < ncol) then if (dis3d%idomain(jcol+1, irow, layer) == 1) then @@ -202,7 +202,7 @@ subroutine process_block(this, insertLine, WriteBeginEnd, parser) endif endif ! - if (.not. dclosetest(yoff, DZERO)) then + if (.not. IS_SAME(yoff, DZERO)) then if (yoff > DZERO) then if (irow > 1) then if (dis3d%idomain(jcol, irow-1, layer) == 1) then diff --git a/utils/mf5to6/src/Preproc/ObservePHMF.f90 b/utils/mf5to6/src/Preproc/ObservePHMF.f90 index 7aae8836f73..bea127f6524 100644 --- a/utils/mf5to6/src/Preproc/ObservePHMF.f90 +++ b/utils/mf5to6/src/Preproc/ObservePHMF.f90 @@ -12,13 +12,13 @@ !----------------------------------------------------------------------- module ObserveModule - use ConstantsModule, only: DONE, DZERO, LENOBSNAME, & - LENOBSTYPE, MAXCHARLEN - use ConstantsPHMFModule, only: LENOBSNAMENEW, HUGEDBL, HDRYDEFAULT - use InputOutputModule, only: dclosetest - use ListModule, only: ListType - use SimModule, only: store_warning, store_error, & - store_error_unit, ustop + use ConstantsModule, only: DONE, DZERO, LENOBSNAME, & + LENOBSTYPE, MAXCHARLEN + use ConstantsPHMFModule, only: LENOBSNAMENEW, HUGEDBL, HDRYDEFAULT + use GenericUtilitiesModule, only: IS_SAME + use ListModule, only: ListType + use SimModule, only: store_warning, store_error, & + store_error_unit, ustop implicit none @@ -206,7 +206,7 @@ subroutine CalcSimVal(this, itime) sumweights = DZERO k = 0 do i=1,nsrc - if (dclosetest(this%srcvals(itime, i), this%hdry)) then + if (IS_SAME(this%srcvals(itime, i), this%hdry)) then k = k + 1 weights(i) = DZERO else diff --git a/utils/mf5to6/src/Preproc/Preproc.f90 b/utils/mf5to6/src/Preproc/Preproc.f90 index e7c1814802b..d6826717f14 100644 --- a/utils/mf5to6/src/Preproc/Preproc.f90 +++ b/utils/mf5to6/src/Preproc/Preproc.f90 @@ -16,7 +16,7 @@ module PreprocModule use GlobalVariablesPHMFModule, only: prognamPHMF, verbose, vnam use InputOutputModule, only: GetUnit, uget_block, urword, & uterminate_block, GetUnit, openfile, & - uget_any_block, dclosetest + uget_any_block use ListModule, only: ListType use ObsBlockModule, only: ObsBlockType, ConstructObsBlockType, & AddObsBlockToList, GetObsBlockFromList diff --git a/utils/mf5to6/src/Preproc/SimListVariables.f90 b/utils/mf5to6/src/Preproc/SimListVariables.f90 new file mode 100644 index 00000000000..5fd22c0b316 --- /dev/null +++ b/utils/mf5to6/src/Preproc/SimListVariables.f90 @@ -0,0 +1,12 @@ +module SimListVariablesModule + use ListModule, only: ListType + + implicit none + + private + public :: ModelPacks, SimMovers + + type(ListType), pointer :: SimMovers => null() + type(ListType) :: ModelPacks + +end module SimListVariablesModule diff --git a/utils/mf5to6/src/Preproc/SimVariables.f90 b/utils/mf5to6/src/Preproc/SimVariables.f90 deleted file mode 100644 index 89e10a3eb7c..00000000000 --- a/utils/mf5to6/src/Preproc/SimVariables.f90 +++ /dev/null @@ -1,13 +0,0 @@ -module SimVariablesModule - - use ConstantsModule, only: MAXCHARLEN - use GLOBAL, only: IOUT - use ListModule, only: ListType - - private - public :: ModelPacks, SimMovers, iout - - type(ListType), pointer :: SimMovers => null() - type(ListType) :: ModelPacks - -end module SimVariablesModule diff --git a/utils/mf5to6/src/SfrPackageWriter.f90 b/utils/mf5to6/src/SfrPackageWriter.f90 index 5e491f7aef1..c1fcf563534 100755 --- a/utils/mf5to6/src/SfrPackageWriter.f90 +++ b/utils/mf5to6/src/SfrPackageWriter.f90 @@ -402,7 +402,7 @@ subroutine AssignReachData(this) integer :: icalc, iprior, iupseg integer :: i, irch, nrch, nseg integer :: rchnumpkg, rchnumseg - real :: area + real :: area real :: q type(SfrSegmentType), pointer :: segptr type(SfrReachType), pointer :: rch @@ -437,40 +437,40 @@ subroutine AssignReachData(this) ! Ned todo: Assign diversion +/or upstream fraction !rch%diversion = SEG(2,i) endif - else + else q = SEG(2,i) ! inflow to 1st reach of segment - if (q /= rch%inflow) then - rch%inflow = q - rch%inflow_iprn = 1 - else - rch%inflow_iprn = 0 - end if + if (q /= rch%inflow) then + rch%inflow = q + rch%inflow_iprn = 1 + else + rch%inflow_iprn = 0 + end if endif else rch%ustrf = 0.0 rch%inflow = 0.0 - endif - q = STRM(14,rchnumpkg) / area ! convert rainfall Q to flux - if (q /= rch%rainfall) then - rch%rainfall = q - rch%rainfall_iprn = 1 - else - rch%rainfall_iprn = 0 + endif + q = STRM(14,rchnumpkg) / area ! convert rainfall Q to flux + if (q /= rch%rainfall) then + rch%rainfall = q + rch%rainfall_iprn = 1 + else + rch%rainfall_iprn = 0 end if q = STRM(13,rchnumpkg) / area ! convert evaporation Q to flux - if (q /= rch%evap) then - rch%evap = q - rch%evap_iprn = 1 - else - rch%evap_iprn = 0 - end if + if (q /= rch%evap) then + rch%evap = q + rch%evap_iprn = 1 + else + rch%evap_iprn = 0 + end if q = STRM(12,rchnumpkg) - if (q /= rch%runoff) then - rch%runoff = q - rch%runoff_iprn = 1 - else - rch%runoff_iprn = 0 - end if + if (q /= rch%runoff) then + rch%runoff = q + rch%runoff_iprn = 1 + else + rch%runoff_iprn = 0 + end if enddo enddo ! @@ -495,7 +495,7 @@ subroutine WriteStressPeriodListData(this, lineList) ! if (.not. this%Active) return ! - ! Ned todo: Write stress-period data for MF6. + ! Ned todo: Write stress period data for MF6. ! Write keywords and values for each reach. ! Keywords include: inflow, rainfall, evaporation, runoff, ! diversion, upstream_fraction, auxiliary. @@ -509,22 +509,22 @@ subroutine WriteStressPeriodListData(this, lineList) ! inflow if (rch%inflow_iprn /= 0) then write(line,40)rch%newReachNum,'inflow',rch%inflow - call lineList%AddLine(line) + call lineList%AddLine(line) end if - ! rainfall + ! rainfall if (rch%rainfall_iprn /= 0) then write(line,40)rch%newReachNum,'rainfall',rch%rainfall - call lineList%AddLine(line) + call lineList%AddLine(line) end if ! evaporation if (rch%evap_iprn /= 0) then write(line,40)rch%newReachNum,'evaporation',rch%evap - call lineList%AddLine(line) + call lineList%AddLine(line) end if ! runoff if (rch%runoff_iprn /= 0) then write(line,40)rch%newReachNum,'runoff',rch%runoff - call lineList%AddLine(line) + call lineList%AddLine(line) end if ! iterate through diversions (volumetric or as fraction of upstream flow) ndiv = rch%Diversions%Count() diff --git a/utils/mf5to6/src/SfrReach.f90 b/utils/mf5to6/src/SfrReach.f90 index 19cb2f90bc5..6852fdc72e6 100755 --- a/utils/mf5to6/src/SfrReach.f90 +++ b/utils/mf5to6/src/SfrReach.f90 @@ -28,7 +28,7 @@ module SfrReachModule real, public :: ustrf ! upstream flow fraction real, public :: stage = -9999. ! specified stage at center of reach ! - ! Stress-period input for SFR6 + ! Stress period input for SFR6 real, public :: inflow real, public :: rainfall real, public :: evap diff --git a/utils/mf5to6/src/SimFileWriter.f90 b/utils/mf5to6/src/SimFileWriter.f90 index a5c39f92669..9db3c7870ed 100644 --- a/utils/mf5to6/src/SimFileWriter.f90 +++ b/utils/mf5to6/src/SimFileWriter.f90 @@ -9,7 +9,7 @@ module SimFileWriterModule use ModelModule, only: ModelType use MoverModule, only: MoverType, AddMoverToList use MvrPackageWriterModule, only: MvrPackageWriterType - use SimVariablesModule, only: SimMovers + use SimListVariablesModule, only: SimMovers implicit none 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/mf5to6/src/mf5to6.f90 b/utils/mf5to6/src/mf5to6.f90 index 0c01a5991fa..9c82942992e 100644 --- a/utils/mf5to6/src/mf5to6.f90 +++ b/utils/mf5to6/src/mf5to6.f90 @@ -18,7 +18,7 @@ program mf5to6 AllSfrPkgWriters use SimFileWriterModule, only: SimFileWriterType use SimModule, only: ustop - use SimVariablesModule, only: SimMovers + use SimListVariablesModule, only: SimMovers use UtilitiesModule, only: GetArgs, ReadMf5to6Options, PhmfOption ! implicit none diff --git a/utils/zonebudget/make/makefile b/utils/zonebudget/make/makefile index 2485a86d91c..8301d518a4e 100644 --- a/utils/zonebudget/make/makefile +++ b/utils/zonebudget/make/makefile @@ -1,4 +1,4 @@ -# makefile created on 2018-08-09 13:41:24.005512 +# makefile created on 2019-12-12 13:31:04.803316 # by pymake (version 1.1.0) # using the gfortran fortran and gcc c/c++ compilers. @@ -23,26 +23,27 @@ FFLAGS = -O2 -fbacktrace # Define the C compile flags CC = gcc -CFLAGS = -O3 -D_UF +CFLAGS = -O2 -D_UF # Define the libraries SYSLIBS = OBJECTS = \ -$(OBJDIR)/kind.o \ $(OBJDIR)/OpenSpec.o \ +$(OBJDIR)/kind.o \ $(OBJDIR)/Constants.o \ -$(OBJDIR)/version.o \ $(OBJDIR)/SimVariables.o \ +$(OBJDIR)/genericutils.o \ +$(OBJDIR)/version.o \ $(OBJDIR)/ArrayHandlers.o \ $(OBJDIR)/Sim.o \ $(OBJDIR)/Budget.o \ -$(OBJDIR)/InputOutput.o \ $(OBJDIR)/budgetdata.o \ -$(OBJDIR)/grb.o \ $(OBJDIR)/sort.o \ -$(OBJDIR)/ArrayReaders.o \ +$(OBJDIR)/InputOutput.o \ $(OBJDIR)/BlockParser.o \ +$(OBJDIR)/ArrayReaders.o \ +$(OBJDIR)/grb.o \ $(OBJDIR)/zone.o \ $(OBJDIR)/zoneoutput.o \ $(OBJDIR)/zbud6.o 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 13829a7bbb8..62ca3587830 100644 --- a/utils/zonebudget/msvs/zonebudget.vfproj +++ b/utils/zonebudget/msvs/zonebudget.vfproj @@ -1,48 +1,49 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/utils/zonebudget/pymake/extrafiles.txt b/utils/zonebudget/pymake/extrafiles.txt index eed5972d081..5a2daedbf15 100644 --- a/utils/zonebudget/pymake/extrafiles.txt +++ b/utils/zonebudget/pymake/extrafiles.txt @@ -1,13 +1,14 @@ -../../../src/Utilities/ArrayHandlers.f90 -../../../src/Utilities/ArrayReaders.f90 -../../../src/Utilities/BlockParser.f90 -../../../src/Utilities/Budget.f90 -../../../src/Utilities/Constants.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 5bcf6f79bcf..94be1892b2d 100644 --- a/utils/zonebudget/src/zbud6.f90 +++ b/utils/zonebudget/src/zbud6.f90 @@ -1,375 +1,385 @@ -program zonbudmf6 +program zonbudmf6 use KindModule - use SimModule, only: ustop - use ConstantsModule, only: LENHUGELINE - use VersionModule, only: VERSION - use SimVariablesModule, only: iout - use InputOutputModule, only: openfile, write_centered - - implicit none - - character(len=10), parameter :: mfvnam=' Version 6' - 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, 6, 80) - call write_centered('U.S. GEOLOGICAL SURVEY', 6, 80) - call write_centered('VERSION '//VERSION, 6, 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(6, *) - write(6, '(a)') 'ERROR. Name file not found.' - write(6, '(a)') 'Looking for: ' // trim(fnam) - 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, iout, 80) - call write_centered('U.S. GEOLOGICAL SURVEY', iout, 80) - call write_centered('VERSION '//VERSION, iout, 80) - ! - ! -- 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(6, '(a)') 'Normal Termination' - ! -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 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=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 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 - write(6, '(a)', advance='no') '.' - 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 - write(6, '(a)') '.' - 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 diff --git a/version.txt b/version.txt index a16351671f5..a4a64112a00 100644 --- a/version.txt +++ b/version.txt @@ -1,12 +1,7 @@ -# MODFLOW 6 version file automatically created using...pre-commit.py -# created on...September 06, 2018 09:56:06 - -# add some comments on how this version file -# should be manually updated and used +# MODFLOW 6 version file automatically created using...make-release.py +# created on...December 12, 2019 15:20:23 major = 6 -minor = 0 -micro = 3 -build = 8 -commit = 109 - +minor = 1 +micro = 1 +__version__ = '{:d}.{:d}.{:d}'.format(major, minor, micro)