├── .github └── workflows │ ├── build_docs.yml │ └── build_test.yml ├── .gitignore ├── LICENSE ├── README.md ├── apidocs ├── Doxyfile.cfg └── Doxygen-featom.cfg ├── app ├── conv.f90 ├── conv_potential.f90 ├── gpd_coulomb_schroed_nelements.f90 ├── main.f90 └── meson.build ├── environment.yml ├── fpm.toml ├── meson.build ├── meson_options.txt ├── nb └── Plot.md ├── scripts └── mkdoxydoc.sh ├── src ├── constants.f90 ├── dirac.f90 ├── energies.f90 ├── fe.f90 ├── feutils.f90 ├── gjp_gw_single.f90 ├── graphs.f90 ├── graphs_potential.f90 ├── hartree_screening.f90 ├── lapack.f90 ├── linalg.f90 ├── mesh.f90 ├── meson.build ├── mixings.f90 ├── quadrature.f90 ├── schroed_dirac_solver.f90 ├── schroed_glob.f90 ├── solvers.f90 ├── states.f90 ├── string_utils.f90 ├── types.f90 └── xc.f90 └── test ├── test_coulomb_dirac.f90 ├── test_coulomb_schroed.f90 ├── test_dft_dirac.f90 ├── test_dft_dirac_fast.f90 ├── test_dft_schroed.f90 ├── test_dft_schroed_fast.f90 ├── test_harmonic_dirac.f90 └── test_harmonic_schroed.f90 /.github/workflows/build_docs.yml: -------------------------------------------------------------------------------- 1 | name: Build documentation 2 | concurrency: 3 | group: ${{ github.workflow }}-${{ github.head_ref }} 4 | cancel-in-progress: true 5 | on: [push, pull_request] 6 | jobs: 7 | build_docs: 8 | name: Build documentation 9 | runs-on: ubuntu-latest 10 | strategy: 11 | fail-fast: true 12 | steps: 13 | - uses: actions/checkout@v3 14 | - uses: mamba-org/setup-micromamba@v1 15 | with: 16 | environment-file: environment.yml 17 | init-shell: >- 18 | bash 19 | cache-environment: true 20 | post-cleanup: 'all' 21 | - name: Get external tags 22 | shell: bash -el {0} 23 | run: | 24 | cd apidocs 25 | mkdir -p tags 26 | cd tags 27 | curl https://upload.cppreference.com/mwiki/images/f/f8/cppreference-doxygen-web.tag.xml -o cppreference-doxygen-web.tag.xml 28 | - name: Get Theme 29 | shell: bash -el {0} 30 | run: | 31 | cd apidocs 32 | wget https://github.com/HaoZeke/doxyYoda/releases/download/0.0.2/doxyYoda_0.0.2.tar.gz 33 | tar xf doxyYoda_0.0.2.tar.gz 34 | - name: Generate Docs 35 | shell: bash -el {0} 36 | run: | 37 | doxygen apidocs/Doxygen-featom.cfg 38 | - name: Archive artifact 39 | shell: sh 40 | if: runner.os == 'Linux' 41 | run: | 42 | tar \ 43 | --dereference --hard-dereference \ 44 | --exclude=.git \ 45 | --exclude=.github \ 46 | -cvf "$RUNNER_TEMP/artifact.tar" \ 47 | --directory=html . 48 | - name: Upload artifacts 49 | uses: actions/upload-artifact@v3 50 | with: 51 | name: github-pages 52 | path: ${{ runner.temp }}/artifact.tar 53 | if-no-files-found: error 54 | # Deploy job 55 | deploy: 56 | # Add a dependency to the build job 57 | needs: build_docs 58 | if: github.event_name == 'push' && github.repository == 'atomic-solvers/featom' 59 | permissions: 60 | pages: write # to deploy to Pages 61 | id-token: write # to verify the deployment originates from an appropriate source 62 | # Deploy to the github-pages environment 63 | environment: 64 | name: github-pages 65 | url: ${{ steps.deployment.outputs.page_url }} 66 | # Specify runner + deployment step 67 | runs-on: ubuntu-latest 68 | steps: 69 | - name: Deploy to GitHub Pages 70 | id: deployment 71 | uses: actions/deploy-pages@v2 # or the latest "vX.X.X" version tag for this action 72 | -------------------------------------------------------------------------------- /.github/workflows/build_test.yml: -------------------------------------------------------------------------------- 1 | name: Build and Test 2 | 3 | concurrency: 4 | group: ${{ github.workflow }}-${{ github.head_ref }} 5 | cancel-in-progress: true 6 | 7 | on: 8 | push: 9 | branches: [main] 10 | pull_request: 11 | branches: [main] 12 | 13 | jobs: 14 | buildfpm: 15 | runs-on: ubuntu-latest 16 | steps: 17 | - name: Checkout code 18 | uses: actions/checkout@v2 19 | - name: Install packages 20 | run: | 21 | set -ex 22 | echo "Update information of package list.." 23 | sudo apt-get update 24 | echo "Install Fortran compiler .." 25 | sudo apt-get install -y gfortran 26 | echo "Install OpenMP headers .." 27 | sudo apt-get install -y libomp-dev 28 | echo "Install lapack .." 29 | sudo apt-get install -y libopenblas-dev liblapack-dev 30 | echo "install meson" 31 | sudo apt-get install -y meson 32 | 33 | - name: Install fpm 34 | uses: fortran-lang/setup-fpm@v5 35 | with: 36 | fpm-version: 'v0.9.0' 37 | 38 | - name: Build featom 39 | run: | 40 | set -ex 41 | fpm build 42 | 43 | - name: Test featom 44 | run: | 45 | set -ex 46 | fpm test 47 | 48 | - name: Test convergence 49 | run: | 50 | set -ex 51 | fpm run gpd_coulomb_schroed_nelements 52 | 53 | - name: Test Release Mode 54 | run: | 55 | set -ex 56 | fpm test --profile=release 57 | fpm run --profile=release gpd_coulomb_schroed_nelements 58 | 59 | buildmeson: 60 | runs-on: ubuntu-latest 61 | steps: 62 | - name: Checkout code 63 | uses: actions/checkout@v2 64 | - name: Install packages 65 | run: | 66 | set -ex 67 | echo "Update information of package list.." 68 | sudo apt-get update 69 | echo "Install Fortran compiler .." 70 | sudo apt-get install -y gfortran 71 | echo "Install OpenMP headers .." 72 | sudo apt-get install -y libomp-dev 73 | echo "Install lapack .." 74 | sudo apt-get install -y libopenblas-dev liblapack-dev 75 | echo "install meson" 76 | sudo apt-get install -y meson 77 | 78 | - name: Build featom 79 | run: | 80 | set -ex 81 | meson setup bbdir -Dwith_tests=True -Dwith_app=True 82 | 83 | - name: Test featom 84 | run: | 85 | set -ex 86 | meson test -C bbdir 87 | 88 | - name: Test convergence [release] 89 | run: | 90 | set -ex 91 | meson compile -C bbdir 92 | ./bbdir/app/gpd_coulomb_schroed_nelements 93 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | ### https://raw.github.com/github/gitignore/218a941be92679ce67d0484547e3e142b2f5f6f0/Fortran.gitignore 2 | 3 | # Prerequisites 4 | *.d 5 | 6 | # Compiled Object files 7 | *.slo 8 | *.lo 9 | *.o 10 | *.obj 11 | 12 | # Precompiled Headers 13 | *.gch 14 | *.pch 15 | 16 | # Compiled Dynamic libraries 17 | *.so 18 | *.dylib 19 | *.dll 20 | 21 | # Fortran module files 22 | *.mod 23 | *.smod 24 | 25 | # Compiled Static libraries 26 | *.lai 27 | *.la 28 | *.a 29 | *.lib 30 | 31 | # Executables 32 | *.exe 33 | *.out 34 | *.app 35 | 36 | 37 | ### https://raw.github.com/github/gitignore/218a941be92679ce67d0484547e3e142b2f5f6f0/Python.gitignore 38 | 39 | # Byte-compiled / optimized / DLL files 40 | __pycache__/ 41 | *.py[cod] 42 | *$py.class 43 | 44 | # C extensions 45 | *.so 46 | 47 | # Distribution / packaging 48 | .Python 49 | build/ 50 | develop-eggs/ 51 | dist/ 52 | downloads/ 53 | eggs/ 54 | .eggs/ 55 | lib/ 56 | lib64/ 57 | parts/ 58 | sdist/ 59 | var/ 60 | wheels/ 61 | share/python-wheels/ 62 | *.egg-info/ 63 | .installed.cfg 64 | *.egg 65 | MANIFEST 66 | 67 | # PyInstaller 68 | # Usually these files are written by a python script from a template 69 | # before PyInstaller builds the exe, so as to inject date/other infos into it. 70 | *.manifest 71 | *.spec 72 | 73 | # Installer logs 74 | pip-log.txt 75 | pip-delete-this-directory.txt 76 | 77 | # Unit test / coverage reports 78 | htmlcov/ 79 | .tox/ 80 | .nox/ 81 | .coverage 82 | .coverage.* 83 | .cache 84 | nosetests.xml 85 | coverage.xml 86 | *.cover 87 | *.py,cover 88 | .hypothesis/ 89 | .pytest_cache/ 90 | cover/ 91 | 92 | # Translations 93 | *.mo 94 | *.pot 95 | 96 | # Django stuff: 97 | *.log 98 | local_settings.py 99 | db.sqlite3 100 | db.sqlite3-journal 101 | 102 | # Flask stuff: 103 | instance/ 104 | .webassets-cache 105 | 106 | # Scrapy stuff: 107 | .scrapy 108 | 109 | # Sphinx documentation 110 | docs/_build/ 111 | 112 | # PyBuilder 113 | .pybuilder/ 114 | target/ 115 | 116 | # Jupyter Notebook 117 | .ipynb_checkpoints 118 | 119 | # IPython 120 | profile_default/ 121 | ipython_config.py 122 | 123 | # pyenv 124 | # For a library or package, you might want to ignore these files since the code is 125 | # intended to run in multiple environments; otherwise, check them in: 126 | # .python-version 127 | 128 | # pipenv 129 | # According to pypa/pipenv#598, it is recommended to include Pipfile.lock in version control. 130 | # However, in case of collaboration, if having platform-specific dependencies or dependencies 131 | # having no cross-platform support, pipenv may install dependencies that don't work, or not 132 | # install all needed dependencies. 133 | #Pipfile.lock 134 | 135 | # PEP 582; used by e.g. github.com/David-OConnor/pyflow 136 | __pypackages__/ 137 | 138 | # Celery stuff 139 | celerybeat-schedule 140 | celerybeat.pid 141 | 142 | # SageMath parsed files 143 | *.sage.py 144 | 145 | # Environments 146 | .env 147 | .venv 148 | env/ 149 | venv/ 150 | ENV/ 151 | env.bak/ 152 | venv.bak/ 153 | 154 | # Spyder project settings 155 | .spyderproject 156 | .spyproject 157 | 158 | # Rope project settings 159 | .ropeproject 160 | 161 | # mkdocs documentation 162 | /site 163 | 164 | # mypy 165 | .mypy_cache/ 166 | .dmypy.json 167 | dmypy.json 168 | 169 | # Pyre type checker 170 | .pyre/ 171 | 172 | # pytype static type analyzer 173 | .pytype/ 174 | 175 | # Cython debug symbols 176 | cython_debug/ 177 | 178 | 179 | ### https://raw.github.com/github/gitignore/218a941be92679ce67d0484547e3e142b2f5f6f0/Global/macOS.gitignore 180 | 181 | # General 182 | .DS_Store 183 | .AppleDouble 184 | .LSOverride 185 | 186 | # Icon must end with two \r 187 | Icon 188 | 189 | # Thumbnails 190 | ._* 191 | 192 | # Files that might appear in the root of a volume 193 | .DocumentRevisions-V100 194 | .fseventsd 195 | .Spotlight-V100 196 | .TemporaryItems 197 | .Trashes 198 | .VolumeIcon.icns 199 | .com.apple.timemachine.donotpresent 200 | 201 | # Directories potentially created on remote AFP share 202 | .AppleDB 203 | .AppleDesktop 204 | Network Trash Folder 205 | Temporary Items 206 | .apdisk 207 | 208 | 209 | ### https://raw.github.com/github/gitignore/218a941be92679ce67d0484547e3e142b2f5f6f0/C++.gitignore 210 | 211 | # Prerequisites 212 | *.d 213 | 214 | # Compiled Object files 215 | *.slo 216 | *.lo 217 | *.o 218 | *.obj 219 | 220 | # Precompiled Headers 221 | *.gch 222 | *.pch 223 | 224 | # Compiled Dynamic libraries 225 | *.so 226 | *.dylib 227 | *.dll 228 | 229 | # Fortran module files 230 | *.mod 231 | *.smod 232 | 233 | # Compiled Static libraries 234 | *.lai 235 | *.la 236 | *.a 237 | *.lib 238 | 239 | # Executables 240 | *.exe 241 | *.out 242 | *.app 243 | 244 | # Documentation 245 | apidocs/doxyYoda 246 | html/ 247 | .auctex* 248 | todo.org 249 | tmp/ 250 | 251 | python/pyfeatom.c 252 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License Copyright (c) 2021-2023 featom developers 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is furnished 8 | to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice (including the next 11 | paragraph) shall be included in all copies or substantial portions of the 12 | Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 16 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS 17 | OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 18 | WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF 19 | OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # featom: Finite Element Solvers for Atomic Structure Calculations 2 | 3 | This library implements accurate and efficient radial Schrödinger and Dirac 4 | finite element solvers. The formulation admits general potentials and meshes: 5 | uniform, exponential, or other. Additionally, a squared Hamiltonian approach has 6 | been used for the Dirac equation, which eliminates spurious states. 7 | 8 | ## Article 9 | 10 | Detailed description of methods, convergence studies and implementation details 11 | may be found in the following article: 12 | 13 | > Čertík, Ondřej, et al. High-Order Finite Element Method for Atomic Structure Calculations. Computer Physics Communications, Volume 297, 2024, ISSN 0010-4655. https://www.sciencedirect.com/science/article/pii/S001046552300396X, http://arxiv.org/abs/2307.05856. 14 | 15 | ## Accuracy 16 | 17 | With the provided meshes, the solvers (both Schrödinger and Dirac) can converge 18 | to at least 1e-8 Ha accuracy (with double precision of approximately 16 19 | significant digits) for all eigenvalues and total DFT energies for all atoms up 20 | to uranium (Z=92). 21 | 22 | The converged nonrelativistic and relativistic results agree with 23 | [dftatom](https://github.com/certik/dftatom) to 24 | 1e-8 Ha accuracy, and with the NIST benchmarks to the stated accuracy of those 25 | benchmarks (2e-6 Ha in eigenvalues and 1e-6 Ha in total energies). 26 | 27 | http://physics.nist.gov/PhysRefData/DFTdata/Tables/ptable.html 28 | 29 | The accuracy is on par with [dftatom](https://github.com/certik/dftatom/) and 30 | uses significantly less computationally expensive routines. 31 | 32 | ## Compilation 33 | 34 | This program is packaged with `fpm`, the [Fortran package manager](https://fpm.fortran-lang.org/). 35 | 36 | ``` bash 37 | # All of these can be passed the --profile=release flag 38 | fpm build 39 | fpm test 40 | fpm run --profile=release conv -- 0 0 5 41 | ``` 42 | 43 | Where the parameters to `conv` are: 44 | 45 | ```fortran 46 | ! can be, 47 | ! 0: error as p is varied 48 | ! 1: error as rmax is varied 49 | ! 2: error as Ne is varied 50 | ! 51 | ! can be, 52 | ! 0: Schroedinger 53 | ! 1: Dirac 54 | ! 55 | ! For 56 | ! 0, 1: 3rd parameter = Ne (Number of elements) 57 | ! 2 : 3rd parameter = p (Polynomial order) 58 | ``` 59 | 60 | ### Setting up 61 | 62 | We can use an `anaconda` helper like `micromamba` (installation instructions [are here](https://mamba.readthedocs.io/en/latest/installation.html). 63 | 64 | We can now set up the tools needed. We support both `fpm` and `meson` as build systems. 65 | 66 | ``` bash 67 | # Global 68 | micromamba install fpm meson -c conda-forge 69 | # Project Local 70 | micromamba create -p ./tmp fpm meson -c conda-forge 71 | micromamba activate ./tmp 72 | # Optionally: blas lapack openmp gfortran 73 | # Best obtained with a package manager 74 | # Alternative 75 | micromamba create -f environment.yml # creates fe 76 | micromamba activate fe 77 | ``` 78 | 79 | #### Using `fpm` 80 | 81 | ``` bash 82 | fpm build 83 | fpm run --profile=release conv -- 0 0 5 84 | ``` 85 | 86 | #### Using `meson` 87 | 88 | ``` bash 89 | # release mode is the default 90 | meson setup bbdir -Dwith_app=true 91 | ./bbdir/app/conv 0 0 5 92 | ``` 93 | 94 | ## Testing 95 | 96 | Tests can be run by: 97 | ``` 98 | fpm test 99 | # Or, changing to debug 100 | meson setup bbdir -Dwith_tests=true --buildtype=debug 101 | meson test -C bbdir 102 | 1/8 CoulombSchroed OK 0.05s 103 | 2/8 DftSchroedFast OK 0.06s 104 | 3/8 HarmonicSchroed OK 0.11s 105 | 4/8 DftSchroed OK 0.12s 106 | 5/8 HarmonicDirac OK 0.47s 107 | 6/8 CoulombDirac OK 0.49s 108 | 7/8 DftDiracFast OK 1.95s 109 | 8/8 DftDirac OK 6.45s 110 | 111 | Ok: 8 112 | Expected Fail: 0 113 | Fail: 0 114 | Unexpected Pass: 0 115 | Skipped: 0 116 | Timeout: 0 117 | ``` 118 | 119 | Individual test binaries can also be executed, e.g.: 120 | 121 | ``` bash 122 | meson compile -C bbdir 123 | ./bbdir/testDftDirac 124 | ``` 125 | 126 | ## Documentation 127 | 128 | The API documentation is generated by [doxygen](https://www.doxygen.nl/index.html) with the [doxyYoda](https://github.com/HaoZeke/doxyYoda) theme. 129 | 130 | To build a local copy and serve it consider: 131 | 132 | ``` bash 133 | bash scrpits/mkdoxydoc.sh 134 | ``` 135 | 136 | 137 | ## License 138 | 139 | This program is MIT licensed, see the LICENSE file for details. 140 | -------------------------------------------------------------------------------- /apidocs/Doxygen-featom.cfg: -------------------------------------------------------------------------------- 1 | # Customized Options 2 | # Make changes here to prevent things from being overwritten when the main file 3 | # is updated 4 | # Defaults 5 | @INCLUDE = "apidocs/Doxyfile.cfg" 6 | 7 | # XML 8 | GENERATE_XML = NO 9 | XML_PROGRAMLISTING = NO 10 | 11 | # HTML 12 | GENERATE_HTML = YES 13 | 14 | # LaTeX 15 | GENERATE_LATEX = NO 16 | 17 | # Project Settings 18 | PROJECT_NAME = "featom" 19 | PROJECT_NUMBER = "0.1.0" 20 | PROJECT_BRIEF = "Finite Element Solvers for Atomic Structure Calculations" 21 | # PROJECT_LOGO = "images/Logo.png" 22 | # IMAGE_PATH = "./images" 23 | 24 | # Apidocs Settings 25 | RECURSIVE = YES 26 | EXTRACT_ALL = YES 27 | INPUT = README.md . 28 | EXCLUDE = build 29 | USE_MDFILE_AS_MAINPAGE = README.md 30 | CITE_BIB_FILES = refs.bib 31 | 32 | # Language additions 33 | OPTIMIZE_FOR_FORTRAN = YES 34 | 35 | # XML 36 | GENERATE_XML = NO 37 | XML_PROGRAMLISTING = NO 38 | # LaTeX 39 | GENERATE_LATEX = NO 40 | 41 | # Style 42 | JAVADOC_BANNER = YES 43 | JAVADOC_AUTOBRIEF = NO 44 | INHERIT_DOCS = YES 45 | INLINE_SOURCES = YES 46 | SOURCE_BROWSER = YES 47 | DISABLE_INDEX = NO 48 | GENERATE_TREEVIEW = NO 49 | HAVE_DOT = YES 50 | DOT_IMAGE_FORMAT = YES 51 | HTML_DYNAMIC_SECTIONS = YES 52 | INTERACTIVE_SVG = YES 53 | # Theme 54 | # HTML 55 | GENERATE_HTML = YES 56 | USE_MATHJAX = YES 57 | HTML_HEADER = "apidocs/doxyYoda/html/header.html" 58 | HTML_FOOTER = "apidocs/doxyYoda/html/footer.html" 59 | HTML_EXTRA_STYLESHEET = "apidocs/doxyYoda/css/doxyYoda.min.css" 60 | LAYOUT_FILE = "apidocs/doxyYoda/xml/doxyYoda.xml" 61 | 62 | # Extract everything 63 | # EXTRACT_ALL = NO 64 | EXTRACT_PRIVATE = YES 65 | EXTRACT_PRIV_VIRTUAL = YES 66 | EXTRACT_PACKAGE = YES 67 | EXTRACT_STATIC = YES 68 | MACRO_EXPANSION = YES 69 | ENABLE_PREPROCESSING = YES 70 | 71 | # Local Variables: 72 | # mode: conf 73 | # End: 74 | -------------------------------------------------------------------------------- /app/conv.f90: -------------------------------------------------------------------------------- 1 | program conv 2 | 3 | ! Compute convergence studies for Schroedinger or Dirac. 4 | ! One can do convergence with respect to any parameter. 5 | ! run ./conv 6 | ! 7 | ! can be, 8 | ! 0: error as p is varied 9 | ! 1: error as rmax is varied 10 | ! 2: error as Ne is varied 11 | ! 12 | ! can be, 13 | ! 0: Schroedinger 14 | ! 1: Dirac 15 | ! 16 | ! For 17 | ! 0, 1: 3rd parameter = Ne (Number of elements) 18 | ! 2 : 3rd parameter = p (Polynomial order) 19 | 20 | use graphs, only: run_convergence 21 | implicit none 22 | 23 | integer :: dirac_int, study_type, p_or_Ne 24 | character(len=128) :: arg 25 | 26 | if (command_argument_count() /= 3) then 27 | print *, "./conv " 28 | error stop "Must supply 3 arguments" 29 | end if 30 | 31 | call get_command_argument(1, arg) 32 | read(arg, '(i4)') study_type 33 | call get_command_argument(2, arg) 34 | read(arg, '(i4)') dirac_int 35 | call get_command_argument(3, arg) 36 | read(arg, '(i4)') p_or_Ne 37 | 38 | call run_convergence(study_type, dirac_int, p_or_Ne, ".") 39 | 40 | end program 41 | -------------------------------------------------------------------------------- /app/conv_potential.f90: -------------------------------------------------------------------------------- 1 | program conv_potential 2 | 3 | ! Compute convergence studies for Schroedinger or Dirac. 4 | ! One can do convergence with respect to any parameter. 5 | ! run ./conv_potential 6 | ! 7 | ! can be, 8 | ! 0: error as p is varied 9 | ! 1: error as rmax is varied 10 | ! 2: error as Ne is varied 11 | ! 12 | ! can be, 13 | ! 0: Schroedinger 14 | ! 1: Dirac 15 | ! 16 | ! For 17 | ! 0, 1: 3rd parameter = Ne (Number of elements) 18 | ! 2 : 3rd parameter = p (Polynomial order) 19 | ! 20 | ! can be, 21 | ! 0: Coulomb 22 | ! 1: Harmonic 23 | ! 24 | ! can be 0, 1, -1 (-1 implies beta). used only for Dirac. 25 | 26 | use graphs_potential, only: run_convergence_potential 27 | implicit none 28 | 29 | integer :: dirac_int, study_type, p_or_Ne, potential_type, alpha_int 30 | character(len=128) :: arg 31 | 32 | if (command_argument_count() /= 5) then 33 | print *, "./conv_potential " 34 | error stop "Must supply 5 arguments" 35 | end if 36 | 37 | call get_command_argument(1, arg) 38 | read(arg, '(i4)') study_type 39 | call get_command_argument(2, arg) 40 | read(arg, '(i4)') dirac_int 41 | call get_command_argument(3, arg) 42 | read(arg, '(i4)') p_or_Ne 43 | call get_command_argument(4, arg) 44 | read(arg, '(i4)') potential_type 45 | call get_command_argument(5, arg) 46 | read(arg, '(i4)') alpha_int 47 | 48 | call run_convergence_potential(study_type, dirac_int, p_or_Ne, & 49 | potential_type, alpha_int, ".") 50 | 51 | end program 52 | -------------------------------------------------------------------------------- /app/gpd_coulomb_schroed_nelements.f90: -------------------------------------------------------------------------------- 1 | program gpd_coulomb_schroed_nelements 2 | use graphs_potential, only: run_convergence_potential 3 | implicit none 4 | ! Compute convergence studies for Schroedinger or Dirac. 5 | ! One can do convergence with respect to any parameter. 6 | ! run ./conv_potential 7 | ! 8 | ! can be, 9 | ! 0: error as p is varied 10 | ! 1: error as rmax is varied 11 | ! 2: error as Ne is varied 12 | ! 13 | ! can be, 14 | ! 0: Schroedinger 15 | ! 1: Dirac 16 | ! 17 | ! For 18 | ! 0, 1: 3rd parameter = Ne (Number of elements) 19 | ! 2 : 3rd parameter = p (Polynomial order) 20 | ! 21 | ! can be, 22 | ! 0: Coulomb 23 | ! 1: Harmonic 24 | ! 25 | ! can be 0, 1, -1 (-1 implies beta). used only for Dirac. 26 | integer, parameter, dimension(*) :: p_values = [2, 3, 4, 8, 16, 32] 27 | integer :: idx 28 | 29 | 30 | do idx = 1, size(p_values) 31 | print*, "Running Schroedinger Coulomb number of elements ", & 32 | 2, 0, p_values(idx), 0, -1 33 | call run_convergence_potential(2, 0, p_values(idx), & 34 | 0, -1, "app") 35 | end do 36 | 37 | end program gpd_coulomb_schroed_nelements 38 | -------------------------------------------------------------------------------- /app/main.f90: -------------------------------------------------------------------------------- 1 | program main 2 | end program main 3 | -------------------------------------------------------------------------------- /app/meson.build: -------------------------------------------------------------------------------- 1 | # --------------------- Executable apps 2 | 3 | conv = executable('conv', 'conv.f90', 4 | dependencies: _deps, 5 | include_directories: _incdirs, 6 | cpp_args: _args, 7 | link_with: _linkto, 8 | install: false) 9 | 10 | conv_potential = executable('conv_potential', 11 | 'conv_potential.f90', 12 | dependencies: _deps, 13 | include_directories: _incdirs, 14 | cpp_args: _args, 15 | link_with: _linkto, 16 | install: false) 17 | 18 | gpd_coulomb_schroed_nelements = executable('gpd_coulomb_schroed_nelements', 19 | 'gpd_coulomb_schroed_nelements.f90', 20 | dependencies: _deps, 21 | include_directories: _incdirs, 22 | cpp_args: _args, 23 | link_with: _linkto, 24 | install: false) 25 | -------------------------------------------------------------------------------- /environment.yml: -------------------------------------------------------------------------------- 1 | # To use: 2 | # 3 | # $ micromamba env create -f environment.yml # `micromamba` works too for this command 4 | # $ micromamba activate fe 5 | # 6 | name: fe 7 | channels: 8 | - conda-forge 9 | dependencies: 10 | - compilers 11 | - fpm 12 | - blas 13 | - gfortran 14 | - pkg-config 15 | - openblas 16 | - meson 17 | - intel::intel-openmp 18 | - mkl-devel=2023.2=ha770c72_49502 19 | - ninja 20 | - cmake 21 | # Documentation 22 | - doxygen==1.9.1 # for doxyYoda 23 | - graphviz # for dot 24 | -------------------------------------------------------------------------------- /fpm.toml: -------------------------------------------------------------------------------- 1 | name = "featom" 2 | version = "0.1.0" 3 | license = "MIT" 4 | author = "Ondrej Certik, John E. Pask, Isuru Fernando, Rohit Goswami, N. Sukumar, Lee. A. Collins, Gianmarco Manzini, Jiri Vackar" 5 | maintainer = "ondrej@certik.us" 6 | copyright = "Copyright 2023, featom developers" 7 | [build] 8 | auto-executables = true 9 | auto-tests = true 10 | auto-examples = true 11 | link = ["blas", "lapack"] 12 | [install] 13 | library = false 14 | -------------------------------------------------------------------------------- /meson.build: -------------------------------------------------------------------------------- 1 | project('featom', 'fortran', 2 | version:'0.1.0', 3 | default_options: ['wrap_mode=default', 4 | 'warning_level=3']) 5 | 6 | # Add compiler options 7 | _args = [] # Extra arguments 8 | _deps = [] # Dependencies 9 | _linkto = [] # All the sub-libraries 10 | _incdirs = [] # All the includes 11 | 12 | fc = meson.get_compiler('fortran') 13 | 14 | # Platform detection 15 | host_system = host_machine.system() 16 | is_windows = host_system == 'windows' 17 | is_mingw = is_windows and fc.get_id() == 'gcc' 18 | 19 | cpu_family = host_machine.cpu_family() 20 | 21 | if is_mingw 22 | # For mingw-w64, don't use LTO 23 | add_project_arguments('-fno-use-linker-plugin', language: ['fortran']) 24 | endif 25 | 26 | # --------------------- Dependencies 27 | mkldep = dependency('mkl-dynamic-lp64-seq', required: false) 28 | if not mkldep.found() 29 | lapack = dependency('lapack', required: true) 30 | _deps += [lapack] 31 | else 32 | _deps += [mkldep] 33 | endif 34 | 35 | # --------------------- Library 36 | subdir('src') # defines featom_dep 37 | _deps += [featom_dep] 38 | 39 | # --------------------- Executable apps 40 | if get_option('with_app') 41 | subdir('app') 42 | endif 43 | 44 | # ------------------------ Tests 45 | 46 | if get_option('with_tests') and not is_windows 47 | test_array = [# 48 | ['CoulombDirac', 'testCoulombDirac', 'test_coulomb_dirac.f90'], 49 | ['CoulombSchroed', 'testCoulombSchroed', 'test_coulomb_schroed.f90'], 50 | ['DftDirac', 'testDftDirac', 'test_dft_dirac.f90'], 51 | ['DftSchroed', 'testDftSchroed', 'test_dft_schroed.f90'], 52 | ['HarmonicSchroed', 'testHarmonicSchroed', 'test_harmonic_schroed.f90'], 53 | ['HarmonicDirac', 'testHarmonicDirac', 'test_harmonic_dirac.f90'], 54 | ['DftDiracFast', 'testDftDiracFast', 'test_dft_dirac_fast.f90'], 55 | ['DftSchroedFast', 'testDftSchroedFast', 'test_dft_schroed_fast.f90'], 56 | ] 57 | foreach test : test_array 58 | test(test.get(0), 59 | executable(test.get(1), 60 | sources : ['test/'+test.get(2)], 61 | dependencies : _deps, 62 | link_with : _linkto, 63 | cpp_args : _args, 64 | include_directories: _incdirs, 65 | ), 66 | ) 67 | endforeach 68 | endif 69 | -------------------------------------------------------------------------------- /meson_options.txt: -------------------------------------------------------------------------------- 1 | # Booleans 2 | option('with_tests', type : 'boolean', value : false) 3 | option('with_app', type : 'boolean', value : false) 4 | -------------------------------------------------------------------------------- /nb/Plot.md: -------------------------------------------------------------------------------- 1 | --- 2 | jupytext: 3 | formats: ipynb,md:myst 4 | text_representation: 5 | extension: .md 6 | format_name: myst 7 | format_version: 0.13 8 | jupytext_version: 1.13.8 9 | kernelspec: 10 | display_name: Python 3 (ipykernel) 11 | language: python 12 | name: python3 13 | --- 14 | 15 | Run the tests in the root directory: 16 | 17 | fpm test 18 | 19 | This will generate the `data_*.txt` files that we can then plot below. 20 | 21 | ```{code-cell} ipython3 22 | %pylab inline 23 | ``` 24 | 25 | ```{code-cell} ipython3 26 | D = loadtxt("../data_harmonic_schroed.txt") 27 | x = D[0,:] 28 | #n = size(D,0) 29 | n = 8 30 | figure(figsize=(20,12)) 31 | for i in range(1,n): 32 | plot(x, D[i,:], "-", label=f"{i}") 33 | xlim([0,5]) 34 | xlabel("r [a.u.]") 35 | ylabel("wavefunction [a.u.]") 36 | title("Schrödinger Harmonic Oscillator Wavefunctions") 37 | legend() 38 | savefig("harmonic_schroed.pdf") 39 | show() 40 | ``` 41 | 42 | ```{code-cell} ipython3 43 | D = loadtxt("../data_harmonic_dirac.txt") 44 | x = D[0,:] 45 | #n = size(D,0) 46 | n = 8 47 | figure(figsize=(20,12)) 48 | for i in range(1,n): 49 | plot(x, D[i,:], "-", label=f"{i}") 50 | xlim([0,5]) 51 | xlabel("r [a.u.]") 52 | ylabel("wavefunction [a.u.]") 53 | title("Dirac Harmonic Oscillator Wavefunctions") 54 | legend() 55 | savefig("harmonic_dirac.pdf") 56 | show() 57 | ``` 58 | 59 | ```{code-cell} ipython3 60 | D = loadtxt("../data_coulomb_schroed.txt") 61 | x = D[0,:] 62 | #n = size(D,0) 63 | n = 8 64 | figure(figsize=(20,12)) 65 | for i in range(1,n): 66 | semilogx(x, D[i,:]*x, "-", label=f"{i}") 67 | xlim([None,1.5]) 68 | xlabel("r [a.u.]") 69 | ylabel("wavefunction [a.u.]") 70 | title("Schrödinger Coulomb Wavefunctions") 71 | legend() 72 | savefig("coulomb_schroed.pdf") 73 | show() 74 | ``` 75 | 76 | ```{code-cell} ipython3 77 | D = loadtxt("../data_coulomb_dirac.txt") 78 | x = D[0,:] 79 | #n = size(D,0) 80 | n = 8 81 | figure(figsize=(20,12)) 82 | for i in range(1,n): 83 | semilogx(x, D[i,:]*x, "-", label=f"{i}") 84 | xlim([None,1.5]) 85 | xlabel("r [a.u.]") 86 | ylabel("wavefunction [a.u.]") 87 | title("Dirac Coulomb Wavefunctions") 88 | legend() 89 | savefig("coulomb_dirac.pdf") 90 | show() 91 | ``` 92 | -------------------------------------------------------------------------------- /scripts/mkdoxydoc.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | set -euo pipefail 3 | IFS=$'\n\t' 4 | 5 | cd apidocs 6 | wget https://github.com/HaoZeke/doxyYoda/releases/download/0.0.2/doxyYoda_0.0.2.tar.gz 7 | tar -xf doxyYoda_0.0.2.tar.gz 8 | rm -rf doxyYoda_0.0.2.tar.gz 9 | cd ../ 10 | doxygen apidocs/Doxygen-featom.cfg 11 | python3 -m http.server --bind 0.0.0.0 8000 -d html 12 | -------------------------------------------------------------------------------- /src/constants.f90: -------------------------------------------------------------------------------- 1 | !> @brief Constants contain more digits than double precision, so that 2 | !> they are rounded correctly. 3 | !> @details Single letter constants contain underscore so 4 | !> that they do not clash with user variables ("e" and "i" are frequently used as 5 | !> loop variables). The public parameters are enumerated below: 6 | !> @param c_year values correspond to different CODATA standards for the inverse fine-structure constant 7 | !> @param Ha2eV_year values is the conversion factor for converting Hartree to eV as per varying CODATA standards 8 | !> @param e_ is Euler's constant 9 | !> @param i_ denotes one unit length along the complex axis as a conversion helper 10 | 11 | module constants 12 | use types, only: dp 13 | implicit none 14 | private 15 | public pi, e_, i_, Ha2eV_2010, c_2010, c_2006, c_1998, c_1986 16 | 17 | real(dp), parameter :: pi = 3.1415926535897932384626433832795_dp 18 | real(dp), parameter :: e_ = 2.7182818284590452353602874713527_dp 19 | complex(dp), parameter :: i_ = (0, 1) 20 | 21 | real(dp), parameter :: Ha2eV_2010 = 27.21138505_dp ! 1 Ha = (1 * Ha2eV) eV 22 | ! Standard uncertainty: 0.000000000053 eV (Source: 2010 CODATA) 23 | 24 | ! speed of light in atomic units --> inverse fine-structure constant 25 | real(dp), parameter :: c_2010 = 137.035999074_dp 26 | real(dp), parameter :: c_2006 = 137.035999679_dp 27 | real(dp), parameter :: c_2002 = 137.03599911_dp 28 | real(dp), parameter :: c_1998 = 137.03599976_dp 29 | real(dp), parameter :: c_1986 = 137.0359895_dp ! To compare with dftatom 30 | end module 31 | -------------------------------------------------------------------------------- /src/dirac.f90: -------------------------------------------------------------------------------- 1 | module dirac 2 | 3 | use types, only: dp 4 | use mesh, only: meshexp 5 | use feutils, only: define_connect, get_quad_pts, get_parent_quad_pts_wts, & 6 | get_parent_nodes, phih, dphih, c2fullc2, fe2quad_core, get_nodes, & 7 | integrate, proj_fn, phih_array, integrate2, fe2quad 8 | use linalg, only: eigh 9 | use gjp_gw, only: gauss_jacobi_gw 10 | use fe, only: assemble_radial_SH, assemble_radial_dirac_SH 11 | use constants, only: pi, c => c_1986 12 | use hartree_screening, only: hartree_potential_gj 13 | use xc, only: xc_vwn3 14 | use mixings, only: mixing_linear, mixing_pulay 15 | use states, only: get_atomic_states_nonrel_focc, get_atomic_states_rel_focc, & 16 | nlsf2focc, get_atomic_states_rel, nlf2focc, get_atomic_states_nonrel 17 | use energies, only: thomas_fermi_potential 18 | use iso_c_binding, only: c_double, c_int 19 | implicit none 20 | private 21 | public solve_dirac, csolve_dirac, solve_dirac_eigenproblem 22 | 23 | contains 24 | 25 | subroutine solve_dirac_eigenproblem(Nb, Nq, Lmin, Lmax, alpha, alpha_j, xe, xiq_gj, & 26 | xq, xq1, wtq_gj, V, Z, Vin, D, S, H, lam, rho0, rho1, accurate_eigensolver, fullc, & 27 | ib, in, idx, lam_tmp, uq, wtq, xin, xiq, focc, focc_idx, eng, xq2, E_dirac_shift) 28 | logical, intent(in) :: accurate_eigensolver 29 | integer, intent(in) :: Lmin, Lmax, Z, Nb, Nq 30 | real(dp), intent(in) :: alpha_j(Lmin:), alpha(Lmin:), Vin(:,:), xq(:,:) 31 | real(dp), intent(in) :: xe(:), xiq_gj(:,Lmin:), wtq_gj(:,Lmin:) 32 | real(dp), intent(in) :: wtq(:), xin(:) 33 | real(dp), intent(in) :: xiq(:), focc(:,Lmin:), xq2(:,:) 34 | real(dp), intent(inout) :: xq1(:,:), fullc(:), uq(:,:), rho0(:,:), rho1(:,:) 35 | integer, intent(in) :: ib(:,:), in(:,:), focc_idx(:,Lmin:) 36 | real(dp), intent(inout) :: D(:,:), S(:,:), H(:,:), lam(:), lam_tmp(:), eng(:) 37 | real(dp), intent(out) :: V(:,:) 38 | integer, intent(out) :: idx 39 | real(dp), intent(in) :: E_dirac_shift 40 | integer :: kappa, i 41 | idx = 0 42 | do kappa = Lmin, Lmax 43 | if (kappa == 0) cycle 44 | !print *, "Calculating kappa =", kappa 45 | if (alpha_j(kappa) > -1) then 46 | call get_quad_pts(xe(:2), xiq_gj(:, kappa), xq1) 47 | call proj_fn(Nq-1, xe(:2), xiq_gj(:,-1), wtq_gj(:,-1), xiq_gj(:, kappa), Vin, V(:,:1)) 48 | V(:,1) = V(:,1) - Z/xq1(:,1) - E_dirac_shift 49 | V(:,2:) = Vin(:,2:) - Z/xq(:,2:) - E_dirac_shift 50 | else 51 | V = Vin - Z/xq - E_dirac_shift 52 | endif 53 | 54 | call assemble_radial_dirac_SH(V, kappa, xin, xe, ib, xiq, wtq, & 55 | xiq_gj(:, kappa), wtq_gj(:, kappa), alpha(kappa), alpha_j(kappa), c, S, H) 56 | 57 | ! One can enforce symmetry using the following lines, it helps but 58 | ! we still need two seperate eigensolves for 1e-8 accuracy: 59 | !H = (H + transpose(H))/2 60 | !S = (S + transpose(S))/2 61 | 62 | if (accurate_eigensolver) then 63 | call eigh(H, S, lam) 64 | call eigh(H, S, lam_tmp, D) 65 | else 66 | call eigh(H, S, lam, D) 67 | end if 68 | 69 | do i = 1, size(focc,1) 70 | if (focc(i,kappa) < tiny(1._dp)) cycle 71 | 72 | call c2fullc2(in, ib, D(:Nb,i), fullc) 73 | call fe2quad(xe, xin, xiq, in, fullc, uq) 74 | rho0 = rho0 - focc(i,kappa)*uq**2 * xq**alpha_j(kappa) 75 | call fe2quad(xe, xin, xiq_gj(:,-1), in, fullc, uq) 76 | rho1(:,1) = rho1(:,1) - focc(i,kappa)*uq(:,1)**2 * xq2(:,1)**alpha_j(kappa) 77 | 78 | call c2fullc2(in, ib, D(Nb+1:,i), fullc) 79 | call fe2quad(xe, xin, xiq, in, fullc, uq) 80 | rho0 = rho0 - focc(i,kappa)*uq**2 * xq**alpha_j(kappa) 81 | call fe2quad(xe, xin, xiq_gj(:,-1), in, fullc, uq) 82 | rho1(:,1) = rho1(:,1) - focc(i,kappa)*uq(:,1)**2 * xq2(:,1)**alpha_j(kappa) 83 | 84 | idx = idx + 1 85 | eng(focc_idx(i,kappa)) = sqrt(lam(i)) - c**2 + E_dirac_shift 86 | end do 87 | 88 | end do 89 | end subroutine 90 | 91 | 92 | subroutine solve_dirac(Z, p, xiq, wtq, xe, eps, energies, Etot, V, DOFs) 93 | integer, intent(in) :: Z, p 94 | real(dp), intent(in) :: xe(:) ! element coordinates 95 | real(dp), intent(in) :: xiq(:) ! quadrature points 96 | real(dp), intent(in) :: wtq(:) ! quadrature weights 97 | real(dp), intent(in) :: eps 98 | real(dp), allocatable, intent(out) :: energies(:) 99 | real(dp), intent(out) :: Etot 100 | real(dp), intent(out) :: V(:,:) ! SCF potential 101 | integer, intent(out) :: DOFs 102 | 103 | integer :: n, Nq 104 | real(dp), allocatable :: H(:,:), S(:,:), D(:,:), lam(:), lam_tmp(:) 105 | real(dp), allocatable :: xiq_gj(:,:) ! quadrature points first element 106 | real(dp), allocatable :: wtq_gj(:,:) ! quadrature weights first element 107 | real(dp), allocatable :: xin(:) ! parent basis nodes 108 | integer, allocatable :: ib(:, :) ! basis connectivity: ib(i,j) = index of 109 | ! basis function associated with local basis function i of element j. 0 = no 110 | ! associated basis fn. 111 | integer, allocatable :: in(:, :) 112 | real(dp), allocatable :: xq(:, :), fullc(:), uq(:,:), rho(:,:), Vee(:,:), & 113 | Vxc(:,:), exc(:,:), Vin(:,:), Vout(:,:), xn(:), un(:), xq1(:,:), & 114 | phihq(:,:), xq2(:,:), rho0(:,:), rho1(:,:) 115 | integer :: Ne, Nb, Nn 116 | real(dp) :: rmin, rmax, asympt 117 | real(dp), allocatable :: alpha_j(:), alpha(:) 118 | integer :: kappa, i, Lmin, Lmax, al 119 | real(dp), allocatable :: focc(:,:), focc_idx_r(:,:), tmp(:) 120 | real(dp) :: scf_alpha, scf_L2_eps, scf_eig_eps 121 | integer, parameter :: mixing_scheme_linear = 1, mixing_scheme_pulay = 3 122 | integer :: mixing_scheme 123 | integer, allocatable :: no(:), lo(:), so(:), focc_idx(:,:) 124 | real(dp), allocatable :: fo_idx(:), fo(:) 125 | real(dp) :: T_s, E_ee, E_en, EE_xc 126 | 127 | 128 | integer :: nband, scf_max_iter, iter 129 | 130 | Nq = size(xiq) 131 | rmin = 0 132 | rmax = 50 133 | Ne = size(xe)-1 134 | mixing_scheme = mixing_scheme_pulay 135 | 136 | call get_atomic_states_rel_focc(Z, focc) 137 | call get_atomic_states_rel(Z, no, lo, so, fo) 138 | allocate(fo_idx(size(fo))) 139 | do i = 1, size(fo_idx) 140 | fo_idx(i) = i 141 | end do 142 | call nlsf2focc(no, lo, so, fo_idx, focc_idx_r) 143 | allocate(focc_idx(size(focc_idx_r,1),lbound(focc,2):ubound(focc,2))) 144 | focc_idx = int(focc_idx_r) 145 | 146 | Lmax = ubound(focc,2) 147 | Lmin = lbound(focc,2) 148 | 149 | allocate(alpha(Lmin:Lmax), alpha_j(Lmin:Lmax)) 150 | 151 | do kappa = Lmin, Lmax 152 | if (kappa == 0) cycle 153 | ! asymptotic at r = 0 154 | asympt = sqrt(kappa**2 - Z**2 / c**2) 155 | ! alpha can be [0, asympt] 156 | alpha(kappa) = asympt 157 | ! power of r for Gauss-Jacobi quadrature 158 | alpha_j(kappa) = 2*alpha(kappa) - 2 159 | end do 160 | 161 | Nn = Ne*p+1 162 | 163 | allocate(xin(p+1)) 164 | call get_parent_nodes(2, p, xin) 165 | allocate(in(p+1, Ne), ib(p+1, Ne)) 166 | call define_connect(2, 1, Ne, p, in, ib) 167 | Nb = maxval(ib) 168 | if ( .not. (Nn == maxval(in)) ) then 169 | error stop 'Size mismatch' 170 | end if 171 | allocate(xq(Nq, Ne), xq1(Nq, 1), xn(Nn), un(Nn)) 172 | call get_quad_pts(xe, xiq, xq) 173 | call get_nodes(xe, xin, xn) 174 | 175 | allocate(xiq_gj(Nq, Lmin:Lmax), wtq_gj(Nq, Lmin:Lmax)) 176 | if (any(alpha_j > - 1)) then 177 | !print *, "Using Gauss-Jacobi quadrature" 178 | do kappa = Lmin, Lmax 179 | if (kappa == 0) cycle 180 | if (alpha_j(kappa) > -1) then 181 | call gauss_jacobi_gw(Nq, 0.0_dp, alpha_j(kappa), xiq_gj(:, kappa), wtq_gj(:, kappa)) 182 | end if 183 | end do 184 | else 185 | !print *, "Using Gauss-Legendre quadrature" 186 | end if 187 | 188 | allocate(phihq(Nq, p+1)) 189 | ! tabulate parent basis at quadrature points 190 | do al = 1, p+1 191 | call phih_array(xin, al, xiq, phihq(:, al)) 192 | end do 193 | 194 | n = Nb * 2 195 | DOFs = n 196 | allocate(H(n, n), S(n, n)) 197 | allocate(D(n, n), lam(n), lam_tmp(n), fullc(Nn), uq(Nq,Ne), rho(Nq,Ne), Vee(Nq,Ne), & 198 | Vxc(Nq,Ne), exc(Nq,Ne), Vin(Nq,Ne), Vout(Nq,Ne), xq2(Nq, Ne), & 199 | rho0(Nq,Ne), rho1(Nq,Ne)) 200 | 201 | nband = count(focc > 0) 202 | scf_max_iter = 100 203 | scf_alpha = 0.4_dp 204 | scf_L2_eps = 1e-4_dp 205 | scf_eig_eps = eps 206 | 207 | allocate(tmp(Nq*Ne)) 208 | allocate(energies(nband)) 209 | xq2=xq 210 | call get_quad_pts(xe(:2), xiq_gj(:, -1), xq2) 211 | Vin = reshape(thomas_fermi_potential(reshape(xq2, [Nq*Ne]), Z), [Nq, Ne]) + & 212 | Z / xq2 213 | iter = 0 214 | 215 | select case (mixing_scheme) 216 | case (mixing_scheme_linear) 217 | call mixing_linear & 218 | (Ffunc, integral, reshape(Vin, [Nq*Ne]), & 219 | nband, scf_max_iter, scf_alpha, scf_L2_eps, scf_eig_eps, tmp) 220 | case (mixing_scheme_pulay) 221 | call mixing_pulay & 222 | (Ffunc, integral, matvec, matmat, reshape(Vin, [Nq*Ne]), & 223 | nband, scf_max_iter, scf_alpha, scf_L2_eps, scf_eig_eps, tmp, 5, 1) 224 | case default 225 | error stop "Type of mixing not implemented." 226 | end select 227 | 228 | contains 229 | 230 | subroutine Ffunc(x, y, eng) 231 | ! Converge Vee+Vxc only (the other components are constant) 232 | real(dp), intent(in) :: x(:) 233 | real(dp), intent(out) :: y(:), eng(:) 234 | real(dp) :: E_dirac_shift 235 | integer :: idx 236 | logical :: accurate_eigensolver 237 | accurate_eigensolver = .true. 238 | iter = iter + 1 239 | print *, "SCF iteration:", iter 240 | Vin = reshape(x, shape(Vin)) 241 | rho = 0 242 | idx = 0 243 | Vee = 0 244 | rho0 = 0 245 | rho1 = 0 246 | E_dirac_shift = 0 247 | call solve_dirac_eigenproblem(Nb, Nq, Lmin, Lmax, alpha, alpha_j, xe, xiq_gj, & 248 | xq, xq1, wtq_gj, V, Z, Vin, D, S, H, lam, rho0, rho1, accurate_eigensolver, fullc, & 249 | ib, in, idx, lam_tmp, uq, wtq, xin, xiq, focc, focc_idx, eng, xq2, E_dirac_shift) 250 | if ( .not. (size(eng) == idx) ) then 251 | error stop 'Size mismatch in energy array' 252 | end if 253 | energies = eng 254 | 255 | rho0(:,1) = rho1(:,1) 256 | rho = rho0 / (4*pi) 257 | Vee = Vee + hartree_potential_gj(Nq-1, xe, xiq, wtq, & 258 | xiq_gj(:,-1), wtq_gj(:,-1), alpha_j(-1), -rho0) 259 | 260 | !print *, "Energies:" 261 | !do i = 1, size(eng) 262 | ! print *, i, no(i), lo(i), so(i), energies(i) 263 | !end do 264 | 265 | call xc_vwn3(size(rho), -rho, .TRUE. , c, exc, Vxc) 266 | Vout = Vee + Vxc ! This term is added later: -Z/xq 267 | y = reshape(Vout, shape(y)) 268 | 269 | call total_energy(xe, xiq, wtq, xiq_gj(:,-1), wtq_gj(:,-1), alpha_j(-1), fo, energies, Vin-Z/xq2, Vee, -Z/xq2, exc, & 270 | xq2, -rho, T_s, E_ee, E_en, EE_xc, Etot) 271 | !print *, Etot 272 | end subroutine 273 | 274 | real(dp) function integral(x) 275 | ! Computes the integral of the vector 'x' 276 | real(dp), intent(in) :: x(:) 277 | integral = integrate2(xe, xiq, xiq_gj(:,-1), wtq, wtq_gj(:,-1), alpha_j(-1), reshape(x, shape(uq))) 278 | end function 279 | 280 | function matvec(A, b) result(r) 281 | real(dp), intent(in) :: A(:,:), b(:) 282 | real(dp) :: r(size(A,1)) 283 | r = matmul(A, b) 284 | end function 285 | 286 | function matmat(A, B) result(r) 287 | real(dp), intent(in) :: A(:,:), B(:,:) 288 | real(dp) :: r(size(A,1), size(B,2)) 289 | r = matmul(A, B) 290 | end function 291 | 292 | subroutine total_energy(xe, xiq, wtq, xiq1, wtq1, alpha, fo, ks_energies, V_in, V_h, V_coulomb, e_xc, & 293 | R, n, T_s, E_ee, E_en, EE_xc, Etot) 294 | ! This is a variational, quadratically convergent form of total energy 295 | real(dp), intent(in) :: xe(:), xiq(:), xiq1(:), wtq(:), wtq1(:), alpha 296 | real(dp), intent(in) :: R(:,:) ! Function 'r' on quadrature grid 297 | real(dp), intent(in) :: fo(:), ks_energies(:) ! occupations, energies 298 | real(dp), intent(in) :: V_in(:,:) ! Total input effective potential 299 | real(dp), intent(in) :: V_h(:,:) ! Hartree energy, solution of Poiss. eq. 300 | real(dp), intent(in) :: V_coulomb(:,:) ! Coulomb inter. -Z/r (negative) 301 | real(dp), intent(in) :: e_xc(:,:) ! XC density 302 | real(dp), intent(in) :: n(:,:) ! number density (positive) 303 | real(dp), intent(out) :: Etot ! Total energy 304 | real(dp), intent(out) :: T_s, E_ee, E_en, EE_xc ! Parts of the total energy 305 | 306 | real(dp) :: rho(size(n,1), size(n,2)) 307 | real(dp) :: E_c, E_band 308 | rho = -n 309 | 310 | E_band = sum(fo * ks_energies) 311 | T_s = E_band + 4*pi * integrate2(xe, xiq, xiq1, wtq, wtq1, alpha, V_in * rho * R**2) 312 | 313 | E_ee = -2*pi * integrate2(xe, xiq, xiq1, wtq, wtq1, alpha, V_h * rho * R**2) 314 | E_en = 4*pi * integrate2(xe, xiq, xiq1, wtq, wtq1, alpha, (-V_coulomb) * rho * R**2) 315 | E_c = E_ee + E_en 316 | 317 | EE_xc = -4*pi * integrate2(xe, xiq, xiq1, wtq, wtq1, alpha, e_xc * rho * R**2) 318 | 319 | Etot = T_s + E_c + EE_xc 320 | end subroutine 321 | 322 | end subroutine 323 | 324 | subroutine csolve_dirac(Z, p, xiq, wtq, xe, eps, Nq, Ne, nenergies, energies, & 325 | Etot, V) bind(c) 326 | integer(c_int), intent(in) :: Z, p, Nq, Ne, nenergies 327 | real(c_double), intent(in) :: xe(Ne) ! element coordinates 328 | real(c_double), intent(in) :: xiq(Nq) ! quadrature points 329 | real(c_double), intent(in) :: wtq(Nq) ! quadrature weights 330 | real(c_double), intent(in) :: eps 331 | real(c_double), intent(out) :: energies(nenergies) 332 | real(c_double), intent(out) :: Etot 333 | real(c_double), intent(out) :: V(size(xiq),size(xe)-1) ! SCF potential 334 | integer :: DOFs 335 | real(dp), allocatable :: energies2(:) 336 | 337 | call solve_dirac(Z, p, xiq, wtq, xe, eps, energies2, Etot, V, DOFs) 338 | energies = energies2 339 | end subroutine 340 | 341 | end module 342 | -------------------------------------------------------------------------------- /src/energies.f90: -------------------------------------------------------------------------------- 1 | module energies 2 | 3 | ! Calculates Hydrogen nonrelativistic and relativistic energies (exact), 4 | ! Thomas-Fermi (TF) energies (only very approximate), TF potential and charge 5 | ! density (very accurate). 6 | 7 | use types, only: dp 8 | use constants, only: pi 9 | implicit none 10 | private 11 | public E_nl, thomas_fermi_potential, get_tf_energies, get_hydrogen_energies, & 12 | thomas_fermi_density 13 | 14 | contains 15 | 16 | real(dp) function E_nl(c, n, l, Z, relat) 17 | ! Calculates exact energy for the radial Schroedinger/Dirac equations 18 | real(dp), intent(in) :: c ! speed of light in atomic units 19 | integer, intent(in) :: n, l, Z, relat 20 | ! quantum numbers (n, l), atomic number (z) 21 | ! relat == 0 ... Schroedinger equation 22 | ! relat == 2 ... Dirac equation, spin up 23 | ! relat == 3 ... Dirac equation, spin down 24 | 25 | integer :: kappa 26 | real(dp) :: beta 27 | if (.not. (l >= 0)) error stop "'l' must be positive or zero" 28 | if (.not. (n > l)) error stop "'n' must be greater than 'l'" 29 | if (l == 0 .and. relat == 3) error stop "Spin must be up for l==0." 30 | if (relat == 0) then 31 | E_nl = - Z**2 / (2.0_dp * n**2) 32 | else 33 | if (relat == 2) then 34 | kappa = -l - 1 35 | else 36 | kappa = l 37 | end if 38 | beta = sqrt(kappa**2 - (Z/c)**2) 39 | E_nl = c**2/sqrt(1 + (Z/c)**2/(n - abs(kappa) + beta)**2) - c**2 40 | end if 41 | end function 42 | 43 | function thomas_fermi_potential(R, Z, cut) result(V) 44 | ! Generalized Thomas-Fermi atomic potential 45 | real(dp), intent(in) :: R(:) ! Radial grid 46 | integer, intent(in) :: Z ! Atomic number 47 | logical, intent(in), optional :: cut ! Cut the potential, default .true. 48 | real(dp) :: x(size(R)), Z_eff(size(R)), V(size(R)) 49 | real(dp) :: alpha, beta, gamma 50 | 51 | x = R * (128*Z/(9*pi**2)) ** (1.0_dp/3) 52 | ! Z_eff(x) = Z * phi(x), where phi(x) satisfies the Thomas-Fermi equation: 53 | ! phi'' = phi**(3/2) / sqrt(x) 54 | ! with boundary conditions: 55 | ! phi(0) = 1 56 | ! phi(oo) = 0 57 | ! There is no analytic solution, but one can solve this approximately. We use: 58 | ! http://arxiv.org/abs/physics/0511017 59 | alpha = 0.7280642371_dp 60 | beta = -0.5430794693_dp 61 | gamma = 0.3612163121_dp 62 | Z_eff = Z * (1 + alpha*sqrt(x) + beta*x*exp(-gamma*sqrt(x)))**2 * & 63 | exp(-2*alpha*sqrt(x)) 64 | ! This keeps all the eigenvalues of the radial problem negative: 65 | if (.not. present(cut)) where (Z_eff < 1) Z_eff = 1 66 | V = -Z_eff / r 67 | end function 68 | 69 | function thomas_fermi_density(R, Z) result(rho) 70 | ! Generalized Thomas-Fermi atomic potential 71 | real(dp), intent(in) :: R(:) ! Radial grid 72 | integer, intent(in) :: Z ! Atomic number 73 | real(dp) :: V(size(R)), rho(size(R)) 74 | V = thomas_fermi_potential(R, Z, .false.) 75 | rho = -1 / (3*pi**2) * (-2*V)**(3._dp/2) 76 | end function 77 | 78 | function get_tf_energies(Z, no, fo) result(E) 79 | integer, intent(in) :: Z, no(:) 80 | real(dp), intent(in) :: fo(:) 81 | real(dp) :: E(size(no)) 82 | 83 | integer :: Zeff, i 84 | Zeff = Z + 1 85 | do i = 1, size(no) 86 | if (i > 1) then 87 | if (no(i) < no(i-1)) error stop "State order wrong" 88 | end if 89 | Zeff = Zeff - int(fo(i)) 90 | if (Zeff <= 0) error stop "Negative ions not allowed" 91 | E(i) = -(1.0_dp * Zeff / no(i))**2/2 92 | end do 93 | end function 94 | 95 | function get_hydrogen_energies(Z, no) result(E) 96 | integer, intent(in) :: Z, no(:) 97 | real(dp) :: E(size(no)) 98 | integer :: i 99 | do i = 1, size(no) 100 | E(i) = -1.0_dp * Z**2 / (2*no(i)**2) 101 | end do 102 | end function 103 | 104 | end module 105 | -------------------------------------------------------------------------------- /src/fe.f90: -------------------------------------------------------------------------------- 1 | module fe 2 | use types, only: dp 3 | use constants, only: pi 4 | use feutils, only: get_quad_pts, phih, dphih, phih_array, dphih_array 5 | implicit none 6 | private 7 | public assemble_radial_SH, & 8 | assemble_radial_dirac_SH, assemble_radial_S, assemble_radial_H, & 9 | assemble_radial_H_setup, assemble_radial_H_complete 10 | 11 | contains 12 | 13 | subroutine assemble_radial_SH(V, l, xin, xe, ib, xiq, wtq, alpha, S, H) 14 | real(dp), intent(in) :: V(:,:) ! V(:,e) potential at quadrature grid for 15 | ! element `e` 16 | integer, intent(in) :: l 17 | real(dp), intent(in) :: xin(:) ! parent basis nodes 18 | real(dp), intent(in) :: xe(:) ! element coordinates 19 | integer, intent(in) :: ib(:, :) ! basis connectivity: ib(i,j) = index of 20 | ! basis function associated with local basis function i of element j. 0 = no 21 | ! associated basis fn. 22 | real(dp), intent(in) :: xiq(:) ! quadrature points 23 | real(dp), intent(in) :: wtq(:) ! quadrature weights 24 | real(dp), intent(in) :: alpha 25 | real(dp), intent(out) :: S(:,:), H(:,:) 26 | integer Ne, Nb, p, e, i, j, al, be 27 | real(dp) xa, xb, jac 28 | real(dp), dimension(size(xiq), size(xin)) :: phihq, dphihq 29 | real(dp), dimension(size(xiq)) :: hq, x, Bi, Bj, Bip, Bjp, m 30 | 31 | Ne = size(xe)-1 32 | Nb = maxval(ib) 33 | p = size(xin)-1 34 | ! tabulate parent basis and derivatives at quadrature points 35 | do al = 1, p+1 36 | call phih_array(xin, al, xiq, phihq(:, al)) 37 | call dphih_array(xin, al, xiq, dphihq(:, al)) 38 | end do 39 | S = 0 40 | H = 0 41 | do e = 1, Ne 42 | xa = xe(e) 43 | xb = xe(e+1) 44 | jac = (xb-xa)/2 ! affine mapping 45 | x = (xiq+1)/2*(xb-xa)+xa 46 | m = x**(2*alpha) * jac*wtq 47 | do be = 1, p+1 48 | j = ib(be, e) 49 | if (j==0) cycle ! omit boundary basis fns for Dirichlet BCs 50 | do al = 1, p+1 51 | i = ib(al, e) 52 | if (i==0) cycle ! omit boundary basis fns for Dirichlet BCs 53 | if (j>i) cycle ! compute only lower triangles 54 | 55 | Bi = phihq(:,al) 56 | Bj = phihq(:,be) 57 | Bip = dphihq(:,al)/jac 58 | Bjp = dphihq(:,be)/jac 59 | 60 | hq = Bi * Bj 61 | S(i,j) = S(i,j) + sum(hq*m) 62 | hq = 0.5_dp * Bip*Bjp & 63 | + Bi * (l*(l+1) - alpha*(alpha-1))/(2*x**2) * Bj & 64 | + Bi * V(:,e) * Bj 65 | H(i,j) = H(i,j) + sum(hq*m) 66 | end do 67 | end do 68 | end do 69 | ! fill in upper triangles 70 | do j = 1, Nb 71 | do i = 1, j-1 72 | S(i,j) = S(j,i) 73 | H(i,j) = H(j,i) 74 | end do 75 | end do 76 | end subroutine 77 | 78 | subroutine assemble_radial_H_setup(Lmin, Lmax, xin, xe, ib, xiq, wtq, phihq, dphihq, H) 79 | integer, intent(in) :: Lmax, Lmin 80 | real(dp), intent(in) :: xin(:) ! parent basis nodes 81 | real(dp), intent(in) :: xe(:) ! element coordinates 82 | integer, intent(in) :: ib(:, :) ! basis connectivity: ib(i,j) = index of 83 | ! basis function associated with local basis function i of element j. 0 = no 84 | ! associated basis fn. 85 | real(dp), intent(in) :: xiq(:) ! quadrature points 86 | real(dp), intent(in) :: wtq(:) ! quadrature weights 87 | real(dp), intent(in) :: phihq(:,:) ! parent basis at quadrature points 88 | real(dp), intent(in) :: dphihq(:,:) ! parent basis derivative at quadrature points 89 | real(dp), intent(out) :: H(maxval(ib),maxval(ib),Lmin:Lmax) 90 | integer Ne, Nb, p, e, i, j, al, be, l 91 | real(dp) xa, xb, jac, h0 92 | real(dp), dimension(size(xiq)) :: x, Bi, Bj, Bip, Bjp, m, m2 93 | 94 | Ne = size(xe)-1 95 | Nb = maxval(ib) 96 | p = size(xin)-1 97 | H = 0 98 | do e = 1, Ne 99 | xa = xe(e) 100 | xb = xe(e+1) 101 | jac = (xb-xa)/2 ! affine mapping 102 | x = (xiq+1)/2*(xb-xa)+xa 103 | m = jac*wtq * 0.5_dp / x**2 104 | m2 = jac*wtq * 0.5_dp / jac**2 105 | do be = 1, p+1 106 | j = ib(be, e) 107 | if (j==0) cycle ! omit boundary basis fns for Dirichlet BCs 108 | do al = 1, p+1 109 | i = ib(al, e) 110 | if (i==0) cycle ! omit boundary basis fns for Dirichlet BCs 111 | if (j>i) cycle ! compute only lower triangles 112 | 113 | Bi = phihq(:,al) 114 | Bj = phihq(:,be) 115 | Bip = dphihq(:,al) 116 | Bjp = dphihq(:,be) 117 | 118 | h0 = sum(m2*Bip*Bjp) 119 | do l = Lmin, Lmax 120 | H(i, j, l) = H(i, j, l) + l*(l+1)*sum(Bi*Bj*m) + h0 121 | end do 122 | end do 123 | end do 124 | end do 125 | 126 | end subroutine 127 | 128 | subroutine assemble_radial_H_complete(V, xin, xe, ib, xiq, wtq, phihq, H0, H) 129 | real(dp), intent(in) :: V(:,:) ! V(:,e) potential at quadrature grid for 130 | ! element `e` 131 | real(dp), intent(in) :: xin(:) ! parent basis nodes 132 | real(dp), intent(in) :: xe(:) ! element coordinates 133 | integer, intent(in) :: ib(:, :) ! basis connectivity: ib(i,j) = index of 134 | ! basis function associated with local basis function i of element j. 0 = no 135 | ! associated basis fn. 136 | real(dp), intent(in) :: xiq(:) ! quadrature points 137 | real(dp), intent(in) :: wtq(:) ! quadrature weights 138 | real(dp), intent(in) :: phihq(:,:) ! parent basis at quadrature points 139 | real(dp), intent(in) :: H0(:,:) 140 | real(dp), intent(out) :: H(maxval(ib),maxval(ib)) 141 | integer Ne, Nb, p, e, i, j, al, be 142 | real(dp) xa, xb, jac 143 | real(dp), dimension(size(xiq)) :: Bi, Bj, m 144 | 145 | Ne = size(xe)-1 146 | Nb = maxval(ib) 147 | p = size(xin)-1 148 | H = 0 149 | do e = 1, Ne 150 | xa = xe(e) 151 | xb = xe(e+1) 152 | jac = (xb-xa)/2 ! affine mapping 153 | m = jac*wtq * V(:,e) 154 | do be = 1, p+1 155 | j = ib(be, e) 156 | if (j==0) cycle ! omit boundary basis fns for Dirichlet BCs 157 | do al = 1, p+1 158 | i = ib(al, e) 159 | if (i==0) cycle ! omit boundary basis fns for Dirichlet BCs 160 | if (j>i) cycle ! compute only lower triangles 161 | Bi = phihq(:,al) 162 | Bj = phihq(:,be) 163 | H(i,j) = H(i,j) + sum(Bi * Bj * m) 164 | end do 165 | end do 166 | end do 167 | 168 | do concurrent (i = 1:Nb, j = 1:Nb, i>=j) 169 | H(i, j) = H(i, j) + H0(i, j) 170 | end do 171 | 172 | end subroutine 173 | 174 | 175 | subroutine assemble_radial_H(V, l, xin, xe, ib, xiq, wtq, phihq, dphihq, H) 176 | real(dp), intent(in) :: V(:,:) ! V(:,e) potential at quadrature grid for 177 | ! element `e` 178 | integer, intent(in) :: l 179 | real(dp), intent(in) :: xin(:) ! parent basis nodes 180 | real(dp), intent(in) :: xe(:) ! element coordinates 181 | integer, intent(in) :: ib(:, :) ! basis connectivity: ib(i,j) = index of 182 | ! basis function associated with local basis function i of element j. 0 = no 183 | ! associated basis fn. 184 | real(dp), intent(in) :: xiq(:) ! quadrature points 185 | real(dp), intent(in) :: wtq(:) ! quadrature weights 186 | real(dp), intent(in) :: phihq(:,:) ! parent basis at quadrature points 187 | real(dp), intent(in) :: dphihq(:,:) ! parent basis derivative at quadrature points 188 | real(dp), intent(out) :: H(:,:) 189 | integer Ne, Nb, p, e, i, j, al, be 190 | real(dp) xa, xb, jac 191 | real(dp), dimension(size(xiq)) :: hq, x, Bi, Bj, Bip, Bjp, m 192 | 193 | Ne = size(xe)-1 194 | Nb = maxval(ib) 195 | p = size(xin)-1 196 | H = 0 197 | do e = 1, Ne 198 | xa = xe(e) 199 | xb = xe(e+1) 200 | jac = (xb-xa)/2 ! affine mapping 201 | x = (xiq+1)/2*(xb-xa)+xa 202 | m = jac*wtq 203 | do be = 1, p+1 204 | j = ib(be, e) 205 | if (j==0) cycle ! omit boundary basis fns for Dirichlet BCs 206 | do al = 1, p+1 207 | i = ib(al, e) 208 | if (i==0) cycle ! omit boundary basis fns for Dirichlet BCs 209 | if (j>i) cycle ! compute only lower triangles 210 | 211 | Bi = phihq(:,al) 212 | Bj = phihq(:,be) 213 | Bip = dphihq(:,al)/jac 214 | Bjp = dphihq(:,be)/jac 215 | hq = 0.5_dp * Bip*Bjp & 216 | + Bi * (l*(l+1))/(2*x**2) * Bj & 217 | + Bi * V(:,e) * Bj 218 | H(i,j) = H(i,j) + sum(hq*m) 219 | end do 220 | end do 221 | end do 222 | end subroutine 223 | 224 | subroutine assemble_radial_S(xin, xe, ib, wtq, S) 225 | real(dp), intent(in) :: xin(:) ! parent basis nodes 226 | real(dp), intent(in) :: xe(:) ! element coordinates 227 | integer, intent(in) :: ib(:, :) ! basis connectivity: ib(i,j) = index of 228 | ! basis function associated with local basis function i of element j. 0 = no 229 | ! associated basis fn. 230 | real(dp), intent(in) :: wtq(:) ! quadrature weights 231 | real(dp), intent(out) :: S(:) 232 | integer Ne, p, e, j, be 233 | real(dp) xa, xb, jac 234 | 235 | Ne = size(xe)-1 236 | p = size(xin)-1 237 | S = 0 238 | do e = 1, Ne 239 | xa = xe(e) 240 | xb = xe(e+1) 241 | jac = (xb-xa)/2 ! affine mapping 242 | do be = 1, p+1 243 | j = ib(be, e) 244 | if (j==0) cycle ! omit boundary basis fns for Dirichlet BCs 245 | S(j) = S(j) + jac*wtq(be) 246 | end do 247 | end do 248 | end subroutine 249 | 250 | subroutine assemble_radial_dirac_SH(V, kappa, xin, xe, ib, xiq, wtq, xiq1, wtq1, & 251 | alpha, alpha_j, c, S, H) 252 | real(dp), intent(in) :: V(:,:) ! V(:,e) potential at quadrature grid for 253 | ! element `e 254 | integer, intent(in) :: kappa 255 | real(dp), intent(in) :: xin(:) ! parent basis nodes 256 | real(dp), intent(in) :: xe(:) ! element coordinates 257 | integer, intent(in) :: ib(:, :) ! basis connectivity: ib(i,j) = index of 258 | ! basis function associated with local basis function i of element j. 0 = no 259 | ! associated basis fn. 260 | real(dp), intent(in) :: xiq(:) ! quadrature points 261 | real(dp), intent(in) :: wtq(:) ! quadrature weights 262 | real(dp), intent(in) :: xiq1(:) ! quadrature points first element 263 | real(dp), intent(in) :: wtq1(:) ! quadrature weights first element 264 | real(dp), intent(in) :: alpha ! alpha in r^(2*alpha) in Dirac equations 265 | real(dp), intent(in) :: alpha_j ! The alpha to use in Gauss-Jacobi quadrature 266 | ! On the first element. Set alpha_j = -2 to use 267 | ! Gauss-Legendre quadrature on the first element 268 | real(dp), intent(in) :: c ! Speed of light in atomic units 269 | real(dp), intent(out) :: S(:,:), H(:,:) 270 | integer Ne, Nb, p, e, i, j, al, be 271 | real(dp) xa, xb, jac 272 | real(dp), dimension(size(xiq), size(xin)) :: phihq, dphihq, phihq1, dphihq1 273 | real(dp), dimension(size(xiq)) :: hq, x, Bi, Bj, Bip, Bjp, Vq, m 274 | 275 | Ne = size(xe)-1 276 | Nb = maxval(ib) 277 | p = size(xin)-1 278 | ! tabulate parent basis and derivatives at quadrature points 279 | do al = 1, p+1 280 | call phih_array(xin, al, xiq, phihq(:, al)) 281 | call phih_array(xin, al, xiq1, phihq1(:, al)) 282 | call dphih_array(xin, al, xiq, dphihq(:, al)) 283 | call dphih_array(xin, al, xiq1, dphihq1(:, al)) 284 | end do 285 | 286 | S = 0 287 | H = 0 288 | do e = 1, Ne 289 | xa = xe(e) 290 | xb = xe(e+1) 291 | jac = (xb-xa)/2 ! affine mapping 292 | ! m contains the r^(2*alpha) term, either directly, or as part 293 | ! of the Gauss-Jacobi quadrature on the first element 294 | if (e == 1 .and. alpha_j > -1) then 295 | x = (xiq1+1)/2*(xb-xa)+xa 296 | m = x**(2*alpha-alpha_j) * jac**(alpha_j) * jac*wtq1 297 | else 298 | x = (xiq+1)/2*(xb-xa)+xa 299 | m = x**(2*alpha-alpha_j) * x**(alpha_j) * jac*wtq 300 | ! Note: The last line is equivalent to: 301 | !m = x**(2*alpha) * jac*wtq 302 | end if 303 | Vq = V(:, e) 304 | do be = 1, p+1 305 | j = ib(be, e) 306 | if (j==0) cycle ! omit boundary basis fns for Dirichlet BCs 307 | do al = 1, p+1 308 | i = ib(al, e) 309 | if (i==0) cycle ! omit boundary basis fns for Dirichlet BCs 310 | if (e == 1 .and. alpha_j > -1) then 311 | Bi = phihq1(:,al) 312 | Bj = phihq1(:,be) 313 | Bip = dphihq1(:,al)/jac 314 | Bjp = dphihq1(:,be)/jac 315 | else 316 | Bi = phihq(:,al) 317 | Bj = phihq(:,be) 318 | Bip = dphihq(:,al)/jac 319 | Bjp = dphihq(:,be)/jac 320 | end if 321 | ! The diagonal terms are given by the equations 322 | ! A11 323 | hq = c**2*Bip*Bjp + ((Vq + c**2)**2 + & 324 | c**2*(kappa*(kappa+1)-alpha*(alpha-1))/x**2)*Bi*Bj 325 | H(i,j) = H(i,j) + sum(m*hq) 326 | ! A22 327 | hq = c**2*Bip*Bjp + ((Vq - c**2)**2 + & 328 | c**2*(kappa*(kappa-1)-alpha*(alpha-1))/x**2)*Bi*Bj 329 | H(i+Nb,j+Nb) = H(i+Nb,j+Nb) + sum(m*hq) 330 | 331 | 332 | !hq = -c*2*Vq*Bi*Bjp + c*(2*(kappa-alpha)/x*Vq)*Bi*Bj & 333 | ! - c*Vqp*Bi*Bj 334 | ! We expand the last term using: 335 | 336 | ! V' * Bi * Bj * r^(2*alpha) 337 | ! = - V * (Bi * Bj * r^(2*alpha))' 338 | ! = - V * (Bi' * Bj * r^(2*alpha) + Bi * Bj' * r^(2*alpha) 339 | ! + Bi * Bj * 2*alpha*r^(2*alpha-1)) 340 | ! = - V * (Bi'*Bj + Bi*Bj' + Bi*Bj * 2*alpha/r) * r^(2*alpha) 341 | 342 | ! to get: 343 | ! + c*Vq*(Bip*Bj + Bi*Bjp + Bi*Bj*2*alpha/x) 344 | ! and add things together: 345 | !hq = -c*Vq*Bi*Bjp + c*(2*(kappa-alpha)/x*Vq)*Bi*Bj & 346 | ! + c*Vq*Bip*Bj + c*Vq*Bi*Bj*2*alpha/x 347 | ! The alpha terms cancel: 348 | !hq = -c*Vq*Bi*Bjp + c*(2*kappa/x*Vq)*Bi*Bj & 349 | ! + c*Vq*Bip*Bj 350 | ! We get c*Vq out: 351 | !hq = c*Vq(-Bi*Bjp + (2*kappa/x)*Bi*Bj + Bip*Bj) 352 | 353 | ! If you exchange i <-> j, the A12 term becomes A21, i.e.: 354 | ! A^{12}_{ij} = A^{21}_{ji} 355 | ! A12 356 | hq = c*Vq*(-Bi*Bjp + 2*kappa/x*Bi*Bj + Bip*Bj) 357 | H(i,j+Nb) = H(i,j+Nb) + sum(m*hq) 358 | ! A21 359 | hq = c*Vq*( Bi*Bjp + 2*kappa/x*Bi*Bj - Bip*Bj) 360 | H(i+Nb,j) = H(i+Nb,j) + sum(m*hq) 361 | 362 | ! B11 363 | hq = Bi*Bj 364 | S(i,j) = S(i,j) + sum(m*hq) 365 | ! B22 366 | S(i+Nb,j+Nb) = S(i,j) 367 | end do 368 | end do 369 | end do 370 | 371 | !print *, "Checking symmetry" 372 | do j = 1, 2*Nb 373 | do i = 1, j-1 374 | if (abs(H(i,j) - H(j,i)) > 1e-8_dp) then 375 | if (abs(H(i,j)-H(j,i)) / max(abs(H(i,j)), abs(H(j,i))) & 376 | > 1e-8_dp) then 377 | print *, i, j, H(i,j)-H(j,i), H(i,j), H(j,i) 378 | error stop "H not symmetric" 379 | end if 380 | end if 381 | if (abs(S(i,j)-S(j,i)) > 1e-12_dp) error stop "S not symmetric" 382 | end do 383 | end do 384 | end subroutine 385 | 386 | 387 | end module 388 | -------------------------------------------------------------------------------- /src/feutils.f90: -------------------------------------------------------------------------------- 1 | module feutils 2 | ! Various Finite Element (FE) utilities 3 | ! Based on code written by John E. Pask, LLNL. 4 | use types 5 | use quadrature, only: gauss_pts, gauss_wts, lobatto_wts, lobatto_pts 6 | use solvers, only: solve_sym 7 | implicit none 8 | private 9 | public get_nodes, define_connect, get_quad_pts, define_connect_n, & 10 | define_connect_np, get_parent_quad_pts_wts, & 11 | fe2quad, fe2quad_core, c2fullc, c2fullc2, fe_evaluate, calc_proj_error, & 12 | get_parent_nodes, phih, dphih, dphih_array, phih_array, ddphih, & 13 | quad_gauss, quad_lobatto, integrate, proj_fn, integrate2, fe2quad_gj 14 | 15 | integer, parameter :: quad_gauss = 1, quad_lobatto = 2 16 | 17 | contains 18 | 19 | subroutine get_parent_quad_pts_wts(qtype, Nq, xiq, wtq) 20 | ! Quadrature points and weights 21 | integer, intent(in) :: qtype ! type of quadrature: 1= Gauss, 2= Lobatto 22 | integer, intent(in) :: Nq ! number or quadrature points/weights 23 | real(dp), intent(out) :: xiq(:) ! quadrature points 24 | real(dp), intent(out) :: wtq(:) ! quadrature weights 25 | select case(qtype) 26 | case(1) ! Gauss 27 | xiq = gauss_pts(Nq) 28 | wtq = gauss_wts(Nq) 29 | case(2) ! Lobatto 30 | xiq = lobatto_pts(Nq) 31 | wtq = lobatto_wts(Nq) 32 | case default 33 | error stop "Invalid quadrature type." 34 | end select 35 | end subroutine 36 | 37 | subroutine get_nodes(xe,xin,xn) 38 | ! generates basis nodes xn via affine mapping of parent nodes xin to elements xe 39 | real(dp), intent(in) :: xe(:) ! elements: xe(i/i+1) = coord of left/right boundary of ith element 40 | real(dp), intent(in) :: xin(:) ! parent basis nodes: xin(i) = coord of ith parent basis fn node 41 | real(dp), intent(out) :: xn(:) ! basis nodes: xn(i) = coordinate of ith basis fn node 42 | real(dp) :: xa,xb ! left and right element boundaries 43 | integer Ne,p,i,j 44 | Ne=size(xe)-1 45 | p=size(xin)-1 46 | xn(1)=xe(1) ! left-most node 47 | do i=1,Ne ! for each element ... 48 | xa=xe(i); xb=xe(i+1) 49 | xn(i*p+1)=xb ! right-end node 50 | do j=2,p 51 | xn((i-1)*p+j)=(xin(j)+1)/2*(xb-xa)+xa ! internal nodes: affine mapping 52 | end do 53 | end do 54 | end subroutine 55 | 56 | !-------------------------------------------------------------------------------------------------! 57 | 58 | subroutine define_connect(bca,bcb,Ne,p,in,ib) 59 | ! constructs connectivity matrices in and ib defining local-global node and basis 60 | ! correspondence, respectively 61 | integer, intent(in):: bca ! boundary condition at x=a: 1=Dirichlet, 2=Neumann, 62 | ! 3=periodic, 4=antiperiodic. If bca=3 or 4, bcb must be set correspondingly 63 | integer, intent(in):: bcb ! boundary condition at x=b: 1=Dirichlet, 2=Neumann, 64 | ! 3=periodic, 4=antiperiodic. If bcb = 3 or 4, bca must be set correspondingly 65 | integer, intent(in):: Ne ! number of elements 66 | integer, intent(in):: p ! order of FE/SE basis 67 | integer, intent(out):: in(:,:) ! nodal connectivity: in(i,j) = index of basis node 68 | ! corresponding to local node i of element j 69 | integer, intent(out):: ib(:,:) ! basis connectivity: ib(i,j) = index of basis function 70 | ! associated with local basis function i of element j. 0 = no associated basis fn. 71 | ! -1 = associated with antiperiodic basis fn, with negative multiplier 72 | integer i,e 73 | ! check boundary condition consistency 74 | if ((bca>2 .or. bcb>2) .and. bcb/=bca) then 75 | write(*,'(1x,a,i0,a,i0)') "Error: bca = ", bca, " /= bcb = ", bcb 76 | error stop "stop" 77 | end if 78 | ! construct nodal connectivity matrix 79 | do e=1,Ne 80 | do i=1,p+1 81 | in(i,e)=(e-1)*p+i 82 | end do 83 | end do 84 | ! construct basis connectivity matrix 85 | ! construct for natural BCs 86 | ib=in 87 | ! modify for other BCs 88 | if (bca==1) ib=ib-1 ! Dirichlet at x=a -> omit basis fn at node 1 89 | select case(bcb) ! x=b.... 90 | case(1); ib(p+1,Ne)=0 ! Dirichlet 91 | case(3); ib(p+1,Ne)=1 ! periodic 92 | case(4); ib(p+1,Ne)=-1 ! antiperiodic 93 | end select 94 | end subroutine 95 | 96 | subroutine define_connect_n(bca, bcb, Ne, p, Nm, in, ib) 97 | ! constructs connectivity matrices in and ib defining local-global node and 98 | ! basis correspondence, respectively. Works for arbitrary number of meshes 99 | integer, intent(in):: bca(:) ! bca(m) boundary condition at x=a for mesh 100 | ! m: 1=Dirichlet, 2=Neumann 101 | integer, intent(in):: bcb(:) ! bca(m) boundary condition at x=b for mesh 102 | ! m: 1=Dirichlet, 2=Neumann 103 | integer, intent(in):: Ne ! number of elements 104 | integer, intent(in):: p ! order of FE/SE basis 105 | integer, intent(in):: Nm ! number of meshes 106 | integer, intent(out):: in(:,:,:) ! nodal connectivity: in(i,j,k) = index of 107 | ! basis node corresponding to local node i of element j of mesh k 108 | integer, intent(out):: ib(:,:,:) ! basis connectivity: ib(i,j,k) = index of 109 | ! basis function associated with local basis function i of element j of 110 | ! mesh k. 0 = no associated basis fn 111 | integer :: i, e, m, dofs 112 | ! construct nodal connectivity matrix 113 | dofs = 0 114 | do m = 1, Nm 115 | do e = 1, Ne 116 | do i = 1, p+1 117 | dofs = dofs + 1 118 | in(i, e, m) = dofs 119 | end do 120 | dofs = dofs - 1 ! connect the shape functions across the element 121 | end do 122 | dofs = dofs + 1 ! don't connect the shape functions across meshes 123 | end do 124 | ! construct basis connectivity matrix 125 | dofs = 0 126 | do m = 1, Nm 127 | do e = 1, Ne 128 | do i = 1, p+1 129 | if (i == 1 .and. e == 1 .and. bca(m) == 1) then 130 | ib(i, e, m) = 0 ! Dirichlet 131 | cycle 132 | end if 133 | if (i == p+1 .and. e == Ne .and. bcb(m) == 1) then 134 | ib(i, e, m) = 0 ! Dirichlet 135 | cycle 136 | end if 137 | dofs = dofs + 1 138 | ib(i, e, m) = dofs 139 | end do 140 | dofs = dofs - 1 ! connect the shape functions across the element 141 | end do 142 | dofs = dofs + 1 ! don't connect the shape functions across meshes 143 | end do 144 | end subroutine 145 | 146 | subroutine define_connect_np(bca, bcb, Ne, p, Nm, in, ib) 147 | ! constructs connectivity matrices in and ib defining local-global node and 148 | ! basis correspondence, respectively. Works for arbitrary number of meshes 149 | integer, intent(in):: bca(:) ! bca(m) boundary condition at x=a for mesh 150 | ! m: 1=Dirichlet, 2=Neumann 151 | integer, intent(in):: bcb(:) ! bca(m) boundary condition at x=b for mesh 152 | ! m: 1=Dirichlet, 2=Neumann 153 | integer, intent(in):: Ne ! number of elements 154 | integer, intent(in):: p(:) ! order of FE/SE basis 155 | integer, intent(in):: Nm ! number of meshes 156 | integer, intent(out):: in(:,:,:) ! nodal connectivity: in(i,j,k) = index of 157 | ! basis node corresponding to local node i of element j of mesh k 158 | integer, intent(out):: ib(:,:,:) ! basis connectivity: ib(i,j,k) = index of 159 | ! basis function associated with local basis function i of element j of 160 | ! mesh k. 0 = no associated basis fn 161 | integer :: i, e, m, dofs 162 | ! Initialize the arrays to -1 163 | in = -1 164 | ib = -1 165 | ! construct nodal connectivity matrix 166 | dofs = 0 167 | do m = 1, Nm 168 | do e = 1, Ne 169 | do i = 1, p(m)+1 170 | dofs = dofs + 1 171 | in(i, e, m) = dofs 172 | end do 173 | dofs = dofs - 1 ! connect the shape functions across the element 174 | end do 175 | dofs = dofs + 1 ! don't connect the shape functions across meshes 176 | end do 177 | ! construct basis connectivity matrix 178 | dofs = 0 179 | do m = 1, Nm 180 | do e = 1, Ne 181 | do i = 1, p(m)+1 182 | if (i == 1 .and. e == 1 .and. bca(m) == 1) then 183 | ib(i, e, m) = 0 ! Dirichlet 184 | cycle 185 | end if 186 | if (i == p(m)+1 .and. e == Ne .and. bcb(m) == 1) then 187 | ib(i, e, m) = 0 ! Dirichlet 188 | cycle 189 | end if 190 | dofs = dofs + 1 191 | ib(i, e, m) = dofs 192 | end do 193 | dofs = dofs - 1 ! connect the shape functions across the element 194 | end do 195 | dofs = dofs + 1 ! don't connect the shape functions across meshes 196 | end do 197 | end subroutine 198 | 199 | subroutine get_quad_pts(xe,xiq,xq) 200 | ! generates quadrature points xq via affine mapping of parent quad points xiq to elements xe 201 | real(dp), intent(in):: xe(:) ! elements: xe(i/i+1) = coord of left/right boundary of ith element 202 | real(dp), intent(in):: xiq(:) ! parent quad pts 203 | real(dp), intent(out):: xq(:,:) ! quad pts: xq(i,j) = coordinate of ith point in jth element 204 | real(dp) xa,xb ! left and right element boundaries 205 | integer ie 206 | do ie=1,size(xe)-1 207 | xa=xe(ie); xb=xe(ie+1) 208 | xq(:,ie)=(xb-xa)/2*xiq+(xb+xa)/2 ! affine transformation 209 | end do 210 | end subroutine 211 | 212 | subroutine fe2quad(xe, xin, xiq, in, fullu, uq) 213 | ! transforms fullu from FE-coefficient to quadrature-grid representation. 214 | ! fullu is a full FE coefficient vector, having values for all nodes in the mesh, 215 | ! including domain-boundary nodes. 216 | real(dp), intent(in) :: xe(:) ! elements: xe(i/i+1) = coord of left/right boundary of ith element 217 | real(dp), intent(in) :: xin(:) ! parent basis nodes: xin(i) = coordinate of ith parent basis node 218 | real(dp), intent(in) :: xiq(:) ! quadrature points 219 | integer, intent(in) :: in(:,:) ! nodal connectivity: in(i,j) = index of basis node 220 | ! corresponding to local node i of element j 221 | real(dp), intent(in) :: fullu(:) ! FE coefficient representation of fullu: full vector, including 222 | ! values for domain-boundary nodes / basis functions 223 | real(dp), intent(out) :: uq(:,:) ! quadrature-grid representation of fullu 224 | ! uq(i,j) = value at ith quadrature point of jth element 225 | real(dp) :: phihq(size(xiq), size(xin)) ! parent basis fn values at quadrature points: 226 | ! phihq(i,j) = value of jth function at ith quadrature point 227 | integer :: iln, iq ! local node, quad point indices 228 | 229 | ! tabulate parent basis at quadrature points 230 | do iln = 1, size(xin) 231 | do iq = 1, size(xiq) 232 | phihq(iq, iln) = phih(xin, iln, xiq(iq)) 233 | end do 234 | end do 235 | ! call the core method after calculating phihq 236 | call fe2quad_core(xe, xin, in, fullu, phihq, uq) 237 | end subroutine 238 | 239 | subroutine fe2quad_core(xe, xin, in, fullu, phihq, uq) 240 | ! transforms fullu from FE-coefficient to quadrature-grid representation. 241 | ! fullu is a full FE coefficient vector, having values for all nodes in the mesh, 242 | ! including domain-boundary nodes. 243 | real(dp), intent(in) :: xe(:) ! elements: xe(i/i+1) = coord of left/right boundary of ith element 244 | real(dp), intent(in) :: xin(:) ! parent basis nodes: xin(i) = coordinate of ith parent basis node 245 | integer, intent(in) :: in(:,:) ! nodal connectivity: in(i,j) = index of basis node 246 | ! corresponding to local node i of element j 247 | real(dp), intent(in) :: fullu(:) ! FE coefficient representatin of fullu: full vector, including 248 | ! values for domain-boundary nodes / basis functions 249 | real(dp), intent(in) :: phihq(:, :) ! parent basis at quadrature points 250 | real(dp), intent(out) :: uq(:,:) ! quadrature-grid representatin of fullu 251 | ! uq(i,j) = value at ith quadrature point of jth element 252 | integer :: ie, iln ! element, local node 253 | 254 | ! evaluate at quad points in each element 255 | do ie = 1, size(xe)-1 256 | uq(:, ie) = 0 257 | do iln = 1, size(xin) 258 | uq(:, ie) = uq(:, ie) + fullu(in(iln, ie)) * phihq(:, iln) 259 | end do 260 | end do 261 | end subroutine 262 | 263 | 264 | subroutine fe2quad_gj(xe, xin, xiq, xiq1, in, fullu, uq) 265 | ! transforms fullu from FE-coefficient to quadrature-grid representation. 266 | ! fullu is a full FE coefficient vector, having values for all nodes in the mesh, 267 | ! including domain-boundary nodes. 268 | real(dp), intent(in) :: xe(:) ! elements: xe(i/i+1) = coord of left/right boundary of ith element 269 | real(dp), intent(in) :: xin(:) ! parent basis nodes: xin(i) = coordinate of ith parent basis node 270 | real(dp), intent(in) :: xiq(:) ! quadrature points 271 | real(dp), intent(in) :: xiq1(:) ! quadrature points for first element 272 | integer, intent(in) :: in(:,:) ! nodal connectivity: in(i,j) = index of basis node 273 | ! corresponding to local node i of element j 274 | real(dp), intent(in) :: fullu(:) ! FE coefficient representatin of fullu: full vector, including 275 | ! values for domain-boundary nodes / basis functions 276 | real(dp), intent(out) :: uq(:,:) ! quadrature-grid representatin of fullu 277 | ! uq(i,j) = value at ith quadrature point of jth element 278 | real(dp) :: phihq(size(xiq), size(xin)) ! parent basis fn values at quadrature points: 279 | ! phihq(i,j) = value of jth function at ith quadrature point 280 | real(dp) :: phihq1(size(xiq), size(xin)) ! parent basis fn values at quadrature points: 281 | ! phihq(i,j) = value of jth function at ith quadrature point 282 | integer :: ie, iln, iq ! element, local node, quad point indices 283 | 284 | ! tabulate parent basis at quadrature points 285 | do iln = 1, size(xin) 286 | do iq = 1, size(xiq) 287 | phihq(iq, iln) = phih(xin, iln, xiq(iq)) 288 | phihq1(iq, iln) = phih(xin, iln, xiq1(iq)) 289 | end do 290 | end do 291 | ! evaluate at quad points in each element 292 | do ie = 1, size(xe)-1 293 | uq(:, ie) = 0 294 | do iln = 1, size(xin) 295 | if (ie == 1) then 296 | uq(:, ie) = uq(:, ie) + fullu(in(iln, ie)) * phihq1(:, iln) 297 | else 298 | uq(:, ie) = uq(:, ie) + fullu(in(iln, ie)) * phihq(:, iln) 299 | end if 300 | end do 301 | end do 302 | end subroutine 303 | 304 | subroutine c2fullc(in, ib, c, fullc) 305 | ! Converts FE coefficient vector to full coefficient vector 306 | integer, intent(in) :: in(:,:,:) ! nodal connectivity: in(i,j) = index of basis 307 | ! node 308 | ! corresponding to local node i of element j 309 | integer, intent(in) :: ib(:,:,:) ! basis connectivity: ib(i,j) = index of basis 310 | ! function associated with local basis function i of element j. 0 = no 311 | ! associated basis fn. 312 | real(dp), intent(in) :: c(:) ! coefficient vector with regards to ib 313 | real(dp), intent(out) :: fullc(:) ! full coefficients vector with regards to in 314 | integer :: m, e, i 315 | do m = 1, size(in, 3) 316 | do e = 1, size(in, 2) 317 | do i = 1, size(in, 1) 318 | if (in(i, e, m) == -1) cycle 319 | if (ib(i, e, m) == 0) then 320 | fullc(in(i, e, m)) = 0 ! Dirichlet 321 | else 322 | fullc(in(i, e, m)) = c(ib(i, e, m)) 323 | end if 324 | end do 325 | end do 326 | end do 327 | end subroutine 328 | 329 | subroutine c2fullc2(in, ib, c, fullc) 330 | ! Converts FE coefficient vector to full coefficient vector 331 | ! It puts 0 for Dirichlet boundary conditions (ib==0), otherwise it just copies 332 | ! the coefficients. 333 | integer, intent(in) :: in(:,:) ! nodal connectivity: in(i,j) = index of basis 334 | ! node 335 | ! corresponding to local node i of element j 336 | integer, intent(in) :: ib(:,:) ! basis connectivity: ib(i,j) = index of basis 337 | ! function associated with local basis function i of element j. 0 = no 338 | ! associated basis fn. 339 | real(dp), intent(in) :: c(:) ! coefficient vector with regards to ib 340 | real(dp), intent(out) :: fullc(:) ! full coefficients vector with regards to in 341 | integer :: e, i 342 | do e = 1, size(in, 2) 343 | do i = 1, size(in, 1) 344 | if (ib(i, e) == 0) then 345 | fullc(in(i, e)) = 0 ! Dirichlet 346 | else 347 | fullc(in(i, e)) = c(ib(i, e)) 348 | end if 349 | end do 350 | end do 351 | end subroutine 352 | 353 | subroutine fe_evaluate(xe, xin, xn, in, fullu, xout, yout) 354 | ! Evaluates the FE solution (fullu) on a grid. 355 | ! fullu is a full FE coefficient vector, having values for all nodes in the mesh, 356 | ! including domain-boundary nodes. 357 | real(dp), intent(in):: xe(:) ! elements: xe(i/i+1) = coord of left/right boundary of ith element 358 | real(dp), intent(in):: xin(:) ! parent basis nodes: xin(i) = coordinate of ith parent basis node 359 | real(dp), intent(in):: xn(:) ! basis nodes: xn(i) = coordinate of ith basis node 360 | integer, intent(in):: in(:,:) ! nodal connectivity: in(i,j) = index of basis node 361 | ! corresponding to local node i of element j 362 | real(dp), intent(in):: fullu(:, :) ! FE coefficient representatin of fullu: full vector, including 363 | ! values for domain-boundary nodes / basis functions 364 | real(dp), intent(in):: xout(:) ! grid points to evaluate the solution at 365 | real(dp), intent(out):: yout(:, :) ! values of the solution at 'xout' 366 | real(dp) :: phihx(size(xin)) ! parent basis fn values at a point 367 | integer :: p, n, e, i, j 368 | real(dp) :: x, xa, xb, xi 369 | 370 | p = size(xin) - 1 371 | e = 1 372 | do i = 1, size(xout) 373 | ! get x and element containing x 374 | x = xout(i) 375 | call getElement(xn, p, x, e) 376 | ! get parent coordinates xi 377 | xa = xe(e) 378 | xb = xe(e+1) 379 | xi = (x-xa)/(xb-xa)*2-1 380 | ! get parent basis values at xi 381 | do n= 1, p+1 382 | phihx(n) = phih(xin, n, xi) 383 | end do 384 | ! get eigenfunction value at x 385 | do j = 1, size(fullu, 2) 386 | yout(i, j) = sum(fullu(in(:,e), j) * phihx) 387 | end do 388 | end do 389 | end subroutine 390 | 391 | subroutine getElement(xn,p,x,e) 392 | ! returns element containing point x, at or after element e 393 | real(dp), intent(in):: xn(:) ! basis nodes: xn(i) = coordinate of ith basis node 394 | integer, intent(in):: p ! order of FE/SE basis 395 | real(dp), intent(in):: x ! point x 396 | integer, intent(inout):: e ! input: index of element to start search 397 | ! output: index of element containing x, at or after element e 398 | integer Ne ! number of elements 399 | Ne=(size(xn)-1)/p 400 | if (e<1 .or. e>Ne) e=1 401 | do 402 | if (x>=xn((e-1)*p+1) .and. x<=xn(e*p+1)) exit 403 | e=e+1 404 | if (e>Ne) error stop "getElement error: x not in mesh." 405 | end do 406 | end subroutine 407 | 408 | subroutine proj_fn(p, xe, xiq, wtq, xiq2, uq, uq2) 409 | ! L2 projects a function `uq` defined on a quadrature onto the FE basis. 410 | ! Then it evaluates the values of the result on a new quadrature grid xiq2. 411 | integer, intent(in) :: p 412 | real(dp), intent(in) :: xe(:) ! elements: xe(i/i+1) = coord of left/right boundary of ith element 413 | real(dp), intent(in) :: xiq(:), wtq(:) ! quadrature points and weights 414 | real(dp), intent(in) :: xiq2(:) 415 | real(dp), intent(in) :: uq(:,:) ! FE coefficient representatin of fullu: full vector, including 416 | real(dp), intent(out) :: uq2(:,:) 417 | real(dp) phihq(size(xiq),p+1) ! parent basis fn values at quadrature points: 418 | ! phihq(i,j) = value of jth function at ith quadrature point 419 | integer :: ie,iln,iq ! element, local node, quad point indices 420 | integer :: i, j, Ne, dofs 421 | real(dp) :: xin(p+1), al, be, jac, xa, xb 422 | real(dp), allocatable :: A(:, :), f(:), x(:) 423 | integer, allocatable :: in(:, :), ib(:, :) 424 | 425 | if (.not. p >= 1) error stop "p >= 1 required" 426 | 427 | ! define parent basis 428 | call get_parent_nodes(2, p, xin) 429 | 430 | Ne = size(xe) - 1 431 | 432 | allocate(in(p+1,Ne),ib(p+1,Ne)) 433 | call define_connect(2, 2, Ne, p, in, ib) 434 | 435 | ! tabulate parent basis at quadrature points 436 | do iln = 1, p+1 437 | do iq = 1, size(xiq) 438 | phihq(iq,iln) = phih(xin,iln,xiq(iq)) 439 | end do 440 | end do 441 | 442 | dofs = maxval(in) 443 | allocate(A(dofs, dofs), f(dofs), x(dofs)) 444 | 445 | A = 0 446 | f = 0 447 | do ie = 1, Ne ! sum over elements 448 | xa=xe(ie); xb=xe(ie+1) 449 | al=(xb-xa)/2; be=(xb+xa)/2 450 | jac=al 451 | do i = 1, p+1 452 | do j = 1, p+1 453 | A(in(i,ie), in(j,ie)) = A(in(i,ie), in(j,ie)) + & 454 | sum(wtq*phihq(:, i)*phihq(:, j)*jac) 455 | end do 456 | f(in(i,ie)) = f(in(i,ie)) + sum(wtq*phihq(:, i)*uq(:, ie)*jac) 457 | end do 458 | end do 459 | ! Solve A x = f 460 | x = solve_sym(A, f) 461 | call fe2quad(xe,xin,xiq2,in,x,uq2) 462 | end subroutine 463 | 464 | function calc_proj_error(p, xe, xiq, wtq, uq) result(error) 465 | ! Calculates the L2 error of the projected solution on the mesh "p" 466 | integer, intent(in) :: p 467 | real(dp), intent(in):: xe(:) ! elements: xe(i/i+1) = coord of left/right boundary of ith element 468 | real(dp), intent(in):: xiq(:), wtq(:) ! quadrature points and weights 469 | real(dp), intent(in):: uq(:,:) ! FE coefficient representatin of fullu: full vector, including 470 | real(dp) :: error(size(xe)-1) ! errors for each element 471 | ! values for domain-boundary nodes / basis functions 472 | real(dp) phihq(size(xiq),p+1) ! parent basis fn values at quadrature points: 473 | ! phihq(i,j) = value of jth function at ith quadrature point 474 | integer :: ie,iln,iq ! element, local node, quad point indices 475 | integer :: i, j, Ne, dofs 476 | real(dp) :: xin(p+1), al, be, jac, xa, xb, norm 477 | real(dp), allocatable :: A(:, :), f(:), x(:), xn(:) 478 | integer, allocatable :: in(:, :), ib(:, :) 479 | real(dp) :: projq(size(uq, 1), size(uq, 2)) 480 | 481 | if (.not. p >= 1) error stop "p >= 1 required" 482 | 483 | ! define parent basis 484 | call get_parent_nodes(2, p, xin) 485 | 486 | Ne = size(xe) - 1 487 | 488 | ! define basis 489 | allocate(xn(Ne*p+1)) 490 | call get_nodes(xe, xin, xn) 491 | 492 | allocate(in(p+1,Ne),ib(p+1,Ne)) 493 | call define_connect(2, 2, Ne, p, in, ib) 494 | 495 | ! tabulate parent basis at quadrature points 496 | do iln = 1, p+1 497 | do iq = 1, size(xiq) 498 | phihq(iq,iln) = phih(xin,iln,xiq(iq)) 499 | end do 500 | end do 501 | 502 | dofs = maxval(in) 503 | !print *, "DOFS=", dofs 504 | allocate(A(dofs, dofs), f(dofs), x(dofs)) 505 | 506 | A = 0 507 | f = 0 508 | do ie = 1, Ne ! sum over elements 509 | xa=xe(ie); xb=xe(ie+1) 510 | al=(xb-xa)/2; be=(xb+xa)/2 511 | jac=al 512 | do i = 1, p+1 513 | do j = 1, p+1 514 | A(in(i,ie), in(j,ie)) = A(in(i,ie), in(j,ie)) + & 515 | sum(wtq*phihq(:, i)*phihq(:, j)*jac) 516 | end do 517 | f(in(i,ie)) = f(in(i,ie)) + sum(wtq*phihq(:, i)*uq(:, ie)*jac) 518 | end do 519 | end do 520 | ! Solve A x = f 521 | x = solve_sym(A, f) 522 | call fe2quad(xe,xin,xiq,in,x,projq) 523 | norm = 0 524 | do ie = 1, Ne ! sum over elements 525 | xa=xe(ie); xb=xe(ie+1) 526 | al=(xb-xa)/2; be=(xb+xa)/2 527 | jac=al 528 | !print *, "el =", ie, sqrt(sum(wtq * abs(uq(:, ie)-projq(:, ie))**2 * jac)) 529 | error(ie) = sum(wtq * abs(uq(:, ie)-projq(:, ie))**2 * jac) 530 | norm = norm + sum(wtq * abs(uq(:, ie))**2 * jac) 531 | end do 532 | norm = sqrt(norm) 533 | error = sqrt(error)/norm 534 | !open(newunit=ff, file="proj.dat", status="replace") 535 | !write(ff, *) xn 536 | !write(ff, *) x 537 | !close(ff) 538 | end function 539 | 540 | subroutine get_parent_nodes(btype, p, xin) 541 | integer, intent(in):: btype ! type of basis: 1=uniform node, 2=Lobatto node 542 | integer, intent(in):: p ! order of FE/SE basis 543 | ! parent basis nodes: xin(i) = coordinate of ith parent basis node: 544 | real(dp), intent(out):: xin(:) 545 | integer i 546 | if (p < 1) error stop "Error: p < 1." 547 | if (size(xin) /= p+1) error stop "Error: size(xin) /= p+1" 548 | select case (btype) 549 | case(1) ! uniform 550 | do i = 1, p+1 551 | xin(i) = real(i-1, dp)/p*2-1 552 | end do 553 | case(2) ! Lobatto 554 | xin=lobatto_pts(p+1) 555 | case default 556 | error stop "Error: invalid basis type." 557 | end select 558 | end subroutine 559 | 560 | real(dp) pure function phih(xin, n, xi) 561 | ! "phi hat": nth Lagrange polynomial with nodes xin at point xi. 562 | ! Value equals to 1 for xi=xin(n) and zero for all other nodes. 563 | real(dp), intent(in) :: xin(:) ! polynomial nodes 564 | integer, intent(in) :: n ! polynomial index 565 | real(dp), intent(in) :: xi ! point at which to evaluate phih 566 | integer :: i 567 | ! compute nth polynomial: 1 at node n, 0 at all others 568 | phih = 1 569 | do i = 1, size(xin) 570 | if (i == n) cycle 571 | phih = phih * (xi-xin(i))/(xin(n)-xin(i)) 572 | end do 573 | end function 574 | 575 | real(dp) pure function dphih(xin, n, xi) 576 | ! "d phi hat": derivative of nth Lagrange polynomial with nodes 'xin' at point 577 | ! 'xi'. 578 | real(dp), intent(in) :: xin(:) ! polynomial nodes 579 | integer, intent(in) :: n ! polynomial index 580 | real(dp), intent(in) :: xi ! point at which to evaluate dphih 581 | real(dp) :: term 582 | real(dp) :: tmp(size(xin)) 583 | integer :: i, j 584 | do i = 1, size(xin) 585 | if (i==n) cycle 586 | tmp(i) = (xi-xin(i))/(xin(n)-xin(i)) 587 | end do 588 | ! compute derivative of nth polynomial 589 | dphih = 0 590 | do j = 1, size(xin) 591 | if (j == n) cycle 592 | term = 1 / (xin(n)-xin(j)) 593 | do i = 1, size(xin) 594 | if (i==n .or. i==j) cycle 595 | term = term * tmp(i) 596 | end do 597 | dphih = dphih + term 598 | end do 599 | end function 600 | 601 | subroutine phih_array(xin, n, xi, xo) 602 | ! "phi hat": nth Lagrange polynomial with nodes xin at point xi. 603 | ! Value equals to 1 for xi=xin(n) and zero for all other nodes. 604 | real(dp), intent(in) :: xin(:) ! polynomial nodes 605 | integer, intent(in) :: n ! polynomial index 606 | real(dp), intent(in) :: xi(:) ! point at which to evaluate phih 607 | real(dp), intent(out) :: xo(:) ! output 608 | integer :: i 609 | ! compute nth polynomial: 1 at node n, 0 at all others 610 | xo = 1 611 | do i = 1, size(xin) 612 | if (i == n) cycle 613 | xo = xo * (xi-xin(i))/(xin(n)-xin(i)) 614 | end do 615 | end subroutine 616 | 617 | subroutine dphih_array(xin, n, xi, xo) 618 | ! "d phi hat": derivative of nth Lagrange polynomial with nodes 'xin' at point 619 | ! 'xi'. 620 | real(dp), intent(in) :: xin(:) ! polynomial nodes 621 | integer, intent(in) :: n ! polynomial index 622 | real(dp), intent(in) :: xi(:) ! points at which to evaluate dphih 623 | real(dp), intent(out) :: xo(:) ! output 624 | real(dp) :: prod(size(xi), size(xin)), prod2(size(xi), size(xin)) 625 | real(dp) :: tmp(size(xi), size(xin)) 626 | integer :: i, j 627 | do i = 1, size(xin) 628 | if (i==n) then 629 | tmp(:,i) = 1 630 | else 631 | tmp(:,i) = (xi-xin(i))/(xin(n)-xin(i)) 632 | end if 633 | if (i==1) then 634 | prod(:, i) = 1 635 | else 636 | prod(:, i) = prod(:, i-1) * tmp(:, i-1) 637 | end if 638 | end do 639 | 640 | prod2(:, size(xin)) = 1 641 | do i = size(xin)-1, 1, -1 642 | prod2(:, i) = prod2(:, i+1) * tmp(:, i+1) 643 | end do 644 | 645 | ! compute derivative of nth polynomial 646 | xo = 0 647 | do j = 1, size(xin) 648 | if (j == n) cycle 649 | xo = xo + prod(:, j)*prod2(:,j)/ (xin(n)-xin(j)) 650 | end do 651 | end subroutine 652 | 653 | real(dp) pure function ddphih(xin, n, xi) 654 | ! For debugging purposes only 655 | ! "d^2 phi hat": 2nd derivative of nth Lagrange polynomial with nodes 'xin' at 656 | ! point 'xi'. 2nd derivates have delta functions at element boundaries and cannot 657 | ! be used in Finite Element basis. 658 | real(dp), intent(in) :: xin(:) ! polynomial nodes 659 | integer, intent(in) :: n ! polynomial index 660 | real(dp), intent(in) :: xi ! point at which to evaluate dphih 661 | real(dp) :: term 662 | real(dp) :: tmp(size(xin)) 663 | integer :: i, j, k 664 | do i = 1, size(xin) 665 | if (i==n) cycle 666 | tmp(i) = (xi-xin(i))/(xin(n)-xin(i)) 667 | end do 668 | ! compute derivative of nth polynomial 669 | ddphih = 0 670 | do k = 1, size(xin) 671 | if (k == n) cycle 672 | do j = 1, size(xin) 673 | if (j == k .or. j == n) cycle 674 | term = 1 / ((xin(n)-xin(j))*(xin(n)-xin(k))) 675 | do i = 1, size(xin) 676 | if (i==n .or. i==j .or. i==k) cycle 677 | term = term * tmp(i) 678 | end do 679 | ddphih = ddphih + term 680 | end do 681 | end do 682 | end function 683 | 684 | real(dp) function integrate(xe, wtq, uq) result(r) 685 | ! Computes the integral of the function 'uq' given at quadrature points 686 | real(dp), intent(in) :: xe(:), wtq(:), uq(:,:) 687 | real(dp) :: xa, xb, jac 688 | integer :: e 689 | r = 0 690 | do e = 1, size(xe)-1 691 | xa = xe(e) 692 | xb = xe(e+1) 693 | jac = (xb-xa)/2 ! affine mapping 694 | r = r + sum(uq(:,e)*wtq*jac) 695 | end do 696 | end function 697 | 698 | real(dp) function integrate2(xe, xiq, xiq_gj, wtq, wtq_gj, zeta, uq) result(r) 699 | ! Computes the integral of the function 'uq' given at quadrature points 700 | ! xiq_gj are Gauss-Jacobi quadrature points for the first element 701 | ! xiq are Gauss-Legendre quadrature points for the rest 702 | real(dp), intent(in) :: xe(:), xiq(:), xiq_gj(:), wtq(:), wtq_gj(:), uq(:,:), zeta 703 | real(dp) :: xa, xb, jac 704 | real(dp) :: xq(size(xiq)) 705 | integer :: e 706 | r = 0 707 | do e = 1, size(xe)-1 708 | xa = xe(e) 709 | xb = xe(e+1) 710 | jac = (xb-xa)/2 ! affine mapping 711 | xq = (xiq_gj + 1)*jac 712 | if (e == 1 .and. zeta > -1) then 713 | r = r + sum(uq(:,e)*xq**(-zeta)*jac**zeta*wtq_gj*jac) 714 | else 715 | r = r + sum(uq(:,e)*wtq*jac) 716 | end if 717 | end do 718 | end function 719 | 720 | end module 721 | -------------------------------------------------------------------------------- /src/gjp_gw_single.f90: -------------------------------------------------------------------------------- 1 | ! BEGIN_HEADER 2 | ! ----------------------------------------------------------------------------- 3 | ! Gauss-Jacobi Quadrature Implementation 4 | ! Authors: Rohit Goswami 5 | ! Source: GaussJacobiQuad Library 6 | ! License: MIT 7 | ! GitHub Repository: https://github.com/HaoZeke/GaussJacobiQuad 8 | ! Date: 2023-09-06 9 | ! Commit: 2a265ce 10 | ! ----------------------------------------------------------------------------- 11 | ! This code is part of the GaussJacobiQuad library, providing an efficient 12 | ! implementation for Gauss-Jacobi quadrature nodes and weights computation. 13 | ! ----------------------------------------------------------------------------- 14 | ! To cite this software: 15 | ! Rohit Goswami (2023). HaoZeke/GaussJacobiQuad: v0.1.0. 16 | ! Zenodo: https://doi.org/10.5281/ZENODO.8285112 17 | ! --------------------------------------------------------------------- 18 | ! END_HEADER 19 | 20 | module gjp_types 21 | implicit none 22 | private 23 | public sp, dp, hp, qp, gjp_sparse_matrix 24 | integer, parameter :: dp = kind(0.d0), & 25 | hp = selected_real_kind(15), & 26 | qp = selected_real_kind(32), & 27 | sp = kind(0.) 28 | type gjp_sparse_matrix 29 | real(dp), allocatable :: diagonal(:) 30 | real(dp), allocatable :: off_diagonal(:) 31 | end type gjp_sparse_matrix 32 | 33 | end module gjp_types 34 | 35 | module gjp_lapack 36 | implicit none 37 | 38 | integer, parameter :: dp = kind(0.d0) 39 | interface 40 | subroutine DSTEQR(COMPZ, N, D, E, Z, LDZ, WORK, INFO) 41 | import :: dp 42 | character :: COMPZ 43 | integer :: N, LDZ, INFO 44 | real(dp) :: D(*), E(*), Z(LDZ, *), WORK(*) 45 | end subroutine DSTEQR 46 | end interface 47 | 48 | contains 49 | 50 | end module gjp_lapack 51 | 52 | module gjp_common 53 | use gjp_types, only: dp, gjp_sparse_matrix 54 | implicit none 55 | 56 | contains 57 | function jacobi_matrix(n, alpha, beta) result(jacmat) 58 | integer, intent(in) :: n 59 | real(dp), intent(in) :: alpha, beta 60 | type(gjp_sparse_matrix) :: jacmat 61 | integer :: idx 62 | real(dp) :: ab, abi, a2b2 63 | 64 | allocate (jacmat%diagonal(n)) 65 | allocate (jacmat%off_diagonal(n - 1)) 66 | 67 | ab = alpha + beta 68 | abi = 2.0_dp + ab 69 | jacmat%diagonal(1) = (beta - alpha) / abi 70 | jacmat%off_diagonal(1) = 4.0_dp * (1.0_dp + alpha) * (1.0_dp + beta) & 71 | / ((abi + 1.0_dp) * abi * abi) 72 | a2b2 = beta * beta - alpha * alpha 73 | do idx = 2, n 74 | abi = 2.0_dp * idx + ab 75 | jacmat%diagonal(idx) = a2b2 / ((abi - 2.0_dp) * abi) 76 | abi = abi**2 77 | if (idx < n) then 78 | jacmat%off_diagonal(idx) = 4.0_dp * idx * (idx + alpha) * (idx + beta) & 79 | * (idx + ab) / ((abi - 1.0_dp) * abi) 80 | end if 81 | end do 82 | jacmat%off_diagonal(1:n - 1) = sqrt(jacmat%off_diagonal(1:n - 1)) 83 | end function jacobi_matrix 84 | function jacobi_zeroeth_moment(alpha, beta) result(zmom) 85 | real(dp), intent(in) :: alpha, beta 86 | real(dp) :: zmom 87 | real(dp) :: ab, abi 88 | 89 | ab = alpha + beta 90 | abi = 2.0_dp + ab 91 | 92 | zmom = 2.0_dp**(alpha + beta + 1.0_dp) * exp(log_gamma(alpha + 1.0_dp) & 93 | + log_gamma(beta + 1.0_dp) - log_gamma(abi)) 94 | 95 | if (zmom <= 0.0_dp) then 96 | error stop "Zeroth moment is not positive but should be" 97 | end if 98 | end function jacobi_zeroeth_moment 99 | 100 | end module gjp_common 101 | 102 | module gjp_gw 103 | use gjp_types, only: dp, gjp_sparse_matrix 104 | use gjp_lapack, only: DSTEQR 105 | use gjp_common, only: jacobi_matrix, jacobi_zeroeth_moment 106 | implicit none 107 | contains 108 | subroutine gauss_jacobi_gw(npts, alpha, beta, x, wts) 109 | integer, intent(in) :: npts 110 | real(dp), intent(in) :: alpha, beta 111 | real(dp), intent(out) :: x(npts), wts(npts) 112 | real(dp) :: zeroeth_moment 113 | type(gjp_sparse_matrix) :: jacobi_mat 114 | real(dp) :: diagonal_elements(npts), & 115 | off_diagonal_elements(npts - 1), & 116 | eigenvectors(npts, npts), & 117 | workspace(2 * npts - 2) 118 | integer :: computation_info, i 119 | 120 | jacobi_mat = jacobi_matrix(npts, alpha, beta) 121 | zeroeth_moment = jacobi_zeroeth_moment(alpha, beta) 122 | diagonal_elements = jacobi_mat%diagonal(1:npts) 123 | off_diagonal_elements = jacobi_mat%off_diagonal(1:npts - 1) 124 | eigenvectors = 0.0_dp 125 | do i = 1, npts 126 | eigenvectors(i, i) = 1.0_dp 127 | end do 128 | call DSTEQR('V', npts, diagonal_elements, off_diagonal_elements, & 129 | eigenvectors, npts, workspace, computation_info) 130 | 131 | if (computation_info /= 0) then 132 | write (*, *) 'Error in DSTEQR, info:', computation_info 133 | error stop 134 | end if 135 | x = diagonal_elements 136 | wts = eigenvectors(1, :)**2 * zeroeth_moment 137 | 138 | end subroutine gauss_jacobi_gw 139 | 140 | end module gjp_gw 141 | 142 | -------------------------------------------------------------------------------- /src/graphs.f90: -------------------------------------------------------------------------------- 1 | module graphs 2 | 3 | use types, only: dp 4 | use mesh, only: meshexp 5 | use schroed_glob, only: solve_schroed 6 | use dirac, only: solve_dirac 7 | use feutils, only: get_parent_quad_pts_wts 8 | use string_utils, only: str 9 | implicit none 10 | 11 | contains 12 | 13 | subroutine run_convergence(study_type, dirac_int, p_or_Ne, directory) 14 | ! can be, 15 | ! 0: error as p is varied 16 | ! 1: error as rmax is varied 17 | ! 2: error as Ne is varied 18 | integer, intent(in) :: study_type 19 | ! can be, 20 | ! 0: Schroedinger 21 | ! 1: Dirac 22 | integer, intent(in) :: dirac_int 23 | ! For 24 | ! 0, 1: 3rd argument p_or_Ne = Ne (Number of elements) 25 | ! 2 : 3rd argument p_or_Ne = p (Polynomial order) 26 | integer, intent(in) :: p_or_Ne 27 | 28 | ! The directory where to save the output files 29 | character(len=*), intent(in) :: directory 30 | 31 | integer :: p, Ne, Nq, Z, u, i, DOFs 32 | real(dp) :: rmax, a, Etot 33 | real(dp) :: optim_a(2:7) 34 | integer, allocatable :: Nes(:), rmax_values(:) 35 | real(dp), allocatable :: energies(:) 36 | character(len=:), allocatable :: filename 37 | Z = 92 38 | rmax = 50 39 | a = 200 40 | Ne = 4 41 | Nq = 64 42 | p = 25 43 | 44 | if (study_type == 2) then 45 | p = p_or_Ne 46 | else 47 | Ne = p_or_Ne 48 | end if 49 | filename = str(p_or_Ne) 50 | 51 | 52 | optim_a = [58.985048682607555, 163.13530060338942, 340.82602039608668, & 53 | 444.68894311026423, 591.72463734788732, 596.61404750045062] 54 | 55 | if (Ne >= 2 .and. Ne <= 7) then 56 | a = optim_a(Ne) 57 | end if 58 | if (dirac_int == 1 .and. study_type == 0) then 59 | a = 600 60 | rmax = 30 61 | end if 62 | if (dirac_int == 1 .and. study_type == 1) then 63 | a = 600 64 | p = 25 65 | end if 66 | if (dirac_int == 1 .and. study_type == 2) then 67 | a = 600 68 | rmax = 30 69 | end if 70 | 71 | if (study_type == 0) then 72 | filename = "conv_" // trim(filename) // ".txt" 73 | else if (study_type == 1) then 74 | filename = "rmax_" // trim(filename) // ".txt" 75 | else 76 | filename = "ne_" // trim(filename) // ".txt" 77 | end if 78 | 79 | if (dirac_int == 1) then 80 | filename = "dft_dirac_" // trim(filename) 81 | else 82 | filename = "dft_schroed_" // trim(filename) 83 | end if 84 | 85 | filename = directory // "/" // filename 86 | 87 | open(newunit=u, file=filename, status="replace") 88 | print "(a3,a6,a5,a8,a3,a3,a5,a22)", "Z", "rmax", "Ne", "a", "p", "Nq", & 89 | "DOFs", "Etot" 90 | 91 | 92 | if (study_type == 0) then 93 | do i = 7, 31 94 | ! change p for p-conv study. p must be less than 31. 95 | p = i 96 | call total_energy(Z, rmax, Ne, a, p, Nq, DOFs, Etot) 97 | print "(i3, f6.1, i5, f8.1, i3, i3, i5, f22.12)", Z, rmax, Ne, a, p, Nq, & 98 | DOFs, Etot 99 | write(u,*) Z, rmax, Ne, a, p, Nq, DOFs, Etot 100 | end do 101 | else if (study_type == 1) then 102 | allocate(rmax_values(5)) 103 | rmax_values = [5, 10, 20, 30, 40] 104 | do i = 1, size(rmax_values) 105 | ! change rmax for rmax study. 106 | rmax = rmax_values(i) 107 | call total_energy(Z, rmax, Ne, a, p, Nq, DOFs, Etot) 108 | print "(i3, f6.1, i5, f8.1, i3, i3, i5, 40f22.12)", Z, rmax, Ne, a, p, Nq, & 109 | DOFs, Etot, energies 110 | write(u,*) Z, rmax, Ne, a, p, Nq, DOFs, Etot, energies 111 | end do 112 | else if (study_type == 2) then 113 | allocate(Nes(3)) 114 | Nes = [6,10,20] 115 | do i = 1, size(Nes) 116 | Ne = Nes(i) 117 | call total_energy(Z, rmax, Ne, a, p, Nq, DOFs, Etot) 118 | print "(i3, f6.1, i5, f8.1, i3, i3, i5, f22.12)", Z, rmax, Ne, a, p, Nq, & 119 | DOFs, Etot 120 | write(u,*) Z, rmax, Ne, a, p, Nq, DOFs, Etot, energies 121 | end do 122 | end if 123 | close(u) 124 | 125 | contains 126 | 127 | subroutine total_energy(Z, rmax, Ne, a, p, Nq, DOFs, Etot) 128 | integer, intent(in) :: Z, Ne, Nq, p 129 | real(dp), intent(in) :: rmax, a 130 | integer, intent(out) :: DOFs 131 | real(dp), intent(out) :: Etot 132 | real(dp), allocatable :: xe(:), xiq(:), wtq(:), V(:,:) 133 | real(dp) :: rmin, r0 134 | rmin = 0 135 | allocate(xe(Ne+1), xiq(Nq), wtq(Nq), V(Nq, Ne)) 136 | if (dirac_int == 1 .and. study_type == 0) then 137 | r0 = 0.005_dp 138 | xe(1) = rmin 139 | xe(2:) = meshexp(r0, rmax, a, Ne-1) 140 | else if (dirac_int == 1 .and. study_type == 1) then 141 | r0 = 0.005_dp 142 | xe(1) = rmin 143 | xe(2:) = meshexp(r0, rmax, a, Ne-1) 144 | else if (dirac_int == 1 .and. study_type == 2) then 145 | r0 = 0.005_dp 146 | xe(1) = rmin 147 | xe(2:) = meshexp(r0, rmax, a, Ne-1) 148 | else 149 | xe = meshexp(rmin, rmax, a, Ne) 150 | end if 151 | call get_parent_quad_pts_wts(1, Nq, xiq, wtq) 152 | if (dirac_int == 1) then 153 | call solve_dirac(Z, p, xiq, wtq, xe, 1e-9_dp, energies, Etot, V, DOFs) 154 | else 155 | call solve_schroed(Z, p, xiq, wtq, xe, 1e-9_dp, energies, Etot, V, DOFs) 156 | end if 157 | end subroutine 158 | 159 | end subroutine 160 | 161 | end module 162 | -------------------------------------------------------------------------------- /src/graphs_potential.f90: -------------------------------------------------------------------------------- 1 | module graphs_potential 2 | 3 | use types, only: dp 4 | use mesh, only: meshexp 5 | use schroed_glob, only: solve_schroed 6 | use dirac, only: solve_dirac 7 | use feutils, only: define_connect, get_quad_pts, get_parent_quad_pts_wts, & 8 | get_parent_nodes, phih, dphih, phih_array, dphih_array 9 | use fe, only: assemble_radial_S, assemble_radial_H, assemble_radial_dirac_SH 10 | use linalg, only: eigh 11 | use string_utils, only: str 12 | use schroed_dirac_solver, only: total_energy 13 | implicit none 14 | 15 | contains 16 | 17 | subroutine run_convergence_potential(study_type, dirac_int, p_or_Ne, & 18 | potential_type, alpha_int, directory) 19 | ! can be, 20 | ! 0: error as p is varied 21 | ! 1: error as rmax is varied 22 | ! 2: error as Ne is varied 23 | integer, intent(in) :: study_type 24 | ! can be, 25 | ! 0: Schroedinger 26 | ! 1: Dirac 27 | integer, intent(in) :: dirac_int 28 | ! For 29 | ! 0, 1: 3rd argument p_or_Ne = Ne (Number of elements) 30 | ! 2 : 3rd argument p_or_Ne = p (Polynomial order) 31 | integer, intent(in) :: p_or_Ne 32 | ! can be, 33 | ! 0: Coulomb 34 | ! 1: Harmonic 35 | integer, intent(in) :: potential_type 36 | ! can be 0, 1, -1 (-1 implies beta). used only for Dirac. 37 | integer, intent(in) :: alpha_int 38 | 39 | ! The directory where to save the output files 40 | character(len=*), intent(in) :: directory 41 | 42 | integer :: p, Ne, Nq, Z, u, i, DOFs 43 | real(dp) :: rmax, a, asympt, c 44 | real(dp), allocatable :: alpha_j(:), alpha(:) 45 | integer :: Lmax, Lmin, kappa 46 | real(dp) :: optim_a(2:7) 47 | integer :: Nes(11) 48 | real(dp), allocatable :: lam(:), eigfn(:,:,:), xq(:,:) 49 | character(len=:), allocatable :: filename 50 | Z = 92 51 | rmax = 50 52 | a = 200 53 | Ne = 4 54 | Nq = 64 55 | p = 25 56 | c = 137.0359895_dp 57 | 58 | if (study_type == 2) then 59 | p = p_or_Ne 60 | else 61 | Ne = p_or_Ne 62 | end if 63 | filename = str(p_or_Ne) 64 | 65 | if (alpha_int == 0) then 66 | filename = trim(filename) // "_0" 67 | else if (alpha_int == 1) then 68 | filename = trim(filename) // "_1" 69 | else 70 | filename = trim(filename) // "_beta" 71 | end if 72 | 73 | Lmax=6 74 | Lmin=-7 75 | 76 | allocate(alpha(Lmin:Lmax), alpha_j(Lmin:Lmax)) 77 | allocate(xq(Nq, Ne)) 78 | do kappa = Lmin, Lmax 79 | if (kappa == 0) cycle 80 | ! asymptotic at r = 0 81 | asympt = sqrt(kappa**2 - Z**2 / c**2) 82 | ! solve for P/r**alpha 83 | if (alpha_int == -1) then 84 | alpha(kappa) = asympt 85 | ! power of r for Gauss-Jacobi quadrature 86 | alpha_j(kappa) = 2*asympt - 2 87 | else 88 | alpha(kappa) = alpha_int 89 | ! don't use Gauss-Jacobi quadrature 90 | alpha_j(kappa) = -2 91 | end if 92 | end do 93 | 94 | optim_a = [58.985048682607555, 163.13530060338942, 340.82602039608668, & 95 | 444.68894311026423, 591.72463734788732, 596.61404750045062] 96 | 97 | if (Ne >= 2 .and. Ne <= 7) then 98 | a = optim_a(Ne) 99 | end if 100 | 101 | a = 100 102 | 103 | if (study_type == 0) then 104 | filename = "conv_" // trim(filename) // ".txt" 105 | else if (study_type == 1) then 106 | filename = "rmax_" // trim(filename) // ".txt" 107 | else 108 | filename = "ne_" // trim(filename) // ".txt" 109 | end if 110 | 111 | if (dirac_int == 1) then 112 | filename = "dirac_" // trim(filename) 113 | else 114 | filename = "schroed_" // trim(filename) 115 | end if 116 | 117 | if (potential_type == 0) then 118 | filename = "coulomb_" // trim(filename) 119 | else 120 | filename = "harmonic_" // trim(filename) 121 | end if 122 | 123 | filename = directory // "/" // filename 124 | 125 | open(newunit=u, file=filename, status="replace") 126 | print "(a3,a6,a5,a8,a3,a3,a5)", "Z", "rmax", "Ne", "a", "p", "Nq", & 127 | "DOFs" 128 | 129 | if (study_type == 0) then 130 | do i = 7, 63 131 | ! change p for p-conv study. p must be less than 31. 132 | if (dirac_int == 1 .and. i > 22) then 133 | exit 134 | end if 135 | p = i 136 | call total_energy(Z, rmax, Ne, a, p, Nq, DOFs, alpha_int, dirac_int, & 137 | c, potential_type, Lmin, alpha_j, alpha, lam, eigfn, xq) 138 | print "(i3, f6.1, i5, f8.1, i3, i3, i5, f22.12)", Z, rmax, Ne, a, p, Nq, & 139 | DOFs, sum(lam) 140 | write(u,*) Z, rmax, Ne, a, p, Nq, DOFs, sum(lam), lam 141 | end do 142 | else if (study_type == 1) then 143 | rmax = 0.5_dp 144 | do while (rmax < 9) 145 | ! change rmax for rmax study. 146 | if (dirac_int == 1) then 147 | p = 22 148 | end if 149 | call total_energy(Z, rmax, Ne, a, p, Nq, DOFs, alpha_int, dirac_int, & 150 | c, potential_type, Lmin, alpha_j, alpha, lam, eigfn, xq) 151 | print "(i3, f6.1, i5, f8.1, i3, i3, i5, f22.12)", Z, rmax, Ne, a, p, Nq, & 152 | DOFs, sum(lam) 153 | write(u,*) Z, rmax, Ne, a, p, Nq, DOFs, sum(lam), lam 154 | rmax = rmax + 0.3_dp 155 | end do 156 | else if (study_type == 2) then 157 | Nes = [3,4,5,6,7,8,9,10,20,25,30] 158 | a = 600 159 | do i = 1, 11 160 | Ne = Nes(i) 161 | deallocate(xq) 162 | allocate(xq(Nq, Ne)) 163 | call total_energy(Z, rmax, Ne, a, p, Nq, DOFs, alpha_int, dirac_int, & 164 | c, potential_type, Lmin, alpha_j, alpha, lam, eigfn, xq) 165 | print "(i3, f6.1, i5, f8.1, i3, i3, i5, f22.12)", Z, rmax, Ne, a, p, Nq, & 166 | DOFs, sum(lam) 167 | write(u,*) Z, rmax, Ne, a, p, Nq, DOFs, sum(lam), lam 168 | end do 169 | end if 170 | close(u) 171 | end subroutine 172 | 173 | end module 174 | -------------------------------------------------------------------------------- /src/hartree_screening.f90: -------------------------------------------------------------------------------- 1 | module hartree_screening 2 | ! Hartree screening function 3 | use types, only: dp 4 | use feutils, only: define_connect, c2fullc2, fe2quad, get_parent_nodes, & 5 | phih, dphih, phih_array, dphih_array, get_quad_pts, & 6 | fe2quad_core, fe2quad_gj 7 | use solvers, only: solve_sym, solve_sym2 8 | implicit none 9 | private 10 | public assemble_poisson_A, hartree_potential3, hartree_potential_gj 11 | 12 | contains 13 | 14 | subroutine assemble_poisson_A(xin, xe, ib, xiq, wtq, dphihq, Am) 15 | ! forms system equation matrices corresponding to the problem 16 | ! -u''(r) = f(x)*r 17 | ! subject to boundary conditions consistent with basis specified by ib 18 | ! The weak formulation is: 19 | ! \int u'(r)*v'(r) \d r = \int f(x) * r * v(x) \d r 20 | real(dp), intent(in) :: xin(:) ! parent basis nodes 21 | real(dp), intent(in) :: xe(:) ! element coordinates 22 | integer, intent(in) :: ib(:,:) ! basis connectivity: ib(i,j) = index of 23 | ! basis function associated with local basis function i of element j. 24 | ! 0 = no associated basis fn. 25 | real(dp), intent(in) :: xiq(:) ! quadrature points 26 | real(dp), intent(in) :: wtq(:) ! quadrature weights 27 | real(dp), intent(in) :: dphihq(:,:) ! parent basis derivative at quadrature points 28 | real(dp), intent(out) :: Am(:,:) ! system matrix: Am c = bv 29 | integer :: Ne, Nb ! number of elements, basis functions 30 | integer :: p ! order of FE/SE basis 31 | integer :: e ! element index 32 | integer :: i,j ! basis fn indices 33 | integer :: al,be ! "alpha", "beta": local basis fn indices 34 | real(dp) :: xa,xb ! element boundary node coordinates 35 | real(dp) :: jac ! Jacobian of transformation from parent 36 | ! coords xi in [-1,1] to coords x in [xa,xb]: x = (xb-xa)/2 xi + (xb+xa)/2 37 | real(dp), dimension(size(xiq)) :: intq, xq, m 38 | 39 | ! initializations 40 | Ne = size(ib, 2) 41 | Nb = maxval(ib) 42 | p = size(xin)-1 43 | if (size(xin) /= size(ib,1)) & 44 | error stop "Error: inconsistent parent node and connectivity dimensions." 45 | if (size(Am,1) /= Nb) & 46 | error stop "Error: size of Am inconsistent with Nb." 47 | ! accumulate Am matrix and bv vector 48 | ! compute lower triangle 49 | Am = 0 50 | do e = 1, Ne 51 | xa = xe(e) 52 | xb = xe(e+1) 53 | jac = (xb - xa)/2 ! affine mapping 54 | xq = (xiq+1)/2*(xb-xa)+xa 55 | m = wtq*xq**2/jac 56 | ! compute matrix/vector elements (integrals transformed to [-1,1]) 57 | do al = 1, p+1 58 | i = ib(al, e) 59 | if (i == 0) cycle ! omit boundary basis fns for Dirichlet BCs 60 | do be = 1, p+1 61 | j = ib(be, e) 62 | if (j == 0) cycle ! omit boundary basis fns for Dirichlet BCs 63 | if (j > i) cycle ! compute only lower triangles 64 | intq = dphihq(:, al) * dphihq(:, be) 65 | Am(i, j) = Am(i, j) + sum(m*intq) 66 | end do 67 | end do 68 | end do 69 | ! fill in upper triangle 70 | do j = 1, Nb 71 | do i = 1, j-1 72 | Am(i, j) = Am(j, i) 73 | end do 74 | end do 75 | end subroutine 76 | 77 | subroutine assemble_poisson_b(f_vals, xin, xe, ib, xiq, wtq, phihq, bv) 78 | ! forms system equation matrices corresponding to the problem 79 | ! -u''(r) = f(x)*r 80 | ! subject to boundary conditions consistent with basis specified by ib 81 | ! The weak formulation is: 82 | ! \int u'(r)*v'(r) \d r = \int f(x) * r * v(x) \d r 83 | real(dp), intent(in) :: f_vals(:,:) ! f(x) at quadrature points: 84 | ! f_vals(i,j) = value at ith point in jth element 85 | real(dp), intent(in) :: xin(:) ! parent basis nodes 86 | real(dp), intent(in) :: xe(:) ! element coordinates 87 | integer, intent(in) :: ib(:,:) ! basis connectivity: ib(i,j) = index of 88 | ! basis function associated with local basis function i of element j. 89 | ! 0 = no associated basis fn. 90 | real(dp), intent(in) :: xiq(:) ! quadrature points 91 | real(dp), intent(in) :: wtq(:) ! quadrature weights 92 | real(dp), intent(in) :: phihq(:,:) ! parent basis at quadrature points 93 | real(dp), intent(out) :: bv(:) ! source vector: Am c = bv 94 | integer :: Ne, Nb ! number of elements, basis functions 95 | integer :: p ! order of FE/SE basis 96 | integer :: e ! element index 97 | integer :: i ! basis fn indices 98 | integer :: al ! "alpha", local basis fn indices 99 | real(dp) :: xa,xb ! element boundary node coordinates 100 | real(dp) :: jac ! Jacobian of transformation from parent 101 | ! coords xi in [-1,1] to coords x in [xa,xb]: x = (xb-xa)/2 xi + (xb+xa)/2 102 | real(dp), dimension(size(xiq)) :: xq, bq, m 103 | 104 | ! initializations 105 | Ne = size(ib, 2) 106 | Nb = maxval(ib) 107 | p = size(xin)-1 108 | if (size(xin) /= size(ib,1)) & 109 | error stop "Error: inconsistent parent node and connectivity dimensions." 110 | if (size(bv,1) /= Nb) & 111 | error stop "Error: size of bv inconsistent with Nb." 112 | ! accumulate Am matrix and bv vector 113 | ! compute lower triangle 114 | bv = 0 115 | do e = 1, Ne 116 | xa = xe(e) 117 | xb = xe(e+1) 118 | jac = (xb - xa)/2 ! affine mapping 119 | xq = (xiq+1)/2*(xb-xa)+xa 120 | m = wtq*xq**2*jac 121 | ! compute matrix/vector elements (integrals transformed to [-1,1]) 122 | do al = 1, p+1 123 | i = ib(al, e) 124 | if (i == 0) cycle ! omit boundary basis fns for Dirichlet BCs 125 | bq = f_vals(:,e)*phihq(:,al) 126 | bv(i) = bv(i) + sum(m * bq) 127 | end do 128 | end do 129 | end subroutine 130 | 131 | function hartree_potential3(Z, p, xe, xin, in, ib, xiq, wtq, phihq, Am, ipiv, f) result(uq) 132 | ! Equivalently, the V(r) is the solution of the radial Poisson equation: 133 | ! V''(r) + (2/r)*V'(r) = -f(r) 134 | ! Note that in DFT, f(r) = 4*pi*n(r) 135 | ! We rewrite the equation as: 136 | ! -u''(r) = f(r)*r 137 | ! where u(r) = V(r)*r. 138 | ! The weak form is: 139 | ! \int u'(r)*v'(r) \d r = \int f(x) * r * v(x) \d r 140 | ! And the boundary conditions are u(0) = 0 and u'(rmax) = 0. Finally, the 141 | ! potential is calculated as V(r) = u(r) / r. 142 | ! 143 | ! The input f is the function f(r) defined on Gauss-Legendre (GL) quadrature 144 | ! grid. 145 | ! 146 | ! The V(r) is returned on the GL grid. 147 | ! 148 | real(dp), intent(in) :: Z 149 | integer, intent(in) :: p ! polynomial order to use for Y^k 150 | real(dp), intent(in) :: xe(:), xin(:), xiq(:), wtq(:), f(:,:), phihq(:,:), Am(:,:) 151 | integer, intent(in) :: in(:,:), ib(:,:), ipiv(:) 152 | real(dp), dimension(size(xiq), size(xe)-1) :: uq, xq 153 | integer :: Ne 154 | real(dp) :: fullc((size(xe-1)-1)*p+1) 155 | real(dp), allocatable :: bv(:), u(:) 156 | integer :: Nb 157 | Ne = size(xe)-1 158 | ! Make sure the fullc has the right size: 159 | if ( .not. (size(fullc) == maxval(in)) ) then 160 | error stop 'Wrong size for fullc' 161 | end if 162 | call get_quad_pts(xe, xiq, xq) 163 | 164 | Nb = maxval(ib) 165 | allocate(bv(Nb), u(Nb)) 166 | call assemble_poisson_b(f, xin, xe, ib, xiq, wtq, phihq, bv) 167 | ! solve 168 | u = solve_sym2(Am, bv, ipiv) 169 | ! Transform solution from FE coefficient vector to full coefficient vector 170 | call c2fullc2(in, ib, u, fullc) 171 | ! transform solution to quadrature grid 172 | call fe2quad_core(xe, xin, in, fullc, phihq, uq) 173 | uq = uq + Z/xe(Ne+1) 174 | end function 175 | 176 | 177 | subroutine assemble_poisson_gj(f_vals, xin, xe, ib, xiq, wtq, xiq1, wtq1, & 178 | zeta, Am, bv) 179 | ! forms system equation matrices corresponding to the problem 180 | ! -u''(r) = f(x)*r 181 | ! subject to boundary conditions consistent with basis specified by ib 182 | ! The weak formulation is: 183 | ! \int u'(r)*v'(r) \d r = \int f(x) * r * v(x) \d r 184 | ! The f(r) is rewritten as f(r) = r^zeta * (f(r)/r^zeta) and the GJ quadrature 185 | ! integrates f(r)/r^zeta. The zeta and xiq1/wtq1 must be consistent and 186 | ! contain the GJ quadrature. 187 | real(dp), intent(in) :: f_vals(:,:) ! f(x) at quadrature points: 188 | ! f_vals(i,j) = value at ith point in jth element 189 | real(dp), intent(in) :: xin(:) ! parent basis nodes 190 | real(dp), intent(in) :: xe(:) ! element coordinates 191 | integer, intent(in) :: ib(:,:) ! basis connectivity: ib(i,j) = index of 192 | ! basis function associated with local basis function i of element j. 193 | ! 0 = no associated basis fn. 194 | real(dp), intent(in) :: xiq(:), xiq1(:) ! quadrature points 195 | real(dp), intent(in) :: wtq(:), wtq1(:) ! quadrature weights 196 | real(dp), intent(in) :: zeta 197 | real(dp), intent(out) :: Am(:,:) ! system matrix: Am c = bv 198 | real(dp), intent(out) :: bv(:) ! source vector: Am c = bv 199 | integer :: Ne, Nb ! number of elements, basis functions 200 | integer :: p ! order of FE/SE basis 201 | integer :: e ! element index 202 | integer :: i,j ! basis fn indices 203 | integer :: al,be ! "alpha", "beta": local basis fn indices 204 | integer :: iq ! quadrature point index 205 | real(dp) :: xa,xb ! element boundary node coordinates 206 | real(dp) :: jac ! Jacobian of transformation from parent 207 | ! coords xi in [-1,1] to coords x in [xa,xb]: x = (xb-xa)/2 xi + (xb+xa)/2 208 | real(dp), dimension(size(xiq),size(xin)) :: phihq, dphihq, phihq1 ! parent 209 | ! basis fns and derivs at quadrature points: 210 | ! phihq(i,j) = value of jth function at ith quadrature point 211 | real(dp), dimension(size(xiq)) :: intq, bq, xq 212 | 213 | ! initializations 214 | Ne = size(ib, 2) 215 | Nb = maxval(ib) 216 | p = size(xin)-1 217 | if (size(xin) /= size(ib,1)) & 218 | error stop "Error: inconsistent parent node and connectivity dimensions." 219 | if (size(Am,1) /= Nb .or. size(bv,1) /= Nb) & 220 | error stop "Error: size of Am and/or bv inconsistent with Nb." 221 | ! tabulate parent basis and derivatives at quadrature points 222 | do al = 1, p+1 223 | do iq = 1, size(xiq) 224 | phihq(iq, al) = phih(xin, al, xiq(iq)) 225 | phihq1(iq, al) = phih(xin, al, xiq1(iq)) 226 | dphihq(iq, al) = dphih(xin, al, xiq(iq)) 227 | end do 228 | end do 229 | ! accumulate Am matrix and bv vector 230 | ! compute lower triangle 231 | Am = 0; bv = 0 232 | do e = 1, Ne 233 | xa = xe(e) 234 | xb = xe(e+1) 235 | jac = (xb - xa)/2 ! affine mapping 236 | if (e == 1 .and. zeta > -1) then 237 | xq = (xiq1+1)/2*(xb-xa)+xa 238 | bq = xq * jac**(zeta) * jac*wtq1 / xq**(zeta) 239 | else 240 | xq = (xiq+1)/2*(xb-xa)+xa 241 | bq = xq * jac*wtq 242 | end if 243 | ! compute matrix/vector elements (integrals transformed to [-1,1]) 244 | do al = 1, p+1 245 | i = ib(al, e) 246 | if (i == 0) cycle ! omit boundary basis fns for Dirichlet BCs 247 | if (e == 1 .and. zeta > -1) then 248 | bv(i) = bv(i) + sum(bq*f_vals(:, e)*phihq1(:,al)) 249 | else 250 | bv(i) = bv(i) + sum(bq*f_vals(:, e)*phihq(:,al)) 251 | end if 252 | do be = 1, p+1 253 | j = ib(be, e) 254 | if (j == 0) cycle ! omit boundary basis fns for Dirichlet BCs 255 | if (j > i) cycle ! compute only lower triangles 256 | intq = dphihq(:, al) * dphihq(:, be) / jac**2 257 | Am(i, j) = Am(i, j) + sum(wtq*intq*jac) 258 | end do 259 | end do 260 | end do 261 | ! fill in upper triangle 262 | do j = 1, Nb 263 | do i = 1, j-1 264 | Am(i, j) = Am(j, i) 265 | end do 266 | end do 267 | end subroutine 268 | 269 | function hartree_potential_gj(p, xe, xiq, wtq, xiq1, wtq1, zeta, f0) result(uq) 270 | ! Equivalently, the V(r) is the solution of the radial Poisson equation: 271 | ! V''(r) + (2/r)*V'(r) = -f(r) 272 | ! Note that in DFT, f(r) = 4*pi*n(r) 273 | ! We rewrite the equation as: 274 | ! -u''(r) = f(r)*r 275 | ! where u(r) = V(r)*r. 276 | ! The weak form is: 277 | ! \int u'(r)*v'(r) \d r = \int f(x) * r * v(x) \d r 278 | ! And the boundary conditions are u(0) = 0 and u'(rmax) = 0. Finally, the 279 | ! potential is calculated as V(r) = u(r) / r. 280 | ! 281 | ! The input f0 is the function f(r) defined on Gauss-Legendre (GL) quadrature 282 | ! grid for all the elements except for the first element where f(r) is defined 283 | ! on a Gauss-Jacobi (GJ) quadrature grid with exponent zeta at the origin. 284 | ! 285 | ! The solution V(r) is returned on the same grid. 286 | ! 287 | integer, intent(in) :: p ! polynomial order to use for Y^k 288 | real(dp), intent(in) :: xe(:), xiq(:), wtq(:), xiq1(:), wtq1(:), f0(:,:) 289 | real(dp), dimension(size(xiq), size(xe)-1) :: uq, xq 290 | real(dp), intent(in) :: zeta 291 | real(dp) :: Yq(size(xiq), size(xe)-1) 292 | !real(dp) :: xn(p+1, size(xe)-1) 293 | real(dp), allocatable :: xin(:) 294 | integer, allocatable :: ib(:, :), in(:, :) 295 | integer :: Ne 296 | real(dp) :: fullc((size(xe-1)-1)*p+1), f(size(f0,1), size(f0,2)) 297 | real(dp), allocatable :: Am(:, :), bv(:), u(:) 298 | integer :: Nb 299 | Ne = size(xe)-1 300 | allocate(xin(p+1)) 301 | call get_parent_nodes(2, p, xin) 302 | allocate(in(p+1, Ne), ib(p+1, Ne)) 303 | call define_connect(1, 2, Ne, p, in, ib) 304 | ! Make sure the fullc has the right size: 305 | if ( .not. (size(fullc) == maxval(in)) ) then 306 | error stop 'Wrong size for fullc' 307 | end if 308 | 309 | call get_quad_pts(xe, xiq, xq) 310 | 311 | !print *, "Poisson: zeta =", zeta 312 | !print *, "Poisson: using GJ" 313 | f = f0 314 | 315 | Nb = maxval(ib) 316 | allocate(Am(Nb, Nb), bv(Nb), u(Nb)) 317 | call assemble_poisson_gj(f, xin, xe, ib, xiq, wtq, xiq1, wtq1, zeta, Am, bv) 318 | 319 | ! solve 320 | u = solve_sym(Am, bv) 321 | ! Transform solution from FE coefficient vector to full coefficient vector 322 | call c2fullc2(in, ib, u, fullc) 323 | ! transform solution to quadrature grid 324 | call fe2quad(xe, xin, xiq, in, fullc, Yq) 325 | 326 | call get_quad_pts(xe(:2), xiq1, xq(:,:1)) 327 | call fe2quad_gj(xe, xin, xiq, xiq1, in, fullc, Yq) 328 | uq = Yq/xq 329 | end function 330 | 331 | end module 332 | -------------------------------------------------------------------------------- /src/lapack.f90: -------------------------------------------------------------------------------- 1 | !> @brief Double precision LAPACK subroutines 2 | !> @details This is the precision that LAPACK "d" routines were compiled with (typically 3 | !> double precision, unless a special compiler option was used while compiling 4 | !> LAPACK). This "dp" is only used in lapack.f90 5 | !> The "d" routines data type is defined as "double precision", so 6 | !> we make "dp" the same kind as 0.d0 ("double precision"), so 7 | !> as long as LAPACK and this file were compiled with the same compiler options, 8 | !> it will be consistent. (If for example all double precision is promoted to 9 | !> quadruple precision, it will be promoted both in LAPACK and here.) 10 | !> 11 | !> The remaining documentation is taken from [LAPACK](http://www.netlib.org/lapack/explore-html/index.html) and can be augmented by the [quick reference guide](https://www.maths.tcd.ie/~domijank/lapack.pdf) 12 | module lapack 13 | implicit none 14 | 15 | integer, parameter:: dp=kind(0.d0) 16 | 17 | interface 18 | 19 | SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) 20 | import :: dp 21 | INTEGER INFO, LDA, LDB, N, NRHS 22 | INTEGER IPIV( * ) 23 | REAL(dp) A( LDA, * ), B( LDB, * ) 24 | END SUBROUTINE 25 | 26 | SUBROUTINE DSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO ) 27 | import :: dp 28 | CHARACTER UPLO 29 | INTEGER INFO, LDA, LDB, LWORK, N, NRHS 30 | INTEGER IPIV( * ) 31 | REAL(dp) A( LDA, * ), B( LDB, * ), WORK( * ) 32 | END SUBROUTINE 33 | 34 | SUBROUTINE DSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) 35 | import :: dp 36 | CHARACTER UPLO 37 | INTEGER INFO, LDA, LDB, N, NRHS 38 | INTEGER IPIV( * ) 39 | REAL(dp) A( LDA, * ), B( LDB, * ) 40 | END SUBROUTINE 41 | 42 | SUBROUTINE DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) 43 | import :: dp 44 | CHARACTER UPLO 45 | INTEGER INFO, LDA, LWORK, N 46 | INTEGER IPIV( * ) 47 | REAL(dp) A( LDA, * ), WORK( * ) 48 | END SUBROUTINE 49 | 50 | SUBROUTINE DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, & 51 | LIWORK, INFO ) 52 | import :: dp 53 | CHARACTER JOBZ, UPLO 54 | INTEGER INFO, LDA, LIWORK, LWORK, N 55 | INTEGER IWORK( * ) 56 | REAL(dp) A( LDA, * ), W( * ), WORK( * ) 57 | END SUBROUTINE 58 | 59 | SUBROUTINE DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, & 60 | VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, & 61 | LWORK, IWORK, IFAIL, INFO ) 62 | import :: dp 63 | CHARACTER JOBZ, RANGE, UPLO 64 | INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N 65 | REAL(dp) ABSTOL, VL, VU 66 | INTEGER IFAIL( * ), IWORK( * ) 67 | REAL(dp) A( LDA, * ), W( * ), WORK( * ), & 68 | Z( LDZ, * ) 69 | END SUBROUTINE 70 | 71 | SUBROUTINE DSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, & 72 | LWORK, IWORK, LIWORK, INFO ) 73 | import :: dp 74 | CHARACTER JOBZ, UPLO 75 | INTEGER INFO, ITYPE, LDA, LDB, LIWORK, LWORK, N 76 | INTEGER IWORK( * ) 77 | REAL(dp) A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) 78 | END SUBROUTINE 79 | 80 | REAL(dp) FUNCTION DLAMCH( CMACH ) 81 | import :: dp 82 | CHARACTER CMACH 83 | END FUNCTION 84 | end interface 85 | 86 | contains 87 | 88 | end module 89 | -------------------------------------------------------------------------------- /src/linalg.f90: -------------------------------------------------------------------------------- 1 | module linalg 2 | use types, only: dp 3 | use lapack, only: dsyevd, dsygvd, dgesv 4 | implicit none 5 | private 6 | public eigh, solve 7 | 8 | interface eigh 9 | module procedure deigh_generalized 10 | module procedure deigh_generalized_values 11 | module procedure deigh_simple 12 | end interface eigh 13 | 14 | contains 15 | 16 | subroutine deigh_generalized(Am, Bm, lam, c) 17 | ! solves generalized eigen value problem for all eigenvalues and eigenvectors 18 | ! Am must by symmetric, Bm symmetric positive definite. 19 | ! Only the lower triangular part of Am and Bm is used. 20 | real(dp), intent(in) :: Am(:,:) ! LHS matrix: Am c = lam Bm c 21 | real(dp), intent(in) :: Bm(:,:) ! RHS matrix: Am c = lam Bm c 22 | real(dp), intent(out) :: lam(:) ! eigenvalues: Am c = lam Bm c 23 | real(dp), intent(out) :: c(:,:) ! eigenvectors: Am c = lam Bm c; c(i,j) = ith component of jth vec. 24 | integer :: n 25 | ! lapack variables 26 | integer :: lwork, liwork, info 27 | integer, allocatable :: iwork(:) 28 | real(dp), allocatable :: Bmt(:,:), work(:) 29 | 30 | ! solve 31 | n = size(Am,1) 32 | call assert_shape(Am, [n, n], "eigh", "Am") 33 | call assert_shape(Bm, [n, n], "eigh", "B") 34 | call assert_shape(c, [n, n], "eigh", "c") 35 | lwork = 1 + 6*n + 2*n**2 36 | liwork = 3 + 5*n 37 | allocate(Bmt(n,n), work(lwork), iwork(liwork)) 38 | c = Am; Bmt = Bm ! Bmt temporaries overwritten by dsygvd 39 | call dsygvd(1,'V','L',n,c,n,Bmt,n,lam,work,lwork,iwork,liwork,info) 40 | if (info /= 0) then 41 | print *, "dsygvd returned info =", info 42 | if (info < 0) then 43 | print *, "the", -info, "-th argument had an illegal value" 44 | else if (info <= n) then 45 | print *, "the algorithm failed to compute an eigenvalue while working" 46 | print *, "on the submatrix lying in rows and columns", 1.0_dp*info/(n+1) 47 | print *, "through", mod(info, n+1) 48 | else 49 | print *, "The leading minor of order ", info-n, & 50 | "of B is not positive definite. The factorization of B could ", & 51 | "not be completed and no eigenvalues or eigenvectors were computed." 52 | end if 53 | error stop 'eigh: dsygvd error' 54 | end if 55 | end subroutine deigh_generalized 56 | 57 | subroutine deigh_generalized_values(Am, Bm, lam) 58 | ! solves generalized eigen value problem for all eigenvalues 59 | ! Am must by symmetric, Bm symmetric positive definite. 60 | ! Only the upper triangular part of Am and Bm is used. 61 | real(dp), intent(in) :: Am(:,:) ! LHS matrix: Am c = lam Bm c 62 | real(dp), intent(in) :: Bm(:,:) ! RHS matrix: Am c = lam Bm c 63 | real(dp), intent(out) :: lam(:) ! eigenvalues: Am c = lam Bm c 64 | integer :: n 65 | ! lapack variables 66 | integer :: lwork, liwork, info 67 | integer, allocatable :: iwork(:) 68 | real(dp), allocatable :: work(:) 69 | real(dp) :: c(size(Am, 1), size(Am, 2)), Bmt(size(Bm, 1), size(Bm, 2)) 70 | 71 | ! solve 72 | n = size(Am,1) 73 | call assert_shape(Am, [n, n], "eigh", "Am") 74 | call assert_shape(Bm, [n, n], "eigh", "B") 75 | lwork = 1 + 2*n 76 | liwork = 1 77 | allocate(work(lwork), iwork(liwork)) 78 | c = Am; Bmt = Bm ! Bmt temporaries overwritten by dsygvd 79 | call dsygvd(1,'N','U',n,c,n,Bmt,n,lam,work,lwork,iwork,liwork,info) 80 | if (info /= 0) then 81 | print *, "dsygvd returned info =", info 82 | if (info < 0) then 83 | print *, "the", -info, "-th argument had an illegal value" 84 | else if (info <= n) then 85 | print *, " the algorithm failed to converge; " 86 | print *, info, " off-diagonal elements of an intermediate tridiagonal form " 87 | print *, "did not converge to zero" 88 | else 89 | print *, "The leading minor of order ", info-n, & 90 | "of B is not positive definite. The factorization of B could ", & 91 | "not be completed and no eigenvalues or eigenvectors were computed." 92 | end if 93 | error stop 'eigh: dsygvd error' 94 | end if 95 | end subroutine deigh_generalized_values 96 | 97 | subroutine deigh_simple(Am, lam, c) 98 | ! solves eigen value problem for all eigenvalues and eigenvectors 99 | ! Am must by symmetric 100 | ! Only the lower triangular part of Am is used. 101 | real(dp), intent(in) :: Am(:,:) ! LHS matrix: Am c = lam c 102 | real(dp), intent(out) :: lam(:) ! eigenvalues: Am c = lam c 103 | real(dp), intent(out) :: c(:,:) ! eigenvectors: Am c = lam c; c(i,j) = ith component of jth vec. 104 | integer :: n 105 | ! lapack variables 106 | integer :: lwork, liwork, info 107 | integer, allocatable :: iwork(:) 108 | real(dp), allocatable :: work(:) 109 | 110 | ! solve 111 | n = size(Am,1) 112 | call assert_shape(Am, [n, n], "eigh", "Am") 113 | call assert_shape(c, [n, n], "eigh", "c") 114 | lwork = 1 + 6*n + 2*n**2 115 | liwork = 3 + 5*n 116 | allocate(work(lwork), iwork(liwork)) 117 | c = Am 118 | call dsyevd('V','L',n,c,n,lam,work,lwork,iwork,liwork,info) 119 | if (info /= 0) then 120 | print *, "dsyevd returned info =", info 121 | if (info < 0) then 122 | print *, "the", -info, "-th argument had an illegal value" 123 | else 124 | print *, "the algorithm failed to compute an eigenvalue while working" 125 | print *, "on the submatrix lying in rows and columns", 1.0_dp*info/(n+1) 126 | print *, "through", mod(info, n+1) 127 | end if 128 | error stop 'eigh: dsyevd error' 129 | end if 130 | end subroutine deigh_simple 131 | 132 | function solve(A, b) result(x) 133 | ! solves a system of equations A x = b with one right hand side 134 | real(dp), intent(in) :: A(:,:) ! coefficient matrix A 135 | real(dp), intent(in) :: b(:) ! right-hand-side A x = b 136 | real(dp), allocatable :: x(:) 137 | ! LAPACK variables: 138 | real(dp), allocatable :: At(:,:), bt(:,:) 139 | integer :: n, info, lda 140 | integer, allocatable :: ipiv(:) 141 | 142 | n = size(A(1,:)) 143 | lda = size(A(:, 1)) ! TODO: remove lda (which is = n!) 144 | call assert_shape(A, [n, n], "solve", "A") 145 | allocate(At(lda,n), bt(n,1), ipiv(n), x(n)) 146 | At = A 147 | bt(:,1) = b(:) 148 | call dgesv(n, 1, At, lda, ipiv, bt, n, info) 149 | if(info /= 0) then 150 | print *, "dgesv returned info =", info 151 | if (info < 0) then 152 | print *, "the", -info, "-th argument had an illegal value" 153 | else 154 | print *, "U(", info, ",", info, ") is exactly zero; The factorization" 155 | print *, "has been completed, but the factor U is exactly" 156 | print *, "singular, so the solution could not be computed." 157 | end if 158 | error stop 'inv: dgesv error' 159 | endif 160 | x = bt(:,1) 161 | end function solve 162 | 163 | subroutine assert_shape(A, shap, routine, matname) 164 | ! make sure a given real matrix has a given shape 165 | real(dp), intent(in) :: A(:,:) 166 | integer, intent(in) :: shap(:) 167 | character(len=*) :: routine, matname 168 | 169 | if(any(shape(A) /= shap)) then 170 | print *, "In routine " // routine // " matrix " // matname // " has illegal shape ", shape(A) 171 | print *, "Shape should be ", shap 172 | error stop "Aborting due to illegal matrix operation" 173 | end if 174 | end subroutine assert_shape 175 | 176 | end module linalg 177 | -------------------------------------------------------------------------------- /src/mesh.f90: -------------------------------------------------------------------------------- 1 | !> @brief This module is used to generate meshes and derivatives 2 | !> @details The supported meshes are currently: 3 | !> - Linearly spaced 4 | !> - Exponential meshes 5 | !> The time step used for derivatives is a uniformly spaced series of integers from 1 to N+1. 6 | module mesh 7 | 8 | use types, only: dp 9 | 10 | implicit none 11 | 12 | private 13 | public meshexp, meshexp_der, get_meshexp_pars, meshexp_der2, & 14 | linspace, meshgrid 15 | 16 | contains 17 | 18 | !> @brief This function generates an exponential mesh of N elements on @f$ [r_{\mathrm{min}}, r_{\mathrm{max}}] @f$ 19 | !> @param[in] rmin Inclusive endpoint 20 | !> @param[in] rmax Inclusive endpoint 21 | !> @param[in] a Ratio of the rightmost and leftmost elements in the mesh, 22 | !> controls the mesh spacing. Must satisfy @f$ a > 0 @f$. For @f$ a == 1 @f$ a uniform mesh is 23 | !> returned. For @f$ a > 1 @f$ this is the largest/smallest ratio. 24 | !> @param[in] N The number of elements in the mesh. 25 | !> @returns mesh The generated mesh as an array of N+1 one elements 26 | !> 27 | !> @details Every exponential mesh is fully determined by the set of parameters 28 | !> `(rmin, rmax, a, N)`. Use the @ref get_meshexp_pars() subroutine to obtain them 29 | !> from the given mesh. 30 | !> 31 | !> @b Example: 32 | !> 33 | !> real(dp) :: r(11) 34 | !> r = meshexp(0._dp, 50._dp, 1e9_dp, 10) 35 | function meshexp(rmin, rmax, a, N) result(mesh) 36 | ! The domain [rmin, rmax], the mesh will contain both endpoints. 37 | real(dp), intent(in) :: rmin, rmax 38 | ! The ratio of the rightmost to leftmost element lengths in the mesh 39 | real(dp), intent(in) :: a 40 | ! The number of elements in the mesh: 41 | integer, intent(in) :: N 42 | ! The generated mesh: 43 | real(dp) :: mesh(N+1) 44 | 45 | integer :: i 46 | real(dp) :: alpha, beta 47 | if (a < 0) then 48 | error stop "meshexp: a > 0 required" 49 | else if (abs(a - 1) < tiny(1._dp)) then 50 | alpha = (rmax - rmin) / N 51 | do i = 1, N+1 52 | mesh(i) = alpha * (i-1.0_dp) + rmin 53 | end do 54 | else 55 | if (N > 1) then 56 | beta = log(a) / (N-1) 57 | alpha = (rmax - rmin) / (exp(beta*N) - 1) 58 | do i = 1, N+1 59 | mesh(i) = alpha * (exp(beta*(i-1)) - 1) + rmin 60 | end do 61 | else if (N == 1) then 62 | mesh(1) = rmin 63 | mesh(2) = rmax 64 | else 65 | error stop "meshexp: N >= 1 required" 66 | end if 67 | end if 68 | end function 69 | 70 | !> @brief Generates the first derivative dR/dt where R(t) is the mesh returned by @ref meshexp() 71 | !> @param[in] rmin Inclusive endpoint 72 | !> @param[in] rmax Inclusive endpoint 73 | !> @param[in] a Ratio of the rightmost and leftmost elements in the mesh, 74 | !> controls the mesh spacing. Must satisfy @f$ a > 0 @f$. For @f$ a == 1 @f$ a uniform mesh is 75 | !> returned. For @f$ a > 1 @f$ this is the largest/smallest ratio. 76 | !> @param[in] N The number of elements in the mesh. 77 | !> @returns Rp(N+1) The first derivative w.r.t time for the mesh as an array of N+1 one elements 78 | !> 79 | !> @details The input parameters are the same as for @ref meshexp(). 80 | !> The variable "t" is defined by: 81 | !> t = 1, 2, ..., N+1 82 | !> So it describes a uniform mesh, with a step size 1, and the corresponding 83 | !> physical points are given by the R(t) array. 84 | function meshexp_der(rmin, rmax, a, N) result(Rp) 85 | real(dp), intent(in) :: rmin 86 | real(dp), intent(in) :: rmax 87 | real(dp), intent(in) :: a 88 | integer, intent(in) :: N 89 | real(dp) :: Rp(N+1) 90 | 91 | integer :: i 92 | real(dp) :: alpha, beta 93 | if (a < 0) then 94 | error stop "meshexp_der: a > 0 required" 95 | else if (abs(a - 1) < tiny(1._dp)) then 96 | error stop "meshexp_der: a == 1 not implemented" 97 | else 98 | if (N > 1) then 99 | beta = log(a)/(N-1) 100 | alpha = (rmax - rmin) / (exp(beta*N) - 1) 101 | do i = 1, N+1 102 | Rp(i) = alpha * beta * exp(beta*(i-1)) 103 | end do 104 | else 105 | error stop "meshexp_der: N > 1 required" 106 | end if 107 | end if 108 | end function 109 | 110 | !> @brief Generates the second derivative d^R/dt^2 where R(t) is the mesh returned by @ref meshexp() 111 | !> @param[in] rmin Inclusive endpoint 112 | !> @param[in] rmax Inclusive endpoint 113 | !> @param[in] a Ratio of the rightmost and leftmost elements in the mesh, 114 | !> controls the mesh spacing. Must satisfy @f$ a > 0 @f$. For @f$ a == 1 @f$ a uniform mesh is 115 | !> returned. For @f$ a > 1 @f$ this is the largest/smallest ratio. 116 | !> @param[in] N The number of elements in the mesh. 117 | !> @returns Rpp(N+1) The second derivative w.r.t time for the mesh as an array of N+1 one elements 118 | !> 119 | !> @details The input parameters are the same as for @ref meshexp(). 120 | !> The variable "t" is defined by: 121 | !> t = 1, 2, ..., N+1 122 | !> So it describes a uniform mesh, with a step size 1, and the corresponding 123 | !> physical points are given by the R(t) array. 124 | function meshexp_der2(rmin, rmax, a, N) result(Rpp) 125 | real(dp), intent(in) :: rmin 126 | real(dp), intent(in) :: rmax 127 | real(dp), intent(in) :: a 128 | integer, intent(in) :: N 129 | real(dp) :: Rpp(N+1) 130 | 131 | integer :: i 132 | real(dp) :: alpha, beta 133 | if (a < 0) then 134 | error stop "meshexp_der2: a > 0 required" 135 | else if (abs(a - 1) < tiny(1._dp)) then 136 | error stop "meshexp_der2: a == 1 not implemented" 137 | else 138 | if (N > 1) then 139 | beta = log(a)/(N-1) 140 | alpha = (rmax - rmin) / (exp(beta*N) - 1) 141 | do i = 1, N+1 142 | Rpp(i) = alpha * beta**2 * exp(beta*(i-1)) 143 | end do 144 | else 145 | error stop "meshexp_der2: N > 1 required" 146 | end if 147 | end if 148 | end function 149 | 150 | !> @brief Given any exponential mesh R, it determines the parameters 151 | !> @param[in] R The input mesh array 152 | !> @param[out] rmin Inclusive endpoint 153 | !> @param[out] rmax Inclusive endpoint 154 | !> @param[out] a Ratio of the rightmost and leftmost elements in the mesh, 155 | !> controls the mesh spacing. Must satisfy @f$ a > 0 @f$. For @f$ a == 1 @f$ a uniform mesh is 156 | !> returned. For @f$ a > 1 @f$ this is the largest/smallest ratio. 157 | !> @param[out] N The number of elements in the mesh. 158 | !> 159 | !> @details This only looks at the number of elements, the leftmost and the rightmost 160 | !> elements (so the middle elements are not checked/taken into account). 161 | subroutine get_meshexp_pars(R, rmin, rmax, a, N) 162 | real(dp), intent(in) :: R(:) 163 | real(dp), intent(out) :: rmin, rmax, a 164 | integer, intent(out) :: N 165 | rmin = R(1) 166 | rmax = R(size(R)) 167 | a = (R(size(R)) - R(size(R)-1)) / (R(2) - R(1)) 168 | N = size(R) - 1 169 | end subroutine 170 | 171 | !> @brief A helper function to generate a linearly spaced mesh 172 | !> @param[in] a Inclusive endpoint 173 | !> @param[in] b Inclusive endpoint 174 | !> @param[in] n The number of elements in the mesh. 175 | !> @returns s(n) The generated mesh as an array of N+1 one elements 176 | !> @see meshexp() 177 | !> 178 | !> @details This calls @ref meshexp() 179 | function linspace(a, b, n) result(s) 180 | real(dp), intent(in) :: a, b 181 | integer, intent(in) :: n 182 | real(dp) :: s(n) 183 | s = meshexp(a, b, 1.0_dp, n-1) 184 | end function 185 | 186 | !> @brief A helper subroutine to generate a two dimensional mesh 187 | !> @param[in] x Mesh along dimension 1 188 | !> @param[in] y Mesh along dimension 2 189 | !> @param[out] x2 Mesh elements replicated y times along dimension 1 190 | !> @param[out] y2 Mesh elements replicated x times along dimension 2 191 | subroutine meshgrid(x, y, x2, y2) 192 | real(dp), intent(in) :: x(:), y(:) 193 | real(dp), intent(out) :: x2(:, :), y2(:, :) 194 | x2 = spread(x, 1, size(y)) 195 | y2 = spread(y, 2, size(x)) 196 | end subroutine 197 | 198 | end module 199 | -------------------------------------------------------------------------------- /src/meson.build: -------------------------------------------------------------------------------- 1 | # Source files 2 | _srcs = [ 3 | 'constants.f90', 4 | 'dirac.f90', 5 | 'energies.f90', 6 | 'fe.f90', 7 | 'feutils.f90', 8 | 'graphs.f90', 9 | 'graphs_potential.f90', 10 | 'hartree_screening.f90', 11 | 'lapack.f90', 12 | 'linalg.f90', 13 | 'mesh.f90', 14 | 'mixings.f90', 15 | 'quadrature.f90', 16 | 'schroed_dirac_solver.f90', 17 | 'schroed_glob.f90', 18 | 'solvers.f90', 19 | 'states.f90', 20 | 'string_utils.f90', 21 | 'types.f90', 22 | 'xc.f90', 23 | ] 24 | 25 | # Dependencies 26 | gauss_jacobilib = library('gjp_gw', 27 | ['gjp_gw_single.f90'], 28 | dependencies: _deps, 29 | cpp_args: _args, 30 | link_with: _linkto, 31 | include_directories: _incdirs, 32 | install: true) 33 | 34 | _linkto += [gauss_jacobilib] 35 | 36 | # Create library 37 | featomlib = library('featom', 38 | _srcs, 39 | dependencies: _deps, 40 | cpp_args: _args, 41 | link_with: _linkto, 42 | include_directories: _incdirs, 43 | install: true) 44 | 45 | featom_dep = declare_dependency( 46 | include_directories: _incdirs, 47 | link_with: _linkto + [featomlib], 48 | dependencies: _deps) 49 | -------------------------------------------------------------------------------- /src/mixings.f90: -------------------------------------------------------------------------------- 1 | module mixings 2 | 3 | ! This module contains SCF mixing algorithms. 4 | 5 | use types, only: dp 6 | use linalg, only: solve 7 | implicit none 8 | private 9 | public mixing_linear, mixing_anderson, mixing_pulay 10 | 11 | interface 12 | subroutine F_fn(x, y, energies) 13 | ! y = F(x), also return the calculated energies to converge 14 | import :: dp 15 | implicit none 16 | real(dp), intent(in) :: x(:) 17 | real(dp), intent(out) :: y(:), energies(:) 18 | end subroutine 19 | 20 | real(dp) function integral_fn(x) 21 | ! Computes the integral of the vector 'x' 22 | import :: dp 23 | implicit none 24 | real(dp), intent(in) :: x(:) 25 | end function 26 | 27 | function matvec_fn(A, v) result(r) 28 | ! Computes the matmul(A, v) 29 | import :: dp 30 | implicit none 31 | real(dp), intent(in) :: A(:,:), v(:) 32 | real(dp) :: r(size(A,1)) 33 | end function 34 | 35 | function matmat_fn(A, B) result(r) 36 | ! Computes the matmul(A, B) 37 | import :: dp 38 | implicit none 39 | real(dp), intent(in) :: A(:,:), B(:,:) 40 | real(dp) :: r(size(A,1),size(B,2)) 41 | end function 42 | 43 | end interface 44 | 45 | contains 46 | 47 | subroutine mixing_linear(F, integral, x0, nenergies, max_iter, alpha, & 48 | L2_eps, eig_eps, x_out) 49 | ! Finds "x" so that F(x) = x 50 | procedure(F_fn) :: F 51 | procedure(integral_fn) :: integral 52 | real(dp), intent(in) :: x0(:) 53 | integer, intent(in) :: nenergies, max_iter 54 | real(dp), intent(in) :: alpha 55 | real(dp), intent(in) :: L2_eps, eig_eps 56 | real(dp), intent(out) :: x_out(:) 57 | 58 | real(dp), dimension(size(x0)) :: x_i, y_i, R_i 59 | real(dp) :: old_energies(nenergies), energies(nenergies) 60 | real(dp) :: x_i_norm, R_i_norm 61 | real(dp) :: err_old, err, L2_err 62 | integer :: i 63 | x_i = x0 64 | err_old = 1e12_dp 65 | old_energies = 1e12_dp 66 | do i = 1, max_iter 67 | call F(x_i, y_i, energies) 68 | R_i = y_i-x_i 69 | 70 | ! L2 norm of the "input" potential: 71 | x_i_norm = sqrt(integral(x_i**2)) 72 | ! L2 norm of the "output-input" potential: 73 | R_i_norm = sqrt(integral(R_i**2)) 74 | if (x_i_norm < 1e-12_dp) x_i_norm = 1e-12_dp 75 | L2_err = R_i_norm / x_i_norm 76 | err = maxval(abs(energies - old_energies)) 77 | ! Do at least 3 iterations 78 | if (i >= 3 .and. L2_err < L2_eps) then 79 | if (err < eig_eps .and. err_old < eig_eps) then 80 | x_out = x_i 81 | return 82 | end if 83 | end if 84 | old_energies = energies 85 | err_old = err 86 | 87 | x_i = x_i + alpha * R_i 88 | end do 89 | error stop "SCF didn't converge" 90 | end subroutine 91 | 92 | subroutine mixing_anderson(F, integral, x0, nenergies, max_iter, alpha, & 93 | L2_eps, eig_eps, x_out) 94 | ! Finds "x" so that F(x) = x, uses x0 as the initial estimate 95 | procedure(F_fn) :: F 96 | procedure(integral_fn) :: integral 97 | real(dp), intent(in) :: x0(:) 98 | integer, intent(in) :: nenergies, max_iter 99 | real(dp), intent(in) :: alpha 100 | real(dp), intent(in) :: L2_eps, eig_eps 101 | real(dp), intent(out) :: x_out(:) 102 | 103 | real(dp), dimension(size(x0)) :: x_i, y_i, x1_i, R_i, R1_i, delta_R, delta_x 104 | real(dp) :: beta 105 | real(dp) :: sn, sd 106 | real(dp) :: old_energies(nenergies), energies(nenergies) 107 | real(dp) :: x_i_norm, R_i_norm 108 | real(dp) :: err_old, err, L2_err 109 | integer :: i 110 | x_i = x0 111 | err_old = 1e12_dp 112 | old_energies = 1e12_dp 113 | do i = 1, max_iter 114 | call F(x_i, y_i, energies) 115 | R_i = y_i-x_i 116 | 117 | ! L2 norm of the "input" potential: 118 | x_i_norm = sqrt(integral(x_i**2)) 119 | ! L2 norm of the "output-input" potential: 120 | R_i_norm = sqrt(integral(R_i**2)) 121 | if (x_i_norm < 1e-12_dp) x_i_norm = 1e-12_dp 122 | L2_err = R_i_norm / x_i_norm 123 | err = maxval(abs(energies - old_energies)) 124 | ! Do at least 3 iterations 125 | if (i >= 3 .and. L2_err < L2_eps) then 126 | if (err < eig_eps .and. err_old < eig_eps) then 127 | x_out = x_i 128 | return 129 | end if 130 | end if 131 | old_energies = energies 132 | err_old = err 133 | 134 | if (i > 1) then 135 | delta_x = x_i - x1_i 136 | delta_R = R_i - R1_i 137 | end if 138 | x1_i = x_i 139 | R1_i = R_i 140 | x_i = x_i + alpha * R_i 141 | if (i > 1) then 142 | sn = integral(R_i * delta_R) 143 | sd = integral(delta_R**2) 144 | beta = sn / sd 145 | x_i = x_i - beta * (delta_x + alpha * delta_R) 146 | end if 147 | end do 148 | error stop "SCF didn't converge" 149 | end subroutine 150 | 151 | subroutine mixing_pulay(g, integral, matvec, matmat, x0, nenergies, max_iter, & 152 | alpha, L2_eps, eig_eps, x_out, n, k) 153 | ! Finds "x" so that x = g(x) 154 | ! Implements Algorithm 1. from [1], we use the same notation, except we call 155 | ! the independent variable "x" instead of "rho": 156 | ! do i = 1, 2, ... 157 | ! f_i = g(x_i) - x_i 158 | ! if modulo(i+1, k) == 0 159 | ! x_i = x_i + alpha*f_i - (R_i+alpha*F_i)*(F_i^T F_i)^-1 F_i^T f_i 160 | ! else 161 | ! x_i = x_i + alpha*f_i 162 | ! until |f_i| < tol 163 | ! 164 | ! [1] Banerjee, A. S., Suryanarayana, P., Pask, J. E. (2016). Periodic Pulay 165 | ! method for robust and efficient convergence acceleration of self-consistent 166 | ! field iterations. Chemical Physics Letters, 647, 31–35. 167 | ! http://doi.org/10.1016/j.cplett.2016.01.033 168 | procedure(F_fn) :: g 169 | procedure(integral_fn) :: integral 170 | procedure(matvec_fn) :: matvec 171 | procedure(matmat_fn) :: matmat 172 | real(dp), intent(in) :: x0(:) 173 | integer, intent(in) :: nenergies, max_iter, n, k 174 | real(dp), intent(in) :: alpha 175 | real(dp), intent(in) :: L2_eps, eig_eps 176 | real(dp), intent(out) :: x_out(:) 177 | 178 | real(dp), dimension(size(x0)) :: x_i, y_i, f_i 179 | real(dp) :: old_energies(nenergies), energies(nenergies) 180 | real(dp) :: x_i_norm, f_i_norm 181 | real(dp) :: err_old, err, L2_err 182 | integer :: i, j 183 | 184 | ! TODO: do not store the whole history in "f" and "x", but only the last "n" 185 | ! iterations: 186 | real(dp) :: Ri(size(x0),n), Fi(size(x0),n), f(size(x0),max_iter), & 187 | x(size(x0),max_iter), FTF_inv(n,n), FTf(n) 188 | 189 | x_i = x0 190 | err_old = 1e12_dp 191 | old_energies = 1e12_dp 192 | do i = 1, max_iter 193 | call g(x_i, y_i, energies) 194 | f_i = y_i-x_i 195 | x(:,i) = x_i 196 | f(:,i) = f_i 197 | 198 | ! L2 norm of the "input" potential: 199 | x_i_norm = sqrt(integral(x_i**2)) 200 | ! L2 norm of the "output-input" potential: 201 | f_i_norm = sqrt(integral(f_i**2)) 202 | if (x_i_norm < 1e-12_dp) x_i_norm = 1e-12_dp 203 | L2_err = f_i_norm / x_i_norm 204 | err = maxval(abs(energies - old_energies)) 205 | ! Do at least 3 iterations 206 | if (i >= 3 .and. L2_err < L2_eps) then 207 | print *, "SCF convergence error:", err 208 | if (err < eig_eps .and. err_old < eig_eps) then 209 | x_out = x_i 210 | return 211 | end if 212 | end if 213 | old_energies = energies 214 | err_old = err 215 | 216 | if (i > n .and. modulo(i, k) == 0) then 217 | do j = i-n+1, i 218 | Ri(:,j-i+n) = x(:,j)-x(:,j-1) 219 | Fi(:,j-i+n) = f(:,j)-f(:,j-1) 220 | end do 221 | FTF_inv = matmat(transpose(Fi), Fi) 222 | FTf = matvec(transpose(Fi), f_i) 223 | x_i = x_i + alpha * f_i - matmul((Ri+alpha*Fi), solve(FTF_inv, FTf)) 224 | else 225 | x_i = x_i + alpha * f_i 226 | end if 227 | end do 228 | error stop "SCF didn't converge" 229 | end subroutine 230 | 231 | end module 232 | -------------------------------------------------------------------------------- /src/schroed_dirac_solver.f90: -------------------------------------------------------------------------------- 1 | module schroed_dirac_solver 2 | use types, only: dp 3 | use constants, only: pi 4 | use mesh, only: meshexp 5 | use schroed_glob, only: solve_schroed 6 | use dirac, only: solve_dirac, solve_dirac_eigenproblem 7 | use feutils, only: define_connect, get_quad_pts, get_parent_quad_pts_wts, & 8 | get_parent_nodes, phih, dphih, phih_array, dphih_array, c2fullc2, & 9 | fe2quad, fe2quad_core 10 | use fe, only: assemble_radial_S, assemble_radial_H, assemble_radial_dirac_SH 11 | use gjp_gw, only: gauss_jacobi_gw 12 | use linalg, only: eigh 13 | use string_utils, only: str 14 | implicit none 15 | 16 | contains 17 | 18 | subroutine total_energy(Z, rmax, Ne, a, p, Nq, DOFs, alpha_int, dirac_int, & 19 | c, potential_type, Lmin, alpha_j, alpha, lam, eigfn, xq) 20 | integer, intent(in) :: Z, Ne, Nq, p, alpha_int, dirac_int, potential_type, & 21 | Lmin 22 | real(dp), intent(in) :: rmax, a, c, alpha_j(Lmin:), alpha(Lmin:) 23 | integer, intent(out) :: DOFs 24 | real(dp), allocatable, intent(out) :: lam(:), eigfn(:,:,:) 25 | real(dp), intent(out) :: xq(Nq, Ne) 26 | real(dp), allocatable :: xe(:), xiq(:), wtq(:), V(:,:), Vin(:,:), xin(:), & 27 | H(:,:), S(:), S2(:,:), DSQ(:), phihq(:,:), dphihq(:,:), xiq_lob(:), wtq_lob(:), & 28 | D(:,:), lam2(:), xiq1(:), wtq1(:), xq1(:,:), fullc(:), uq(:,:), rho(:,:), & 29 | focc(:,:), lam_tmp(:), rho1(:,:), xiq_gj(:,:), wtq_gj(:,:) 30 | integer, allocatable :: in(:,:), ib(:,:), focc_idx(:,:) 31 | real(dp) :: rmin 32 | integer :: al, i, j, l, k, ind, kappa, Nb, Nn, idx, Lmin2, Lmax 33 | real(dp) :: E_dirac_shift 34 | rmin = 0 35 | allocate(xe(Ne+1), xiq(Nq), xiq1(Nq), wtq(Nq), wtq1(Nq), V(Nq, Ne), xiq_lob(p+1), wtq_lob(p+1)) 36 | allocate(phihq(Nq, p+1), dphihq(Nq, p+1), in(p+1, Ne), ib(p+1, Ne), xin(p+1), xq1(Nq,1)) 37 | 38 | xe = meshexp(rmin, rmax, a, Ne) 39 | call get_parent_quad_pts_wts(1, Nq, xiq, wtq) 40 | call get_parent_quad_pts_wts(2, p+1, xiq_lob, wtq_lob) 41 | call get_parent_nodes(2, p, xin) 42 | call get_quad_pts(xe, xiq, xq) 43 | 44 | ! tabulate parent basis at quadrature points 45 | do al = 1, p+1 46 | call phih_array(xin, al, xiq, phihq(:, al)) 47 | call dphih_array(xin, al, xiq, dphihq(:, al)) 48 | end do 49 | 50 | call define_connect(1, 1, Ne, p, in, ib) 51 | if (dirac_int == 1 .and. alpha_int == -1) then 52 | call define_connect(2, 1, Ne, p, in, ib) 53 | end if 54 | Nb = maxval(ib) 55 | DOFS = Nb 56 | if (dirac_int == 1) then 57 | DOFS = 2 * Nb 58 | allocate(S2(DOFS, DOFS)) 59 | end if 60 | Nn = Ne*p+1 61 | if ( .not. (Nn == maxval(in)) ) then 62 | error stop 'Wrong size for Nn' 63 | end if 64 | 65 | allocate(H(DOFS, DOFS), S(DOFS), DSQ(DOFS), uq(Nq,Ne)) 66 | allocate(D(DOFS, DOFS), lam2(DOFS), rho(Nq,Ne), fullc(Nn)) 67 | if (dirac_int == 1) then 68 | allocate(lam(47)) 69 | allocate(eigfn(Nq, Ne, 49)) 70 | else 71 | allocate(lam(28)) 72 | allocate(eigfn(Nq, Ne, 28)) 73 | end if 74 | 75 | allocate(Vin(size(xq,1), size(xq,2))) 76 | 77 | if (potential_type == 0) then 78 | V = -Z/xq 79 | Vin = 0 80 | E_dirac_shift = 500 81 | else 82 | Vin = xq**2/2 83 | V = Vin 84 | E_dirac_shift = 1000 85 | end if 86 | if (dirac_int == 1) then 87 | V = V - E_dirac_shift 88 | end if 89 | 90 | if (dirac_int == 0) then 91 | do l = 0, 6 92 | call assemble_radial_H(V, l, xin, xe, ib, xiq, wtq, phihq, dphihq, H) 93 | call assemble_radial_S(xin, xe, ib, wtq_lob, S) 94 | do i = 1, Nb 95 | DSQ(i) = 1/sqrt(S(i)) 96 | end do 97 | do concurrent (i = 1:Nb, j = 1:Nb) 98 | H(i, j) = H(i, j)*DSQ(i)*DSQ(j) 99 | end do 100 | call eigh(H, lam2, D) 101 | do i = 1, size(S) 102 | D(i,:) = D(i,:)*DSQ(i) 103 | end do 104 | do k = 0, 6-l 105 | ind = (k+l)*(k+l+1)/2+l+1 106 | if (k+1 > size(lam2)) then 107 | lam(ind) = 0 108 | eigfn(:,:,ind) = 0 109 | else 110 | lam(ind) = lam2(k+1) 111 | call c2fullc2(in, ib, D(:Nb,k+1), fullc) 112 | call fe2quad_core(xe, xin, in, fullc, phihq, uq) 113 | eigfn(:,:,ind) = uq/xq 114 | end if 115 | end do 116 | end do 117 | else 118 | Lmin2 = -6 119 | Lmax = 5 120 | allocate(xiq_gj(size(xiq1),Lmin:Lmax)) 121 | allocate(wtq_gj(size(wtq1),Lmin:Lmax)) 122 | allocate(rho1(Nq,Ne)) 123 | 124 | ! Initialize focc and focc_idx 125 | allocate(focc(max(Lmax,abs(Lmin2))+1,Lmin2:Lmax)) 126 | allocate(focc_idx(max(Lmax,abs(Lmin2))+1,Lmin2:Lmax)) 127 | focc = 0 128 | focc_idx = 0 129 | do kappa = Lmin2, Lmax 130 | if (kappa == 0) cycle 131 | if (alpha_j(kappa) > -1) then 132 | call gauss_jacobi_gw(Nq, 0.0_dp, alpha_j(kappa), xiq1, wtq1) 133 | xiq_gj(:,kappa) = xiq1 134 | wtq_gj(:,kappa) = wtq1 135 | end if 136 | if (kappa < 0) then 137 | l = -kappa-1 138 | else 139 | l = kappa 140 | end if 141 | do k = 1, 7-l 142 | ind = (kappa+1)*(kappa+1)+(k-1)*(2*kappa+1)+(k-1)*(k-2) 143 | if (kappa < 0) then 144 | ind = ind + 2*k-2+(4*k-2)*(-1-kappa) 145 | end if 146 | if (kappa == -1) then 147 | ind = ind + 1 148 | end if 149 | focc_idx(k,kappa) = ind 150 | focc(k,kappa) = 1 151 | end do 152 | end do 153 | call solve_dirac_eigenproblem(Nb, Nq, Lmin2, Lmax, alpha, alpha_j, xe, xiq_gj, & 154 | xq, xq1, wtq_gj, V, Z, Vin, D, S2, H, lam2, rho, rho1, .false., fullc, & 155 | ib, in, idx, lam_tmp, uq, wtq, xin, xiq, focc, focc_idx, lam, xq, & 156 | E_dirac_shift) 157 | end if 158 | end subroutine total_energy 159 | 160 | end module 161 | -------------------------------------------------------------------------------- /src/schroed_glob.f90: -------------------------------------------------------------------------------- 1 | module schroed_glob 2 | 3 | use types, only: dp 4 | use mesh, only: meshexp 5 | use feutils, only: define_connect, get_quad_pts, get_parent_quad_pts_wts, & 6 | get_parent_nodes, phih, dphih, c2fullc2, fe2quad_core, get_nodes, & 7 | integrate, proj_fn, phih_array, dphih_array 8 | use linalg, only: eigh 9 | use fe, only: assemble_radial_H, assemble_radial_S, assemble_radial_H_setup, & 10 | assemble_radial_H_complete 11 | use constants, only: pi 12 | use hartree_screening, only: assemble_poisson_A, hartree_potential3 13 | use xc, only: xc_vwn3 14 | use mixings, only: mixing_linear, mixing_pulay 15 | use states, only: get_atomic_states_nonrel_focc, get_atomic_states_rel_focc, & 16 | nlsf2focc, get_atomic_states_rel, nlf2focc, get_atomic_states_nonrel 17 | use energies, only: thomas_fermi_potential 18 | use iso_c_binding, only: c_double, c_int 19 | use solvers, only: solve_eig_irange, solve_sym_setup 20 | use lapack, only: dsytrf, dsytrs 21 | implicit none 22 | private 23 | public solve_schroed!, csolve_schroed, total_energy 24 | 25 | contains 26 | 27 | subroutine solve_schroed(Z, p, xiq, wtq, xe, eps, energies, Etot, V, DOFs) 28 | 29 | integer, intent(in) :: Z, p 30 | real(dp), intent(in) :: xe(:) ! element coordinates 31 | real(dp), intent(in) :: xiq(:) ! quadrature points 32 | real(dp), intent(in) :: wtq(:) ! quadrature weights 33 | real(dp), intent(in) :: eps 34 | real(dp), allocatable, intent(out) :: energies(:) 35 | real(dp), intent(out) :: Etot 36 | real(dp), intent(out) :: V(:,:) ! SCF potential 37 | integer, intent(out) :: DOFs 38 | integer :: n, Nq 39 | real(dp), allocatable :: H(:,:), S(:), D(:,:), lam(:) 40 | 41 | real(dp), allocatable :: xin(:) ! parent basis nodes 42 | integer, allocatable :: ib(:, :) ! basis connectivity: ib(i,j) = index of 43 | ! basis function associated with local basis function i of element j. 0 = no 44 | ! associated basis fn. 45 | integer, allocatable :: in(:, :) 46 | real(dp), allocatable :: xq(:, :), fullc(:), uq(:,:), rho(:,:), Vee(:,:), & 47 | Vxc(:,:), exc(:,:), Vin(:,:), Vout(:,:), xn(:), un(:), xq1(:,:), Am_p(:,:), & 48 | bv_p(:), Hl(:,:,:) 49 | integer, allocatable :: ipiv(:) 50 | real(dp), allocatable :: phihq(:,:) ! parent basis at quadrature points 51 | real(dp), allocatable :: dphihq(:,:) ! parent basis derivative at quadrature points 52 | 53 | real(dp), allocatable :: xin_p(:) ! parent basis nodes for poisson grid 54 | real(dp), allocatable :: xn_p(:) 55 | real(dp), allocatable :: phihq_p(:,:) ! parent basis at quadrature points 56 | real(dp), allocatable :: dphihq_p(:,:) ! parent basis derivative at quadrature points 57 | integer, allocatable :: in_p(:, :), ib_p(:, :) 58 | 59 | integer :: Ne, Nb, Nn, Nb_p, Nn_p, pp 60 | real(dp) :: rmin, rmax 61 | integer :: l, i, j, Lmax, al, eimin, eimax 62 | real(dp) :: c 63 | real(dp), allocatable :: focc(:,:), focc_idx_r(:,:), tmp(:) 64 | real(dp) :: scf_alpha, scf_L2_eps, scf_eig_eps 65 | integer, parameter :: mixing_scheme_linear = 1, mixing_scheme_pulay = 3 66 | integer :: mixing_scheme 67 | integer, allocatable :: no(:), lo(:), focc_idx(:,:), eirange(:,:) 68 | real(dp), allocatable :: fo_idx(:), fo(:) 69 | real(dp) :: T_s, E_ee, E_en, EE_xc 70 | real(dp) :: xiq_lob(p+1), wtq_lob(p+1) 71 | 72 | 73 | integer :: nband, scf_max_iter, iter 74 | 75 | Nq = size(xiq) 76 | c = 137.0359895_dp 77 | rmin = 0 78 | rmax = 50 79 | Ne = size(xe)-1 80 | mixing_scheme = mixing_scheme_pulay 81 | 82 | call get_parent_quad_pts_wts(2, p+1, xiq_lob, wtq_lob) 83 | 84 | 85 | call get_atomic_states_nonrel_focc(Z, focc) 86 | call get_atomic_states_nonrel(Z, no, lo, fo) 87 | allocate(fo_idx(size(fo))) 88 | do i = 1, size(fo_idx) 89 | fo_idx(i) = i 90 | end do 91 | call nlf2focc(no, lo, fo_idx, focc_idx_r) 92 | allocate(focc_idx(size(focc_idx_r,1),lbound(focc,2):ubound(focc,2))) 93 | focc_idx = int(focc_idx_r) 94 | 95 | Lmax = ubound(focc,2) 96 | 97 | Nn = Ne*p+1 98 | 99 | allocate(xin(p+1)) 100 | call get_parent_nodes(2, p, xin) 101 | allocate(in(p+1, Ne), ib(p+1, Ne)) 102 | call define_connect(1, 1, Ne, p, in, ib) 103 | Nb = maxval(ib) 104 | if ( .not. (Nn == maxval(in)) ) then 105 | error stop 'Wrong size for Nn' 106 | end if 107 | DOFs = Nb 108 | allocate(xq(Nq, Ne), xq1(Nq, 1), xn(Nn), un(Nn)) 109 | call get_quad_pts(xe, xiq, xq) 110 | call get_nodes(xe, xin, xn) 111 | 112 | pp = 2*p 113 | Nn_p = Ne*pp+1 114 | allocate(xin_p(pp+1)) 115 | call get_parent_nodes(2, pp, xin_p) 116 | allocate(in_p(pp+1, Ne), ib_p(pp+1, Ne)) 117 | call define_connect(2, 1, Ne, pp, in_p, ib_p) 118 | Nb_p = maxval(ib_p) 119 | if ( .not. (Nn_p == maxval(in_p)) ) then 120 | error stop 'Wrong size for Nn_p' 121 | end if 122 | allocate(xn_p(Nn_p)) 123 | call get_nodes(xe, xin_p, xn_p) 124 | 125 | 126 | allocate(phihq(Nq, p+1)) 127 | allocate(dphihq(Nq, p+1)) 128 | allocate(phihq_p(Nq, pp+1)) 129 | allocate(dphihq_p(Nq, pp+1)) 130 | ! tabulate parent basis at quadrature points 131 | do al = 1, p+1 132 | call phih_array(xin, al, xiq, phihq(:, al)) 133 | call dphih_array(xin, al, xiq, dphihq(:, al)) 134 | end do 135 | do al = 1, pp+1 136 | call phih_array(xin_p, al, xiq, phihq_p(:, al)) 137 | call dphih_array(xin_p, al, xiq, dphihq_p(:, al)) 138 | end do 139 | 140 | n = Nb 141 | allocate(H(n, n), S(n)) 142 | allocate(D(n, n), lam(n), fullc(Nn), uq(Nq,Ne), rho(Nq,Ne), Vee(Nq,Ne), & 143 | Vxc(Nq,Ne), exc(Nq,Ne), Vin(Nq,Ne), Vout(Nq,Ne)) 144 | 145 | nband = count(focc > 0) 146 | scf_max_iter = 100 147 | scf_alpha = 0.7_dp 148 | scf_L2_eps = 1e-4_dp 149 | scf_eig_eps = eps 150 | 151 | allocate(tmp(Nq*Ne)) 152 | allocate(energies(nband)) 153 | Vin = reshape(thomas_fermi_potential(reshape(xq, [Nq*Ne]), Z), [Nq, Ne]) + & 154 | Z / xq 155 | iter = 0 156 | 157 | call assemble_radial_S(xin, xe, ib, wtq_lob, S) 158 | do i = 1, size(S) 159 | S(i) = 1/sqrt(S(i)) 160 | end do 161 | 162 | allocate(Am_p(Nb_p, Nb_p), bv_p(Nb_p), ipiv(Nb_p)) 163 | Am_p = 0 164 | call assemble_poisson_A(xin_p, xe, ib_p, xiq, wtq, dphihq_p, Am_p) 165 | call solve_sym_setup(Am_p, ipiv) 166 | 167 | allocate(Hl(n,n,0:Lmax)) 168 | call assemble_radial_H_setup(0, Lmax, xin, xe, ib, xiq, wtq, phihq, dphihq, Hl) 169 | 170 | allocate(eirange(2,0:Lmax)) 171 | 172 | do l = 0, Lmax 173 | eimax = 0 174 | do i = 1, size(focc,1) 175 | if (focc(i,l) < tiny(1._dp)) cycle 176 | eimax = i 177 | end do 178 | eirange(2, l) = eimax 179 | 180 | eimin = 1 181 | do i = 1, size(focc,1) 182 | if (focc(i,l) >= tiny(1._dp)) exit 183 | eimin = i 184 | end do 185 | eirange(1, l) = eimin 186 | end do 187 | 188 | select case (mixing_scheme) 189 | case (mixing_scheme_linear) 190 | call mixing_linear & 191 | (Ffunc, integral, reshape(Vin, [Nq*Ne]), & 192 | nband, scf_max_iter, scf_alpha, scf_L2_eps, scf_eig_eps, tmp) 193 | case (mixing_scheme_pulay) 194 | call mixing_pulay & 195 | (Ffunc, integral, matvec, matmat, reshape(Vin, [Nq*Ne]), & 196 | nband, scf_max_iter, scf_alpha, scf_L2_eps, scf_eig_eps, tmp, 5, 3) 197 | case default 198 | error stop "Type of mixing not implemented." 199 | end select 200 | 201 | contains 202 | 203 | subroutine Ffunc(x, y, eng) 204 | ! Converge Vee+Vxc only (the other components are constant) 205 | real(dp), intent(in) :: x(:) 206 | real(dp), intent(out) :: y(:), eng(:) 207 | integer :: idx 208 | iter = iter + 1 209 | Vin = reshape(x, shape(Vin)) 210 | rho = 0 211 | idx = 0 212 | V = Vin - Z/xq 213 | do l = 0, Lmax 214 | 215 | call assemble_radial_H_complete(V, xin, xe, ib, xiq, wtq, phihq, Hl(:,:,l), H) 216 | 217 | do concurrent (i = 1:size(S), j = 1:size(S), i>=j) 218 | H(i, j) = H(i, j)*S(i)*S(j) 219 | end do 220 | 221 | eimin = eirange(1, l) 222 | eimax = eirange(2, l) 223 | 224 | call solve_eig_irange(H, eimin, eimax, lam, D) 225 | 226 | do i = 1, size(S) 227 | D(i, eimin:eimax) = D(i, eimin:eimax)*S(i) 228 | end do 229 | 230 | do i = eimin,eimax 231 | if (focc(i,l) < tiny(1._dp)) cycle 232 | 233 | call c2fullc2(in, ib, D(:Nb,i), fullc) 234 | call fe2quad_core(xe, xin, in, fullc, phihq, uq) 235 | rho = rho - focc(i,l)*(uq/xq)**2 / (4*pi) 236 | 237 | idx = idx + 1 238 | eng(focc_idx(i,l)) = lam(i) 239 | end do 240 | end do 241 | if ( .not. (size(eng) == idx) ) then 242 | error stop 'Energy size mismatch' 243 | end if 244 | energies = eng 245 | 246 | !print *, "Energies:" 247 | !do i = 1, size(energies) 248 | ! print *, i, no(i), lo(i), energies(i) 249 | !end do 250 | 251 | Vee = hartree_potential3(real(Z, dp), pp, xe, xin_p, in_p, ib_p, xiq, wtq, phihq_p, Am_p, ipiv, -4*pi*rho) 252 | call xc_vwn3(size(rho), -rho, .FALSE., c, exc, Vxc) 253 | call total_energy(xe, wtq, fo, energies, Vin-Z/xq, Vee, -Z/xq, exc, & 254 | xq, -rho, T_s, E_ee, E_en, EE_xc, Etot) 255 | Vout = Vee + Vxc ! This term is added later: -Z/xq 256 | y = reshape(Vout, shape(y)) 257 | end subroutine 258 | 259 | real(dp) function integral(x) 260 | ! Computes the integral of the vector 'x' 261 | real(dp), intent(in) :: x(:) 262 | integral = integrate(xe, wtq, reshape(x, shape(uq))) 263 | end function 264 | 265 | function matvec(A, b) result(r) 266 | real(dp), intent(in) :: A(:,:), b(:) 267 | real(dp) :: r(size(A,1)) 268 | r = matmul(A, b) 269 | end function 270 | 271 | function matmat(A, B) result(r) 272 | real(dp), intent(in) :: A(:,:), B(:,:) 273 | real(dp) :: r(size(A,1), size(B,2)) 274 | r = matmul(A, B) 275 | end function 276 | 277 | end subroutine 278 | 279 | 280 | subroutine total_energy(xe, wtq, fo, ks_energies, V_in, V_h, V_coulomb, e_xc, & 281 | R, n, T_s, E_ee, E_en, EE_xc, Etot) 282 | ! This is a variational, quadratically convergent form of total energy 283 | real(dp), intent(in) :: xe(:), wtq(:) 284 | real(dp), intent(in) :: R(:,:) ! Function 'r' on quadrature grid 285 | real(dp), intent(in) :: fo(:), ks_energies(:) ! occupations, energies 286 | real(dp), intent(in) :: V_in(:,:) ! Total input effective potential 287 | real(dp), intent(in) :: V_h(:,:) ! Hartree energy, solution of Poiss. eq. 288 | real(dp), intent(in) :: V_coulomb(:,:) ! Coulomb inter. -Z/r (negative) 289 | real(dp), intent(in) :: e_xc(:,:) ! XC density 290 | real(dp), intent(in) :: n(:,:) ! number density (positive) 291 | real(dp), intent(out) :: Etot ! Total energy 292 | real(dp), intent(out) :: T_s, E_ee, E_en, EE_xc ! Parts of the total energy 293 | 294 | real(dp) :: rho(size(n,1), size(n,2)) 295 | real(dp) :: E_c, E_band 296 | rho = -n 297 | 298 | E_band = sum(fo * ks_energies) 299 | T_s = E_band + 4*pi * integrate(xe, wtq, V_in * rho * R**2) 300 | 301 | E_ee = -2*pi * integrate(xe, wtq, V_h * rho * R**2) 302 | E_en = 4*pi * integrate(xe, wtq, (-V_coulomb) * rho * R**2) 303 | E_c = E_ee + E_en 304 | 305 | EE_xc = -4*pi * integrate(xe, wtq, e_xc * rho * R**2) 306 | 307 | Etot = T_s + E_c + EE_xc 308 | end subroutine 309 | 310 | 311 | subroutine csolve_schroed(Z, p, xiq, wtq, xe, eps, Nq, Ne, & 312 | nenergies, energies, Etot, V) bind(c) 313 | integer(c_int), intent(in) :: Z, p, Nq, Ne, nenergies 314 | real(c_double), intent(in) :: xe(Ne+1) ! element coordinates 315 | real(c_double), intent(in) :: xiq(Nq) ! quadrature points 316 | real(c_double), intent(in) :: wtq(Nq) ! quadrature weights 317 | real(c_double), intent(in) :: eps 318 | real(c_double), intent(out) :: energies(nenergies) 319 | real(c_double), intent(out) :: Etot 320 | real(c_double), intent(out) :: V(Nq, Ne) ! SCF potential 321 | integer :: DOFs 322 | real(dp), allocatable :: energies2(:) 323 | 324 | call solve_schroed(Z, p, xiq, wtq, xe, eps, energies2, Etot, V, DOFs) 325 | energies = energies2 326 | end subroutine 327 | 328 | end module 329 | -------------------------------------------------------------------------------- /src/solvers.f90: -------------------------------------------------------------------------------- 1 | module solvers 2 | use types, only: dp 3 | use lapack, only: dlamch, dsysv, dsyevx, dsytrf, dsytrs 4 | implicit none 5 | private 6 | public solve_sym, solve_eig_irange, solve_sym2, solve_sym_setup 7 | 8 | contains 9 | 10 | subroutine solve_eig_irange(Am, l, h, lam, c) 11 | ! solve standard eigenvalue problem and return l-th to h-th eigenvalues 12 | ! and eigenvectors 13 | real(dp), intent(in) :: Am(:,:) ! LHS matrix: Am c = lam c 14 | integer, intent(in) :: l, h 15 | real(dp), intent(out) :: lam(:) ! eigenvalues: Am c = lam c 16 | real(dp), intent(out) :: c(:,:) ! eigenvectors: Am c = lam c; c(i,j) = ith component of jth vec. 17 | integer n 18 | ! lapack variables 19 | integer lwork, info, m 20 | integer, allocatable:: iwork(:), ifail(:) 21 | real(dp) abstol 22 | real(dp), allocatable:: Amt(:,:), work(:) 23 | 24 | ! solve 25 | n=size(Am,1) 26 | lwork=8*n 27 | if ( .not. (h >= l) ) then 28 | error stop 'h must be greater than l' 29 | end if 30 | if ( .not. (size(c,1) == n) ) then 31 | error stop 'Wrong size for the first eigenvector' 32 | end if 33 | if ( .not. (size(c,2) >= h-l+1) ) then 34 | error stop 'Wrong size for the second eigenvector' 35 | end if 36 | if ( .not. (size(lam) == n) ) then 37 | error stop 'Wrong size for the eigenvalues' 38 | end if 39 | allocate(Amt(n,n),work(lwork),iwork(5*n),ifail(n)) 40 | Amt=Am; ! Amt temporaries overwritten by dsyevx 41 | abstol=2*dlamch('S') 42 | call dsyevx('V','I','L',n,Amt,n,0.0_dp,0.0_dp,l,h,abstol,m, & 43 | lam,c,n,work,lwork,iwork,ifail,info) 44 | if (info/=0) then 45 | print *, "dsyevx returned info =", info 46 | if (info > 0) then 47 | print *, "algorithm failed to compute an eigenvalue while working ", & 48 | "on the submatrix lying in rows and columns ", info/(n+1), & 49 | " through ", mod(info, n+1) 50 | else 51 | print *, -info, "-th argument had an illegal value" 52 | end if 53 | error stop 'DSYEVX ERROR' 54 | end if 55 | if ( .not. (m == h-l+1) ) then 56 | error stop 'Wrong size for the lapack helper' 57 | end if 58 | end subroutine 59 | 60 | function solve_sym(Am, bv) result(c) 61 | ! solves symmetric dense system of equations 62 | real(dp), intent(in) :: Am(:,:) ! system matrix: Am c = bv 63 | real(dp), intent(in) :: bv(:) ! source vector: Am c = bv 64 | real(dp) :: c(size(bv)) ! solution vector: Am c = bv 65 | !real(dp) :: r(size(bv)) 66 | integer :: n 67 | ! lapack variables 68 | integer :: lwork, info 69 | integer, allocatable :: ipiv(:) 70 | real(dp), allocatable :: Amt(:,:),bm(:,:),work(:) 71 | 72 | n = size(c) 73 | lwork = n 74 | allocate(Amt(n,n), bm(n,1), ipiv(n), work(lwork)) 75 | Amt=Am; bm(:,1)=bv ! temporaries for dsysv 76 | call dsysv('L', n, 1, Amt, n, ipiv, bm, n, work, lwork, info) 77 | if (info < 0) then 78 | print *, "The", -info, "-th argument had illegal value" 79 | error stop 'DSYSV ERROR.' 80 | end if 81 | if (info > 0) then 82 | print *, "D(", info, ",", info, ") is exactly zero." 83 | print *, "The factorization has been completed, but the block diagonal" 84 | print *, "matrix D is exactly singular, so the solution could not be" 85 | print *, "computed." 86 | error stop 'DSYSV ERROR.' 87 | end if 88 | c = bm(:, 1) 89 | ! error 90 | !r=matmul(Am, c)-bv 91 | !write(*,'(1x,a,es18.11)') "Solution vector residual ||Am c - bv||/||bv||: ", & 92 | ! sqrt(dot_product(r,r)/dot_product(bv,bv)) 93 | end function 94 | 95 | subroutine solve_sym_setup(Am, ipiv) 96 | ! factorizes symmetric matrix Am, such that solve_sym2 can use the factorization 97 | real(dp), intent(inout) :: Am(:,:) ! system matrix: Am c = bv 98 | integer, intent(out) :: ipiv(size(Am, 1)) ! internal details 99 | integer :: n 100 | ! lapack variables 101 | integer :: lwork, info 102 | real(dp), allocatable :: work(:) 103 | 104 | n = size(Am, 1) 105 | lwork = n 106 | allocate(work(lwork)) 107 | call dsytrf('L', n, Am, n, ipiv, work, lwork, info) 108 | if (info < 0) then 109 | print *, "The", -info, "-th argument had illegal value" 110 | error stop 'DSYTRF ERROR.' 111 | end if 112 | if (info > 0) then 113 | print *, "D(", info, ",", info, ") is exactly zero." 114 | print *, "The factorization has been completed, but the block diagonal" 115 | print *, "matrix D is exactly singular, and division by zero will occur" 116 | print *, "if it is used to solve a system of equations." 117 | error stop 'DSYTRF ERROR.' 118 | end if 119 | end subroutine 120 | 121 | function solve_sym2(Am, bv, ipiv) result(c) 122 | ! Uses factorization of Am from solve_sym_setup to solve a symmetric system 123 | real(dp), intent(in) :: Am(:,:) ! system matrix: Am c = bv 124 | real(dp), intent(in) :: bv(:) ! source vector: Am c = bv 125 | integer, intent(in) :: ipiv(size(Am, 1)) ! internal details 126 | real(dp) :: c(size(bv)) ! solution vector: Am c = bv 127 | integer :: n 128 | ! lapack variables 129 | integer :: info 130 | 131 | n = size(Am, 1) 132 | c = bv 133 | call dsytrs('L', n, 1, Am, n, ipiv, c, n, info) 134 | if (info < 0) then 135 | print *, "The", -info, "-th argument had illegal value" 136 | error stop 'DSYTRS ERROR.' 137 | end if 138 | end function 139 | 140 | end module 141 | -------------------------------------------------------------------------------- /src/string_utils.f90: -------------------------------------------------------------------------------- 1 | module string_utils 2 | 3 | use types, only: dp 4 | implicit none 5 | private 6 | public str 7 | 8 | interface str 9 | module procedure str_int, str_real, str_real_n 10 | end interface 11 | 12 | contains 13 | 14 | 15 | pure integer function str_int_len(i) result(sz) 16 | ! Returns the length of the string representation of 'i' 17 | integer, intent(in) :: i 18 | integer, parameter :: MAX_STR = 100 19 | character(MAX_STR) :: s 20 | ! If 's' is too short (MAX_STR too small), Fortan will abort with: 21 | ! "Fortran runtime error: End of record" 22 | write(s, '(i0)') i 23 | sz = len_trim(s) 24 | end function 25 | 26 | pure function str_int(i) result(s) 27 | ! Converts integer "i" to string 28 | integer, intent(in) :: i 29 | character(len=str_int_len(i)) :: s 30 | write(s, '(i0)') i 31 | end function 32 | 33 | pure integer function str_real_len(r, fmt) result(sz) 34 | ! Returns the length of the string representation of 'i' 35 | real(dp), intent(in) :: r 36 | character(len=*), intent(in) :: fmt 37 | integer, parameter :: MAX_STR = 100 38 | character(MAX_STR) :: s 39 | ! If 's' is too short (MAX_STR too small), Fortan will abort with: 40 | ! "Fortran runtime error: End of record" 41 | write(s, fmt) r 42 | sz = len_trim(s) 43 | end function 44 | 45 | pure function str_real(r) result(s) 46 | ! Converts the real number "r" to string with 7 decimal digits. 47 | real(dp), intent(in) :: r 48 | character(len=*), parameter :: fmt="(f0.6)" 49 | character(len=str_real_len(r, fmt)) :: s 50 | write(s, fmt) r 51 | end function 52 | 53 | pure function str_real_n(r, n) result(s) 54 | ! Converts the real number "r" to string with 'n' decimal digits. 55 | real(dp), intent(in) :: r 56 | integer, intent(in) :: n 57 | character(len=str_real_len(r, "(f0." // str_int(n) // ")")) :: s 58 | write(s, "(f0." // str_int(n) // ")") r 59 | end function 60 | 61 | end module 62 | -------------------------------------------------------------------------------- /src/types.f90: -------------------------------------------------------------------------------- 1 | module types 2 | implicit none 3 | private 4 | public sp, dp, hp, qp, ivector, dvector, zvector 5 | 6 | integer, parameter :: dp=kind(0.d0), & ! double precision 7 | hp=selected_real_kind(15), & ! high precision 8 | qp=selected_real_kind(32), & ! quadruple precision 9 | sp = kind(0.) ! single precision 10 | 11 | type ivector ! allocatable integer vector 12 | integer, pointer :: vec(:) => null() 13 | end type 14 | 15 | type dvector ! allocatable real double precision vector 16 | real(dp), pointer :: vec(:) => null() 17 | end type 18 | 19 | type zvector ! allocatable complex double precision vector 20 | complex(dp), pointer :: vec(:) => null() 21 | end type 22 | 23 | end module 24 | -------------------------------------------------------------------------------- /src/xc.f90: -------------------------------------------------------------------------------- 1 | !> @brief This module contains exchange and correlation potentials 2 | !> @details Currently supported: 3 | !> - LDA exchange (VWN: Vosko, Wilk & Nusair) 4 | !> - [S. H. Vosko, L. Wilk, and M. Nusair, Can. J. Phys. 58, 1200 (1980)](https://cdnsciencepub.com/doi/10.1139/p80-159) (doi: 10.1139/p80-159) 5 | !> - LDA correlation (PZ: Perdew & Zunger) 6 | !> - [J. P. Perdew and A. Zunger, Phys. Rev. B 23, 5048 (1981)](https://journals.aps.org/prb/abstract/10.1103/PhysRevB.23.5048) (doi: 10.1103/PhysRevB.23.5048) 7 | module xc 8 | 9 | use types, only: dp 10 | use constants, only: pi 11 | implicit none 12 | private 13 | public get_Vxc_vwn, xc_pz, xc_pz2, xc_vwn2, xc_vwn3 14 | 15 | contains 16 | 17 | !> @brief This function calculates the LDA potential over a grid 18 | !> @param[in] n Size of the charge density array 19 | !> @param[in] rho(n) Charge density 20 | !> @param[in] relat If T 21 | subroutine xc_vwn3(n, rho, relat, c, exc, Vxc) 22 | integer, intent(in) :: n ! size of the charge density array 23 | real(dp), intent(in) :: rho(n) ! charge density 24 | logical, intent(in) :: relat ! .true. return RLDA, otherwise LDA 25 | real(dp), intent(in) :: c ! speed of light 26 | real(dp), intent(out) :: Vxc(n), exc(n) 27 | integer :: i 28 | do i = 1, n 29 | call xc_vwn(rho(i), relat, c, exc(i), Vxc(i)) 30 | end do 31 | end subroutine 32 | 33 | subroutine get_Vxc_vwn(R, rho, relat, c, exc, Vxc) 34 | real(dp), intent(in) :: R(:) ! radial grid 35 | real(dp), intent(in) :: rho(:) ! charge density 36 | logical, intent(in) :: relat ! .true. return RLDA, otherwise LDA 37 | real(dp), intent(in) :: c ! speed of light 38 | real(dp), intent(out) :: Vxc(:), exc(:) 39 | 40 | integer :: i 41 | do i = 1, size(R) 42 | call xc_vwn(rho(i), relat, c, exc(i), Vxc(i)) 43 | end do 44 | end subroutine 45 | 46 | subroutine xc_vwn(n, relat, c_light, exc, Vxc) 47 | ! Calculates XC LDA density and potential from the charge density "n". 48 | real(dp), intent(in) :: n ! charge density (scalar) 49 | real(dp), intent(in) :: c_light ! speed of light 50 | logical, intent(in) :: relat ! if .true. returns RLDA, otherwise LDA 51 | real(dp), intent(out) :: exc ! XC density 52 | real(dp), intent(out) :: Vxc ! XC potential 53 | 54 | real(dp), parameter :: y0 = -0.10498_dp 55 | real(dp), parameter :: b = 3.72744_dp 56 | real(dp), parameter :: c = 12.9352_dp 57 | real(dp), parameter :: A = 0.0621814_dp 58 | 59 | real(dp) :: Q, rs, y, ec, ex, Vc, Vx, beta, mu, R, S 60 | 61 | if (abs(n) < tiny(1._dp)) then 62 | exc = 0 63 | Vxc = 0 64 | return 65 | end if 66 | 67 | Q = sqrt(4*c - b**2) 68 | rs = (3/(4*pi*n))**(1.0_dp/3) 69 | y = sqrt(rs) 70 | ec = A/2 * (log(y**2/get_Y(y, b, c)) + 2*b/Q * atan(Q/(2*y+b)) & 71 | - b*y0/get_Y(y0, b, c) * ( & 72 | log((y-y0)**2 / get_Y(y, b, c)) & 73 | + 2*(b+2*y0) / Q * atan(Q/(2*y+b)) & 74 | ) ) 75 | Vc = ec - A/6 * (c*(y-y0)-b*y0*y)/((y-y0)*get_Y(y, b, c)) 76 | ex = -3/(4*pi) * (3*pi**2*n)**(1.0_dp/3) 77 | Vx = 4*ex/3 78 | 79 | if (relat) then 80 | beta = -4 * pi * ex / (3 * c_light) 81 | mu = sqrt(1 + beta**2) 82 | R = 1 - 3 * ((beta * mu - log(beta + mu)) / (beta ** 2))**2 / 2 83 | S = 3 * log(beta + mu) / (2 * beta * mu) - 1.0_dp/2 84 | 85 | ex = ex * R 86 | Vx = Vx * S 87 | end if 88 | exc = ex + ec 89 | Vxc = Vx + Vc 90 | 91 | contains 92 | 93 | real(dp) function get_Y(y, b, c) 94 | real(dp), intent(in) :: y, b, c 95 | get_Y = y**2 + b*y + c 96 | end function 97 | 98 | end subroutine 99 | 100 | elemental subroutine xc_vwn2(n, exc, Vxc) 101 | ! Same as xc_vwn, but an elemental procedure, and non-relativistic only 102 | real(dp), intent(in) :: n ! charge density (scalar) 103 | real(dp), intent(out) :: exc ! XC density 104 | real(dp), intent(out) :: Vxc ! XC potential 105 | 106 | real(dp), parameter :: y0 = -0.10498_dp 107 | real(dp), parameter :: b = 3.72744_dp 108 | real(dp), parameter :: c = 12.9352_dp 109 | real(dp), parameter :: A = 0.0621814_dp 110 | 111 | real(dp) :: Q, rs, y, ec, ex, Vc, Vx 112 | 113 | if (abs(n) < tiny(1._dp)) then 114 | exc = 0 115 | Vxc = 0 116 | return 117 | end if 118 | 119 | Q = sqrt(4*c - b**2) 120 | rs = (3/(4*pi*n))**(1.0_dp/3) 121 | y = sqrt(rs) 122 | ec = A/2 * (log(y**2/get_Y(y, b, c)) + 2*b/Q * atan(Q/(2*y+b)) & 123 | - b*y0/get_Y(y0, b, c) * ( & 124 | log((y-y0)**2 / get_Y(y, b, c)) & 125 | + 2*(b+2*y0) / Q * atan(Q/(2*y+b)) & 126 | ) ) 127 | Vc = ec - A/6 * (c*(y-y0)-b*y0*y)/((y-y0)*get_Y(y, b, c)) 128 | ex = -3/(4*pi) * (3*pi**2*n)**(1.0_dp/3) 129 | Vx = 4*ex/3 130 | 131 | exc = ex + ec 132 | Vxc = Vx + Vc 133 | 134 | contains 135 | 136 | real(dp) pure function get_Y(y, b, c) 137 | real(dp), intent(in) :: y, b, c 138 | get_Y = y**2 + b*y + c 139 | end function 140 | 141 | end subroutine 142 | 143 | elemental subroutine xc_pz(n, exc, Vxc) 144 | ! Calculates XC LDA density and potential from the charge density "n". 145 | ! Uses the Perdew Zunger [1] parametrization. 146 | ! 147 | ! [1] Perdew, J. P., & Zunger, A. (1981). Self-interaction correction to 148 | ! density-functional approximations for many-electron systems. Physical Review 149 | ! B, 23(10), 5048–5079. 150 | real(dp), intent(in) :: n ! charge density 151 | real(dp), intent(out) :: exc ! XC density 152 | real(dp), intent(out) :: Vxc ! XC potential 153 | 154 | real(dp), parameter :: gam = -0.1423_dp 155 | real(dp), parameter :: beta1 = 1.0529_dp 156 | real(dp), parameter :: beta2 = 0.3334_dp 157 | real(dp), parameter :: A = 0.0311_dp 158 | real(dp), parameter :: B = -0.048_dp 159 | real(dp), parameter :: C = 0.0020_dp 160 | real(dp), parameter :: D = -0.0116_dp 161 | real(dp) :: ex, ec, Vx, Vc, rs, sqrt_rs, log_rs 162 | 163 | if (abs(n) < tiny(1._dp)) then 164 | exc = 0 165 | Vxc = 0 166 | return 167 | end if 168 | 169 | ex = -3/(4*pi) * (3*pi**2*n)**(1.0_dp/3) 170 | Vx = 4*ex/3 171 | 172 | rs = (3/(4*pi*n))**(1.0_dp/3) 173 | if (rs >= 1) then 174 | sqrt_rs = sqrt(rs) 175 | ec = gam / (1+beta1*sqrt_rs+beta2*rs) 176 | Vc = ec * (1+7*beta1*sqrt_rs/6 + 4*beta2*rs/3) / & 177 | (1+beta1*sqrt_rs + beta2*rs) 178 | else 179 | log_rs = log(rs) 180 | ec = A*log_rs + B + C*rs*log_rs + D*rs 181 | Vc = A*log_rs + (B-A/3) + 2*C*rs*log_rs/3 + (2*D-C)*rs/3 182 | end if 183 | 184 | exc = ex + ec 185 | Vxc = Vx + Vc 186 | end subroutine 187 | 188 | elemental subroutine xc_pz2(n, Vxc) 189 | ! The same as 'xc_pz', but only calculates Vxc. 190 | real(dp), intent(in) :: n ! charge density 191 | real(dp), intent(out) :: Vxc ! XC potential 192 | 193 | real(dp), parameter :: gam = -0.1423_dp 194 | real(dp), parameter :: beta1 = 1.0529_dp 195 | real(dp), parameter :: beta2 = 0.3334_dp 196 | real(dp), parameter :: A = 0.0311_dp 197 | real(dp), parameter :: B = -0.048_dp 198 | real(dp), parameter :: C = 0.0020_dp 199 | real(dp), parameter :: D = -0.0116_dp 200 | real(dp) :: ex, ec, Vx, Vc, rs, sqrt_rs, log_rs 201 | 202 | ex = -3/(4*pi) * (3*pi**2*n)**(1.0_dp/3) 203 | Vx = 4*ex/3 204 | 205 | rs = (3/(4*pi*n))**(1.0_dp/3) 206 | if (rs >= 1) then 207 | sqrt_rs = sqrt(rs) 208 | ec = gam / (1+beta1*sqrt_rs+beta2*rs) 209 | Vc = ec * (1+7*beta1*sqrt_rs/6 + 4*beta2*rs/3) / & 210 | (1+beta1*sqrt_rs + beta2*rs) 211 | else 212 | log_rs = log(rs) 213 | Vc = A*log_rs + (B-A/3) + 2*C*rs*log_rs/3 + (2*D-C)*rs/3 214 | end if 215 | 216 | Vxc = Vx + Vc 217 | end subroutine 218 | 219 | end module 220 | -------------------------------------------------------------------------------- /test/test_coulomb_dirac.f90: -------------------------------------------------------------------------------- 1 | program test_coulomb_dirac 2 | use types, only: dp 3 | use mesh, only: meshexp 4 | use schroed_glob, only: solve_schroed 5 | use dirac, only: solve_dirac 6 | use feutils, only: get_parent_quad_pts_wts 7 | use graphs_potential, only: run_convergence_potential 8 | use string_utils, only: str 9 | use schroed_dirac_solver, only: total_energy 10 | implicit none 11 | 12 | integer :: p, Ne, Nq, Z, i, DOFs 13 | real(dp) :: rmin, rmax, a, err, Etot 14 | real(dp), allocatable :: energies(:), xq(:,:), eigfn(:,:,:) 15 | real(dp) :: Etot_ref 16 | real(dp), allocatable :: energies_ref(:) 17 | ! can be, 18 | ! 0: error as p is varied 19 | ! 1: error as rmax is varied 20 | ! 2: error as Ne is varied 21 | integer :: study_type 22 | ! can be, 23 | ! 0: Schroedinger 24 | ! 1: Dirac 25 | integer :: dirac_int 26 | ! For 27 | ! 0, 1: 3rd argument p_or_Ne = Ne (Number of elements) 28 | ! 2 : 3rd argument p_or_Ne = p (Polynomial order) 29 | integer :: p_or_Ne 30 | ! can be, 31 | ! 0: Coulomb 32 | ! 1: Harmonic 33 | integer :: potential_type 34 | ! can be 0, 1, -1 (-1 implies beta). used only for Dirac. 35 | integer :: alpha_int 36 | 37 | ! The directory where to save the output files 38 | character(len=:), allocatable :: directory 39 | 40 | integer :: u 41 | real(dp) :: asympt, c 42 | real(dp), allocatable :: alpha_j(:), alpha(:) 43 | integer :: Lmax, Lmin, kappa 44 | real(dp) :: optim_a(2:7) 45 | integer :: n, l, relat, relat_max 46 | 47 | Z = 92 48 | rmin = 0 49 | rmax = 50 50 | a = 200 51 | Ne = 4 52 | Nq = 53 53 | p = 26 54 | 55 | i = 7 56 | !call run_convergence_potential(0, 1, i, & 57 | ! 0, -1, ".") 58 | 59 | 60 | study_type = 0 61 | dirac_int = 1 62 | p_or_Ne = i 63 | potential_type = 0 64 | alpha_int = -1 65 | directory = "." 66 | 67 | c = 137.0359895_dp 68 | 69 | if (study_type == 2) then 70 | p = p_or_Ne 71 | else 72 | Ne = p_or_Ne 73 | end if 74 | 75 | Lmax=5 76 | Lmin=-6 77 | 78 | allocate(alpha(Lmin:Lmax), alpha_j(Lmin:Lmax)) 79 | do kappa = Lmin, Lmax 80 | if (kappa == 0) cycle 81 | ! asymptotic at r = 0 82 | asympt = sqrt(kappa**2 - Z**2 / c**2) 83 | ! solve for P/r**alpha 84 | if (alpha_int == -1) then 85 | alpha(kappa) = asympt 86 | ! power of r for Gauss-Jacobi quadrature 87 | alpha_j(kappa) = 2*asympt - 2 88 | else 89 | alpha(kappa) = alpha_int 90 | ! don't use Gauss-Jacobi quadrature 91 | alpha_j(kappa) = -2 92 | end if 93 | end do 94 | 95 | optim_a = [58.985048682607555, 163.13530060338942, 340.82602039608668, & 96 | 444.68894311026423, 591.72463734788732, 596.61404750045062] 97 | 98 | if (Ne >= 2 .and. Ne <= 7) then 99 | a = optim_a(Ne) 100 | end if 101 | 102 | a = 100 103 | 104 | print "(a3,a6,a5,a8,a3,a3,a5)", "Z", "rmax", "Ne", "a", "p", "Nq", & 105 | "DOFs" 106 | 107 | i = 23 108 | ! change p for p-conv study. p must be less than 31. 109 | !if (dirac_int == 1 .and. i > 23) then 110 | ! exit 111 | !end if 112 | p = i 113 | allocate(xq(Nq, Ne)) 114 | call total_energy(Z, rmax, Ne, a, p, Nq, DOFs, alpha_int, dirac_int, & 115 | c, potential_type, Lmin, alpha_j, alpha, energies, eigfn, xq) 116 | Etot = sum(energies) 117 | 118 | allocate(energies_ref(size(energies))) 119 | i = 1 120 | outer: do n = 1, 7 121 | do l = 0, n-1 122 | if (l == 0) then 123 | relat_max = 2 124 | else 125 | relat_max = 3 126 | end if 127 | do relat = 2, relat_max 128 | energies_ref(i) = E_nl(c, n, l, Z, relat) 129 | if (i == size(energies_ref)) exit outer 130 | i = i + 1 131 | end do 132 | end do 133 | end do outer 134 | Etot_ref = sum(energies_ref) 135 | 136 | print "(i3, f6.1, i5, f8.1, i3, i3, i5, f22.12)", Z, rmax, Ne, a, p, Nq, & 137 | DOFs, Etot 138 | print * 139 | print *, "Comparison of calculated and reference energies" 140 | print * 141 | print *, "Total energy:" 142 | print "(a20,a20,a10)", "E", "E_ref", "error" 143 | err = abs(Etot - Etot_ref) 144 | print "(f20.12, f20.12, es10.2)", Etot, Etot_ref, err 145 | if ( .not. (err < 5e-9_dp)) then 146 | error stop 'assert failed' 147 | end if 148 | 149 | print *, "Eigenvalues:" 150 | print "(a4,a20,a20,a10)", "n", "E", "E_ref", "error" 151 | do i = 1, size(energies) 152 | err = abs(energies(i) - energies_ref(i)) 153 | print "(i4, f20.12, f20.12, es10.2)", i, energies(i), energies_ref(i), err 154 | if ( .not. (err < 5e-9_dp)) then 155 | error stop 'assert failed' 156 | end if 157 | end do 158 | 159 | print *, "Eigenfunctions saved in data_coulomb_dirac.txt" 160 | open(newunit=u, file="data_coulomb_dirac.txt", status="replace") 161 | write(u, *) xq 162 | do i = 1, size(energies) 163 | write(u, *) eigfn(:,:,i) 164 | end do 165 | close(u) 166 | 167 | contains 168 | 169 | real(dp) function E_nl(c, n, l, Z, relat) 170 | ! Calculates exact energy for the radial Schroedinger/Dirac equations 171 | real(dp), intent(in) :: c ! speed of light in atomic units 172 | integer, intent(in) :: n, l, Z, relat 173 | ! quantum numbers (n, l), atomic number (z) 174 | ! relat == 0 ... Schroedinger equation 175 | ! relat == 2 ... Dirac equation, spin up 176 | ! relat == 3 ... Dirac equation, spin down 177 | 178 | integer :: kappa 179 | real(dp) :: beta 180 | if (.not. (l >= 0)) error stop "'l' must be positive or zero" 181 | if (.not. (n > l)) error stop "'n' must be greater than 'l'" 182 | if (l == 0 .and. relat == 3) error stop "Spin must be up for l==0." 183 | if (relat == 0) then 184 | E_nl = - Z**2 / (2.0_dp * n**2) 185 | else 186 | if (relat == 2) then 187 | kappa = -l - 1 188 | else 189 | kappa = l 190 | end if 191 | beta = sqrt(kappa**2 - (Z/c)**2) 192 | E_nl = c**2/sqrt(1 + (Z/c)**2/(n - abs(kappa) + beta)**2) - c**2 193 | end if 194 | end function 195 | 196 | end program 197 | -------------------------------------------------------------------------------- /test/test_coulomb_schroed.f90: -------------------------------------------------------------------------------- 1 | program test_coulomb_schroed 2 | 3 | use types, only: dp 4 | use mesh, only: meshexp 5 | use schroed_glob, only: solve_schroed 6 | use dirac, only: solve_dirac 7 | use feutils, only: get_parent_quad_pts_wts 8 | use graphs_potential, only: run_convergence_potential 9 | use string_utils, only: str 10 | use schroed_dirac_solver, only: total_energy 11 | implicit none 12 | 13 | integer :: p, Ne, Nq, Z, i, DOFs 14 | real(dp) :: rmin, rmax, a, err, Etot 15 | real(dp), allocatable :: energies(:), xq(:,:), eigfn(:,:,:) 16 | real(dp), parameter :: Etot_ref = -10972.97142857139_dp 17 | real(dp), parameter :: energies_ref(*) = [ & 18 | -4232._dp, & 19 | -1058._dp, & 20 | -1058._dp, & 21 | -470.2222222222222222_dp, & 22 | -470.2222222222222222_dp, & 23 | -470.2222222222222222_dp, & 24 | -264.5_dp, & 25 | -264.5_dp, & 26 | -264.5_dp, & 27 | -264.5_dp, & 28 | -169.28_dp, & 29 | -169.28_dp, & 30 | -169.28_dp, & 31 | -169.28_dp, & 32 | -169.28_dp, & 33 | -117.55555555555555_dp, & 34 | -117.55555555555555_dp, & 35 | -117.55555555555555_dp, & 36 | -117.55555555555555_dp, & 37 | -117.55555555555555_dp, & 38 | -117.55555555555555_dp, & 39 | -86.36734693877_dp, & 40 | -86.36734693877_dp, & 41 | -86.36734693877_dp, & 42 | -86.36734693877_dp, & 43 | -86.36734693877_dp, & 44 | -86.36734693877_dp, & 45 | -86.36734693877_dp & 46 | ] 47 | 48 | 49 | ! can be, 50 | ! 0: error as p is varied 51 | ! 1: error as rmax is varied 52 | ! 2: error as Ne is varied 53 | integer :: study_type 54 | ! can be, 55 | ! 0: Schroedinger 56 | ! 1: Dirac 57 | integer :: dirac_int 58 | ! For 59 | ! 0, 1: 3rd argument p_or_Ne = Ne (Number of elements) 60 | ! 2 : 3rd argument p_or_Ne = p (Polynomial order) 61 | integer :: p_or_Ne 62 | ! can be, 63 | ! 0: Coulomb 64 | ! 1: Harmonic 65 | integer :: potential_type 66 | ! can be 0, 1, -1 (-1 implies beta). used only for Dirac. 67 | integer :: alpha_int 68 | 69 | ! The directory where to save the output files 70 | character(len=:), allocatable :: directory 71 | 72 | integer :: u 73 | real(dp) :: asympt, c 74 | real(dp), allocatable :: alpha_j(:), alpha(:) 75 | integer :: Lmax, Lmin, kappa 76 | real(dp) :: optim_a(2:7) 77 | 78 | Z = 92 79 | rmin = 0 80 | rmax = 50 81 | a = 200 82 | Ne = 4 83 | Nq = 53 84 | p = 26 85 | 86 | i = 7 87 | !call run_convergence_potential(0, 0, i, & 88 | ! 0, -1, ".") 89 | 90 | 91 | study_type = 0 92 | dirac_int = 0 93 | p_or_Ne = i 94 | potential_type = 0 95 | alpha_int = -1 96 | directory = "." 97 | 98 | c = 137.0359895_dp 99 | 100 | if (study_type == 2) then 101 | p = p_or_Ne 102 | else 103 | Ne = p_or_Ne 104 | end if 105 | 106 | Lmax=6 107 | Lmin=-7 108 | 109 | allocate(alpha(Lmin:Lmax), alpha_j(Lmin:Lmax)) 110 | do kappa = Lmin, Lmax 111 | if (kappa == 0) cycle 112 | ! asymptotic at r = 0 113 | asympt = sqrt(kappa**2 - Z**2 / c**2) 114 | ! solve for P/r**alpha 115 | if (alpha_int == -1) then 116 | alpha(kappa) = asympt 117 | ! power of r for Gauss-Jacobi quadrature 118 | alpha_j(kappa) = 2*asympt - 2 119 | else 120 | alpha(kappa) = alpha_int 121 | ! don't use Gauss-Jacobi quadrature 122 | alpha_j(kappa) = -2 123 | end if 124 | end do 125 | 126 | optim_a = [58.985048682607555, 163.13530060338942, 340.82602039608668, & 127 | 444.68894311026423, 591.72463734788732, 596.61404750045062] 128 | 129 | if (Ne >= 2 .and. Ne <= 7) then 130 | a = optim_a(Ne) 131 | end if 132 | 133 | a = 100 134 | 135 | print "(a3,a6,a5,a8,a3,a3,a5)", "Z", "rmax", "Ne", "a", "p", "Nq", & 136 | "DOFs" 137 | 138 | i = 31 139 | ! change p for p-conv study. p must be less than 31. 140 | !if (dirac_int == 1 .and. i > 23) then 141 | ! exit 142 | !end if 143 | p = i 144 | allocate(xq(Nq, Ne)) 145 | call total_energy(Z, rmax, Ne, a, p, Nq, DOFs, alpha_int, dirac_int, & 146 | c, potential_type, Lmin, alpha_j, alpha, energies, eigfn, xq) 147 | Etot = sum(energies) 148 | print "(i3, f6.1, i5, f8.1, i3, i3, i5, f22.12)", Z, rmax, Ne, a, p, Nq, & 149 | DOFs, Etot 150 | print * 151 | print *, "Comparison of calculated and reference energies" 152 | print * 153 | print *, "Total energy:" 154 | print "(a20,a20,a10)", "E", "E_ref", "error" 155 | err = abs(Etot - Etot_ref) 156 | print "(f20.12, f20.12, es10.2)", Etot, Etot_ref, err 157 | if ( .not. (err < 1e-9_dp)) then 158 | error stop 'assert failed' 159 | end if 160 | print *, "Eigenvalues:" 161 | print "(a4,a20,a20,a10)", "n", "E", "E_ref", "error" 162 | do i = 1, size(energies) 163 | err = abs(energies(i) - energies_ref(i)) 164 | print "(i4, f20.12, f20.12, es10.2)", i, energies(i), energies_ref(i), err 165 | if ( .not. (err < 5e-10_dp)) then 166 | error stop 'assert failed' 167 | end if 168 | end do 169 | 170 | print *, "Eigenfunctions saved in data_coulomb_schroed.txt" 171 | open(newunit=u, file="data_coulomb_schroed.txt", status="replace") 172 | write(u, *) xq 173 | do i = 1, size(energies) 174 | write(u, *) eigfn(:,:,i) 175 | end do 176 | close(u) 177 | 178 | end program 179 | -------------------------------------------------------------------------------- /test/test_dft_dirac.f90: -------------------------------------------------------------------------------- 1 | program test_dft_dirac 2 | 3 | use types, only: dp 4 | use mesh, only: meshexp 5 | use dirac, only: solve_dirac 6 | use feutils, only: get_parent_quad_pts_wts 7 | implicit none 8 | 9 | real(dp), allocatable :: xe(:) ! element coordinates 10 | real(dp), allocatable :: xiq(:), wtq(:) ! quadrature points and weights 11 | integer :: p, Ne, Nq, Z, i, DOFs 12 | real(dp) :: rmin, rmax, a, c, err, Etot, r0 13 | real(dp), allocatable :: energies(:), V(:,:) 14 | real(dp), parameter :: Etot_ref = -28001.1323254868_dp 15 | real(dp), parameter :: energies_ref(*) = [ & 16 | -4223.4190204552_dp, & 17 | -789.4897823303_dp, & 18 | -761.3744759730_dp, & 19 | -622.8480945649_dp, & 20 | -199.4298056450_dp, & 21 | -186.6637131249_dp, & 22 | -154.7010266741_dp, & 23 | -134.5411802896_dp, & 24 | -128.0166573820_dp, & 25 | -50.7889480646_dp, & 26 | -45.0371712884_dp, & 27 | -36.6886104859_dp, & 28 | -27.5293062430_dp, & 29 | -25.9854289064_dp, & 30 | -13.8895142333_dp, & 31 | -13.4854696912_dp, & 32 | -11.2955870987_dp, & 33 | -9.0579642498_dp, & 34 | -7.0692956350_dp, & 35 | -3.7974162278_dp, & 36 | -3.5012171832_dp, & 37 | -0.1467883850_dp, & 38 | -0.1160471651_dp, & 39 | -1.7480399541_dp, & 40 | -1.1011189998_dp, & 41 | -0.7757841787_dp, & 42 | -0.1030408153_dp, & 43 | -0.0848020246_dp, & 44 | -0.1609472826_dp ] 45 | 46 | 47 | Z = 92 48 | c = 137.0359895_dp 49 | rmin = 0 50 | r0 = 0.005_dp 51 | rmax = 30 52 | a = 600 53 | Ne = 6 54 | Nq = 64 55 | p = 25 56 | 57 | allocate(xe(Ne+1), xiq(Nq), wtq(Nq), V(Nq, Ne)) 58 | xe(1) = rmin 59 | xe(2:) = meshexp(r0, rmax, a, Ne-1) 60 | call get_parent_quad_pts_wts(1, Nq, xiq, wtq) 61 | 62 | call solve_dirac(Z, p, xiq, wtq, xe, 1e-9_dp, energies, Etot, V, DOFs) 63 | 64 | if ( .not. (size(energies) == size(energies_ref))) then 65 | error stop 'assert failed' 66 | end if 67 | print *, "Comparison of calculated and reference energies" 68 | print * 69 | print *, "Total energy:" 70 | print "(a16,a16,a10)", "E", "E_ref", "error" 71 | err = abs(Etot - Etot_ref) 72 | print "(f16.8, f16.8, es10.2)", Etot, Etot_ref, err 73 | if ( .not. (err < 1e-8_dp)) then 74 | error stop 'assert failed' 75 | end if 76 | print * 77 | print *, "Eigenvalues:" 78 | print "(a4,a16,a16,a10)", "n", "E", "E_ref", "error" 79 | do i = 1, size(energies) 80 | err = abs(energies(i) - energies_ref(i)) 81 | print "(i4, f16.8, f16.8, es10.2)", i, energies(i), energies_ref(i), err 82 | if ( .not. (err < 1e-8_dp)) then 83 | error stop 'assert failed' 84 | end if 85 | end do 86 | 87 | end program 88 | -------------------------------------------------------------------------------- /test/test_dft_dirac_fast.f90: -------------------------------------------------------------------------------- 1 | program test_dft_dirac_fast 2 | 3 | use types, only: dp 4 | use mesh, only: meshexp 5 | use dirac, only: solve_dirac 6 | use feutils, only: get_parent_quad_pts_wts 7 | implicit none 8 | 9 | real(dp), allocatable :: xe(:) ! element coordinates 10 | real(dp), allocatable :: xiq(:), wtq(:) ! quadrature points and weights 11 | integer :: p, Ne, Nq, Z, i, DOFs 12 | real(dp) :: rmin, rmax, a, c, err, Etot, r0 13 | real(dp), allocatable :: energies(:), V(:,:) 14 | real(dp), parameter :: Etot_ref = -28001.1323254868_dp 15 | real(dp), parameter :: energies_ref(*) = [ & 16 | -4223.4190204552_dp, & 17 | -789.4897823303_dp, & 18 | -761.3744759730_dp, & 19 | -622.8480945649_dp, & 20 | -199.4298056450_dp, & 21 | -186.6637131249_dp, & 22 | -154.7010266741_dp, & 23 | -134.5411802896_dp, & 24 | -128.0166573820_dp, & 25 | -50.7889480646_dp, & 26 | -45.0371712884_dp, & 27 | -36.6886104859_dp, & 28 | -27.5293062430_dp, & 29 | -25.9854289064_dp, & 30 | -13.8895142333_dp, & 31 | -13.4854696912_dp, & 32 | -11.2955870987_dp, & 33 | -9.0579642498_dp, & 34 | -7.0692956350_dp, & 35 | -3.7974162278_dp, & 36 | -3.5012171832_dp, & 37 | -0.1467883850_dp, & 38 | -0.1160471651_dp, & 39 | -1.7480399541_dp, & 40 | -1.1011189998_dp, & 41 | -0.7757841787_dp, & 42 | -0.1030408153_dp, & 43 | -0.0848020246_dp, & 44 | -0.1609472826_dp ] 45 | 46 | 47 | Z = 92 48 | c = 137.0359895_dp 49 | rmin = 0 50 | r0 = 0.005_dp 51 | rmax = 30 52 | a = 100 53 | Ne = 5 54 | Nq = 40 55 | p = 24 56 | 57 | allocate(xe(Ne+1), xiq(Nq), wtq(Nq), V(Nq, Ne)) 58 | xe(1) = rmin 59 | xe(2:) = meshexp(r0, rmax, a, Ne-1) 60 | call get_parent_quad_pts_wts(1, Nq, xiq, wtq) 61 | 62 | call solve_dirac(Z, p, xiq, wtq, xe, 1e-6_dp, energies, Etot, V, DOFs) 63 | 64 | if ( .not. (size(energies) == size(energies_ref))) then 65 | error stop 'assert failed' 66 | end if 67 | print *, "Comparison of calculated and reference energies" 68 | print * 69 | print *, "Total energy:" 70 | print "(a16,a16,a10)", "E", "E_ref", "error" 71 | err = abs(Etot - Etot_ref) 72 | print "(f16.8, f16.8, es10.2)", Etot, Etot_ref, err 73 | if ( .not. (err < 1e-6_dp)) then 74 | error stop 'assert failed' 75 | end if 76 | print * 77 | print *, "Eigenvalues:" 78 | print "(a4,a16,a16,a10)", "n", "E", "E_ref", "error" 79 | do i = 1, size(energies) 80 | err = abs(energies(i) - energies_ref(i)) 81 | print "(i4, f16.8, f16.8, es10.2)", i, energies(i), energies_ref(i), err 82 | if ( .not. (err < 1e-6_dp)) then 83 | error stop 'assert failed' 84 | end if 85 | end do 86 | 87 | end program 88 | -------------------------------------------------------------------------------- /test/test_dft_schroed.f90: -------------------------------------------------------------------------------- 1 | program test_dft_schroed 2 | 3 | use types, only: dp 4 | use mesh, only: meshexp 5 | use schroed_glob, only: solve_schroed 6 | use dirac, only: solve_dirac 7 | use feutils, only: get_parent_quad_pts_wts 8 | implicit none 9 | 10 | real(dp), allocatable :: xe(:) ! element coordinates 11 | real(dp), allocatable :: xiq(:), wtq(:) ! quadrature points and weights 12 | integer :: p, Ne, Nq, Z, i, DOFs 13 | real(dp) :: rmin, rmax, a, err, Etot 14 | real(dp), allocatable :: energies(:), V(:,:) 15 | real(dp), parameter :: Etot_ref = -25658.4178888534_dp 16 | real(dp), parameter :: energies_ref(*) = [ & 17 | -3689.3551398369_dp, & 18 | -639.7787280866_dp, & 19 | -619.1085501807_dp, & 20 | -161.1180732100_dp, & 21 | -150.9789801633_dp, & 22 | -131.9773582831_dp, & 23 | -40.5280842452_dp, & 24 | -35.8533208325_dp, & 25 | -27.1232122996_dp, & 26 | -15.0274600691_dp, & 27 | -8.8240894015_dp, & 28 | -7.0180922045_dp, & 29 | -3.8661751349_dp, & 30 | -0.3665433531_dp, & 31 | -1.3259763180_dp, & 32 | -0.8225379709_dp, & 33 | -0.1431901813_dp, & 34 | -0.1309478622_dp ] 35 | 36 | 37 | Z = 92 38 | rmin = 0 39 | rmax = 50 40 | a = 200 41 | Ne = 4 42 | Nq = 53 43 | p = 26 44 | 45 | allocate(xe(Ne+1), xiq(Nq), wtq(Nq), V(Nq, Ne)) 46 | xe = meshexp(rmin, rmax, a, Ne) 47 | call get_parent_quad_pts_wts(1, Nq, xiq, wtq) 48 | 49 | call solve_schroed(Z, p, xiq, wtq, xe, 1e-8_dp, energies, Etot, V, DOFs) 50 | if ( .not. (size(energies) == size(energies_ref))) then 51 | error stop 'assert failed' 52 | end if 53 | print *, "Comparison of calculated and reference energies" 54 | print * 55 | print *, "Total energy:" 56 | print "(a16,a16,a10)", "E", "E_ref", "error" 57 | err = abs(Etot - Etot_ref) 58 | print "(f16.8, f16.8, es10.2)", Etot, Etot_ref, err 59 | if ( .not. (err < 1e-8_dp)) then 60 | error stop 'assert failed' 61 | end if 62 | print * 63 | print *, "Eigenvalues:" 64 | print "(a4,a16,a16,a10)", "n", "E", "E_ref", "error" 65 | do i = 1, size(energies) 66 | err = abs(energies(i) - energies_ref(i)) 67 | print "(i4, f16.8, f16.8, es10.2)", i, energies(i), energies_ref(i), err 68 | if ( .not. (err < 1e-8_dp)) then 69 | error stop 'assert failed' 70 | end if 71 | end do 72 | end program 73 | -------------------------------------------------------------------------------- /test/test_dft_schroed_fast.f90: -------------------------------------------------------------------------------- 1 | program test_dft_schroed_fast 2 | 3 | use types, only: dp 4 | use mesh, only: meshexp 5 | use schroed_glob, only: solve_schroed 6 | use dirac, only: solve_dirac 7 | use feutils, only: get_parent_quad_pts_wts 8 | implicit none 9 | 10 | real(dp), allocatable :: xe(:) ! element coordinates 11 | real(dp), allocatable :: xiq(:), wtq(:) ! quadrature points and weights 12 | integer :: p, Ne, Nq, Z, i, DOFs 13 | real(dp) :: rmin, rmax, a, err, Etot 14 | real(dp), allocatable :: energies(:), V(:,:) 15 | real(dp), parameter :: Etot_ref = -25658.4178888534_dp 16 | real(dp), parameter :: energies_ref(*) = [ & 17 | -3689.3551398369_dp, & 18 | -639.7787280866_dp, & 19 | -619.1085501807_dp, & 20 | -161.1180732100_dp, & 21 | -150.9789801633_dp, & 22 | -131.9773582831_dp, & 23 | -40.5280842452_dp, & 24 | -35.8533208325_dp, & 25 | -27.1232122996_dp, & 26 | -15.0274600691_dp, & 27 | -8.8240894015_dp, & 28 | -7.0180922045_dp, & 29 | -3.8661751349_dp, & 30 | -0.3665433531_dp, & 31 | -1.3259763180_dp, & 32 | -0.8225379709_dp, & 33 | -0.1431901813_dp, & 34 | -0.1309478622_dp ] 35 | 36 | 37 | Z = 92 38 | rmin = 0 39 | rmax = 30 40 | a = 200 41 | Ne = 4 42 | Nq = 35 43 | p = 17 44 | 45 | allocate(xe(Ne+1), xiq(Nq), wtq(Nq), V(Nq, Ne)) 46 | xe = meshexp(rmin, rmax, a, Ne) 47 | call get_parent_quad_pts_wts(1, Nq, xiq, wtq) 48 | 49 | call solve_schroed(Z, p, xiq, wtq, xe, 1e-8_dp, energies, Etot, V, DOFs) 50 | if ( .not. (size(energies) == size(energies_ref))) then 51 | error stop 'assert failed' 52 | end if 53 | print *, "Comparison of calculated and reference energies" 54 | print * 55 | print *, "Total energy:" 56 | print "(a16,a16,a10)", "E", "E_ref", "error" 57 | err = abs(Etot - Etot_ref) 58 | print "(f16.8, f16.8, es10.2)", Etot, Etot_ref, err 59 | if ( .not. (err < 1e-6_dp)) then 60 | error stop 'assert failed' 61 | end if 62 | print * 63 | print *, "Eigenvalues:" 64 | print "(a4,a16,a16,a10)", "n", "E", "E_ref", "error" 65 | do i = 1, size(energies) 66 | err = abs(energies(i) - energies_ref(i)) 67 | print "(i4, f16.8, f16.8, es10.2)", i, energies(i), energies_ref(i), err 68 | if ( .not. (err < 1e-6_dp)) then 69 | error stop 'assert failed' 70 | end if 71 | end do 72 | end program 73 | -------------------------------------------------------------------------------- /test/test_harmonic_dirac.f90: -------------------------------------------------------------------------------- 1 | program test_harmonic_dirac 2 | use types, only: dp 3 | use mesh, only: meshexp 4 | use schroed_glob, only: solve_schroed 5 | use dirac, only: solve_dirac 6 | use feutils, only: get_parent_quad_pts_wts 7 | use graphs_potential, only: run_convergence_potential 8 | use string_utils, only: str 9 | use schroed_dirac_solver, only: total_energy 10 | implicit none 11 | 12 | integer :: p, Ne, Nq, Z, i, DOFs 13 | real(dp) :: rmin, rmax, a, err, Etot 14 | real(dp), allocatable :: energies(:), xq(:,:), eigfn(:,:,:) 15 | real(dp) :: Etot_ref 16 | real(dp), allocatable :: energies_ref(:) 17 | ! can be, 18 | ! 0: error as p is varied 19 | ! 1: error as rmax is varied 20 | ! 2: error as Ne is varied 21 | integer :: study_type 22 | ! can be, 23 | ! 0: Schroedinger 24 | ! 1: Dirac 25 | integer :: dirac_int 26 | ! For 27 | ! 0, 1: 3rd argument p_or_Ne = Ne (Number of elements) 28 | ! 2 : 3rd argument p_or_Ne = p (Polynomial order) 29 | integer :: p_or_Ne 30 | ! can be, 31 | ! 0: Coulomb 32 | ! 1: Harmonic 33 | integer :: potential_type 34 | ! can be 0, 1, -1 (-1 implies beta). used only for Dirac. 35 | integer :: alpha_int 36 | 37 | ! The directory where to save the output files 38 | character(len=:), allocatable :: directory 39 | 40 | integer :: u 41 | real(dp) :: asympt, c 42 | real(dp), allocatable :: alpha_j(:), alpha(:) 43 | integer :: Lmax, Lmin, kappa 44 | real(dp) :: optim_a(2:7) 45 | integer :: n, l, relat, relat_max 46 | real(dp) :: E_exact(7, -7:7) ! E_exact(n, kappa) 47 | E_exact = 0 48 | E_exact(7, -7) = 7.4996755269_dp 49 | E_exact(6:7, -6) = [ & 50 | 6.4997620499_dp, & 51 | 8.4994625812_dp & 52 | ] 53 | E_exact(5:7, -5) = [ & 54 | 5.4998352632_dp, & 55 | 7.4995757160_dp, & 56 | 9.4992363376_dp & 57 | ] 58 | E_exact(4:7, -4) = [ & 59 | 4.4998951661_dp, & 60 | 6.4996755428_dp, & 61 | 8.4993760822_dp, & 62 | 10.4989967965_dp & 63 | ] 64 | E_exact(3:7, -3) = [ & 65 | 3.4999417582_dp, & 66 | 5.4997620612_dp, & 67 | 7.4995025208_dp, & 68 | 9.4991631492_dp, & 69 | 11.4987439585_dp & 70 | ] 71 | E_exact(2:7, -2) = [ & 72 | 2.4999750389_dp, & 73 | 4.4998352706_dp, & 74 | 6.4996156527_dp, & 75 | 8.4993161976_dp, & 76 | 10.4989369173_dp, & 77 | 12.4984778242_dp & 78 | ] 79 | E_exact(1:7, -1) = [ & 80 | 1.4999950078_dp, & 81 | 3.4998951705_dp, & 82 | 5.4997154776_dp, & 83 | 7.4994559413_dp, & 84 | 9.4991165738_dp, & 85 | 11.4986973873_dp, & 86 | 13.4981983940_dp & 87 | ] 88 | E_exact(2:7, 1) = [ & 89 | 2.4999351051_dp, & 90 | 4.4997953424_dp, & 91 | 6.4995757249_dp, & 92 | 8.4992762722_dp, & 93 | 10.4988969952_dp, & 94 | 12.4984379048_dp & 95 | ] 96 | E_exact(3:7, 2) = [ & 97 | 3.4998752033_dp, & 98 | 5.4996955116_dp, & 99 | 7.4994359765_dp, & 100 | 9.4990966102_dp, & 101 | 11.4986774249_dp & 102 | ] 103 | E_exact(4:7, 3) = [ & 104 | 4.4998019930_dp, & 105 | 6.4995823772_dp, & 106 | 8.4992829240_dp, & 107 | 10.4989036457_dp & 108 | ] 109 | E_exact(5:7, 4) = [ & 110 | 5.4997154739_dp, & 111 | 7.4994559363_dp, & 112 | 9.4991165675_dp & 113 | ] 114 | E_exact(6:7, 5) = [ & 115 | 6.4996156467_dp, & 116 | 8.4993161897_dp & 117 | ] 118 | E_exact(7, 6) = 7.4995025118_dp 119 | 120 | 121 | Z = 92 122 | rmin = 0 123 | rmax = 50 124 | a = 200 125 | Ne = 4 126 | Nq = 53 127 | p = 26 128 | 129 | i = 7 130 | !call run_convergence_potential(0, 1, i, & 131 | ! 1, 0, ".") 132 | 133 | study_type = 0 134 | dirac_int = 1 135 | p_or_Ne = i 136 | potential_type = 1 137 | alpha_int = 0 138 | directory = "." 139 | 140 | c = 137.0359895_dp 141 | 142 | if (study_type == 2) then 143 | p = p_or_Ne 144 | else 145 | Ne = p_or_Ne 146 | end if 147 | 148 | Lmax=5 149 | Lmin=-6 150 | 151 | allocate(alpha(Lmin:Lmax), alpha_j(Lmin:Lmax)) 152 | do kappa = Lmin, Lmax 153 | if (kappa == 0) cycle 154 | ! asymptotic at r = 0 155 | asympt = sqrt(kappa**2 - Z**2 / c**2) 156 | ! solve for P/r**alpha 157 | if (alpha_int == -1) then 158 | alpha(kappa) = asympt 159 | ! power of r for Gauss-Jacobi quadrature 160 | alpha_j(kappa) = 2*asympt - 2 161 | else 162 | alpha(kappa) = alpha_int 163 | ! don't use Gauss-Jacobi quadrature 164 | alpha_j(kappa) = -2 165 | end if 166 | end do 167 | 168 | optim_a = [58.985048682607555, 163.13530060338942, 340.82602039608668, & 169 | 444.68894311026423, 591.72463734788732, 596.61404750045062] 170 | 171 | if (Ne >= 2 .and. Ne <= 7) then 172 | a = optim_a(Ne) 173 | end if 174 | 175 | a = 100 176 | 177 | print "(a3,a6,a5,a8,a3,a3,a5)", "Z", "rmax", "Ne", "a", "p", "Nq", & 178 | "DOFs" 179 | 180 | i = 23 181 | ! change p for p-conv study. p must be less than 31. 182 | !if (dirac_int == 1 .and. i > 23) then 183 | ! exit 184 | !end if 185 | p = i 186 | allocate(xq(Nq, Ne)) 187 | call total_energy(0, rmax, Ne, a, p, Nq, DOFs, alpha_int, dirac_int, & 188 | c, potential_type, Lmin, alpha_j, alpha, energies, eigfn, xq) 189 | Etot = sum(energies) 190 | allocate(energies_ref(size(energies))) 191 | i = 1 192 | outer: do n = 1, 7 193 | do l = 0, n-1 194 | if (l == 0) then 195 | relat_max = 2 196 | else 197 | relat_max = 3 198 | end if 199 | do relat = 2, relat_max 200 | if (relat == 2) then 201 | kappa = -l - 1 202 | else 203 | kappa = l 204 | end if 205 | energies_ref(i) = E_exact(n, kappa) 206 | if (i == size(energies_ref)) exit outer 207 | i = i + 1 208 | end do 209 | end do 210 | end do outer 211 | Etot_ref = sum(energies_ref) 212 | print "(i3, f6.1, i5, f8.1, i3, i3, i5, f22.12)", Z, rmax, Ne, a, p, Nq, & 213 | DOFs, Etot 214 | print * 215 | print *, "Comparison of calculated and reference energies" 216 | print * 217 | print *, "Total energy:" 218 | print "(a20,a20,a10)", "E", "E_ref", "error" 219 | err = abs(Etot - Etot_ref) 220 | print "(f20.12, f20.12, es10.2)", Etot, Etot_ref, err 221 | if ( .not. (err < 1e-8_dp)) then 222 | error stop 'assert failed' 223 | end if 224 | print *, "Eigenvalues:" 225 | print "(a4,a15,a15,a10)", "n", "E", "E_ref", "error" 226 | do i = 1, size(energies) 227 | err = abs(energies(i) - energies_ref(i)) 228 | print "(i4, f15.8, f15.8, es10.2)", i, energies(i), energies_ref(i), err 229 | if ( .not. (err < 1e-8_dp)) then 230 | error stop 'assert failed' 231 | end if 232 | end do 233 | 234 | print *, "Eigenfunctions saved in data_harmonic_dirac.txt" 235 | open(newunit=u, file="data_harmonic_dirac.txt", status="replace") 236 | write(u, *) xq 237 | do i = 1, size(energies) 238 | write(u, *) eigfn(:,:,i) 239 | end do 240 | close(u) 241 | 242 | end program 243 | -------------------------------------------------------------------------------- /test/test_harmonic_schroed.f90: -------------------------------------------------------------------------------- 1 | program test_harmonic_schroed 2 | 3 | use types, only: dp 4 | use mesh, only: meshexp 5 | use schroed_glob, only: solve_schroed 6 | use dirac, only: solve_dirac 7 | use feutils, only: get_parent_quad_pts_wts 8 | use graphs_potential, only: run_convergence_potential 9 | use string_utils, only: str 10 | use schroed_dirac_solver, only: total_energy 11 | implicit none 12 | 13 | integer :: p, Ne, Nq, Z, i, DOFs 14 | real(dp) :: rmin, rmax, a, err, Etot 15 | real(dp), allocatable :: energies(:), xq(:,:), eigfn(:,:,:) 16 | real(dp), parameter :: Etot_ref = 210._dp 17 | real(dp), parameter :: energies_ref(*) = [ & 18 | 1.5_dp, & 19 | 3.5_dp, & 20 | 2.5_dp, & 21 | 5.5_dp, & 22 | 4.5_dp, & 23 | 3.5_dp, & 24 | 7.5_dp, & 25 | 6.5_dp, & 26 | 5.5_dp, & 27 | 4.5_dp, & 28 | 9.5_dp, & 29 | 8.5_dp, & 30 | 7.5_dp, & 31 | 6.5_dp, & 32 | 5.5_dp, & 33 | 11.5_dp, & 34 | 10.5_dp, & 35 | 9.5_dp, & 36 | 8.5_dp, & 37 | 7.5_dp, & 38 | 6.5_dp, & 39 | 13.5_dp, & 40 | 12.5_dp, & 41 | 11.5_dp, & 42 | 10.5_dp, & 43 | 9.5_dp, & 44 | 8.5_dp, & 45 | 7.5_dp ] 46 | ! can be, 47 | ! 0: error as p is varied 48 | ! 1: error as rmax is varied 49 | ! 2: error as Ne is varied 50 | integer :: study_type 51 | ! can be, 52 | ! 0: Schroedinger 53 | ! 1: Dirac 54 | integer :: dirac_int 55 | ! For 56 | ! 0, 1: 3rd argument p_or_Ne = Ne (Number of elements) 57 | ! 2 : 3rd argument p_or_Ne = p (Polynomial order) 58 | integer :: p_or_Ne 59 | ! can be, 60 | ! 0: Coulomb 61 | ! 1: Harmonic 62 | integer :: potential_type 63 | ! can be 0, 1, -1 (-1 implies beta). used only for Dirac. 64 | integer :: alpha_int 65 | 66 | ! The directory where to save the output files 67 | character(len=:), allocatable :: directory 68 | 69 | integer :: u 70 | real(dp) :: asympt, c 71 | real(dp), allocatable :: alpha_j(:), alpha(:) 72 | integer :: Lmax, Lmin, kappa 73 | real(dp) :: optim_a(2:7) 74 | 75 | 76 | Z = 92 77 | rmin = 0 78 | rmax = 50 79 | a = 200 80 | Ne = 4 81 | Nq = 53 82 | p = 26 83 | 84 | i = 7 85 | !call run_convergence_potential(0, 0, i, & 86 | ! 1, 0, ".") 87 | 88 | study_type = 0 89 | dirac_int = 0 90 | p_or_Ne = i 91 | potential_type = 1 92 | alpha_int = 0 93 | directory = "." 94 | 95 | Z = 92 96 | rmax = 50 97 | a = 200 98 | Ne = 4 99 | Nq = 64 100 | p = 25 101 | c = 137.0359895_dp 102 | 103 | if (study_type == 2) then 104 | p = p_or_Ne 105 | else 106 | Ne = p_or_Ne 107 | end if 108 | 109 | Lmax=6 110 | Lmin=-7 111 | 112 | allocate(alpha(Lmin:Lmax), alpha_j(Lmin:Lmax)) 113 | do kappa = Lmin, Lmax 114 | if (kappa == 0) cycle 115 | ! asymptotic at r = 0 116 | asympt = sqrt(kappa**2 - Z**2 / c**2) 117 | ! solve for P/r**alpha 118 | if (alpha_int == -1) then 119 | alpha(kappa) = asympt 120 | ! power of r for Gauss-Jacobi quadrature 121 | alpha_j(kappa) = 2*asympt - 2 122 | else 123 | alpha(kappa) = alpha_int 124 | ! don't use Gauss-Jacobi quadrature 125 | alpha_j(kappa) = -2 126 | end if 127 | end do 128 | 129 | optim_a = [58.985048682607555, 163.13530060338942, 340.82602039608668, & 130 | 444.68894311026423, 591.72463734788732, 596.61404750045062] 131 | 132 | if (Ne >= 2 .and. Ne <= 7) then 133 | a = optim_a(Ne) 134 | end if 135 | 136 | a = 100 137 | 138 | print "(a3,a6,a5,a8,a3,a3,a5)", "Z", "rmax", "Ne", "a", "p", "Nq", & 139 | "DOFs" 140 | 141 | i = 31 142 | ! change p for p-conv study. p must be less than 31. 143 | !if (dirac_int == 1 .and. i > 23) then 144 | ! exit 145 | !end if 146 | p = i 147 | allocate(xq(Nq, Ne)) 148 | call total_energy(Z, rmax, Ne, a, p, Nq, DOFs, alpha_int, dirac_int, & 149 | c, potential_type, Lmin, alpha_j, alpha, energies, eigfn, xq) 150 | Etot = sum(energies) 151 | print "(i3, f6.1, i5, f8.1, i3, i3, i5, f22.12)", Z, rmax, Ne, a, p, Nq, & 152 | DOFs, Etot 153 | print * 154 | print *, "Comparison of calculated and reference energies" 155 | print * 156 | print *, "Total energy:" 157 | print "(a20,a20,a10)", "E", "E_ref", "error" 158 | err = abs(Etot - Etot_ref) 159 | print "(f20.12, f20.12, es10.2)", Etot, Etot_ref, err 160 | if ( .not. (err < 1e-10_dp)) then 161 | error stop 'assert failed' 162 | end if 163 | print *, "Eigenvalues:" 164 | print "(a4,a20,a20,a10)", "n", "E", "E_ref", "error" 165 | do i = 1, size(energies) 166 | err = abs(energies(i) - energies_ref(i)) 167 | print "(i4, f20.12, f20.12, es10.2)", i, energies(i), energies_ref(i), err 168 | if ( .not. (err < 1e-10_dp)) then 169 | error stop 'assert failed' 170 | end if 171 | end do 172 | 173 | print *, "Eigenfunctions saved in data_harmonic_schroed.txt" 174 | open(newunit=u, file="data_harmonic_schroed.txt", status="replace") 175 | write(u, *) xq 176 | do i = 1, size(energies) 177 | write(u, *) eigfn(:,:,i) 178 | end do 179 | close(u) 180 | 181 | end program 182 | --------------------------------------------------------------------------------