pax_global_header00006660000000000000000000000064145257333170014524gustar00rootroot0000000000000052 comment=ac4e807dbd97ec569f02b41b3ae1403097b187a1 libmbd-libmbd-88d61bc/000077500000000000000000000000001452573331700146255ustar00rootroot00000000000000libmbd-libmbd-88d61bc/.fprettify.rc000066400000000000000000000001701452573331700172430ustar00rootroot00000000000000indent = 4 whitespace = 3 enable-replacements = true disable-indent-mod = true c-relations = true disable-indent = true libmbd-libmbd-88d61bc/.github/000077500000000000000000000000001452573331700161655ustar00rootroot00000000000000libmbd-libmbd-88d61bc/.github/workflows/000077500000000000000000000000001452573331700202225ustar00rootroot00000000000000libmbd-libmbd-88d61bc/.github/workflows/doc.yaml000066400000000000000000000012401452573331700216500ustar00rootroot00000000000000name: Documentation on: push: pull_request: schedule: - cron: '0 6 * * 1' jobs: build: name: Build runs-on: ubuntu-latest if: github.event_name != 'schedule' || github.repository == 'libmbd/libmbd' steps: - uses: actions/setup-python@v2 with: python-version: 3.x - name: Install Poetry run: | curl -sSL https://install.python-poetry.org | python - $HOME/.local/share/pypoetry/venv/bin/pip install -U poetry-dynamic-versioning echo $HOME/.local/bin >>$GITHUB_PATH - uses: actions/checkout@v2 - name: Build documentation run: make build_doc VIRTUAL_ENV=none libmbd-libmbd-88d61bc/.github/workflows/install.yaml000066400000000000000000000040601452573331700225540ustar00rootroot00000000000000name: Install on: schedule: - cron: '0 6 * * 1' push: paths: - '.github/workflows/install.yaml' jobs: all: if: github.repository == 'libmbd/libmbd' || github.event_name == 'push' name: All strategy: fail-fast: false matrix: os: [ubuntu-latest, macos-latest] mpi: [nompi, openmpi, mpich] runs-on: ${{ matrix.os }} env: CONDA_ALWAYS_YES: "true" CONDA_QUIET: "true" steps: - name: Set environment variables run: | case ${{ runner.os }} in Linux) XDG_CACHE_HOME=$HOME/.cache ;; macOS) XDG_CACHE_HOME=$HOME/Library/Caches ;; esac if [[ "${{ matrix.mpi}}" == "nompi" ]]; then CONDA_PKGS=libmbd PIP_PKGS=pymbd RUN_PREFIX= else CONDA_PKGS="libmbd='*=mpi_${{ matrix.mpi }}_*' mpi4py" PIP_PKGS="pymbd[mpi]" RUN_PREFIX="mpiexec -n 2" fi echo YEAR_MONTH=$(date +"%Y-%m") >>$GITHUB_ENV echo XDG_CACHE_HOME="$XDG_CACHE_HOME" >>$GITHUB_ENV echo CONDA_PKGS="$CONDA_PKGS" >>$GITHUB_ENV echo PIP_PKGS="$PIP_PKGS" >>$GITHUB_ENV echo RUN_PREFIX="$RUN_PREFIX" >>$GITHUB_ENV echo CONDA_PREFIX=$HOME/env >>$GITHUB_ENV echo CONDA_PKGS_DIRS="$XDG_CACHE_HOME/conda/pkgs" >>$GITHUB_ENV - uses: actions/cache@v2 with: path: | ${{ env.XDG_CACHE_HOME }}/conda/pkgs ${{ env.XDG_CACHE_HOME }}/pip key: ${{ matrix.os }}-${{ matrix.mpi }}-${{ env.YEAR_MONTH }} - name: Create Conda environment run: | conda create -p ${{ env.CONDA_PREFIX }} -c conda-forge python ${{ env.CONDA_PKGS }} numpy scipy echo $CONDA_PREFIX/bin >>$GITHUB_PATH - name: Run pip install ${{ env.PIP_PKGS }} run: | source $CONDA/etc/profile.d/conda.sh && conda activate $HOME/env pip install ${{ env.PIP_PKGS }} - run: ${{ env.RUN_PREFIX }} python -m pymbd libmbd-libmbd-88d61bc/.github/workflows/lint.yaml000066400000000000000000000040211452573331700220510ustar00rootroot00000000000000name: Lint on: push: pull_request: schedule: - cron: '0 6 * * 1' jobs: flake8: runs-on: ubuntu-latest if: github.event_name != 'schedule' || github.repository == 'libmbd/libmbd' steps: - uses: actions/setup-python@v2 with: python-version: 3.x - name: Install dependencies run: pip install flake8 flake8-bugbear flake8-comprehensions flake8-quotes pep8-naming - uses: actions/checkout@v2 - run: flake8 black: runs-on: ubuntu-latest if: github.event_name != 'schedule' || github.repository == 'libmbd/libmbd' steps: - uses: actions/checkout@v2 - uses: actions/setup-python@v2 with: python-version: 3.x - name: Install dependencies run: pip install black - uses: actions/checkout@v2 - run: black . --check isort: runs-on: ubuntu-latest if: github.event_name != 'schedule' || github.repository == 'libmbd/libmbd' steps: - uses: actions/checkout@v2 - uses: actions/setup-python@v2 with: python-version: 3.x - name: Install dependencies run: pip install isort - uses: actions/checkout@v2 - run: isort . --check pydocstyle: runs-on: ubuntu-latest if: github.event_name != 'schedule' || github.repository == 'libmbd/libmbd' steps: - uses: actions/checkout@v2 - uses: actions/setup-python@v2 with: python-version: 3.x - name: Install dependencies run: pip install pydocstyle - uses: actions/checkout@v2 - run: pydocstyle src fprettify: runs-on: ubuntu-latest if: github.event_name != 'schedule' || github.repository == 'libmbd/libmbd' steps: - uses: actions/checkout@v2 - uses: actions/setup-python@v2 with: python-version: 3.x - name: Install dependencies run: pip install fprettify - uses: actions/checkout@v2 - name: Run fprettify run: | fprettify -d -r . | tee diff test -z "$(cat diff)" libmbd-libmbd-88d61bc/.github/workflows/tests.yaml000066400000000000000000000124221452573331700222510ustar00rootroot00000000000000name: Tests on: push: pull_request: schedule: - cron: '0 6 * * 1' jobs: all: if: github.event_name != 'schedule' || github.repository == 'libmbd/libmbd' name: All strategy: fail-fast: false matrix: include: - type: ubuntu mpi-nodes: 2 - type: macos mpi-nodes: 2 - type: conda - type: conda mpi: openmpi mpi-nodes: 8 elsi: elsi - type: conda mpi: mpich mpi-nodes: 2 - type: conda python-version: =3.6 cmake-version: =3.14 gfortran-version: =8 mpi: openmpi mpi-nodes: 8 - type: conda python-version: =3.6 cmake-version: =3.14 gfortran-version: =8 mpi: mpich=3.4.3=\*_100 mpi-nodes: 2 elsi: elsi runs-on: ${{ fromJSON('{"ubuntu":"ubuntu-latest","macos":"macos-latest","conda":"ubuntu-latest"}')[matrix.type] }} env: CONDA_ALWAYS_YES: "true" CONDA_QUIET: "true" steps: - name: Set environment variables run: | case ${{ runner.os }} in Linux) XDG_CACHE_HOME=$HOME/.cache ;; macOS) XDG_CACHE_HOME=$HOME/Library/Caches ;; esac echo YEAR_MONTH=$(date +"%Y-%m") >>$GITHUB_ENV echo XDG_CACHE_HOME="$XDG_CACHE_HOME" >>$GITHUB_ENV if [[ "${{ matrix.mpi-nodes }}" ]]; then echo MPI_NODES=${{ matrix.mpi-nodes }} >>$GITHUB_ENV fi if [[ "${{ matrix.mpi }}" == "openmpi" || "${{ matrix.type }}" == "ubuntu" ]]; then echo MPIEXEC_EXTRA_FLAGS=--oversubscribe >>$GITHUB_ENV fi echo VIRTUAL_ENV=$HOME/env >>$GITHUB_ENV echo CONDA_PKGS_DIRS="$XDG_CACHE_HOME/conda/pkgs" >>$GITHUB_ENV echo $HOME/env/bin >>$GITHUB_PATH - uses: actions/checkout@v2 with: fetch-depth: 0 - uses: actions/cache@v2 with: path: | ${{ env.XDG_CACHE_HOME }}/conda/pkgs ${{ env.XDG_CACHE_HOME }}/pip key: ${{ matrix.type }}-${{ matrix.python-version }}-${{ matrix.cmake-version }}-${{ matrix.gfortran-version }}-${{ matrix.mpi }}-${{ env.YEAR_MONTH }}-${{ hashFiles('pyproject.toml') }} - name: Install libMBD dependencies if: matrix.type == 'ubuntu' run: sudo apt-get install -yq --no-install-suggests --no-install-recommends gfortran libblas-dev liblapack-dev mpi-default-dev mpi-default-bin libscalapack-mpi-dev - name: Install libMBD dependencies if: matrix.type == 'macos' run: brew install open-mpi scalapack - name: Create Conda environment if: matrix.type == 'conda' run: conda create -p ${{ env.VIRTUAL_ENV }} -c conda-forge python${{ matrix.python-version }} cmake${{ matrix.cmake-version }} gfortran_linux-64${{ matrix.gfortran-version }} openblas ${{ matrix.mpi }} scalapack elsi numpy scipy mpi4py - name: Create Python virtual environment if: matrix.type != 'conda' run: | python3 -m venv ${{ env.VIRTUAL_ENV }} ${{ env.VIRTUAL_ENV }}/bin/pip install -U pip - name: Install coverage Python package run: pip install -U coverage - name: Report environment run: | type python type pip python --version cmake --version pip --version git describe --tags --dirty=.dirty - name: Set CMAKE_ARGS run: | FFLAGS=('-fprofile-arcs' '-ftest-coverage') CMAKE_ARGS=() if [[ "${{ matrix.mpi-nodes }}" ]]; then CMAKE_ARGS+=('-DENABLE_SCALAPACK_MPI=ON') fi if [[ "${{ matrix.elsi }}" == "elsi" ]]; then CMAKE_ARGS+=('-DENABLE_ELSI=ON') fi if [[ "${{ matrix.type }}" == "macos" ]]; then CMAKE_ARGS+=('-DCMAKE_Fortran_COMPILER=gfortran-12') fi if [[ "${{ matrix.type }}" == "ubuntu" ]]; then CMAKE_ARGS+=('-DCMAKE_IGNORE_PATH="/usr/lib/cmake/scalapack-2.1.0.openmpi;/lib/cmake/scalapack-2.1.0.openmpi"') fi echo CMAKE_ARGS=${CMAKE_ARGS[@]} echo CMAKE_ARGS=${CMAKE_ARGS[@]} >>$GITHUB_ENV echo FFLAGS=${FFLAGS[@]} echo FFLAGS=${FFLAGS[@]} >>$GITHUB_ENV - name: Run Cmake run: | [[ "${{ matrix.type }}" != "conda" ]] || { source $CONDA/etc/profile.d/conda.sh && conda activate $HOME/env && export CMAKE_ARGS="$CONDA_BACKUP_CMAKE_ARGS"; } make run_cmake - name: Build libMBD run: make build_libmbd -o run_cmake - name: Install libMBD run: make install_libmbd -o build_libmbd - name: Build & install pyMBD run: | [[ "${{ matrix.type }}" != "conda" ]] || { source $CONDA/etc/profile.d/conda.sh && conda activate $HOME/env; } make install -o install_libmbd - run: pip list - name: Test libMBD run: make test_libmbd - name: Test pyMBD run: | make test -o test_libmbd RUN_CMD="coverage run -m" | tee output ! grep failed output >/dev/null - name: Upload to Codecov run: bash <(curl -s https://codecov.io/bash) -f "!*#tests#*" libmbd-libmbd-88d61bc/.gitignore000066400000000000000000000001471452573331700166170ustar00rootroot00000000000000*.pyc *.so *.egg-info/ /.coverage* /.tox /.pytest_cache/ /build /dist/ /doc/build/ /poetry.lock /wiki/ libmbd-libmbd-88d61bc/CHANGELOG.md000066400000000000000000000000641452573331700164360ustar00rootroot00000000000000See https://github.com/libmbd/libmbd/wiki/Changelog libmbd-libmbd-88d61bc/CMakeLists.txt000066400000000000000000000103371452573331700173710ustar00rootroot00000000000000cmake_minimum_required(VERSION 3.14) cmake_policy(SET CMP0042 NEW) cmake_policy(SET CMP0077 NEW) set(CMAKE_USER_MAKE_RULES_OVERRIDE_Fortran "${CMAKE_CURRENT_SOURCE_DIR}/cmake/fortran_flags_override.cmake") project(libMBD DESCRIPTION "Many-body dispersion library" LANGUAGES Fortran C) list(APPEND CMAKE_MODULE_PATH "${CMAKE_CURRENT_SOURCE_DIR}/cmake") include(libMBDVersion) include(GNUInstallDirs) include(CMakeDependentOption) include(CTest) option(ENABLE_SCALAPACK_MPI "Enable parallelisation with ScaLAPACK/MPI") CMAKE_DEPENDENT_OPTION(ENABLE_ELSI "Enable ELSI interface" OFF ENABLE_SCALAPACK_MPI OFF) option(ENABLE_C_API "Enable C API" ON) option(BUILD_SHARED_LIBS "Build shared rather than static library" ON) set(DEFAULT_BUILD_TYPE "Release") if(EXISTS "${CMAKE_CURRENT_SOURCE_DIR}/.git") set(DEFAULT_BUILD_TYPE "Debug") endif() if(NOT CMAKE_BUILD_TYPE AND NOT CMAKE_CONFIGURATION_TYPES) message(STATUS "Setting build type to ${DEFAULT_BUILD_TYPE} as none was set") set(CMAKE_BUILD_TYPE "${DEFAULT_BUILD_TYPE}") endif() if(NOT TARGET LAPACK::LAPACK) find_package(LAPACK REQUIRED) if(CMAKE_VERSION VERSION_LESS 3.18) add_library(LAPACK::LAPACK INTERFACE IMPORTED) target_link_libraries(LAPACK::LAPACK INTERFACE ${LAPACK_LINKER_FLAGS} ${LAPACK_LIBRARIES}) endif() endif() if(ENABLE_SCALAPACK_MPI) if(NOT TARGET MPI::MPI_Fortran) find_package(MPI REQUIRED) if(APPLE) # -flat_namespace (Darwin-specific) is causing a crash (seg fault) when the # Fortran library is called from Python and one writes into a character # variable, but only when the kind is the default one. It causes the # written to variable to appear as being four times shorter than it is. # Only mention of anything possibly related I could find is at # # https://trac.mpich.org/projects/mpich/ticket/1590 get_target_property(_VALUE MPI::MPI_Fortran INTERFACE_LINK_OPTIONS) string(REGEX REPLACE "-Wl\\$-flat_namespace ?" "" _VALUE "${_VALUE}") set_target_properties(MPI::MPI_Fortran PROPERTIES INTERFACE_LINK_OPTIONS "${_VALUE}") endif() endif() if(MPI_Fortran_HAVE_F08_MODULE) message(STATUS "Will use the mpi_f08 Fortran module") endif() if(NOT TARGET scalapack AND NOT DEFINED SCALAPACK_LIBRARY) find_package(scalapack QUIET) if(scalapack_FOUND) message(STATUS "ScaLAPACK CMake package found in ${scalapack_DIR}") else() find_package(PkgConfig) if(PkgConfig_FOUND) unset(scalapack_FOUND CACHE) pkg_search_module(scalapack scalapack scalapack-openmpi) if(scalapack_FOUND) message(STATUS "ScaLAPACK pkg-config package found, version ${scalapack_VERSION}") set(SCALAPACK_LIBRARY "${scalapack_LDFLAGS}") endif() endif() endif() if(NOT scalapack_FOUND) message(SEND_ERROR "ScaLAPACK Cmake or pkg-config package not found, \ specify custom installation with SCALAPACK_LIBRARY") endif() endif() if(NOT TARGET scalapack AND DEFINED SCALAPACK_LIBRARY) add_library(scalapack INTERFACE IMPORTED) target_link_libraries(scalapack INTERFACE "${SCALAPACK_LIBRARY}") endif() endif() if(ENABLE_ELSI AND NOT TARGET elsi::elsi) find_package(elsi 2.0 QUIET) if(elsi_FOUND) message(STATUS "ELSI CMake package found in ${elsi_DIR}") else() find_package(PkgConfig) if(PkgConfig_FOUND) unset(elsi_FOUND CACHE) pkg_search_module(elsi elsi) if(elsi_FOUND) message(STATUS "ELSI pkg-config package found, version ${elsi_VERSION}") add_library(elsi::elsi INTERFACE IMPORTED) target_link_libraries(elsi::elsi INTERFACE "${elsi_LINK_LIBRARIES}") target_include_directories(elsi::elsi INTERFACE "${elsi_INCLUDE_DIRS}") endif() endif() endif() if(NOT elsi_FOUND) message(SEND_ERROR "ELSI Cmake or pkg-config package not found") endif() endif() add_subdirectory(src) if(BUILD_TESTING) add_subdirectory(tests) endif() libmbd-libmbd-88d61bc/LICENSE000066400000000000000000000405261452573331700156410ustar00rootroot00000000000000Mozilla Public License Version 2.0 ================================== 1. Definitions -------------- 1.1. "Contributor" means each individual or legal entity that creates, contributes to the creation of, or owns Covered Software. 1.2. "Contributor Version" means the combination of the Contributions of others (if any) used by a Contributor and that particular Contributor's Contribution. 1.3. "Contribution" means Covered Software of a particular Contributor. 1.4. "Covered Software" means Source Code Form to which the initial Contributor has attached the notice in Exhibit A, the Executable Form of such Source Code Form, and Modifications of such Source Code Form, in each case including portions thereof. 1.5. "Incompatible With Secondary Licenses" means (a) that the initial Contributor has attached the notice described in Exhibit B to the Covered Software; or (b) that the Covered Software was made available under the terms of version 1.1 or earlier of the License, but not also under the terms of a Secondary License. 1.6. "Executable Form" means any form of the work other than Source Code Form. 1.7. "Larger Work" means a work that combines Covered Software with other material, in a separate file or files, that is not Covered Software. 1.8. "License" means this document. 1.9. "Licensable" means having the right to grant, to the maximum extent possible, whether at the time of the initial grant or subsequently, any and all of the rights conveyed by this License. 1.10. "Modifications" means any of the following: (a) any file in Source Code Form that results from an addition to, deletion from, or modification of the contents of Covered Software; or (b) any new file in Source Code Form that contains any Covered Software. 1.11. "Patent Claims" of a Contributor means any patent claim(s), including without limitation, method, process, and apparatus claims, in any patent Licensable by such Contributor that would be infringed, but for the grant of the License, by the making, using, selling, offering for sale, having made, import, or transfer of either its Contributions or its Contributor Version. 1.12. "Secondary License" means either the GNU General Public License, Version 2.0, the GNU Lesser General Public License, Version 2.1, the GNU Affero General Public License, Version 3.0, or any later versions of those licenses. 1.13. "Source Code Form" means the form of the work preferred for making modifications. 1.14. "You" (or "Your") means an individual or a legal entity exercising rights under this License. For legal entities, "You" includes any entity that controls, is controlled by, or is under common control with You. For purposes of this definition, "control" means (a) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (b) ownership of more than fifty percent (50%) of the outstanding shares or beneficial ownership of such entity. 2. License Grants and Conditions -------------------------------- 2.1. Grants Each Contributor hereby grants You a world-wide, royalty-free, non-exclusive license: (a) under intellectual property rights (other than patent or trademark) Licensable by such Contributor to use, reproduce, make available, modify, display, perform, distribute, and otherwise exploit its Contributions, either on an unmodified basis, with Modifications, or as part of a Larger Work; and (b) under Patent Claims of such Contributor to make, use, sell, offer for sale, have made, import, and otherwise transfer either its Contributions or its Contributor Version. 2.2. Effective Date The licenses granted in Section 2.1 with respect to any Contribution become effective for each Contribution on the date the Contributor first distributes such Contribution. 2.3. Limitations on Grant Scope The licenses granted in this Section 2 are the only rights granted under this License. No additional rights or licenses will be implied from the distribution or licensing of Covered Software under this License. Notwithstanding Section 2.1(b) above, no patent license is granted by a Contributor: (a) for any code that a Contributor has removed from Covered Software; or (b) for infringements caused by: (i) Your and any other third party's modifications of Covered Software, or (ii) the combination of its Contributions with other software (except as part of its Contributor Version); or (c) under Patent Claims infringed by Covered Software in the absence of its Contributions. This License does not grant any rights in the trademarks, service marks, or logos of any Contributor (except as may be necessary to comply with the notice requirements in Section 3.4). 2.4. Subsequent Licenses No Contributor makes additional grants as a result of Your choice to distribute the Covered Software under a subsequent version of this License (see Section 10.2) or under the terms of a Secondary License (if permitted under the terms of Section 3.3). 2.5. Representation Each Contributor represents that the Contributor believes its Contributions are its original creation(s) or it has sufficient rights to grant the rights to its Contributions conveyed by this License. 2.6. Fair Use This License is not intended to limit any rights You have under applicable copyright doctrines of fair use, fair dealing, or other equivalents. 2.7. Conditions Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted in Section 2.1. 3. Responsibilities ------------------- 3.1. Distribution of Source Form All distribution of Covered Software in Source Code Form, including any Modifications that You create or to which You contribute, must be under the terms of this License. You must inform recipients that the Source Code Form of the Covered Software is governed by the terms of this License, and how they can obtain a copy of this License. You may not attempt to alter or restrict the recipients' rights in the Source Code Form. 3.2. Distribution of Executable Form If You distribute Covered Software in Executable Form then: (a) such Covered Software must also be made available in Source Code Form, as described in Section 3.1, and You must inform recipients of the Executable Form how they can obtain a copy of such Source Code Form by reasonable means in a timely manner, at a charge no more than the cost of distribution to the recipient; and (b) You may distribute such Executable Form under the terms of this License, or sublicense it under different terms, provided that the license for the Executable Form does not attempt to limit or alter the recipients' rights in the Source Code Form under this License. 3.3. Distribution of a Larger Work You may create and distribute a Larger Work under terms of Your choice, provided that You also comply with the requirements of this License for the Covered Software. If the Larger Work is a combination of Covered Software with a work governed by one or more Secondary Licenses, and the Covered Software is not Incompatible With Secondary Licenses, this License permits You to additionally distribute such Covered Software under the terms of such Secondary License(s), so that the recipient of the Larger Work may, at their option, further distribute the Covered Software under the terms of either this License or such Secondary License(s). 3.4. Notices You may not remove or alter the substance of any license notices (including copyright notices, patent notices, disclaimers of warranty, or limitations of liability) contained within the Source Code Form of the Covered Software, except that You may alter any license notices to the extent required to remedy known factual inaccuracies. 3.5. Application of Additional Terms You may choose to offer, and to charge a fee for, warranty, support, indemnity or liability obligations to one or more recipients of Covered Software. However, You may do so only on Your own behalf, and not on behalf of any Contributor. You must make it absolutely clear that any such warranty, support, indemnity, or liability obligation is offered by You alone, and You hereby agree to indemnify every Contributor for any liability incurred by such Contributor as a result of warranty, support, indemnity or liability terms You offer. You may include additional disclaimers of warranty and limitations of liability specific to any jurisdiction. 4. Inability to Comply Due to Statute or Regulation --------------------------------------------------- If it is impossible for You to comply with any of the terms of this License with respect to some or all of the Covered Software due to statute, judicial order, or regulation then You must: (a) comply with the terms of this License to the maximum extent possible; and (b) describe the limitations and the code they affect. Such description must be placed in a text file included with all distributions of the Covered Software under this License. Except to the extent prohibited by statute or regulation, such description must be sufficiently detailed for a recipient of ordinary skill to be able to understand it. 5. Termination -------------- 5.1. The rights granted under this License will terminate automatically if You fail to comply with any of its terms. However, if You become compliant, then the rights granted under this License from a particular Contributor are reinstated (a) provisionally, unless and until such Contributor explicitly and finally terminates Your grants, and (b) on an ongoing basis, if such Contributor fails to notify You of the non-compliance by some reasonable means prior to 60 days after You have come back into compliance. Moreover, Your grants from a particular Contributor are reinstated on an ongoing basis if such Contributor notifies You of the non-compliance by some reasonable means, this is the first time You have received notice of non-compliance with this License from such Contributor, and You become compliant prior to 30 days after Your receipt of the notice. 5.2. If You initiate litigation against any entity by asserting a patent infringement claim (excluding declaratory judgment actions, counter-claims, and cross-claims) alleging that a Contributor Version directly or indirectly infringes any patent, then the rights granted to You by any and all Contributors for the Covered Software under Section 2.1 of this License shall terminate. 5.3. In the event of termination under Sections 5.1 or 5.2 above, all end user license agreements (excluding distributors and resellers) which have been validly granted by You or Your distributors under this License prior to termination shall survive termination. ************************************************************************ * * * 6. Disclaimer of Warranty * * ------------------------- * * * * Covered Software is provided under this License on an "as is" * * basis, without warranty of any kind, either expressed, implied, or * * statutory, including, without limitation, warranties that the * * Covered Software is free of defects, merchantable, fit for a * * particular purpose or non-infringing. The entire risk as to the * * quality and performance of the Covered Software is with You. * * Should any Covered Software prove defective in any respect, You * * (not any Contributor) assume the cost of any necessary servicing, * * repair, or correction. This disclaimer of warranty constitutes an * * essential part of this License. No use of any Covered Software is * * authorized under this License except under this disclaimer. * * * ************************************************************************ ************************************************************************ * * * 7. Limitation of Liability * * -------------------------- * * * * Under no circumstances and under no legal theory, whether tort * * (including negligence), contract, or otherwise, shall any * * Contributor, or anyone who distributes Covered Software as * * permitted above, be liable to You for any direct, indirect, * * special, incidental, or consequential damages of any character * * including, without limitation, damages for lost profits, loss of * * goodwill, work stoppage, computer failure or malfunction, or any * * and all other commercial damages or losses, even if such party * * shall have been informed of the possibility of such damages. This * * limitation of liability shall not apply to liability for death or * * personal injury resulting from such party's negligence to the * * extent applicable law prohibits such limitation. Some * * jurisdictions do not allow the exclusion or limitation of * * incidental or consequential damages, so this exclusion and * * limitation may not apply to You. * * * ************************************************************************ 8. Litigation ------------- Any litigation relating to this License may be brought only in the courts of a jurisdiction where the defendant maintains its principal place of business and such litigation shall be governed by laws of that jurisdiction, without reference to its conflict-of-law provisions. Nothing in this Section shall prevent a party's ability to bring cross-claims or counter-claims. 9. Miscellaneous ---------------- This License represents the complete agreement concerning the subject matter hereof. If any provision of this License is held to be unenforceable, such provision shall be reformed only to the extent necessary to make it enforceable. Any law or regulation which provides that the language of a contract shall be construed against the drafter shall not be used to construe this License against a Contributor. 10. Versions of the License --------------------------- 10.1. New Versions Mozilla Foundation is the license steward. Except as provided in Section 10.3, no one other than the license steward has the right to modify or publish new versions of this License. Each version will be given a distinguishing version number. 10.2. Effect of New Versions You may distribute the Covered Software under the terms of the version of the License under which You originally received the Covered Software, or under the terms of any subsequent version published by the license steward. 10.3. Modified Versions If you create software not governed by this License, and you want to create a new license for such software, you may create and use a modified version of this License if you rename the license and remove any references to the name of the license steward (except to note that such modified license differs from this License). 10.4. Distributing Source Code Form that is Incompatible With Secondary Licenses If You choose to distribute Source Code Form that is Incompatible With Secondary Licenses under the terms of this version of the License, the notice described in Exhibit B of this License must be attached. Exhibit A - Source Code Form License Notice ------------------------------------------- This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. If a copy of the MPL was not distributed with this file, You can obtain one at http://mozilla.org/MPL/2.0/. If it is not possible or desirable to put the notice in a particular file, then You may include the notice in a location (such as a LICENSE file in a relevant directory) where a recipient would be likely to look for such a notice. You may add additional accurate notices of copyright ownership. Exhibit B - "Incompatible With Secondary Licenses" Notice --------------------------------------------------------- This Source Code Form is "Incompatible With Secondary Licenses", as defined by the Mozilla Public License, v. 2.0. libmbd-libmbd-88d61bc/Makefile000066400000000000000000000023541452573331700162710ustar00rootroot00000000000000ifndef VIRTUAL_ENV $(error Must be run inside a Python virtual environment) endif BLDDIR ?= $(CURDIR)/build export LIBMBD_PREFIX = $(VIRTUAL_ENV) ifdef MPI_NODES override RUN_CMD := env OMP_NUM_THREADS=1 mpiexec $(MPIEXEC_EXTRA_FLAGS) -n $(MPI_NODES) $(RUN_CMD) endif PYMBD_EXTRAS = test ifneq (,$(findstring ENABLE_SCALAPACK_MPI=ON,$(CMAKE_ARGS))) PYMBD_EXTRAS += mpi endif EMPTY = SPACE = $(EMPTY) $(EMPTY) COMMA = , all: install_editable test run_cmake: cmake -B $(BLDDIR) -DCMAKE_INSTALL_PREFIX=$(LIBMBD_PREFIX) $(CMAKE_ARGS) build_libmbd: run_cmake make -C $(BLDDIR) all install_libmbd: build_libmbd make -C $(BLDDIR) install install_editable: install_libmbd pip install -e .[$(subst $(SPACE),$(COMMA),$(PYMBD_EXTRAS))] install: install_libmbd pip install .[$(subst $(SPACE),$(COMMA),$(PYMBD_EXTRAS))] test_libmbd: ctest --test-dir $(BLDDIR) --output-on-failure test: test_libmbd $(RUN_CMD) pytest -v --durations=3 build_doc: pip install "Markdown<3.4" "sphinx<3" "Jinja2<3.1" toml git+https://github.com/libmbd/ford@7b44574da7ec20f4ab4b1842ec7561de2a601930 ford -I. doc/libmbd.md -o build sphinx-build -W -d $(BLDDIR)/doctrees doc doc/build/pymbd touch doc/build/.nojekyll distclean: -rm -r $(BLDDIR)/* -rm src/pymbd/_libmbd.*.so libmbd-libmbd-88d61bc/README.md000066400000000000000000000135151452573331700161110ustar00rootroot00000000000000# libMBD ![checks](https://img.shields.io/github/checks-status/libmbd/libmbd/master.svg) [![coverage](https://img.shields.io/codecov/c/github/libmbd/libmbd.svg)](https://codecov.io/gh/libmbd/libmbd) ![python](https://img.shields.io/pypi/pyversions/pymbd.svg) [![conda](https://img.shields.io/conda/vn/conda-forge/libmbd.svg)](https://anaconda.org/conda-forge/libmbd) [![pypi](https://img.shields.io/pypi/v/pymbd.svg)](https://pypi.org/project/pymbd/) [![commits since](https://img.shields.io/github/commits-since/libmbd/libmbd/latest.svg)](https://github.com/libmbd/libmbd/releases) [![last commit](https://img.shields.io/github/last-commit/libmbd/libmbd.svg)](https://github.com/libmbd/libmbd/commits/master) [![license](https://img.shields.io/github/license/libmbd/libmbd.svg)](https://github.com/libmbd/libmbd/blob/master/LICENSE) [![code style](https://img.shields.io/badge/code%20style-black-202020.svg)](https://github.com/ambv/black) [![chat](https://img.shields.io/gitter/room/libmbd/community)](https://gitter.im/libmbd/community) [![doi](https://img.shields.io/badge/doi-10%2Fk4bm-blue)](http://doi.org/k4bm) > libMBD: A general-purpose package for scalable quantum many-body dispersion calculations. [J. Hermann](https://github.com/jhrmnn), [M. Stöhr](https://github.com/martin-stoehr), S. Góger, [S. Chaudhuri](https://github.com/shaychaudhuri), [B. Aradi](https://github.com/aradi), [R. J. Maurer](https://github.com/reinimaurer1) & A. Tkatchenko. [*J. Chem. Phys.* **159**, 174802](http://doi.org/k4bm) (2023) libMBD implements the [many-body dispersion](http://dx.doi.org/10.1063/1.4865104) (MBD) method in several programming languages and frameworks: - The Fortran implementation is the reference, most advanced implementation, with support for analytical gradients and distributed parallelism, and additional functionality beyond the MBD method itself. It provides a low-level and a high-level Fortran API, as well as a C API. Furthermore, Python bindings to the C API are provided. - The Python/Numpy implementation is intended for prototyping, and as a high-level language reference. - The Python/Tensorflow implementation is an experiment that should enable rapid prototyping of machine learning applications with MBD. The Python-based implementations as well as Python bindings to the libMBD C API are accessible from the Python package called pyMBD. libMBD is included in [FHI-aims](https://aimsclub.fhi-berlin.mpg.de), [Quantum Espresso](https://www.quantum-espresso.org), [DFTB+](https://dftbplus.org), and [ESL Bundle](https://esl.cecam.org/bundle/). ## Installing **TL;DR** Install prebuilt libMBD binaries via [Conda-forge](https://conda-forge.org) and pyMBD with [Pip](https://pip.pypa.io/en/stable/quickstart/). ``` conda install -c conda-forge libmbd pip install pymbd ``` One can also install the ScaLAPACK/MPI version. ``` conda install -c conda-forge 'libmbd=*=mpi_*' mpi4py pip install pymbd[mpi] ``` Verify installation with ``` $ python -m pymbd Expected energy: -0.0002462647623815428 Calculated energy: -0.0002462647623817456 ``` ### libMBD libMBD uses CMake for compiling and installing, and requires a Fortran compiler, LAPACK, and optionally ScaLAPACK/MPI. On Ubuntu: ```bash apt-get install gfortran libblas-dev liblapack-dev [mpi-default-dev mpi-default-bin libscalapack-mpi-dev] ``` On macOS: ```bash brew install gcc [open-mpi scalapack] ``` The compiling and installation can then proceed with ``` cmake -B build [-DENABLE_SCALAPACK_MPI=ON] make -C build install [ctest --test-dir build] ``` This installs the libMBD shared library, C API header file, high-level Fortran API module file, and Cmake package files, and optionally runs tests. ### pyMBD pyMBD can be installed and updated using [Pip](https://pip.pypa.io/en/stable/quickstart/), but requires installed libMBD as a dependency (see above). ``` pip install pymbd ``` To support libMBD built with ScaLAPACK/MPI, the `mpi` extras is required, which installs `mpi4py` as an extra dependency. In this case one has to make sure that `mpi4py` is linked against the same MPI library as libMBD (for instance by compiling both manually, or installing both via Conda-forge). ``` pip install pymbd[mpi] ``` If libMBD is installed in a non-standard location, you can point pyMBD to it with ``` env LIBMBD_PREFIX= pip install pymbd ``` If you don’t need the Fortran bindings in pyMBD, you can install it without the C extension, in which case `pymbd.fortran` becomes unimportable: ``` env LIBMBD_PREFIX= pip install pymbd ``` ## Examples ```python from pymbd import mbd_energy_species from pymbd.fortran import MBDGeom # pure Python implementation energy = mbd_energy_species([(0, 0, 0), (0, 0, 7.5)], ['Ar', 'Ar'], [1, 1], 0.83) # Fortran implementation energy = MBDGeom([(0, 0, 0), (0, 0, 7.5)]).mbd_energy_species( ['Ar', 'Ar'], [1, 1], 0.83 ) ``` ```fortran use mbd, only: mbd_input_t, mbd_calc_t use iso_fortran_env, only: real64 type(mbd_input_t) :: inp type(mbd_calc_t) :: calc real(real64) :: energy, gradients(3, 2) integer :: code character(200) :: origin, msg inp%atom_types = ['Ar', 'Ar'] inp%coords = reshape([0d0, 0d0, 0d0, 0d0, 0d0, 7.5d0], [3, 2]) inp%xc = 'pbe' call calc%init(inp) call calc%get_exception(code, origin, msg) if (code > 0) then print *, msg stop 1 end if call calc%update_vdw_params_from_ratios([0.98d0, 0.98d0]) call calc%evaluate_vdw_method(energy) call calc%get_gradients(gradients) call calc%destroy() ``` ## Links - libMBD documentation: https://libmbd.github.io - pyMBD documentation: https://libmbd.github.io/pymbd ## Developing For development, a top-level `Makefile` is included, which configures and compiles libMBD, compiles the pyMBD C extension, and runs both libMBD and pyMBD tests. ``` git clone https://github.com/libmbd/libmbd.git && cd libmbd python3 -m venv venv && source venv/bin/activate make # development work... make ``` libmbd-libmbd-88d61bc/build.py000066400000000000000000000024301452573331700162750ustar00rootroot00000000000000import os import sys import cffi MBD_H = 'src/mbd.h' LIBMBD_PREFIX = os.environ.get('LIBMBD_PREFIX') if LIBMBD_PREFIX == '': sys.exit() # some Conda environments do not add their include dir into default includes CONDA_PREFIX = os.environ.get('CONDA_PREFIX') if not LIBMBD_PREFIX and CONDA_PREFIX: LIBMBD_PREFIX = CONDA_PREFIX if LIBMBD_PREFIX: ext_kwargs = { 'include_dirs': [f'{LIBMBD_PREFIX}/include'], 'library_dirs': [f'{LIBMBD_PREFIX}/lib'], 'runtime_library_dirs': [f'{LIBMBD_PREFIX}/lib'], } else: ext_kwargs = {} ffibuilder = cffi.FFI() ffibuilder.set_source( 'pymbd._libmbd', '#include "mbd/mbd.h"', libraries=['mbd'], **ext_kwargs ) with open(MBD_H) as f: ffibuilder.cdef(f.read()) if __name__ == '__main__': from cffi.setuptools_ext import cffi_modules from setuptools import Distribution if sys.platform[:6] == 'darwin': from distutils.unixccompiler import UnixCCompiler UnixCCompiler.runtime_library_dir_option = lambda self, dir: ['-rpath', dir] distribution = Distribution({'package_dir': {'': 'src'}}) cffi_modules(distribution, 'cffi_modules', ['build.py:ffibuilder']) cmd = distribution.cmdclass['build_ext'](distribution) cmd.inplace = 1 cmd.ensure_finalized() cmd.run() libmbd-libmbd-88d61bc/cmake/000077500000000000000000000000001452573331700157055ustar00rootroot00000000000000libmbd-libmbd-88d61bc/cmake/fortran_flags_override.cmake000066400000000000000000000004731452573331700234410ustar00rootroot00000000000000if(CMAKE_Fortran_COMPILER_ID STREQUAL "GNU") set(CMAKE_Fortran_FLAGS_INIT "-fall-intrinsics -std=f2008ts -pedantic -Wall -Wcharacter-truncation -Wimplicit-procedure -Wextra -Wno-maybe-uninitialized") set(CMAKE_Fortran_FLAGS_DEBUG_INIT "-Og -fcheck=all -fno-check-array-temporaries") endif() libmbd-libmbd-88d61bc/cmake/libMBDVersion.cmake000066400000000000000000000020201452573331700213400ustar00rootroot00000000000000if(EXISTS "${CMAKE_CURRENT_SOURCE_DIR}/.git") execute_process( COMMAND git describe --tags --dirty=.dirty OUTPUT_VARIABLE VERSION_TAG WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR} ERROR_QUIET OUTPUT_STRIP_TRAILING_WHITESPACE) message(STATUS "Setting version tag to ${VERSION_TAG} from Git") elseif(EXISTS "${CMAKE_CURRENT_SOURCE_DIR}/cmake/libMBDVersionTag.cmake") include(libMBDVersionTag) else() message(FATAL_ERROR "Not in a Git repository and version tag is missing, you most likely " "attempt to install from a copy of the source tree. Obtain the source " "distribution (libmbd-.tar.gz) from a Github release page " "instead.") endif() set(PROJECT_VERSION ${VERSION_TAG}) string(REGEX MATCH "^([0-9]+)\.([0-9]+)\.([0-9]+)-?(.*)?$" VERSION_TAG ${VERSION_TAG}) set(PROJECT_VERSION_MAJOR ${CMAKE_MATCH_1}) set(PROJECT_VERSION_MINOR ${CMAKE_MATCH_2}) set(PROJECT_VERSION_PATCH ${CMAKE_MATCH_3}) set(PROJECT_VERSION_SUFFIX ${CMAKE_MATCH_4}) libmbd-libmbd-88d61bc/devtools/000077500000000000000000000000001452573331700164645ustar00rootroot00000000000000libmbd-libmbd-88d61bc/devtools/CHANGELOG.md.in000066400000000000000000000066701452573331700207130ustar00rootroot00000000000000All notable changes to this project will be documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). ## [Unreleased] $changes ## [0.12.3] - 2021-12-06 ### Added - Honoring existing dependency targets when part of a host build - `--repeat` to `pymbd.benchmark` - pkg-config support for ELSI ### Removed - Support for CMake<3.14 ## [0.12.2] - 2021-11-25 ### Added - `LIBMBD_LOG_LEVEL` environment variable - `pymbd.fortran.print_timing()` and C API `cmbd_print_timing()` - `python -m pymbd.benchmark` ### Fixed - MPI issues from exceptions when k-point parallelization - Missing vdW parameters for f-block elements ## [0.12.1] - 2021-03-01 ### Added - API: Exception integer codes ## [0.12.0] - 2021-02-12 ### Added - MPI parallelization for TS - API for gradients w.r.t. vdW parameters - Scalapack support for RPA evaluation - API to switch on/off calculation of forces ## [0.11.0] - 2021-02-04 ### Added - Ewald evaluation of pairwise dispersion - Analytical gradients w.r.t. coordinates, lattice vectors, and vdW parameters for TS ### Removed - Parameters in `mbd_input_t` related to real-space evaluation of TS - Parameters in `mbd_input_t` related to numerical evaluation of TS gradients ## [0.10.4] - 2021-01-28 ### Added - Support for Python 3.8 and 3.9 ## [0.10.3] - 2020-11-13 ### Fixed - Compatibility with NAG compiler ## [0.10.2] - 2020-10-22 ### Added - Search for Scalapack with pkg-config ## [0.10.1] - 2020-10-08 ### Fixed - Pymbd installation ## [0.10.0] - 2020-10-07 ### Added - Version checking of Libmbd from Pymbd - Support for IBM Fortran compiler by circumventing ICE ### Removed - Python 3.5 support ## [0.9.3] - 2020-08-02 ### Added - Simple `python -m pymbd` installation check ### Fixed - Missing `cffi` dependency of Pymbd ## [0.9.2] - 2020-08-01 ### Added - Numerical gradients for TS - Support for Numpy>1.15 ### Fixed - Compiler error with GCC 10 - Compatibility with Cmake 3.1 when part of a superbuild - Cmake crash on some platforms ## [0.9.1] - 2020-06-26 ### Fixed - Incorrect initialization of MBD-NL damping parameters from XC functional - Support PGI 2019 compiler ## [0.9.0] - 2020-06-23 ### Added - MBD-NL damping parameters - Export of Cmake packages - ENABLE_C_API build option - Improved default Scalapack block size ### Removed - Python 2 support - Support for Cmake <3.1 ## [0.8.0] - 2019-10-30 Minor additions and fixes. ## [0.7.0] - 2019-10-06 ### Added - Optional rescaling of RPA eigenvalues as in [10.1021/acs.jctc.6b00925](http://dx.doi.org/10.1021/acs.jctc.6b00925) ## [0.6.0] - 2019-04-23 ### Added - C/Python API for getting eigenvalues and eigenvectors for crystals - C/Python API for custom k-point grids ### Fixed - Support Hessian evaluation with Tensorflow implementation ## [0.5.0] - 2019-03-01 ### Changed - Python/Fortran/C API changed ## [0.4.3] - 2019-02-28 ### Added - Fortran/Python API for RPA evaluation ### Fixed - Evaluation of RPA orders ## [0.4.2] - 2019-01-20 ### Added - Optional parallelization over k-points ### Fixed - Ifort compiler bug - `WITH_MPIFH` build ## [0.4.1] - 2019-01-15 ### Changed - Numpy requirement restricted to <=1.15 ## [0.4.0] - 2019-01-13 Completely reworked. ### Added - Analytical gradients including lattice-vector derivatives. - Scalapack parallelization of all calculations. $links libmbd-libmbd-88d61bc/devtools/changelog.py000077500000000000000000000020521452573331700207670ustar00rootroot00000000000000#!/usr/bin/env python3 import re import subprocess from string import Template END = 'END' s = subprocess.run( 'git tag -l "*.*.*"' ' --format "%(refname:strip=2),%(taggerdate:short),' f'%(contents:subject)\n\n%(contents:body){END}"' ' --sort=-creatordate', shell=True, capture_output=True, ).stdout.decode() data = [ (v, d, m.strip() if m[0] == '#' else None) for v, d, m in re.findall(rf'(\d+\.\d+\.\d+),([\d-]+),(.*?){END}', s, re.DOTALL) ] with open('devtools/CHANGELOG.md.in') as f: t = Template(f.read()) changes = [f'## [{v}] - {d}\n\n{m}' for v, d, m in data if m] link = '[{0}]: https://github.com/libmbd/libmbd/{1}' vs = [x[0] for x in data] links = [ *( link.format( vs[i - 1] if i else 'unreleased', f'compare/{vs[i]}...{vs[i-1] if i else "HEAD"}', ) for i in range(len(vs)) ), link.format(vs[-1], f'releases/tag/{vs[-1]}'), ] with open('wiki/Changelog.md', 'w') as f: f.write(t.substitute({'changes': '\n\n'.join(changes), 'links': '\n'.join(links)})) libmbd-libmbd-88d61bc/devtools/generate-vdw-params.py000077500000000000000000000020371452573331700227140ustar00rootroot00000000000000#!/usr/bin/env python3 import csv from importlib.resources import open_text with open_text('pymbd', 'vdw-params.csv') as f: reader = csv.DictReader(f, quoting=csv.QUOTE_NONNUMERIC) rows = list(reader) rows = [row for row in rows if row['symbol'][-1] not in '+-'] n = len(rows) print(f'real(dp), parameter :: ts_vdw_params(3, {n}) = reshape([ &') for i, row in enumerate(rows): alpha_0 = row['alpha_0(TS)'] or 0 C6 = row['C6(TS)'] or 0 R_vdw = row['R_vdw(TS)'] or 0 print( f' {alpha_0}d0, {C6}d0, {R_vdw}d0{"," if i < n-1 else ""} &' f' ! {row["symbol"]}' ) print(f'], [3, {n}])') print() print(f'real(dp), parameter :: tssurf_vdw_params(3, {n}) = reshape([ &') for i, row in enumerate(rows): alpha_0 = row['alpha_0(TSsurf)'] or row['alpha_0(TS)'] or 0 C6 = row['C6(TSsurf)'] or row['C6(TS)'] or 0 R_vdw = row['R_vdw(TSsurf)'] or row['R_vdw(TS)'] or 0 print( f' {alpha_0}d0, {C6}d0, {R_vdw}d0{"," if i < n-1 else ""} &' f' ! {row["symbol"]}' ) print(f'], [3, {n}])') libmbd-libmbd-88d61bc/devtools/source-dist.sh000077500000000000000000000007101452573331700212620ustar00rootroot00000000000000#!/bin/bash set -ev VERSION=$(git describe --tags --dirty=.dirty) VERSION_FILE=cmake/libMBDVersionTag.cmake SLUG=libmbd-${VERSION} echo "set(VERSION_TAG ${VERSION})">${VERSION_FILE} mkdir -p dist ARCHIVE=dist/${SLUG}.tar.gz gtar -vcz -f ${ARCHIVE} \ --exclude "*pymbd*" --exclude "__pycache__" --exclude "conftest.py" --exclude ".*" \ --transform "s,^,${SLUG}/," CMakeLists.txt cmake src tests LICENSE README.md rm ${VERSION_FILE} echo ${ARCHIVE} libmbd-libmbd-88d61bc/doc/000077500000000000000000000000001452573331700153725ustar00rootroot00000000000000libmbd-libmbd-88d61bc/doc/anisotropic-gaussians.md000066400000000000000000000107161452573331700222460ustar00rootroot00000000000000### Coulomb interaction of two anisotropic Gaussian charge densities We want to calculate $$ I_1(\mathbf K_1,\mathbf K_2)=\frac{\sqrt{\det\mathbf K_1\mathbf K_2}}{\pi^3}\iint\mathrm d\mathbf r_1\mathrm d\mathbf r_2\frac{\mathrm e^{-(\mathbf r_1-\mathbf R_1)^\mathrm T\mathbf K_1(\mathbf r_1-\mathbf R_1)}\mathrm e^{-(\mathbf r_2-\mathbf R_2)^\mathrm T\mathbf K_2(\mathbf r_2-\mathbf R_2)}}{\lvert\mathbf r_1-\mathbf r_2\rvert} $$ which is normalized such that $$ \lim_{k\rightarrow\infty} I_1(k\mathbf I,k\mathbf I)=\frac1{\lvert\mathbf R_1-\mathbf R_2\rvert} $$ We generalize to a more general problem by introducing $$ \mathbf r=\begin{bmatrix}\mathbf r_1\\\mathbf r_2\end{bmatrix},\qquad \mathbf R=\begin{bmatrix}\mathbf R_1\\\mathbf R_2\end{bmatrix},\qquad \mathbf K=\begin{bmatrix}\mathbf K_1&\mathbf 0\\\mathbf 0&\mathbf K_2\end{bmatrix} $$ and $$ I_2(\mathbf K)=\frac{\sqrt{\det\mathbf K}}\pi\iint\mathrm d\mathbf r_1\mathrm d\mathbf r_2\frac{\mathrm e^{-(\mathbf r-\mathbf R)^\mathrm T\mathbf K(\mathbf r-\mathbf R)}}{\lvert\mathbf r_1-\mathbf r_2\rvert} $$ Using $$ \frac1{\lvert\mathbf r_1-\mathbf r_2\rvert}=\frac2{\sqrt\pi}\int_0^\infty\mathrm du\exp(-\lvert\mathbf r_1-\mathbf r_2\rvert^2u^2) $$ we transform to $$ I_2(\mathbf K)=\frac{2\sqrt{\det\mathbf K}}{\pi^\frac72}\iint\mathrm d\mathbf r_1\mathrm d\mathbf r_2\int_0^\infty\mathrm du\exp\left[-(\mathbf r-\mathbf R)^\mathrm T\mathbf K(\mathbf r-\mathbf R)-\lvert\mathbf r_1-\mathbf r_2\rvert^2u^2\right] \label{eq:I2} $$ Next, we introduce $$ \mathbf U_2=u^2\begin{pmatrix} 1&0&0&-1&0&0\\ 0&1&0&0&-1&0\\ 0&0&1&0&0&-1\\ -1&0&0&1&0&0\\ 0&-1&0&0&1&0\\ 0&0&-1&0&0&1 \end{pmatrix} $$ so that $$ \lvert\mathbf r_1-\mathbf r_2\rvert^2u^2=\mathbf r^\mathrm T\mathbf U_2\mathbf r $$ so that we can rewrite $\eqref{eq:I2}$ as $$ I_2(\mathbf K)=\frac{2\sqrt{\det\mathbf K}}{\pi^\frac72}\int\mathrm d\mathbf r\int_0^\infty\mathrm du\exp\left[-(\mathbf r-\mathbf R)^\mathrm T\mathbf K(\mathbf r-\mathbf R)-\mathbf r^\mathrm T\mathbf U_2\mathbf r\right] $$ Next, we rearrange the terms and [complete the square](https://en.wikipedia.org/wiki/Completing_the_square#Formula): $$ \begin{multline} I_2(\mathbf K)=\frac{2\sqrt{\det\mathbf K}}{\pi^\frac72}\int\mathrm d\mathbf r\int_0^\infty\mathrm du\exp\left[-\mathbf r^\mathrm T(\mathbf K+\mathbf U_2)\mathbf r+2\mathbf R^\mathrm T\mathbf K\mathbf r-\mathbf R^\mathrm T\mathbf K\mathbf R\right] \\ =\frac{2\sqrt{\det\mathbf K}}{\pi^\frac72}\int\mathrm d\mathbf r\int_0^\infty\mathrm du\\ \times\exp\left[-(\mathbf r-\mathbf h)^\mathrm T(\mathbf K+\mathbf U_2)(\mathbf r-\mathbf h)-\mathbf R^\mathrm T\mathbf K\mathbf R+\mathbf R^\mathrm T\mathbf K(\mathbf K+\mathbf U_2)^{-1}\mathbf K\mathbf R\right] \end{multline} $$ The first term in the exponential is a 6-dimensional Gaussian, the integral of which is $\sqrt{\pi^3/\det(\mathbf K+\mathbf U_2)}$. This leaves us with a 1-dimensional integral over $u$: $$ I_2(\mathbf K)=\frac{2}{\sqrt\pi}\int_0^\infty\mathrm du\sqrt{\frac{\det\mathbf K}{\det(\mathbf K+\mathbf U_2)}}\exp\left[-\mathbf R^\mathrm T\left(\mathbf K-\mathbf K(\mathbf K+\mathbf U_2)^{-1}\mathbf K\right)\mathbf R\right] $$ For verification, we consider the special case of $\mathbf K_i=\mathbf I/2\sigma_i^2$. Then, $$ I_1(\sigma_1,\sigma_2)=\frac2{\sqrt\pi}\int_0^\infty\mathrm du\left(1+2u^2(\sigma_1^2+\sigma_2^2)\right)^{-\frac32}\exp\left[-\frac{u^2\lvert\mathbf R_1-\mathbf R_2\rvert^2}{1+2u^2(\sigma_1^2+\sigma_2^2)}\right] $$ Substituting $v^2=u^2/(1+2u^2(\sigma_1^2+\sigma_2^2))$, we obtain $$ \begin{equation} \begin{aligned} I_1(\sigma_1,\sigma_2)&=\frac2{\sqrt\pi}\int_0^{1/\sqrt{2(\sigma_1^2+\sigma_2^2)}}\mathrm dv\exp\left(-v^2\lvert\mathbf R_1-\mathbf R_2\rvert^2\right) \\ &=\operatorname{erf}\Bigg[\frac{\lvert\mathbf R_1-\mathbf R_2\rvert}{\sqrt{2(\sigma_1^2+\sigma_2^2)}}\Bigg]\frac1{\lvert\mathbf R_1-\mathbf R_2\rvert} \end{aligned} \end{equation} $$ which is the expected result. ### Dipole potential Next, we want to take the dipole derivative, $\boldsymbol\nabla_{\mathbf R_1}\otimes\boldsymbol\nabla_{\mathbf R_2}$, to obtain the dipole potential. We will use $$ I_2=\int_0^\infty\mathrm du\,i_2(u) $$ $$ \boldsymbol\nabla_{\mathbf R_1}\otimes\boldsymbol\nabla_{\mathbf R_2}i_2(\mathbf K)=\left[-2\mathbf K_{12}+4(\mathbf K_{11}\mathbf R_1+\mathbf K_{12}\mathbf R_2)\otimes(\mathbf K_{12}\mathbf R_1+\mathbf K_{22}\mathbf R_2)\right]i_2(\mathbf K) $$ where $$ \begin{bmatrix}\mathbf K_{11}&\mathbf K_{12}\\\mathbf K_{12}&\mathbf K_{22}\end{bmatrix}=\mathbf K-\mathbf K(\mathbf K+\mathbf U_2)^{-1}\mathbf K $$ libmbd-libmbd-88d61bc/doc/api.rst000066400000000000000000000005041452573331700166740ustar00rootroot00000000000000API === Pure-Python implementation -------------------------- .. automodule:: pymbd .. autodata:: pymbd.pymbd.ang Can be imported directly as :py:data:`pymbd.ang`. Fortran bindings ---------------- .. automodule:: pymbd.fortran .. autodata:: with_mpi :annotation: .. autodata:: with_scalapack :annotation: libmbd-libmbd-88d61bc/doc/conf.py000066400000000000000000000030401452573331700166660ustar00rootroot00000000000000import datetime import os import subprocess import sys import toml sys.path.insert(0, os.path.abspath('../src')) with open('../pyproject.toml') as f: metadata = toml.load(f)['tool']['poetry'] project = 'libMBD' release = version = ( subprocess.run(['poetry', 'version'], capture_output=True, cwd='..') .stdout.decode() .split()[1] ) author = ' '.join(metadata['authors'][0].split()[:-1]) description = metadata['description'] extensions = [ 'sphinx.ext.autodoc', 'sphinx.ext.todo', 'sphinx.ext.mathjax', 'sphinx.ext.viewcode', 'sphinx.ext.intersphinx', ] intersphinx_mapping = { 'python': ('https://docs.python.org/3', None), } source_suffix = '.rst' master_doc = 'index' copyright = f'2018-{datetime.date.today().year}, {author}' language = None exclude_patterns = ['build', '.DS_Store'] pygments_style = 'sphinx' todo_include_todos = True html_theme = 'alabaster' html_theme_options = { 'description': description, 'github_button': True, 'github_user': 'libmbd', 'github_repo': 'libmbd', 'badge_branch': 'master', 'codecov_button': True, } html_sidebars = { '**': ['about.html', 'navigation.html', 'relations.html', 'searchbox.html'] } autodoc_default_options = {'members': True} autodoc_inherit_docstrings = False autodoc_mock_imports = [ 'numpy', 'scipy', 'pymbd._libmbd', 'mpi4py', ] def skip_namedtuples(app, what, name, obj, skip, options): if hasattr(obj, '_source'): return True def setup(app): app.connect('autodoc-skip-member', skip_namedtuples) libmbd-libmbd-88d61bc/doc/density-coulomb.md000066400000000000000000000332771452573331700210450ustar00rootroot00000000000000We consider a system of $N$ distinguishable particles with masses $m_A$, each individually confined in a harmonic potential with frequency $\omega_A$ and center $\mathbf R_A$. The distinguishability is mandated by the individual (rather than global) harmonic potentials. Each particle has a charge $q_A$, which is compensated by the charge of an opposite sign located at $\mathbf R_A$. The compensating charges can be thought of as nuclei of infinite mass, and the harmonic potentials as representing a harmonic force between the particles and the nuclei. Physical motivation fur such a system is that each particle simulates all electrons of a given atom; the harmonic potential is a Taylor expansion of the true pseudopotential for the valence electrons. The Hamiltonian of such a system is $$ \begin{multline} H=\sum_A\left(-\frac1{2m_A}\boldsymbol\nabla_A^2+\frac12m_A\omega_A^2\lvert\mathbf r_A-\mathbf R_A\rvert^2\right)\\ +\frac12\sum_{AB}q_Aq_B\left(\frac1{\lvert\mathbf r_A-\mathbf r_B\rvert}-\frac1{\lvert\mathbf R_A-\mathbf r_B\rvert}-\frac1{\lvert\mathbf r_A-\mathbf R_B\rvert}+\frac1{\lvert\mathbf R_A-\mathbf R_B\rvert}\right) \label{eq:Hcoulomb} \end{multline} $$ where $\mathbf r_A$ is a position of the $A$-th particle. Assuming small displacements, $\mathbf r_A-\mathbf R_A$, of the particles with respect to the distances between them, $\mathbf R_A-\mathbf R_B$, we can expand the electrostatic terms around the equilibrium positions. At first order, this leads to the dipole potential: $$ \begin{equation} \begin{aligned} \mathbf T_{AB}&=\boldsymbol\nabla_A\otimes\boldsymbol\nabla_B\frac1{|\mathbf r_A-\mathbf r_B|}\Bigg|_{\substack{\mathbf r_A=\mathbf R_A\\\mathbf r_B=\mathbf R_B}} \\ &=\frac{\lvert\mathbf R_A-\mathbf R_B\rvert^2-3(\mathbf R_A-\mathbf R_B)\otimes(\mathbf R_A-\mathbf R_B)}{\lvert\mathbf R_A-\mathbf R_B\rvert^5} \end{aligned} \label{eq:dip} \end{equation} $$ Inserting this expression into $\eqref{eq:Hcoulomb}$, we get $$ \begin{multline} H=\sum_A\left(-\frac1{2m_A}\boldsymbol\nabla_A^2+\frac12m_A\omega_A^2\lvert\mathbf r_A-\mathbf R_A\rvert^2\right)\\ +\frac12\sum_{AB}q_Aq_B(\mathbf r_A-\mathbf R_A)\cdot\mathbf T_{AB}\cdot(\mathbf r_B-\mathbf R_B) \label{eq:MBDhamil} \end{multline} $$ Next, we define $3N$ generalized coordinates $\xi_{3(A-1)+\alpha}=\sqrt{m_A}(r_A^\alpha-R_A^\alpha)$, where $\alpha$ labels the Cartesian dimensions. This also defines a general correspondence between the particle index $A$ and coordinate index $i$, so, for instance, when we write $m_i$, we mean the mass of $A$-th particle that corresponds to the $i$-th generalized coordinate. Using the relationship between the static polarizability $\alpha_0$, mass, frequency, and charge of a charged particle in a harmonic potential, $\alpha_0=q^2/m\omega^2$, and the generalized coordinates, the Hamiltonian can be rewritten as $$ \begin{equation} \begin{aligned} H&=\sum_{i=1}^{3N}\left(-\frac12\frac{\partial^2}{\partial\xi_i^2}+\frac12\omega_i^2\xi_i^2\right)+\frac12\sum_{ij}\omega_i\omega_j\sqrt{\alpha_{0,i}\alpha_{0,j}}\xi_iT_{ij}\xi_j \\ &=\left(\sum_i-\frac12\frac{\partial^2}{\partial\xi_i^2}\right)+\frac12\boldsymbol\xi^\mathrm T\mathbf D\boldsymbol\xi, \qquad D_{ij}=\omega_i^2\delta_{ij}+\omega_i\omega_j\sqrt{\alpha_{0,i}\alpha_{0,j}}T_{ij} \end{aligned} \end{equation} $$ Now, we search for a unitary transformation of $\boldsymbol\xi$ such that the dipole interaction term disappears in the new transformed coordinates. Since the kinetic term ($3N$-dimensional Laplacian) is invariant with respect to unitary transformations, we obtain the new coordinates by diagonalizing $\mathbf D$: $$ H=\sum_i\left(-\frac12\frac{\partial^2}{\partial\tilde\xi_i^2}+\frac12\tilde\omega_i^2\tilde\xi_i^2,\right) $$ Here, $\tilde\omega_i^2$ are the eigenvalues of $\mathbf D$ and $\tilde\xi_i$ are the transformed coordinates, $\tilde\xi_i=\sum_kC_{ki}\xi_k$, $\mathbf C$ being the column-wise matrix of the eigenvectors of $\mathbf D$. But this is a Hamiltonian describing $3N$ uncoupled harmonic oscillators with frequencies $\tilde\omega_i$. The ground-state energy is $$ E=\sum_i\frac{\tilde\omega_i}2 $$ The wavefunction is $$ \Psi(\tilde\xi_i)=\prod_i\left(\frac{\tilde\omega_i}{\pi}\right)^\frac14\exp\left(-\frac12\tilde\omega_i\tilde\xi_i^2\right) $$ ### Particle density Next, we want to calculate the particle density $$ n(\mathbf r)=\langle\Psi|\sum_Aq_A\delta(\mathbf r-\mathbf r_A)|\Psi\rangle=\idotsint\mathrm d\mathbf r_1\cdots\mathrm d\mathbf r_N\sum_Aq_A\delta(\mathbf r-\mathbf r_A)\Psi(\mathbf r_B)^2 \label{eq:density} $$ First, we transform the wavefunction back to $\boldsymbol\xi$ and gather the product of the exponentials, $$ \Psi(\xi_i)=\left[\prod_i\left(\frac{\tilde\omega_i}{\pi}\right)^\frac14\right]\exp\Bigg(-\frac12\sum_{jk}\underbrace{\sum_iC_{ji}\tilde\omega_iC_{ki}}_{\Omega_{jk}}\xi_j\xi_k\Bigg) \label{eq:wavefnc} $$ In the following, we will use $\sum_{i\notin A}$ for a sum that skips the $A$-th particle and $\sum_{i\in A}$ for a sum over the three Cartesian coordinates of the $A$-th particle. For a given $A$, we divide the sum over $jk$ according to the order of $\xi_{i\in A}$: $$ \begin{equation} \begin{aligned} \sum_{jk}\Omega_{jk}\xi_j\xi_k&=\sum_{\substack{j\notin A\\k\notin A}}\Omega_{jk}\xi_j\xi_k+2\sum_{\substack{p\in A\\k\notin A}}\Omega_{pk}\xi_p\xi_k+2\sum_{\substack{p\in A\\q\in A}}\Omega_{pq}\xi_p\xi_q \\ &\equiv\boldsymbol\xi'^\mathrm T_A\boldsymbol\Omega''_A\boldsymbol\xi'_A+2\boldsymbol\xi_A'^\mathrm T\boldsymbol\Omega'_A\boldsymbol\xi_A+\boldsymbol\xi_A^\mathrm T\boldsymbol\Omega_A\boldsymbol\xi_A \end{aligned} \end{equation} $$ [Completing the square](https://en.wikipedia.org/wiki/Completing_the_square#Formula) with respect to $\boldsymbol\xi'_A$, we get $$ \sum_{jk}\Omega_{jk}\xi_j\xi_k=(\boldsymbol\xi'^\mathrm T_A-\mathbf h_A^\mathrm T)\boldsymbol\Omega''_A(\boldsymbol\xi'_A-\mathbf h_A)+\boldsymbol\xi_A^\mathrm T\boldsymbol\Omega_A\boldsymbol\xi_A-\boldsymbol\xi_A^\mathrm T\boldsymbol\Omega'^\mathrm T_A\boldsymbol\Omega_A''^{-1}\boldsymbol\Omega_A'\boldsymbol\xi_A \label{eq:completesq} $$ where $\mathbf h_A$ is some quantity that does not depend on $\boldsymbol\xi'_A$. We can now factor out the exponential and the $3N$-dimensional integral: $$ n(\mathbf r)=\sum_Aq_A\left(\idotsint\mathrm d\mathbf r_1\cdots\mathrm d\mathbf r_{A-1}\mathrm d\mathbf r_{A+1}\mathrm d\cdots\mathbf r_N\right)\int\mathrm d\mathbf r_A\delta(\mathbf r-\mathbf r_A)\ldots $$ First, we deal with the integrals in parentheses. Because $\mathbf h_A$ is constant there, and the integrals are over the whole space, $\mathbf h_A$ can be transformed away. Furthermore, we can rotate $\boldsymbol\Omega''_A$ into a new basis where it becomes diagonal, which factors the $3(N-1)$-dimensional integral into a product of $3(N-1)$ 1-dimensional integrals over gaussian functions of the form $\exp(-\bar\omega_{A,i}\bar\xi_{A,i}^2)$, where $\bar\omega_{A,i}$ are the eigenvalues of $\boldsymbol\Omega''_A$. (The factor of $\frac12$ disappears due to the square of the wavefunction.) Second, the integral over $\mathbf r_A$ picks the value of the following function at point $\mathbf r$ via the $\delta$-function: $$ \exp\big(-\boldsymbol\xi_A^\mathrm T(\underbrace{\boldsymbol\Omega_A-\boldsymbol\Omega'^\mathrm T_A\boldsymbol\Omega_A''^{-1}\boldsymbol\Omega_A'}_{\boldsymbol\Omega^{(A)}})\boldsymbol\xi_A\big) $$ Combining $\eqref{eq:density}$, $\eqref{eq:wavefnc}$, $\eqref{eq:completesq}$, and the previous two paragraphs, and transforming from $\boldsymbol\xi_A$ back to $\mathbf r_A$, we get $$ n(\mathbf r)=\sum_Aq_A\left(\frac{m_A}\pi\right)^\frac32\sqrt{\frac{\prod_{i=1}^{3N}\tilde\omega_i}{\prod_{i=1}^{3(N-1)}\bar\omega_{A,i}}}\exp\big(-m_A(\mathbf r-\mathbf R_A)^\mathrm T\boldsymbol\Omega^{(A)}(\mathbf r-\mathbf R_A)\big) $$ ### Coulomb interaction We want to calculate a first-order perturbation correction to the dipole approximation, that is, $$ E^{(1)}=\langle\Psi|V_\text{ee}-V_{\mathbf{pp}}|\Psi\rangle $$ where $V_\text{ee}$ is the full Coulomb interaction and $V_\mathbf{pp}$ is the dipole interaction. We start by calculating $$ \langle\Psi|\frac12\sum_{AB}\frac{q_Aq_B}{\lvert\mathbf r_A-\mathbf r_B\rvert}|\Psi\rangle $$ In analogy to the calculation of $n(\mathbf r)$, we rotate the $3(N-2)$ coordinates that do not participate in the Coulomb integral such that the integrals become integrals over gaussian functions, and then evaluate the remaining 6-dimensional integral over $\mathbf r_A$ and $\mathbf r_B$. To this end, we need to evaluate $$ I=\iint\mathrm d\boldsymbol\xi_A\mathrm d\boldsymbol\xi_B \frac{\exp\big(-\boldsymbol\xi_{AB}^\mathrm T\boldsymbol\Omega^{(AB)}\boldsymbol\xi_{AB}\big)}{\lvert\mathbf r_A-\mathbf r_B\rvert} \label{eq:intcoulomb} $$ where $\boldsymbol\xi_{AB}$ is a 6-dimensional vector containing $\boldsymbol\xi_A$ and $\boldsymbol\xi_B$, and $\boldsymbol\Omega^{(AB)}$ is the equivalent of $\boldsymbol\Omega^{(A)}$ from the previous section. We start by rewriting the Coulomb potential as $$ \frac1{\lvert\mathbf r_A-\mathbf r_B\rvert}=\frac2{\sqrt\pi}\int_0^\infty\mathrm du\exp(-\lvert\mathbf r_A-\mathbf r_B\rvert^2u^2) $$ Inserting into $\eqref{eq:intcoulomb}$, and transforming to $\mathbf r_A$, we obtain $$ \begin{multline} I=2\sqrt{\frac{m_Am_B}\pi}\iint\mathrm d\mathbf r_A\mathrm d\mathbf r_B\int_0^\infty\mathrm du \\ \times\exp\big[-(\mathbf r_{AB}-\mathbf R_{AB})^\mathrm T\boldsymbol\Omega_m'^{(AB)}(\mathbf r_{AB}-\mathbf R_{AB})-\mathbf r_{AB}^\mathrm T\mathbf U_2\mathbf r_{AB}\big] \end{multline} $$ where $\boldsymbol\Omega'^{(AB)}$ absorbed the masses and $\mathbf U_2$ is defined as $$ \mathbf U_2=u^2\begin{pmatrix} 1&0&0&-1&0&0\\ 0&1&0&0&-1&0\\ 0&0&1&0&0&-1\\ -1&0&0&1&0&0\\ 0&-1&0&0&1&0\\ 0&0&-1&0&0&1 \end{pmatrix} $$ Following only with the integrand, we rearrange terms, and complete the square with respect to $\mathbf r_{AB}$: $$ \begin{multline} \exp\big[-\mathbf r_{AB}^\mathrm T(\boldsymbol\Omega_m'^{(AB)}+\mathbf U_2)\mathbf r_{AB}+2\mathbf R_{AB}^\mathrm T\boldsymbol\Omega_m'^{(AB)}\mathbf r_{AB}-\mathbf R_{AB}^\mathrm T\boldsymbol\Omega_m'^{(AB)}\mathbf R_{AB}\big] \\ =\exp\big[-(\mathbf r_{AB}-\mathbf h_{AB})^\mathrm T(\boldsymbol\Omega_m'^{(AB)}+\mathbf U_2)(\mathbf r_{AB}-\mathbf h_{AB})\big] \\ \times\exp\big[-\mathbf R_{AB}^\mathrm T\big(\boldsymbol\Omega_m'^{(AB)}-\boldsymbol\Omega_m'^{(AB)}(\boldsymbol\Omega_m'^{(AB)}+\mathbf U_2)^{-1}\boldsymbol\Omega_m'^{(AB)}\big)\mathbf R_{AB}\big] \end{multline} $$ As in the density calculation, the first exponential can be shifted and rotated into a diagonal form, upon which the spatial integrals can be easily evaluated: $$ \iint\mathrm d\mathbf r_A\mathrm d\mathbf r_B\exp\big[-\mathbf r_{AB}^\mathrm T(\boldsymbol\Omega_m'^{(AB)}+\mathbf U_2)\mathbf r_{AB}\big]=\frac{\pi^3}{\sqrt{\prod_{i=1}^6\lambda_{AB,i}(u)}} $$ where $\lambda_{AB,i}(u)$ are the eigenvalues of $(\boldsymbol\Omega_m'^{(AB)}+\mathbf U_2)$. The remaining 1-dimensional integral over $u$ from 0 to $\infty$ has a finite integrand that decays exponentially to zero, and so can be readily evaluated numerically. Putting everything together, we get $$ \begin{multline} \langle\Psi|\frac12\sum_{AB}\frac{q_Aq_B}{\lvert\mathbf r_A-\mathbf r_B\rvert}|\Psi\rangle =\frac12\sum_{AB}q_Aq_B\sqrt{\frac{\prod_{i=1}^{3N}\tilde\omega_i}{\prod_{i=1}^{3(N-2)}\bar\omega_{AB,i}}} \\ \times\int_0^\infty\mathrm du\frac{\exp\big[-\mathbf R_{AB}^\mathrm T\big(\boldsymbol\Omega_m'^{(AB)}-\boldsymbol\Omega_m'^{(AB)}(\boldsymbol\Omega_m'^{(AB)}+\mathbf U_2)^{-1}\boldsymbol\Omega_m'^{(AB)}\big)\mathbf R_{AB}\big]}{\sqrt{\prod_{i=1}^6\lambda_{AB,i}(u)}} \label{eq:coulombrr} \end{multline} $$ Swapping $\mathbf r_B$ for $\mathbf R_B$, we follow a similar path, this time with a 3-dimensional integral instead of the 6-dimensional integral. The result is: $$ \langle\Psi|\sum_{AB}-\frac{q_Aq_B}{\lvert\mathbf r_A-\mathbf R_B\rvert}|\Psi\rangle =\sum_{AB}-q_Aq_B\sqrt{\frac{\prod_{i=1}^{3N}\tilde\omega_i}{\prod_{i=1}^{3(N-1)}\bar\omega_{A,i}}}\int_0^\infty\mathrm du\frac{\exp\big[-\mathbf R_{AB}^\mathrm T\bar{\boldsymbol\Omega}_A\mathbf R_{AB}\big]}{\sqrt{\prod_{i=1}^3\lambda_{A,i}(u)}} \label{eq:coulombrR} $$ where $$ \bar{\boldsymbol\Omega}_A=\begin{pmatrix} \boldsymbol\Omega'^{(A)} & \mathbf0 \\ \mathbf 0 & u^2\mathbf I \end{pmatrix}+\begin{pmatrix} \boldsymbol\Omega'^{(A)} \\ u^2\mathbf I \end{pmatrix}\big(\boldsymbol\Omega'^{(A)}+u^2\mathbf I)^{-1}\begin{pmatrix} \boldsymbol\Omega'^{(A)} & u^2\mathbf I \end{pmatrix} $$ The nucleus–nucleus term reduces trivially: $$ \langle\Psi|\frac12\sum_{AB}\frac{q_Aq_B}{\lvert\mathbf R_A-\mathbf R_B\rvert}|\Psi\rangle=\frac12\sum_{AB}\frac{q_Aq_B}{\lvert\mathbf R_A-\mathbf R_B\rvert} \label{eq:coulombRR} $$ For calculation of $E^{(1)}$, we are missing the last piece: $\langle\Psi|V_\mathbf{pp}|\Psi\rangle$. First, we transform the dipole potential to the coupled basis and gather the prefactors: $$ \tilde T_{ij}=\sum_{kl}C_{ki}C_{lj}\omega_k\omega_l\sqrt{\alpha_{0,k}\alpha_{0,l}}T_{kl} $$ Then, $$ \begin{multline} \langle\Psi|V_\mathbf{pp}|\Psi\rangle=\langle\Psi|\frac12\sum_{ij}\tilde\xi_i\tilde\xi_j\tilde T_{ij}|\Psi\rangle \\ =\frac12\sum_{i\neq j}\tilde T_{ij}\left(\frac{\tilde\omega_i\tilde\omega_j}{\pi^2}\right)^\frac14\int\mathrm d\tilde\xi_i\tilde\xi_i\exp\left(-\frac12\tilde\omega_i\tilde\xi_i^2\right)\int\mathrm d\tilde\xi_j\tilde\xi_j\exp\left(-\frac12\tilde\omega_j\tilde\xi_j^2\right) \\ +\frac12\sum_{i}\tilde T_{ii}\sqrt{\frac{\tilde\omega_i}{\pi}}\int\mathrm d\tilde\xi_i\tilde\xi_i^2\exp\left(-\tilde\omega_i\tilde\xi_i^2\right)=\sum_i\frac{\tilde T_{ii}}{4\tilde\omega_i} \label{eq:dipoleterm} \end{multline} $$ where the $i\neq j$ terms disappear because the integrands are odd functions. Putting $\eqref{eq:coulombrr}$, $\eqref{eq:coulombrR}$, $\eqref{eq:coulombRR}$, and $\eqref{eq:dipoleterm}$ together, we have now all terms necessary to calculate the first-order correction to the dipole approximation in $\eqref{eq:MBDhamil}$.libmbd-libmbd-88d61bc/doc/index.rst000066400000000000000000000005741452573331700172410ustar00rootroot00000000000000Welcome to pyMBD ================ Only incomplete API reference is available at the moment. For installation, see the Readme_. For examples, see the Readme_ or the `tests `_. .. _Readme: https://github.com/libmbd/libmbd/blob/master/README.md API reference ------------- .. toctree:: :maxdepth: 2 api libmbd-libmbd-88d61bc/doc/libmbd.md000066400000000000000000000032341452573331700171470ustar00rootroot00000000000000--- project: libMBD summary: Many-body dispersion library license: by src_dir: ../src css: tweaks.css hide_undoc: true preprocessor: gfortran -cpp -E -P -DWITH_MPI -DWITH_SCALAPACK exclude: mbd_blacs.f90 mbd_c_api.F90 mbd_coulomb.f90 mbd_density.f90 mbd_lapack.f90 mbd_linalg.F90 mbd_matrix.F90 mbd_mpi.F90 mbd_rpa.F90 mbd_scalapack.f90 mbd_vdw_param.f90 --- At the moment the documentation consists of an automatically generated API reference and a miniature of a user guide in the following paragraph. All mathematical formulas used in the code are documented directly in the source code and rendered in [Procedures](lists/procedures.html). Installation instructions can be found in the [Readme](https://github.com/libmbd/libmbd/blob/master/README.md). The user-facing Fortran API of libMBD is contained in the [[mbd]] module and consists of the [[mbd_input_t]] and [[mbd_calc_t]] derived types. A [[mbd_input_t]] object serves to set various options for the calculation and is used to initialize a [[mbd_calc_t]] object, which is then used to actually perform the MBD calculation. ```fortran use mbd, only: mbd_input_t, mbd_calc_t type(mbd_input_t) :: inp type(mbd_calc_t) :: calc real(8) :: energy, gradients(3, 2) integer :: code character(200) :: origin, msg inp%atom_types = ['Ar', 'Ar'] inp%coords = reshape([0d0, 0d0, 0d0, 0d0, 0d0, 7.5d0], [3, 2]) inp%xc = 'pbe' call calc%init(inp) call calc%get_exception(code, origin, msg) if (code > 0) then print *, msg stop end if call calc%update_vdw_params_from_ratios([0.98d0, 0.98d0]) call calc%evaluate_vdw_method(energy) call calc%get_gradients(gradients) call calc%destroy() ``` libmbd-libmbd-88d61bc/doc/tweaks.css000066400000000000000000000001541452573331700174020ustar00rootroot00000000000000footer .text-center, .jumbotron { display: none; } .codesum h3, .list-group h3 { font-size: 18px; } libmbd-libmbd-88d61bc/doc/version.h000066400000000000000000000000001452573331700172160ustar00rootroot00000000000000libmbd-libmbd-88d61bc/pyproject.toml000066400000000000000000000037121452573331700175440ustar00rootroot00000000000000[build-system] requires = [ "poetry-core@https://github.com/python-poetry/poetry-core/archive/af08f1ce720da467c9bf3d43eed3d9ebaf4ad7fb.zip", "poetry-dynamic-versioning>=0.12.3", "cffi", "setuptools", ] build-backend = "poetry.core.masonry.api" [tool.poetry] name = "pymbd" version = "0.0.0" description = "Many-body dispersion library" authors = ["Jan Hermann "] readme = "README.md" packages = [{ include = "pymbd", from = "src" }] repository = "https://github.com/libmbd/libmbd" documentation = "https://libmbd.github.io/pymbd" license = "MPL-2.0" include = [ { path = "src/mbd.h" }, { path = "src/pymbd/*.so", format = "wheel" }, ] classifiers = [ "Development Status :: 4 - Beta", "Environment :: Console", "Intended Audience :: Science/Research", "Operating System :: MacOS :: MacOS X", "Operating System :: POSIX :: Linux", "Programming Language :: Fortran", "Topic :: Scientific/Engineering :: Chemistry", "Topic :: Scientific/Engineering :: Physics", ] [tool.poetry.build] script = "build.py" generate-setup-file = false [tool.poetry.dependencies] python = "^3.6" scipy = [ {version = "^1", python = "3.6" }, {version = "^1.6", python = ">=3.7,<3.11" }, ] numpy = [ {version = "^1", python = "3.6" }, {version = "^1.20", python = ">=3.7,<3.11" }, ] cffi = "^1" pytest = { version = "^6", optional = true } mpi4py = { version = "^3", optional = true } [tool.poetry.extras] mpi = ["mpi4py"] test = ["pytest"] [tool.poetry.dev-dependencies] flake8 = "^4" flake8-bugbear = "^21" flake8-comprehensions = "^3" flake8-quotes = "^3" pep8-naming = "^0.12" black = { version = ">=22", python = "^3.7" } pydocstyle = "^5" isort = "^5" fprettify = { git = "https://github.com/jhrmnn/fprettify.git", rev = "fix-config-search" } [tool.poetry-dynamic-versioning] enable = true dirty = true pattern = '^(?P\d+\.\d+\.\d+)$' [tool.black] target-version = ["py36"] skip-string-normalization = true libmbd-libmbd-88d61bc/setup.cfg000066400000000000000000000013251452573331700164470ustar00rootroot00000000000000[flake8] max-complexity = 12 max-line-length = 80 ignore = E501,W503,E741,N802,N803,N806,N812,B905 select = C,E,F,N,W,B,B9,Q0 [isort] multi_line_output = 3 include_trailing_comma = 1 line_length = 85 sections = FUTURE,STDLIB,TYPING,THIRDPARTY,FIRSTPARTY,LOCALFOLDER known_typing = typing, typing_extensions no_lines_before = TYPING combine_as_imports = true [pydocstyle] add-ignore = D100,D104,D105,D107,D202 ignore-decorators = wraps [tool:pytest] norecursedirs = tests/pymbd_testutils filterwarnings = ignore::PendingDeprecationWarning markers = no_scalapack: test doesn't work with ScaLAPACK [coverage:run] branch = true source = pymbd parallel = true omit = */pymbd/tensorflow.py */pymbd/benchmark.py libmbd-libmbd-88d61bc/src/000077500000000000000000000000001452573331700154145ustar00rootroot00000000000000libmbd-libmbd-88d61bc/src/CMakeLists.txt000066400000000000000000000054141452573331700201600ustar00rootroot00000000000000configure_file(mbd_version.f90.in "${CMAKE_CURRENT_BINARY_DIR}/mbd_version.f90") add_library(mbd mbd.F90 mbd_constants.f90 mbd_coulomb.f90 mbd_damping.F90 mbd_density.f90 mbd_defaults.f90 mbd_dipole.F90 mbd_formulas.f90 mbd_geom.F90 mbd_gradients.f90 mbd_hamiltonian.F90 mbd_lapack.f90 mbd_linalg.F90 mbd_matrix.F90 mbd_methods.F90 mbd_rpa.F90 mbd_scs.f90 mbd_ts.F90 mbd_utils.F90 "${CMAKE_CURRENT_BINARY_DIR}/mbd_version.f90" mbd_vdw_param.f90 ) if(ENABLE_SCALAPACK_MPI) target_sources(mbd PRIVATE mbd_mpi.F90 mbd_blacs.f90 mbd_scalapack.f90) if(NOT MPI_Fortran_HAVE_F08_MODULE) if("${CMAKE_Fortran_COMPILER_ID}" STREQUAL "NAG") set(mismatch_flag "-mismatch") elseif("${CMAKE_Fortran_COMPILER_ID}" STREQUAL "GNU" AND "${CMAKE_Fortran_COMPILER_VERSION}" VERSION_GREATER_EQUAL "10") set(mismatch_flag "-fallow-argument-mismatch -Wno-pedantic") endif() if(DEFINED mismatch_flag) set_source_files_properties( SOURCE mbd_geom.F90 mbd_methods.F90 mbd_mpi.F90 mbd_ts.F90 PROPERTY COMPILE_FLAGS ${mismatch_flag} ) endif() endif() endif() if(ENABLE_ELSI) target_sources(mbd PRIVATE mbd_elsi.F90) endif() if(ENABLE_C_API) target_sources(mbd PRIVATE mbd_c_api.F90) endif() set(moduledir "${CMAKE_CURRENT_BINARY_DIR}/modules") set(includedir "${CMAKE_INSTALL_INCLUDEDIR}/mbd") set_target_properties(mbd PROPERTIES Fortran_MODULE_DIRECTORY "${moduledir}") target_include_directories(mbd PRIVATE ${moduledir} INTERFACE $ $ ) if(ENABLE_SCALAPACK_MPI) target_link_libraries(mbd PRIVATE MPI::MPI_Fortran scalapack) set_property(TARGET mbd APPEND PROPERTY COMPILE_DEFINITIONS WITH_MPI WITH_SCALAPACK) if(MPI_Fortran_HAVE_F08_MODULE) set_property(TARGET mbd APPEND PROPERTY COMPILE_DEFINITIONS WITH_MPIF08) endif() endif() target_link_libraries(mbd PRIVATE LAPACK::LAPACK) if(ENABLE_ELSI) target_link_libraries(mbd PRIVATE elsi::elsi) set_property(TARGET mbd APPEND PROPERTY COMPILE_DEFINITIONS WITH_ELSI) endif() if(ENABLE_C_API) set_property(TARGET mbd PROPERTY PUBLIC_HEADER mbd.h) endif() add_library(Mbd INTERFACE) target_link_libraries(Mbd INTERFACE mbd) if(CMAKE_INSTALL_LIBDIR) install(TARGETS mbd Mbd EXPORT MbdConfig LIBRARY DESTINATION "${CMAKE_INSTALL_LIBDIR}" ARCHIVE DESTINATION "${CMAKE_INSTALL_LIBDIR}" PUBLIC_HEADER DESTINATION "${includedir}" ) install(DIRECTORY "${moduledir}/" DESTINATION "${includedir}") install(EXPORT MbdConfig NAMESPACE Mbd:: DESTINATION "${CMAKE_INSTALL_LIBDIR}/cmake/mbd") endif() libmbd-libmbd-88d61bc/src/mbd.F90000066400000000000000000000446661452573331700164560ustar00rootroot00000000000000! This Source Code Form is subject to the terms of the Mozilla Public ! License, v. 2.0. If a copy of the MPL was not distributed with this ! file, You can obtain one at http://mozilla.org/MPL/2.0/. module mbd !! High-level Fortran API. use mbd_constants use mbd_defaults use mbd_version use mbd_damping, only: damping_t use mbd_formulas, only: scale_with_ratio use mbd_geom, only: geom_t use mbd_gradients, only: grad_request_t, grad_t use mbd_methods, only: get_mbd_energy, get_mbd_scs_energy #ifdef WITH_MPIF08 use mbd_mpi #endif use mbd_ts, only: get_ts_energy use mbd_utils, only: result_t, exception_t, printer_i use mbd_vdw_param, only: ts_vdw_params, tssurf_vdw_params, species_index implicit none private public :: MBD_VERSION_MAJOR, MBD_VERSION_MINOR, MBD_VERSION_PATCH, MBD_VERSION_SUFFIX public :: MBD_EXC_NEG_EIGVALS, MBD_EXC_NEG_POL, MBD_EXC_LINALG, MBD_EXC_UNIMPL, & MBD_EXC_DAMPING, MBD_EXC_INPUT type, public :: mbd_input_t !! Contains user input to an MBD calculation. character(len=30) :: method = 'mbd-rsscs' !! VdW method to use to calculate energy and gradients. !! !! - `mbd-rsscs`: The MBD@rsSCS method. !! - `mbd-nl`: The MBD-NL method. !! - `ts`: The TS method. !! - `mbd`: Generic MBD method (without any screening). #ifdef WITH_MPIF08 type(MPI_Comm) :: comm = MPI_COMM_NULL #else integer :: comm = -1 #endif !! MPI communicator. !! !! Only used when compiled with MPI. Leave as is to use the !! MPI_COMM_WORLD communicator. integer :: max_atoms_per_block = MAX_ATOMS_PER_BLOCK !! Number of atoms per block in a BLACS grid. integer :: log_level = MBD_LOG_LVL_INFO !! Level of printing procedure(printer_i), nopass, pointer :: printer => null() !! If assigned, will be used for logging logical :: calculate_forces = .true. !! Whether to calculate forces. logical :: calculate_vdw_params_gradients = .false. !! Whether to calculate gradients of energy w.r.t. vdW parameters logical :: calculate_spectrum = .false. !! Whether to keep MBD eigenvalues. logical :: do_rpa = .false. !! Whether to evalulate the MBD energy as an RPA integral over frequency. logical :: rpa_orders = .false. !! Whether to calculate individual RPA orders logical :: rpa_rescale_eigs = .false. !! Whether to rescale RPA eigenvalues as in 10.1021/acs.jctc.6b00925. integer :: n_omega_grid = N_FREQUENCY_GRID !! Number of imaginary frequency grid points. real(dp) :: k_grid_shift = K_GRID_SHIFT !! Off-\(\Gamma\) shift of the \(k\)-point grid in units of !! inter-\(k\)-point distance. logical :: zero_negative_eigvals = .false. !! Whether to zero out negative eigenvalues. character(len=20) :: xc = '' !! XC functional for automatic setting of damping parameters. real(dp) :: ts_d = TS_DAMPING_D !! TS damping parameter \(d\). real(dp) :: ts_sr = -1 !! Custom TS damping parameter \(s_R\). !! !! Leave as is to use a value based on the XC functional. real(dp) :: mbd_a = MBD_DAMPING_A !! MBD damping parameter \(a\). real(dp) :: mbd_beta = -1 !! Custom MBD damping parameter \(\beta\). !! !! Leave as is to use a value based on the XC functional. character(len=10) :: vdw_params_kind = 'ts' !! Which free-atom reference vdW parameters to use for scaling. !! !! - `ts`: Values from original TS method. !! - `tssurf`: Values from the TS\(^\text{surf}\) approach. character(len=3), allocatable :: atom_types(:) !! (\(N\)) Atom types used for picking free-atom reference values. real(dp), allocatable :: free_values(:, :) !! (\(N\times3\), a.u.) Custom free-atom vdW paramters to use for !! scaling. !! !! Columns contain static polarizabilities, C6 coefficients, and vdW !! radii. real(dp), allocatable :: coords(:, :) !! (\(3\times N\), a.u.) Atomic coordinates. real(dp), allocatable :: lattice_vectors(:, :) !! (\(3\times 3\), a.u.) Lattice vectors in columns, unallocated if not !! periodic. integer :: k_grid(3) = [-1, -1, -1] !! Number of \(k\)-points along reciprocal axes. character(len=10) :: parallel_mode = 'auto' !! Parallelization scheme. !! !! - `auto`: Pick based on system system size and number of \(k\)-points. !! - `kpoints`: Parallelize over \(k\)-points. !! - `atoms`: Parallelize over atom pairs. end type type, public :: mbd_calc_t !! Represents an MBD calculation. private type(geom_t) :: geom type(damping_t) :: damp real(dp), allocatable :: alpha_0(:) real(dp), allocatable :: C6(:) character(len=30) :: method type(result_t) :: results type(grad_t) :: dalpha_0, dC6, dr_vdw logical :: calculate_gradients logical :: calculate_vdw_params_gradients real(dp), allocatable :: free_values(:, :) character(len=30) :: vdw_params_update contains procedure :: init => mbd_calc_init procedure :: destroy => mbd_calc_destroy procedure :: switch_forces => mbd_calc_switch_forces procedure :: update_coords => mbd_calc_update_coords procedure :: update_lattice_vectors => mbd_calc_update_lattice_vectors procedure :: update_vdw_params_custom => mbd_calc_update_vdw_params_custom procedure :: update_vdw_params_from_ratios => mbd_calc_update_vdw_params_from_ratios procedure :: update_vdw_params_nl => mbd_calc_update_vdw_params_nl procedure :: evaluate_vdw_method => mbd_calc_evaluate_vdw_method procedure :: get_gradients => mbd_calc_get_gradients procedure :: get_vdw_params_ratios_gradients => mbd_calc_get_vdw_params_ratios_gradients procedure :: get_lattice_derivs => mbd_calc_get_lattice_derivs procedure :: get_lattice_stress => mbd_calc_get_lattice_stress procedure :: get_spectrum_modes => mbd_calc_get_spectrum_modes procedure :: get_rpa_orders => mbd_calc_get_rpa_orders procedure :: get_exception => mbd_calc_get_exception end type contains subroutine mbd_calc_init(this, input) !! Initialize an MBD calculation from an MBD input. class(mbd_calc_t), target, intent(inout) :: this type(mbd_input_t), intent(in) :: input !! MBD input. #ifdef WITH_MPI # ifdef WITH_MPIF08 if (input%comm /= MPI_COMM_NULL) then # else if (input%comm /= -1) then # endif this%geom%mpi_comm = input%comm end if #endif #ifdef WITH_SCALAPACK this%geom%max_atoms_per_block = input%max_atoms_per_block #endif this%method = input%method this%calculate_gradients = input%calculate_forces this%calculate_vdw_params_gradients = input%calculate_vdw_params_gradients this%geom%get_eigs = input%calculate_spectrum this%geom%get_modes = input%calculate_spectrum this%geom%do_rpa = input%do_rpa this%geom%get_rpa_orders = input%rpa_orders this%geom%param%rpa_rescale_eigs = input%rpa_rescale_eigs this%geom%param%n_freq = input%n_omega_grid this%geom%param%k_grid_shift = input%k_grid_shift this%geom%param%zero_negative_eigvals = input%zero_negative_eigvals if (.not. all(input%k_grid == -1)) this%geom%k_grid = input%k_grid this%geom%coords = input%coords if (allocated(input%lattice_vectors)) then if (input%method /= 'ts' .and. .not. allocated(this%geom%k_grid)) then this%geom%exc = exception_t( & MBD_EXC_INPUT, & 'calc%init()', & 'Lattice vectors present but no k-grid specified' & ) return end if this%geom%lattice = input%lattice_vectors end if this%geom%parallel_mode = input%parallel_mode if (associated(input%printer)) this%geom%log%printer => input%printer this%geom%log%level = input%log_level call this%geom%init() if (allocated(input%free_values)) then this%free_values = input%free_values else select case (input%vdw_params_kind) case ('ts') this%free_values = ts_vdw_params(:, species_index(input%atom_types)) case ('tssurf') this%free_values = tssurf_vdw_params(:, species_index(input%atom_types)) end select end if if (input%xc == '') then this%damp%beta = input%mbd_beta this%damp%a = input%mbd_a this%damp%ts_d = input%ts_d this%damp%ts_sr = input%ts_sr select case (input%method) case ('ts') if (input%ts_sr < 0) then this%geom%exc%code = MBD_EXC_DAMPING this%geom%exc%msg = 'Damping parameter S_r for TS not specified' end if case default if (input%mbd_beta < 0) then this%geom%exc%code = MBD_EXC_DAMPING this%geom%exc%msg = 'Damping parameter beta for MBD not specified' end if end select else this%geom%exc = this%damp%set_params_from_xc(input%xc, input%method) end if if (this%geom%has_exc()) return end subroutine subroutine mbd_calc_destroy(this) !! Finalize an MBD calculation. class(mbd_calc_t), target, intent(inout) :: this call this%geom%destroy() end subroutine subroutine mbd_calc_switch_forces(this, forces) !! Update whether to calculate forces. class(mbd_calc_t), intent(inout) :: this logical, intent(in) :: forces !! Whether to calcualte forces. this%calculate_gradients = forces end subroutine subroutine mbd_calc_update_coords(this, coords) !! Update atomic coordinates. class(mbd_calc_t), intent(inout) :: this real(dp), intent(in) :: coords(:, :) !! (\(3\times N\), a.u.) New atomic coordinates. this%geom%coords = coords end subroutine subroutine mbd_calc_update_lattice_vectors(this, latt_vecs) !! Update unit-cell lattice vectors. class(mbd_calc_t), intent(inout) :: this real(dp), intent(in) :: latt_vecs(:, :) !! (\(3\times 3\), a.u.) New lattice vectors in columns. this%geom%lattice = latt_vecs end subroutine subroutine mbd_calc_update_vdw_params_custom(this, alpha_0, C6, r_vdw) !! Update vdW parameters in a custom way. class(mbd_calc_t), intent(inout) :: this real(dp), intent(in) :: alpha_0(:) !! (a.u.) New atomic static polarizabilities. real(dp), intent(in) :: C6(:) !! (a.u.) New atomic \(C_6\) coefficients. real(dp), intent(in) :: r_vdw(:) !! (a.u.) New atomic vdW radii. this%alpha_0 = alpha_0 this%C6 = C6 this%damp%r_vdw = r_vdw this%vdw_params_update = 'custom' end subroutine subroutine mbd_calc_update_vdw_params_from_ratios(this, ratios) !! Update vdW parameters based on scaling of free-atom values. class(mbd_calc_t), intent(inout) :: this real(dp), intent(in) :: ratios(:) !! Ratios of atomic volumes in the system and in vacuum. real(dp), allocatable :: ones(:) type(grad_request_t) :: grad allocate (ones(size(ratios)), source=1d0) grad%dV = this%calculate_vdw_params_gradients this%alpha_0 = scale_with_ratio( & this%free_values(1, :), ratios, ones, 1d0, this%dalpha_0, grad & ) this%C6 = scale_with_ratio( & this%free_values(2, :), ratios, ones, 2d0, this%dC6, grad & ) this%damp%r_vdw = scale_with_ratio( & this%free_values(3, :), ratios, ones, 1d0 / 3, this%dr_vdw, grad & ) this%vdw_params_update = 'ratios' end subroutine subroutine mbd_calc_get_vdw_params_ratios_gradients(this, dE_dratios) !! Get gradients of the energy w.r.t. Hirshfeld ratios if they were !! requested in the MBD input. class(mbd_calc_t), intent(inout) :: this real(dp), intent(out) :: dE_dratios(:) !! Gradients of the energy w.r.t. Hirshfeld ratios. if (this%vdw_params_update /= 'ratios') return dE_dratios = ( & this%results%dE%dalpha * this%dalpha_0%dV & + this%results%dE%dC6 * this%dC6%dV & + this%results%dE%dr_vdw * this%dr_vdw%dV & ) end subroutine subroutine mbd_calc_update_vdw_params_nl(this, alpha_0_ratios, C6_ratios) !! Update vdW parameters for the MBD-NL method. class(mbd_calc_t), intent(inout) :: this real(dp), intent(in) :: alpha_0_ratios(:) !! Ratios of free-atom exact static polarizabilities and those from the !! VV functional. real(dp), intent(in) :: C6_ratios(:) !! Ratios of free-atom exact \(C_6\) coefficients and those from the VV !! functional. this%alpha_0 = this%free_values(1, :) * alpha_0_ratios this%C6 = this%free_values(2, :) * C6_ratios this%damp%r_vdw = 2.5d0 * this%free_values(1, :)**(1d0 / 7) * alpha_0_ratios**(1d0 / 3) this%vdw_params_update = 'nl' end subroutine subroutine mbd_calc_evaluate_vdw_method(this, energy) !! Evaluate a given vdW method for a given system and vdW parameters, !! retrieve energy. class(mbd_calc_t), intent(inout) :: this real(dp), intent(out) :: energy !! (a.u.) VdW energy. type(grad_request_t) :: grad if (this%calculate_gradients) then grad%dcoords = .true. if (allocated(this%geom%lattice)) grad%dlattice = .true. end if if (this%calculate_vdw_params_gradients) then grad%dalpha = .true. grad%dC6 = .true. grad%dr_vdw = .true. end if select case (this%method) case ('mbd', 'mbd-nl') this%damp%version = 'fermi,dip' this%results = get_mbd_energy( & this%geom, this%alpha_0, this%C6, this%damp, grad & ) energy = this%results%energy case ('mbd-rsscs') this%results = get_mbd_scs_energy( & this%geom, 'rsscs', this%alpha_0, this%C6, this%damp, grad & ) energy = this%results%energy case ('ts') this%damp%version = 'fermi' this%results = get_ts_energy( & this%geom, this%alpha_0, this%C6, this%damp, grad & ) energy = this%results%energy end select if (this%geom%log%level <= MBD_LOG_LVL_DEBUG) call this%geom%timer%print() end subroutine subroutine mbd_calc_get_gradients(this, gradients) ! 3 by N dE/dR !! Retrieve nuclear energy gradients if they were requested in the MBD !! input. !! !! The gradients are calculated together with the energy, so a call to this !! method must be preceeded by a call to !! [[mbd_calc_t:evaluate_vdw_method]]. For the same reason, the !! gradients must be requested prior to this called via !! [[mbd_input_t:calculate_forces]]. class(mbd_calc_t), intent(in) :: this real(dp), intent(out) :: gradients(:, :) !! (\(3\times N\), a.u.) Energy gradients, \(\mathrm dE/\mathrm d\mathbf !! R_i\), index \(i\) runs over columns. gradients = transpose(this%results%dE%dcoords) end subroutine subroutine mbd_calc_get_lattice_derivs(this, latt_derivs) !! Provide lattice-vector energy gradients if they were requested in the MBD !! input. !! !! The gradients are actually calculated together with the energy, so a call !! to this method must be preceeded by a call to !! [[mbd_calc_t:evaluate_vdw_method]]. For the same reason, the !! gradients must be requested prior to this called via !! [[mbd_input_t:calculate_forces]]. class(mbd_calc_t), intent(in) :: this real(dp), intent(out) :: latt_derivs(:, :) !! (\(3\times 3\), a.u.) Energy gradients, \(\mathrm dE/\mathrm d\mathbf !! a_i\), index \(i\) runs over columns. latt_derivs = transpose(this%results%dE%dlattice) end subroutine subroutine mbd_calc_get_lattice_stress(this, stress) !! Provide stress tensor of the lattice. !! !! This is a utility function wrapping [[mbd_calc_t:get_lattice_derivs]]. !! The lattice vector gradients are coverted to the stress tensor. class(mbd_calc_t), intent(in) :: this real(dp), intent(out) :: stress(:, :) !! (\(3\times 3\), a.u.) Stress tensor. stress = ( & matmul(this%geom%lattice, this%results%dE%dlattice) & + matmul(this%geom%coords, this%results%dE%dcoords) & ) end subroutine subroutine mbd_calc_get_spectrum_modes(this, spectrum, modes) !! Provide MBD spectrum if it was requested in the MBD input. !! !! The spectrum is actually calculated together with the energy, so a call !! to this method must be preceeded by a call to !! [[mbd_calc_t:evaluate_vdw_method]]. For the same reason, the !! spectrum must be requested prior to this call via !! [[mbd_input_t:calculate_spectrum]]. class(mbd_calc_t), intent(inout) :: this real(dp), intent(out) :: spectrum(:) !! (\(3N\), a.u.) Energies (frequencies) of coupled MBD modues, !! \(\omega_i\). real(dp), intent(out), allocatable, optional :: modes(:, :) !! (\(3N\times 3N\)) Coupled-mode wave functions (MBD eigenstates), !! \(\psi_j\), in the basis of uncoupled states, !! \(C_{ij}=\langle\phi_i|\psi_j\rangle\), index \(j\) runs over !! columns. !! !! To save memory, the argument must be allocatable, and the method !! transfers allocation from the internal state to the argument. For !! this reason, the method can be called only once wih this optional !! argument per calculation. spectrum = this%results%mode_eigs if (present(modes)) call move_alloc(this%results%modes, modes) end subroutine subroutine mbd_calc_get_rpa_orders(this, rpa_orders) !! Provide RPA orders if they were requested in the MBD input. !! !! The orders are actually calculated together with the energy, so a call !! to this method must be preceeded by a call to !! [[mbd_calc_t:evaluate_vdw_method]]. For the same reason, the !! spectrum must be requested prior to this call via !! [[mbd_input_t:do_rpa]] and [[mbd_input_t:rpa_orders]]. class(mbd_calc_t), intent(inout) :: this real(dp), allocatable, intent(out) :: rpa_orders(:) !! (a.u.) MBD energy decomposed to RPA orders. rpa_orders = this%results%rpa_orders end subroutine subroutine mbd_calc_get_exception(this, code, origin, msg) !! Retrieve an exception in the MBD calculation if it occured. class(mbd_calc_t), intent(inout) :: this integer, intent(out) :: code !! Exception code, values defined in [[mbd_constants]]. character(*), intent(out) :: origin !! Exception origin. character(*), intent(out) :: msg !! Exception message. code = this%geom%exc%code if (code == 0) return origin = this%geom%exc%origin msg = this%geom%exc%msg this%geom%exc%code = 0 this%geom%exc%origin = '' this%geom%exc%msg = '' end subroutine end module libmbd-libmbd-88d61bc/src/mbd.h000066400000000000000000000055121452573331700163320ustar00rootroot00000000000000// vim: set ft=c: extern const _Bool cmbd_with_mpi; extern const _Bool cmbd_with_scalapack; extern const int cmbd_version_major; extern const int cmbd_version_minor; extern const int cmbd_version_patch; extern const char cmbd_version_suffix[30]; struct geom_t* cmbd_init_geom( int n_atoms, double* coords, double* lattice, int* k_grid, int n_kpts, double* custom_k_pts, int n_freq, _Bool do_rpa, _Bool get_spectrum, _Bool get_rpa_orders, _Bool rpa_rescale_eigs, int max_atoms_per_block, double ewald_cutoff_scaling[2] ); void cmbd_update_coords(struct geom_t* geom, double* coords); void cmbd_update_lattice(struct geom_t* geom, double* lattice); void cmbd_destroy_geom(struct geom_t* geom); void cmbd_get_exception( struct geom_t* geom, int* code, char origin[50], char msg[150] ); struct cmbd_damping* cmbd_init_damping( int n_atoms, char* version, double* R_vdw, double* sigma, double beta, double a ); void cmbd_destroy_damping(struct cmbd_damping* damping); void cmbd_print_timing(struct geom_t* geom); struct result_t* cmbd_ts_energy( struct geom_t* geom, double* alpha_0, double* C6, struct cmbd_damping* damping, _Bool grad ); struct result_t* cmbd_mbd_energy( struct geom_t* geom, double* alpha_0, double* C6, struct cmbd_damping* damping, _Bool grad ); struct result_t* cmbd_mbd_scs_energy( struct geom_t* geom, char* variant, double* alpha_0, double* C6, struct cmbd_damping* damping, _Bool grad ); void cmbd_get_results( struct result_t* result, double* energy, double* gradients, double* lattice_gradients, double* eigvals, double* eigvecs, double* rpa_orders, double* eigvals_k, // is actually complex double double* eigvecs_k, // is actually complex double double* alpha_0, double* C6 ); void cmbd_destroy_result(struct result_t* result); double cmbd_dipole_matrix( struct geom_t* geom, struct cmbd_damping* damping, double* q_point, double* dipmat ); double cmbd_coulomb_energy( struct geom_t* geom, int n_atoms, double* q, double* m, double* w_t, char* version, double* r_vdw, double beta, double a, double* C ); double cmbd_dipole_energy( struct geom_t* geom, int n_atoms, double* a0, double* w, double* w_t, char* version, double* r_vdw, double beta, double a, double* C ); double cmbd_nonint_density( struct geom_t* geom, int n_atoms, int n_pts, double* pts, double* charges, double* masses, double* omegas, double* rho ); double cmbd_int_density( struct geom_t* geom, int n_atoms, int n_pts, double* pts, double* charges, double* masses, double* omegas, double* modes, double* rho ); libmbd-libmbd-88d61bc/src/mbd_blacs.f90000066400000000000000000000154121452573331700176450ustar00rootroot00000000000000! This Source Code Form is subject to the terms of the Mozilla Public ! License, v. 2.0. If a copy of the MPL was not distributed with this ! file, You can obtain one at http://mozilla.org/MPL/2.0/. module mbd_blacs use mbd_constants implicit none private public :: blacs_all_reduce type, public :: blacs_grid_t integer :: ctx integer :: comm integer :: nprows integer :: npcols integer :: my_prow integer :: my_pcol contains procedure :: init => blacs_grid_init procedure :: destroy => blacs_grid_destroy end type type, public :: blacs_desc_t integer, allocatable :: i_atom(:) integer, allocatable :: j_atom(:) integer :: n_atoms integer :: desc(9) integer :: ctx integer :: blocksize integer :: comm = -1 contains procedure :: init => blacs_desc_init end type interface blacs_all_reduce module procedure all_reduce_real_scalar module procedure all_reduce_complex_scalar module procedure all_reduce_real_1d module procedure all_reduce_real_2d module procedure all_reduce_complex_1d module procedure all_reduce_complex_2d end interface interface ! The following interfaces were written by hand based on ! https://www.netlib.org/blacs/BLACS/QRef.html and https://www.ibm.com/docs/ subroutine BLACS_PINFO(MYPNUM, NPROCS) integer :: MYPNUM, NPROCS end subroutine BLACS_GRIDINIT(ICONTXT, ORDER, NPROW, NPCOL) integer :: ICONTXT, NPROW, NPCOL character :: ORDER end subroutine BLACS_GRIDINFO(ICONTXT, NPROW, NPCOL, MYPROW, MYPCOL) integer :: ICONTXT, NPROW, NPCOL, MYPROW, MYPNUM end subroutine BLACS_GRIDEXIT(ICONTXT) integer :: ICONTXT end subroutine BLACS_GET(ICONTXT, WHAT, VAL) integer :: ICONTXT, WHAT, VAL end subroutine integer function NUMROC(n, nb, iproc, isrcproc, nprocs) integer :: n, nb, iproc, isrcproc, nprocs end subroutine DGSUM2D(ICONTXT, SCOPE, TOP, M, N, A, LDA, RDEST, CDEST) integer :: ICONTXT, RDEST, CDEST, M, N, LDA character :: SCOPE, TOP double precision :: A(*) end subroutine ZGSUM2D(ICONTXT, SCOPE, TOP, M, N, A, LDA, RDEST, CDEST) import :: dp integer :: ICONTXT, RDEST, CDEST, M, N, LDA character :: SCOPE, TOP complex(dp) :: A(*) end ! The following interfaces were taken straight from the ScaLAPACK codebase SUBROUTINE DESCINIT(DESC, M, N, MB, NB, IRSRC, ICSRC, ICTXT, LLD, INFO) INTEGER ICSRC, ICTXT, INFO, IRSRC, LLD, M, MB, N, NB INTEGER DESC(*) END end interface contains subroutine blacs_grid_init(this, comm) class(blacs_grid_t), intent(inout) :: this integer, intent(in), optional :: comm integer :: my_task, n_tasks, nprows call BLACS_PINFO(my_task, n_tasks) do nprows = int(sqrt(dble(n_tasks))), 1, -1 if (mod(n_tasks, nprows) == 0) exit end do this%nprows = nprows this%npcols = n_tasks / this%nprows if (present(comm)) then this%ctx = comm this%comm = comm else call BLACS_GET(0, 0, this%ctx) end if call BLACS_GRIDINIT(this%ctx, 'R', this%nprows, this%npcols) call BLACS_GRIDINFO( & this%ctx, this%nprows, this%npcols, this%my_prow, this%my_pcol & ) end subroutine ! TODO this should be made a destructor once support for gfortran 4.9 is dropped subroutine blacs_grid_destroy(this) class(blacs_grid_t), intent(inout) :: this call BLACS_GRIDEXIT(this%ctx) end subroutine subroutine blacs_desc_init(this, n_atoms, grid, max_atoms_per_block) class(blacs_desc_t), intent(out) :: this type(blacs_grid_t), intent(in) :: grid integer, intent(in) :: n_atoms integer, intent(in) :: max_atoms_per_block integer :: my_nratoms, my_ncatoms, ierr, atoms_per_block, n_proc this%comm = grid%comm this%ctx = grid%ctx this%n_atoms = n_atoms n_proc = max(grid%nprows, grid%npcols) if (n_proc == 1) return atoms_per_block = (n_atoms - 1) / (n_proc - 1) if (atoms_per_block == 0) return atoms_per_block = min(atoms_per_block, max_atoms_per_block) my_nratoms = NUMROC(n_atoms, atoms_per_block, grid%my_prow, 0, grid%nprows) my_ncatoms = NUMROC(n_atoms, atoms_per_block, grid%my_pcol, 0, grid%npcols) this%blocksize = 3 * atoms_per_block call DESCINIT( & this%desc, 3 * n_atoms, 3 * n_atoms, this%blocksize, this%blocksize, 0, 0, & grid%ctx, 3 * my_nratoms, ierr & ) this%i_atom = idx_map( & grid%my_prow, grid%nprows, n_atoms, atoms_per_block, my_nratoms & ) this%j_atom = idx_map( & grid%my_pcol, grid%npcols, n_atoms, atoms_per_block, my_ncatoms & ) end subroutine function idx_map(my_task, n_tasks, n, blocksize, nidx) integer, intent(in) :: my_task, n_tasks, n, blocksize, nidx integer :: idx_map(nidx) integer :: i, i_block, n_in_block, my_i i_block = 0 n_in_block = 0 my_i = 1 do i = 1, n if (mod(i_block, n_tasks) == my_task) then idx_map(my_i) = i my_i = my_i + 1 end if n_in_block = n_in_block + 1 if (n_in_block == blocksize) then n_in_block = 0 i_block = i_block + 1 end if end do end function subroutine all_reduce_real_scalar(x, blacs) real(dp), intent(inout) :: x type(blacs_desc_t), intent(in) :: blacs real(dp), pointer :: x_arr(:, :) x_arr(1, 1) = x call DGSUM2D(blacs%ctx, 'A', ' ', 1, 1, x_arr, 1, -1, -1) x = x_arr(1, 1) end subroutine subroutine all_reduce_complex_scalar(x, blacs) complex(dp), intent(inout) :: x type(blacs_desc_t), intent(in) :: blacs complex(dp) :: x_arr(1, 1) x_arr(1, 1) = x call ZGSUM2D(blacs%ctx, 'A', ' ', 1, 1, x_arr, 1, -1, -1) x = x_arr(1, 1) end subroutine subroutine all_reduce_real_1d(A, blacs) real(dp), target, intent(inout) :: A(:) type(blacs_desc_t), intent(in) :: blacs real(dp), pointer :: A_p(:, :) A_p(1:size(A), 1:1) => A call DGSUM2D(blacs%ctx, 'A', ' ', size(A), 1, A_p, size(A), -1, -1) end subroutine subroutine all_reduce_real_2d(A, blacs) real(dp), intent(inout) :: A(:, :) type(blacs_desc_t), intent(in) :: blacs call DGSUM2D( & blacs%ctx, 'A', ' ', size(A, 1), size(A, 2), A, size(A, 1), -1, -1 & ) end subroutine subroutine all_reduce_complex_1d(A, blacs) complex(dp), target, intent(inout) :: A(:) type(blacs_desc_t), intent(in) :: blacs complex(dp), pointer :: A_p(:, :) A_p(1:size(A), 1:1) => A call ZGSUM2D(blacs%ctx, 'A', ' ', size(A), 1, A_p, size(A), -1, -1) end subroutine subroutine all_reduce_complex_2d(A, blacs) complex(dp), intent(inout) :: A(:, :) type(blacs_desc_t), intent(in) :: blacs call ZGSUM2D( & blacs%ctx, 'A', ' ', size(A, 1), size(A, 2), A, size(A, 1), -1, -1 & ) end subroutine end module libmbd-libmbd-88d61bc/src/mbd_c_api.F90000066400000000000000000000400441452573331700175730ustar00rootroot00000000000000! This Source Code Form is subject to the terms of the Mozilla Public ! License, v. 2.0. If a copy of the MPL was not distributed with this ! file, You can obtain one at http://mozilla.org/MPL/2.0/. module mbd_c_api !! Implementation of C API. use iso_c_binding use mbd_constants use mbd_version use mbd_coulomb, only: dipole_energy, coulomb_energy use mbd_damping, only: damping_t use mbd_dipole, only: dipole_matrix use mbd_density, only: eval_mbd_nonint_density, eval_mbd_int_density use mbd_geom, only: geom_t use mbd_gradients, only: grad_t, grad_request_t use mbd_matrix, only: matrix_re_t, matrix_cplx_t use mbd_methods, only: get_mbd_energy, get_mbd_scs_energy use mbd_ts, only: get_ts_energy use mbd_utils, only: result_t implicit none private public :: cmbd_with_scalapack, cmbd_with_mpi, cmbd_version_major, & cmbd_version_minor, cmbd_version_patch, cmbd_version_suffix public :: cmbd_init_geom, cmbd_destroy_geom, cmbd_init_damping, & cmbd_destroy_damping, cmbd_get_exception, cmbd_update_coords, cmbd_update_lattice, & cmbd_get_results, cmbd_destroy_result, cmbd_print_timing public :: cmbd_ts_energy, cmbd_mbd_energy, cmbd_mbd_scs_energy, & cmbd_dipole_matrix, cmbd_coulomb_energy, cmbd_dipole_energy #ifdef WITH_MPI logical(c_bool), bind(c) :: cmbd_with_mpi = .true. #else logical(c_bool), bind(c) :: cmbd_with_mpi = .false. #endif #ifdef WITH_SCALAPACK logical(c_bool), bind(c) :: cmbd_with_scalapack = .true. #else logical(c_bool), bind(c) :: cmbd_with_scalapack = .false. #endif integer :: i integer(c_int), bind(c) :: cmbd_version_major = mbd_version_major integer(c_int), bind(c) :: cmbd_version_minor = mbd_version_minor integer(c_int), bind(c) :: cmbd_version_patch = mbd_version_patch character(c_char), bind(c) :: cmbd_version_suffix(30) = [(mbd_version_suffix(i:i), i=1, 30)] contains type(c_ptr) function cmbd_init_geom( & n_atoms, coords, lattice, k_grid, n_kpts, custom_k_pts, & n_freq, do_rpa, get_spectrum, get_rpa_orders, rpa_rescale_eigs, & max_atoms_per_block, ewald_cutoff_scaling & ) bind(c) integer(c_int), value, intent(in) :: n_atoms real(c_double), intent(in) :: coords(3, n_atoms) real(c_double), optional, intent(in) :: lattice(3, 3) integer(c_int), optional, intent(in) :: k_grid(3) integer(c_int), value, intent(in) :: n_kpts real(c_double), optional, intent(in) :: custom_k_pts(3, n_kpts) integer(c_int), value, intent(in) :: n_freq logical(c_bool), value, intent(in) :: do_rpa logical(c_bool), value, intent(in) :: get_spectrum logical(c_bool), value, intent(in) :: get_rpa_orders logical(c_bool), value, intent(in) :: rpa_rescale_eigs integer(c_int), value, intent(in) :: max_atoms_per_block real(c_double), intent(in) :: ewald_cutoff_scaling(2) type(geom_t), pointer :: geom allocate (geom) geom%coords = coords if (present(lattice)) geom%lattice = lattice if (present(k_grid)) geom%k_grid = k_grid if (present(custom_k_pts)) geom%custom_k_pts = custom_k_pts if (n_freq > 0) geom%param%n_freq = n_freq #ifdef WITH_SCALAPACK if (max_atoms_per_block > 0) geom%max_atoms_per_block = max_atoms_per_block #endif geom%do_rpa = do_rpa geom%get_eigs = get_spectrum geom%get_modes = get_spectrum geom%get_rpa_orders = get_rpa_orders geom%param%rpa_rescale_eigs = rpa_rescale_eigs geom%param%ewald_real_cutoff_scaling = ewald_cutoff_scaling(1) geom%param%ewald_rec_cutoff_scaling = ewald_cutoff_scaling(2) call geom%init() cmbd_init_geom = c_loc(geom) end function subroutine cmbd_update_coords(geom_c, coords_c) bind(c) type(c_ptr), value, intent(in) :: geom_c type(c_ptr), value, intent(in) :: coords_c type(geom_t), pointer :: geom real(c_double), pointer :: coords(:, :) call c_f_pointer(geom_c, geom) call c_f_pointer(coords_c, coords, [3, geom%siz()]) geom%coords = coords end subroutine subroutine cmbd_update_lattice(geom_c, lattice) bind(c) type(c_ptr), value, intent(in) :: geom_c real(c_double), intent(in) :: lattice(3, 3) type(geom_t), pointer :: geom call c_f_pointer(geom_c, geom) geom%lattice = lattice end subroutine subroutine cmbd_destroy_geom(geom_c) bind(c) type(c_ptr), value, intent(in) :: geom_c type(geom_t), pointer :: geom call c_f_pointer(geom_c, geom) call geom%destroy() deallocate (geom) end subroutine subroutine cmbd_get_exception(geom_c, code, origin, msg) bind(c) type(c_ptr), value, intent(in) :: geom_c integer(c_int), intent(out) :: code character(kind=c_char), intent(out) :: origin(50), msg(150) type(geom_t), pointer :: geom call c_f_pointer(geom_c, geom) code = geom%exc%code call f_c_string(geom%exc%origin, origin) call f_c_string(geom%exc%msg, msg) geom%exc%code = 0 geom%exc%origin = '' geom%exc%msg = '' end subroutine type(c_ptr) function cmbd_init_damping(n_atoms, version_c, r_vdw, sigma, beta, a) bind(c) integer(c_int), value, intent(in) :: n_atoms character(kind=c_char), intent(in) :: version_c(*) real(c_double), optional, intent(in) :: r_vdw(n_atoms) real(c_double), optional, intent(in) :: sigma(n_atoms) real(c_double), value, intent(in) :: beta real(c_double), value, intent(in) :: a type(damping_t), pointer :: damping allocate (damping) damping%version = f_string(version_c) if (present(r_vdw)) damping%r_vdw = r_vdw if (present(sigma)) damping%sigma = sigma damping%beta = beta damping%a = a damping%ts_sr = beta damping%ts_d = a cmbd_init_damping = c_loc(damping) end function subroutine cmbd_destroy_damping(damping_c) bind(c) type(c_ptr), value, intent(in) :: damping_c type(damping_t), pointer :: damping call c_f_pointer(damping_c, damping) deallocate (damping) end subroutine type(c_ptr) function cmbd_ts_energy(geom_c, alpha_0_c, C6_c, damping_c, grad) bind(c) type(c_ptr), value, intent(in) :: geom_c type(c_ptr), value, intent(in) :: alpha_0_c type(c_ptr), value, intent(in) :: C6_c type(c_ptr), value, intent(in) :: damping_c logical(c_bool), value, intent(in) :: grad type(geom_t), pointer :: geom real(c_double), pointer :: alpha_0(:) real(c_double), pointer :: C6(:) type(damping_t), pointer :: damping type(result_t), pointer :: res call c_f_pointer(geom_c, geom) call c_f_pointer(alpha_0_c, alpha_0, [geom%siz()]) call c_f_pointer(C6_c, C6, [geom%siz()]) call c_f_pointer(damping_c, damping) allocate (res) res = get_ts_energy( & geom, alpha_0, C6, damping, grad_request_t( & dcoords=grad, dlattice=grad .and. allocated(geom%lattice) & ) & ) cmbd_ts_energy = c_loc(res) end function type(c_ptr) function cmbd_mbd_energy(geom_c, alpha_0_c, C6_c, damping_c, grad) bind(c) type(c_ptr), value, intent(in) :: geom_c type(c_ptr), value, intent(in) :: alpha_0_c type(c_ptr), value, intent(in) :: C6_c type(c_ptr), value, intent(in) :: damping_c logical(c_bool), value, intent(in) :: grad type(geom_t), pointer :: geom real(c_double), pointer :: alpha_0(:) real(c_double), pointer :: C6(:) type(damping_t), pointer :: damping type(result_t), pointer :: res call c_f_pointer(geom_c, geom) call c_f_pointer(alpha_0_c, alpha_0, [geom%siz()]) call c_f_pointer(C6_c, C6, [geom%siz()]) call c_f_pointer(damping_c, damping) allocate (res) res = get_mbd_energy( & geom, alpha_0, C6, damping, grad_request_t( & dcoords=grad, dlattice=grad .and. allocated(geom%lattice) & ) & ) cmbd_mbd_energy = c_loc(res) end function type(c_ptr) function cmbd_mbd_scs_energy( & geom_c, variant_c, alpha_0_c, C6_c, damping_c, grad) bind(c) type(c_ptr), value, intent(in) :: geom_c character(kind=c_char), intent(in) :: variant_c(*) type(c_ptr), value, intent(in) :: alpha_0_c type(c_ptr), value, intent(in) :: C6_c type(c_ptr), value, intent(in) :: damping_c logical(c_bool), value, intent(in) :: grad type(geom_t), pointer :: geom character(len=20) :: variant real(c_double), pointer :: alpha_0(:) real(c_double), pointer :: C6(:) type(damping_t), pointer :: damping type(result_t), pointer :: res call c_f_pointer(geom_c, geom) variant = f_string(variant_c) call c_f_pointer(alpha_0_c, alpha_0, [geom%siz()]) call c_f_pointer(C6_c, C6, [geom%siz()]) call c_f_pointer(damping_c, damping) allocate (res) res = get_mbd_scs_energy( & geom, variant, alpha_0, C6, damping, grad_request_t( & dcoords=grad, dlattice=grad .and. allocated(geom%lattice) & ) & ) cmbd_mbd_scs_energy = c_loc(res) end function subroutine cmbd_get_results( & res_c, energy, gradients_c, lattice_gradients_c, eigvals_c, eigvecs_c, rpa_orders_c, & eigvals_k_c, eigvecs_k_c, alpha_0_c, C6_c & ) bind(c) type(c_ptr), value, intent(in) :: res_c real(c_double), intent(out) :: energy type(c_ptr), value, intent(in) :: gradients_c type(c_ptr), value, intent(in) :: lattice_gradients_c type(c_ptr), value, intent(in) :: eigvals_c type(c_ptr), value, intent(in) :: eigvecs_c type(c_ptr), value, intent(in) :: rpa_orders_c type(c_ptr), value, intent(in) :: eigvals_k_c type(c_ptr), value, intent(in) :: eigvecs_k_c type(c_ptr), value, intent(in) :: alpha_0_c type(c_ptr), value, intent(in) :: C6_c type(result_t), pointer :: res real(c_double), pointer :: gradients(:, :) real(c_double), pointer :: lattice_gradients(:, :) real(c_double), pointer :: eigvals(:) real(c_double), pointer :: eigvecs(:, :) real(c_double), pointer :: rpa_orders(:) real(c_double), pointer :: eigvals_k(:, :) complex(c_double_complex), pointer :: eigvecs_k(:, :, :) real(c_double), pointer :: alpha_0(:) real(c_double), pointer :: C6(:) call c_f_pointer(res_c, res) energy = res%energy if (c_associated(gradients_c) .and. allocated(res%dE%dcoords)) then call c_f_pointer(gradients_c, gradients, [3, size(res%dE%dcoords, 1)]) gradients = transpose(res%dE%dcoords) end if if (c_associated(lattice_gradients_c) .and. allocated(res%dE%dlattice)) then call c_f_pointer(lattice_gradients_c, lattice_gradients, [3, 3]) lattice_gradients = transpose(res%dE%dlattice) end if if (c_associated(eigvals_c) .and. allocated(res%mode_eigs)) then call c_f_pointer(eigvals_c, eigvals, [size(res%mode_eigs)]) eigvals = res%mode_eigs end if if (c_associated(eigvecs_c) .and. allocated(res%modes)) then call c_f_pointer(eigvecs_c, eigvecs, [size(res%modes, 1), size(res%modes, 2)]) eigvecs = res%modes end if if (c_associated(rpa_orders_c) .and. allocated(res%rpa_orders)) then call c_f_pointer(rpa_orders_c, rpa_orders, [size(res%rpa_orders)]) rpa_orders = res%rpa_orders end if if (c_associated(eigvals_k_c) .and. allocated(res%mode_eigs_k)) then call c_f_pointer( & eigvals_k_c, eigvals_k, & [size(res%mode_eigs_k, 1), size(res%mode_eigs_k, 2)] & ) eigvals_k = res%mode_eigs_k end if if (c_associated(eigvecs_k_c) .and. allocated(res%modes_k)) then call c_f_pointer( & eigvecs_k_c, eigvecs_k, & [size(res%modes_k, 1), size(res%modes_k, 2), size(res%modes_k, 3)] & ) eigvecs_k = res%modes_k end if if (c_associated(alpha_0_c) .and. allocated(res%alpha_0)) then call c_f_pointer(alpha_0_c, alpha_0, [size(res%alpha_0)]) alpha_0 = res%alpha_0 end if if (c_associated(C6_c) .and. allocated(res%C6)) then call c_f_pointer(C6_c, C6, [size(res%C6)]) C6 = res%C6 end if end subroutine subroutine cmbd_destroy_result(res_c) bind(c) type(c_ptr), value, intent(in) :: res_c type(result_t), pointer :: res call c_f_pointer(res_c, res) deallocate (res) end subroutine subroutine cmbd_print_timing(geom_c) bind(c) type(c_ptr), value, intent(in) :: geom_c type(geom_t), pointer :: geom call c_f_pointer(geom_c, geom) call geom%timer%print() end subroutine subroutine cmbd_dipole_matrix(geom_c, damping_c, q_point, dipmat_c) bind(c) type(c_ptr), value, intent(in) :: geom_c type(c_ptr), value, intent(in) :: damping_c real(c_double), optional, intent(in) :: q_point(3) type(c_ptr), value, intent(in) :: dipmat_c type(geom_t), pointer :: geom type(damping_t), pointer :: damp type(matrix_re_t) :: dipmat_re type(matrix_cplx_t) :: dipmat_cplx real(dp), pointer :: dipmat_re_p(:, :) complex(dp), pointer :: dipmat_cplx_p(:, :) integer :: n_atoms call c_f_pointer(geom_c, geom) n_atoms = size(geom%coords, 2) call c_f_pointer(damping_c, damp) if (present(q_point)) then dipmat_cplx = dipole_matrix(geom, damp, q=q_point) call c_f_pointer(dipmat_c, dipmat_cplx_p, [3 * n_atoms, 3 * n_atoms]) dipmat_cplx_p = transpose(dipmat_cplx%val) else dipmat_re = dipole_matrix(geom, damp) call c_f_pointer(dipmat_c, dipmat_re_p, [3 * n_atoms, 3 * n_atoms]) dipmat_re_p = transpose(dipmat_re%val) end if end subroutine real(c_double) function cmbd_coulomb_energy( & geom_c, n_atoms, q, m, w_t, version, r_vdw, beta, a, C) bind(c) type(c_ptr), value :: geom_c integer(c_int), value, intent(in) :: n_atoms real(c_double), value, intent(in) :: a, beta real(c_double), intent(in) :: C(3 * n_atoms, 3 * n_atoms), & w_t(3 * n_atoms), q(n_atoms), m(n_atoms), r_vdw(n_atoms) character(c_char), intent(in) :: version(20) type(geom_t), pointer :: geom type(damping_t) :: damp damp%version = f_string(version) damp%r_vdw = r_vdw damp%ts_d = a damp%ts_sr = beta call c_f_pointer(geom_c, geom) cmbd_coulomb_energy = coulomb_energy(geom, q, m, w_t, C, damp) end function real(c_double) function cmbd_dipole_energy( & geom_c, n_atoms, a0, w, w_t, version, r_vdw, beta, a, C) bind(c) type(c_ptr), value :: geom_c integer(c_int), value, intent(in) :: n_atoms real(c_double), intent(in) :: C(3 * n_atoms, 3 * n_atoms), & w_t(3 * n_atoms), w(n_atoms), a0(n_atoms), r_vdw(n_atoms) real(c_double), value, intent(in) :: a, beta character(c_char), intent(in) :: version(20) type(geom_t), pointer :: geom type(damping_t) :: damp damp%version = f_string(version) damp%r_vdw = r_vdw damp%beta = beta damp%a = a call c_f_pointer(geom_c, geom) cmbd_dipole_energy = dipole_energy(geom, a0, w, w_t, C, damp) end function subroutine cmbd_nonint_density(geom_c, n_atoms, n_pts, pts, charges, masses, omegas, rho) bind(c) type(c_ptr), value :: geom_c integer(c_int), value, intent(in) :: n_atoms, n_pts real(c_double), intent(in) :: pts(3, n_pts), charges(n_atoms), masses(n_atoms), omegas(n_atoms) real(c_double), intent(out) :: rho(n_pts) type(geom_t), pointer :: geom call c_f_pointer(geom_c, geom) rho = eval_mbd_nonint_density(geom, pts, charges, masses, omegas) end subroutine subroutine cmbd_int_density(geom_c, n_atoms, n_pts, pts, charges, masses, omegas, modes, rho) bind(c) type(c_ptr), value :: geom_c integer(c_int), value, intent(in) :: n_atoms, n_pts real(c_double), intent(in) :: & pts(3, n_pts), charges(n_atoms), masses(n_atoms), & omegas(3 * n_atoms), modes(3 * n_atoms, 3 * n_atoms) real(c_double), intent(out) :: rho(n_pts) type(geom_t), pointer :: geom call c_f_pointer(geom_c, geom) rho = eval_mbd_int_density(geom, pts, charges, masses, omegas, modes) end subroutine function f_string(str_c) result(str_f) character(kind=c_char), intent(in) :: str_c(*) character(len=:), allocatable :: str_f integer :: i i = 0 do if (str_c(i + 1) == c_null_char) exit i = i + 1 end do allocate (character(len=i) :: str_f) str_f = transfer(str_c(1:i), str_f) end function subroutine f_c_string(str_f, str_c) character(len=*), intent(in) :: str_f character(kind=c_char), intent(out) :: str_c(:) integer :: i do i = 1, min(len(trim(str_f)), size(str_c) - 1) str_c(i) = str_f(i:i) end do str_c(i) = c_null_char end subroutine end module libmbd-libmbd-88d61bc/src/mbd_constants.f90000066400000000000000000000023031452573331700205700ustar00rootroot00000000000000! This Source Code Form is subject to the terms of the Mozilla Public ! License, v. 2.0. If a copy of the MPL was not distributed with this ! file, You can obtain one at http://mozilla.org/MPL/2.0/. module mbd_constants !! Constants used throughout. implicit none integer, parameter :: dp = kind(0.d0) real(dp), parameter :: pi = acos(-1.d0) real(dp), parameter :: ang = 1.8897259886d0 !! Value of angstrom in atomic units integer, parameter :: MBD_EXC_NEG_EIGVALS = 1 !! Negative eigenvalue exception integer, parameter :: MBD_EXC_NEG_POL = 2 !! Negative polarizability exception integer, parameter :: MBD_EXC_LINALG = 3 !! Exception in LAPACK or ScaLAPACK integer, parameter :: MBD_EXC_UNIMPL = 4 !! Functionality is not implemented integer, parameter :: MBD_EXC_DAMPING = 5 !! Damping-function exception integer, parameter :: MBD_EXC_INPUT = 6 !! Invalid input integer, parameter :: MBD_LOG_LVL_DEBUG = -1 integer, parameter :: MBD_LOG_LVL_INFO = 0 integer, parameter :: MBD_LOG_LVL_WARN = 1 integer, parameter :: MBD_LOG_LVL_ERROR = 2 real(dp), parameter :: ZERO_REAL = 0d0 complex(dp), parameter :: ZERO_COMPLEX = (0d0, 0d0) complex(dp), parameter :: IMI = (0d0, 1d0) end module libmbd-libmbd-88d61bc/src/mbd_coulomb.f90000066400000000000000000000155301452573331700202220ustar00rootroot00000000000000! This Source Code Form is subject to the terms of the Mozilla Public ! License, v. 2.0. If a copy of the MPL was not distributed with this ! file, You can obtain one at http://mozilla.org/MPL/2.0/. module mbd_coulomb use mbd_constants use mbd_linalg, only: eye, outer, diag use mbd_lapack, only: inverse, det, inv use mbd_geom, only: geom_t use mbd_dipole, only: dipole_matrix use mbd_damping, only: damping_t, damping_fermi use mbd_matrix, only: matrix_re_t implicit none private public :: coulomb_energy, dipole_energy contains subroutine calc_coulomb_coupled_gauss(R1, R2, K, dip, coul) real(dp), intent(in) :: R1(3), R2(3), K(:, :) real(dp), intent(out), optional :: dip(3, 3), coul real(dp), allocatable :: u(:), w(:), x(:) real(dp) :: R(6), det_K integer :: i real(dp) :: det_K_plus_U2, coul_u, dot, dist, work(6, 6) real(dp), dimension(:, :), allocatable :: K11, K12, K22, dip_u integer, parameter :: n_pts_coulomb = 500 real(dp), parameter :: L_coulomb = 10d0 character(len=20), parameter :: quadrature = 'simpson' dist = sqrt(sum((R1 - R2)**2)) allocate (x(n_pts_coulomb), w(n_pts_coulomb)) select case (quadrature) case ('original') w = 1d0 / n_pts_coulomb do concurrent(i=1:n_pts_coulomb) x(i) = w(1) / 2 + (i - 1) * w(1) end do u = log(1d0 / (1d0 - x)) * L_coulomb / dist w = 1d0 / (1d0 - x) * w * L_coulomb / dist case ('simpson') call simpson1by3(n_pts_coulomb, x, w) u = (1d0 - x) / (1d0 + x) w = 2 * w / (1d0 + x)**2 end select R(1:3) = R1 R(4:6) = R2 if (present(coul)) coul = 0d0 if (present(dip)) then dip(:, :) = 0d0 allocate (K11(3, 3), K12(3, 3), K22(3, 3), dip_u(3, 3)) end if do i = 1, n_pts_coulomb select case (size(K, 1)) case (3) work(1:3, 1:3) = K work(4:6, 1:3) = eye(3) * u(i)**2 work = -matmul( & work(:, 1:3), & matmul(inverse(K + eye(3) * u(i)**2), transpose(work(:, 1:3))) & ) work(1:3, 1:3) = work(1:3, 1:3) + K work(4:6, 4:6) = work(4:6, 4:6) + eye(3) * u(i)**2 det_K_plus_U2 = det(K + eye(3) * u(i)**2) case (6) work = K call add_U2(work, u(i)**2) ! work is K+U2 det_K_plus_U2 = det(work) call inv(work) ! work is (K+U2)^-1 work = K - matmul(K, matmul(work, K)) ! work is K-K*(K+U2)^-1*K end select dot = dot_product(R, matmul(work, R)) coul_u = 1d0 / sqrt(det_K_plus_U2) * exp(-dot) * w(i) if (present(coul)) coul = coul + coul_u if (present(dip)) then K11 = work(1:3, 1:3) K12 = work(1:3, 4:6) K22 = work(4:6, 4:6) dip_u = (-2 * K12 + 4 * outer( & matmul(K11, R1) + matmul(K12, R2), & matmul(K12, R1) + matmul(K22, R2) & )) * coul_u dip = dip + dip_u end if end do det_K = det(K) if (present(coul)) coul = 2.d0 / sqrt(pi) * coul * sqrt(det_K) if (present(dip)) dip = 2.d0 / sqrt(pi) * dip * sqrt(det_K) contains subroutine add_U2(A, u_sq) real(dp), intent(inout) :: A(6, 6) real(dp), intent(in) :: u_sq integer :: i do concurrent(i=1:3) A(i, i) = A(i, i) + u_sq A(i, i + 3) = A(i, i + 3) - u_sq A(i + 3, i) = A(i + 3, i) - u_sq A(i + 3, i + 3) = A(i + 3, i + 3) + u_sq end do end subroutine end subroutine real(dp) function coulomb_energy(geom, q, m, w_t, C, damp) type(geom_t), intent(inout) :: geom real(dp), intent(in) :: q(:), m(:), w_t(:), C(:, :) type(damping_t), intent(in) :: damp real(dp), allocatable :: O(:, :) real(dp) :: OAB(6, 6), OABm(6, 6), RA(3), RB(3), ene_ABi(4), prod_w_t, & K(3, 3), s_vdw, f_damp integer, allocatable :: notAB(:) integer :: N, A, B, i, j, AB(6), i2A(6) allocate (notAB(size(C, 1) - 6)) O = matmul(matmul(C, diag(w_t)), transpose(C)) N = geom%siz() prod_w_t = product(w_t) coulomb_energy = 0.d0 do A = 1, N do B = A + 1, N RA = geom%coords(:, A) RB = geom%coords(:, B) AB(:) = [(3 * (A - 1) + i, i=1, 3), (3 * (B - 1) + i, i=1, 3)] notAB(:) = [ & (i, i=1, 3 * (A - 1)), & (i, i=3 * A + 1, 3 * (B - 1)), & (i, i=3 * B + 1, 3 * N) & ] OAB = O(AB, AB) - matmul( & O(AB, notAB), & matmul(inverse(O(notAB, notAB)), O(notAB, AB)) & ) i2A = [(A, i=1, 3), (B, i=1, 3)] do concurrent(i=1:6, j=1:6) OABm(i, j) = OAB(i, j) * sqrt(m(i2A(i)) * m(i2A(j))) end do call calc_coulomb_coupled_gauss(RA, RB, OABm, coul=ene_ABi(1)) K = m(B) * (OAB(4:6, 4:6) - matmul( & OAB(4:6, 1:3), matmul(inverse(OAB(1:3, 1:3)), OAB(1:3, 4:6)) & )) call calc_coulomb_coupled_gauss(RA, RB, K, coul=ene_ABi(2)) K = m(A) * (OAB(1:3, 1:3) - matmul( & OAB(1:3, 4:6), matmul(inverse(OAB(4:6, 4:6)), OAB(4:6, 1:3)) & )) call calc_coulomb_coupled_gauss(RA, RB, K, coul=ene_ABi(3)) ene_ABi(2:3) = -ene_ABi(2:3) ene_ABi(4) = 1d0 / sqrt(sum((RA - RB)**2)) select case (damp%version) case ('fermi') s_vdw = damp%ts_sr * sum(damp%r_vdw([A, B])) f_damp = damping_fermi(RA - RB, s_vdw, damp%ts_d) case default f_damp = 1d0 end select coulomb_energy = coulomb_energy + f_damp * q(A) * q(B) * sum(ene_ABi) end do end do end function real(dp) function dipole_energy(geom, a0, w, w_t, C, damp) type(geom_t), intent(inout) :: geom real(dp), intent(in) :: a0(:), w(:), w_t(:), C(:, :) type(damping_t), intent(in) :: damp integer :: A, B, i, j, N type(matrix_re_t) :: T N = geom%siz() T = dipole_matrix(geom, damp) do A = 1, N do B = 1, N i = 3 * (A - 1) j = 3 * (B - 1) T%val(i + 1:i + 3, j + 1:j + 3) = & w(A) * w(B) * sqrt(a0(A) * a0(B)) * T%val(i + 1:i + 3, j + 1:j + 3) end do end do T%val = matmul(matmul(transpose(C), T%val), C) dipole_energy = sum(diag(T%val) / (4 * w_t)) end function subroutine simpson1by3(n, x, w) integer, intent(in) :: n real(dp), intent(out) :: x(n), w(n) integer :: i real(dp) :: h, delta delta = 1d-6 h = 2 * (1d0 - delta) / (n - 1) do i = 1, n x(i) = -(1d0 - delta) + h * (i - 1) if (2 * (i - (i / 2)) == i) then w(i) = 2 * h / 3 else w(i) = 4 * h / 3 end if end do w(1) = h / 3 w(n) = w(1) end subroutine end module libmbd-libmbd-88d61bc/src/mbd_damping.F90000066400000000000000000000116661452573331700201470ustar00rootroot00000000000000! This Source Code Form is subject to the terms of the Mozilla Public ! License, v. 2.0. If a copy of the MPL was not distributed with this ! file, You can obtain one at http://mozilla.org/MPL/2.0/. module mbd_damping !! Damping functions. use mbd_constants use mbd_defaults use mbd_gradients, only: grad_scalar_t, grad_request_t use mbd_utils, only: lower, exception_t implicit none private public :: damping_fermi, damping_sqrtfermi, op1minus_grad type, public :: damping_t !! Represents a damping function. character(len=20) :: version real(dp) :: beta = 0d0 real(dp) :: a = MBD_DAMPING_A real(dp) :: ts_d = TS_DAMPING_D real(dp) :: ts_sr = 0d0 real(dp) :: mayer_scaling = 1d0 real(dp), allocatable :: r_vdw(:) real(dp), allocatable :: sigma(:) real(dp), allocatable :: damping_custom(:, :) real(dp), allocatable :: potential_custom(:, :, :, :) contains procedure :: set_params_from_xc => damping_set_params_from_xc end type contains real(dp) function damping_fermi(r, s_vdw, d, df, grad) result(f) !! $$ !! \begin{gathered} !! f_{(ij)}=\frac1{1+\exp\big({-}a(\eta-1)\big)},\qquad !! \eta=\frac{R_{(ij)}}{S_{\text{vdW}(ij)}}\equiv !! \frac{R_{(ij)}}{\beta R_{\text{vdW}(ij)}} !! \\ \frac{\mathrm df}{\mathrm dR_c}= !! \frac a{2+2\cosh\big(a(\eta-1)\big)}\frac{\mathrm d\eta}{\mathrm dR_c},\qquad !! \frac{\mathrm d\eta}{\mathrm dR_c}= !! \frac{R_c}{RS_\text{vdW}}- !! \frac{R}{S_\text{vdW}^2}\frac{\mathrm dS_\text{vdW}}{\mathrm dR_c} !! \end{gathered} !! $$ real(dp), intent(in) :: r(3) real(dp), intent(in) :: s_vdw real(dp), intent(in) :: d type(grad_scalar_t), intent(out), optional :: df type(grad_request_t), intent(in), optional :: grad real(dp) :: pre, eta, r_1 r_1 = sqrt(sum(r**2)) eta = r_1 / s_vdw f = 1d0 / (1 + exp(-d * (eta - 1))) if (.not. present(grad)) return pre = d / (2 + 2 * cosh(d - d * eta)) if (grad%dcoords) df%dr = pre * r / (r_1 * s_vdw) if (grad%dr_vdw) df%dvdw = -pre * r_1 / s_vdw**2 end function real(dp) function damping_sqrtfermi(r, s_vdw, d) result(f) real(dp), intent(in) :: r(3) real(dp), intent(in) :: s_vdw real(dp), intent(in) :: d f = sqrt(damping_fermi(r, s_vdw, d)) end function subroutine op1minus_grad(f, df) real(dp), intent(inout) :: f type(grad_scalar_t), intent(inout) :: df f = 1 - f if (allocated(df%dr)) df%dr = -df%dr if (allocated(df%dvdw)) df%dvdw = -df%dvdw end subroutine type(exception_t) function damping_set_params_from_xc(this, xc, variant) result(exc) class(damping_t), intent(inout) :: this character(len=*), intent(in) :: xc character(len=*), intent(in) :: variant select case (lower(variant)) case ('ts') select case (lower(xc)) case ('pbe') this%ts_sr = 0.94d0 case ('pbe0') this%ts_sr = 0.96d0 case ('hse') this%ts_sr = 0.96d0 case ('blyp') this%ts_sr = 0.62d0 case ('b3lyp') this%ts_sr = 0.84d0 case ('revpbe') this%ts_sr = 0.60d0 case ('am05') this%ts_sr = 0.84d0 case default exc%code = MBD_EXC_DAMPING exc%msg = 'Damping parameter S_r of method TS unknown for '//trim(xc) end select case ('mbd-rsscs') select case (lower(xc)) case ('pbe') this%beta = 0.83d0 case ('pbe0') this%beta = 0.85d0 case ('hse') this%beta = 0.85d0 case default exc%code = MBD_EXC_DAMPING exc%msg = 'Damping parameter beta of method MBD@rsSCS unknown for '//trim(xc) end select case ('mbd-nl') select case (lower(xc)) case ('pbe') this%beta = 0.81d0 case ('pbe0') this%beta = 0.83d0 case ('hse') this%beta = 0.83d0 case default exc%code = MBD_EXC_DAMPING exc%msg = 'Damping parameter beta of method MBD-NL unknown for '//trim(xc) end select case ('mbd-ts') select case (lower(xc)) case ('pbe') this%beta = 0.81d0 case ('pbe0') this%beta = 0.83d0 case ('hse') this%beta = 0.83d0 case default exc%code = MBD_EXC_DAMPING exc%msg = 'Damping parameter beta of method MBD@TS unknown for '//trim(xc) end select case ('mbd-scs') select case (lower(xc)) case ('pbe') this%a = 2.56d0 case ('pbe0') this%a = 2.53d0 case ('hse') this%a = 2.53d0 case default exc%code = MBD_EXC_DAMPING exc%msg = 'Damping parameter a of method MBD@SCS unknown for '//trim(xc) end select case default exc%code = MBD_EXC_DAMPING exc%msg = 'Damping paramters of method '//trim(variant)//' unkonwn for '//trim(xc) end select end function end module libmbd-libmbd-88d61bc/src/mbd_defaults.f90000066400000000000000000000010161452573331700203630ustar00rootroot00000000000000! This Source Code Form is subject to the terms of the Mozilla Public ! License, v. 2.0. If a copy of the MPL was not distributed with this ! file, You can obtain one at http://mozilla.org/MPL/2.0/. module mbd_defaults !! Defaults used at multiple places. use mbd_constants implicit none real(dp), parameter :: N_FREQUENCY_GRID = 15 real(dp), parameter :: K_GRID_SHIFT = 0.5d0 real(dp), parameter :: TS_DAMPING_D = 20d0 real(dp), parameter :: MBD_DAMPING_A = 6d0 real(dp), parameter :: MAX_ATOMS_PER_BLOCK = 6 end module libmbd-libmbd-88d61bc/src/mbd_density.f90000066400000000000000000000052561452573331700202450ustar00rootroot00000000000000! This Source Code Form is subject to the terms of the Mozilla Public ! License, v. 2.0. If a copy of the MPL was not distributed with this ! file, You can obtain one at http://mozilla.org/MPL/2.0/. module mbd_density use mbd_constants use mbd_geom, only: geom_t use mbd_linalg, only: diag use mbd_lapack, only: eigvalsh, inverse implicit none contains function eval_mbd_nonint_density(geom, pts, charges, masses, omegas) result(rho) type(geom_t), intent(in) :: geom real(dp), intent(in) :: pts(:, :), charges(:), masses(:), omegas(:) real(dp) :: rho(size(pts, 2)) integer :: i_pt, i_atom, n_atoms real(dp), dimension(:), allocatable :: pre, kernel, rsq pre = charges * (masses * omegas / pi)**(3.d0 / 2) kernel = masses * omegas n_atoms = geom%siz() rho(:) = 0.d0 allocate (rsq(n_atoms)) do i_pt = 1, size(pts, 2) do concurrent(i_atom=1:n_atoms) rsq(i_atom) = sum((pts(:, i_pt) - geom%coords(:, i_atom))**2) end do rho(i_pt) = sum(pre * exp(-kernel * rsq)) end do end function function eval_mbd_int_density(geom, pts, charges, masses, omegas, modes) result(rho) type(geom_t), intent(in) :: geom real(dp), intent(in) :: pts(:, :), charges(:), masses(:), omegas(:), modes(:, :) real(dp) :: rho(size(pts, 2)) integer :: i_pt, i_atom, n_atoms, i, i_xyz, j_xyz, self(3) real(dp) :: rdiffsq(3, 3), rdiff(3) integer, allocatable :: other(:) real(dp), allocatable :: pre(:), factor(:), omegas_p(:, :), kernel(:, :, :) omegas_p = matmul(matmul(modes, diag(omegas)), transpose(modes)) n_atoms = geom%siz() allocate (kernel(3, 3, n_atoms), source=0.d0) allocate (pre(n_atoms), source=0.d0) do i_atom = 1, n_atoms self = (/(3 * (i_atom - 1) + i, i=1, 3)/) other = (/(i, i=1, 3 * (i_atom - 1)), (i, i=3 * i_atom + 1, 3 * n_atoms)/) kernel(:, :, i_atom) = masses(i_atom) & * (omegas_p(self, self) & - matmul(matmul(omegas_p(self, other), inverse(omegas_p(other, other))), & omegas_p(other, self))) pre(i_atom) = charges(i_atom) * (masses(i_atom) / pi)**(3.d0 / 2) & * sqrt(product(omegas) / product(eigvalsh(omegas_p(other, other)))) end do rho(:) = 0.d0 allocate (factor(n_atoms)) do i_pt = 1, size(pts, 2) do i_atom = 1, n_atoms rdiff = pts(:, i_pt) - geom%coords(:, i_atom) do concurrent(i_xyz=1:3, j_xyz=1:3) rdiffsq(i_xyz, j_xyz) = rdiff(i_xyz) * rdiff(j_xyz) end do factor(i_atom) = sum(kernel(:, :, i_atom) * rdiffsq(:, :)) end do rho(i_pt) = sum(pre * exp(-factor)) end do end function end module libmbd-libmbd-88d61bc/src/mbd_dipole.F90000066400000000000000000000730331452573331700200000ustar00rootroot00000000000000! This Source Code Form is subject to the terms of the Mozilla Public ! License, v. 2.0. If a copy of the MPL was not distributed with this ! file, You can obtain one at http://mozilla.org/MPL/2.0/. #ifndef DO_COMPLEX_TYPE module mbd_dipole !! Construction of dipole tensors and dipole matrices. use mbd_constants use mbd_matrix, only: matrix_re_t, matrix_cplx_t use mbd_geom, only: geom_t, supercell_circum use mbd_damping, only: damping_t, damping_fermi, damping_sqrtfermi, & op1minus_grad use mbd_gradients, only: grad_t, grad_matrix_re_t, grad_matrix_cplx_t, & grad_scalar_t, grad_request_t use mbd_lapack, only: eigvals, inverse use mbd_linalg, only: outer use mbd_utils, only: tostr, shift_idx implicit none private public :: dipole_matrix, T_bare, T_erf_coulomb, damping_grad, T_erfc, B_erfc, C_erfc interface dipole_matrix !! Form either a real or a complex dipole matrix. !! !! The real-typed version is equivalent to \(\mathbf q=0\). !! !! $$ !! \boldsymbol{\mathcal A}:=[\mathbf a_1\mathbf a_2\mathbf !! a_3],\qquad\boldsymbol{\mathcal B}:=[\mathbf b_1\mathbf b_2\mathbf b_3] !! \\ \boldsymbol{\mathcal B}=2\pi(\boldsymbol{\mathcal A}^{-1})^\mathrm !! T,\qquad \partial\boldsymbol{\mathcal B}=-\big((\partial\boldsymbol{\mathcal !! A})\boldsymbol{\mathcal A}^{-1}\big)^\mathrm T\boldsymbol{\mathcal B} !! \\ \mathbf R_\mathbf n=\boldsymbol{\mathcal A}\mathbf !! n,\qquad\partial\mathbf R_\mathbf n=(\partial\boldsymbol{\mathcal !! A})\mathbf n, !! \\ \mathbf G_\mathbf m=\boldsymbol{\mathcal B}\mathbf m,\qquad !! \partial\mathbf G_\mathbf m=-\big((\partial\boldsymbol{\mathcal !! A})\boldsymbol{\mathcal A}^{-1}\big)^\mathrm T\mathbf G_\mathbf m, !! \\ \frac{\partial G_{\mathbf ma}}{\partial A_{bc}}=-\mathcal A^{-1}_{ca}G_{\mathbf mb} !! $$ !! !! $$ !! \begin{gathered} !! \mathbf T_{ij}(\mathbf q)=\sum_{\mathbf n}\mathbf T(\mathbf R_{\mathbf !! nij})\mathrm e^{-\mathrm i\mathbf q\cdot\mathbf R_{\mathbf nij}},\quad\mathbf !! R_{\mathbf nij}=\mathbf R_j+\mathbf R_\mathbf n-\mathbf R_i !! \\ \frac{\mathrm d\mathbf R_{\mathbf nij}}{\mathrm d\mathbf !! R_k}=(\delta_{jk}-\delta_{ik})\mathbf I !! \\ \mathbf{T}_{ij}(\mathbf{q})\approx\mathbf{T}^\text{Ew}_{ij}(\mathbf{q}) !! =\sum_\mathbf n^{|\mathbf R_{\mathbf nij}| ZERO_REAL #else type(matrix_cplx_t) function dipole_matrix_complex( & geom, damp, ddipmat, grad, q) result(dipmat) use mbd_constants, only: ZERO => ZERO_COMPLEX #endif type(geom_t), intent(inout) :: geom type(damping_t), intent(in) :: damp type(grad_request_t), intent(in), optional :: grad #ifndef DO_COMPLEX_TYPE type(grad_matrix_re_t), intent(out), optional :: ddipmat #else type(grad_matrix_cplx_t), intent(out), optional :: ddipmat real(dp), intent(in) :: q(3) #endif real(dp) :: Rn(3), Rnij(3), Rnij_norm, T(3, 3), f_damp, & sigma_ij, T0(3, 3), beta_R_vdw integer :: i_atom, j_atom, i_cell, n(3), range_n(3), i, j, & n_atoms, my_i_atom, my_j_atom, i_latt, my_nr, my_nc logical :: do_ewald, is_periodic type(grad_matrix_re_t) :: dT, dT0, dTew type(grad_scalar_t) :: df type(grad_request_t) :: grad_ij #ifndef DO_COMPLEX_TYPE real(dp) :: Tij(3, 3) type(grad_matrix_re_t) :: dTij #else complex(dp) :: Tij(3, 3), exp_qR type(grad_matrix_cplx_t) :: dTij #endif do_ewald = .false. is_periodic = allocated(geom%lattice) n_atoms = geom%siz() if (present(grad)) then grad_ij = grad grad_ij%dcoords = grad%dcoords .or. grad%dlattice end if #ifdef WITH_SCALAPACK call dipmat%init(geom%idx, geom%blacs) #else call dipmat%init(geom%idx) #endif if (is_periodic) then do_ewald = geom%gamm > 0d0 range_n = supercell_circum(geom%lattice, geom%real_space_cutoff) else range_n(:) = 0 end if if (grad_ij%dcoords) allocate (dTij%dr(3, 3, 3)) my_nr = size(dipmat%idx%i_atom) my_nc = size(dipmat%idx%j_atom) allocate (dipmat%val(3 * my_nr, 3 * my_nc), source=ZERO) if (present(grad)) then if (grad%dcoords) allocate (ddipmat%dr(3 * my_nr, 3 * my_nc, 3), source=ZERO) if (grad%dlattice) then allocate (ddipmat%dlattice(3 * my_nr, 3 * my_nc, 3, 3), source=ZERO) end if if (grad%dr_vdw) then allocate (ddipmat%dvdw(3 * my_nr, 3 * my_nc), source=ZERO) allocate (dTij%dvdw(3, 3)) end if if (grad%dsigma) then allocate (ddipmat%dsigma(3 * my_nr, 3 * my_nc), source=ZERO) allocate (dTij%dsigma(3, 3)) end if #ifdef DO_COMPLEX_TYPE if (grad%dq) then allocate (ddipmat%dq(3 * my_nr, 3 * my_nc, 3), source=ZERO) allocate (dTij%dq(3, 3, 3)) end if #endif end if call geom%clock(11) n = [0, 0, -1] each_cell: do i_cell = 1, product(1 + 2 * range_n) call shift_idx(n, -range_n, range_n) if (is_periodic) then Rn = matmul(geom%lattice, n) else Rn(:) = 0d0 end if each_atom: do my_i_atom = 1, size(dipmat%idx%i_atom) i_atom = dipmat%idx%i_atom(my_i_atom) each_atom_pair: do my_j_atom = 1, size(dipmat%idx%j_atom) j_atom = dipmat%idx%j_atom(my_j_atom) if (i_cell == 1) then if (i_atom == j_atom) cycle end if Rnij = geom%coords(:, i_atom) - geom%coords(:, j_atom) - Rn Rnij_norm = sqrt(sum(Rnij**2)) if (is_periodic .and. Rnij_norm > geom%real_space_cutoff) cycle if (allocated(damp%R_vdw)) then beta_R_vdw = damp%beta * sum(damp%R_vdw([i_atom, j_atom])) end if if (allocated(damp%sigma)) then sigma_ij = damp%mayer_scaling & * sqrt(sum(damp%sigma([i_atom, j_atom])**2)) end if select case (damp%version) case ("bare") T = T_bare(Rnij, dT, grad_ij%dcoords) case ("dip,1mexp") T = T_1mexp_coulomb(Rnij, beta_R_vdw, damp%a) case ("fermi,dip") f_damp = damping_fermi(Rnij, beta_R_vdw, damp%a, df, grad_ij) T0 = T_bare(Rnij, dT0, grad_ij%dcoords) T = damping_grad(f_damp, df, T0, dT0, dT, grad_ij) case ("sqrtfermi,dip") T = damping_sqrtfermi(Rnij, beta_R_vdw, damp%a) * T_bare(Rnij) case ("custom,dip") T = damp%damping_custom(i_atom, j_atom) * T_bare(Rnij) case ("dip,custom") T = damp%potential_custom(:, :, i_atom, j_atom) case ("dip,gg") T = T_erf_coulomb(Rnij, sigma_ij, dT, grad_ij) case ("fermi,dip,gg") f_damp = damping_fermi(Rnij, beta_R_vdw, damp%a, df, grad_ij) call op1minus_grad(f_damp, df) T0 = T_erf_coulomb(Rnij, sigma_ij, dT0, grad_ij) T = damping_grad(f_damp, df, T0, dT0, dT, grad_ij) do_ewald = .false. case ("sqrtfermi,dip,gg") T = (1d0 - damping_sqrtfermi(Rnij, beta_R_vdw, damp%a)) * & T_erf_coulomb(Rnij, sigma_ij) do_ewald = .false. case ("custom,dip,gg") T = (1d0 - damp%damping_custom(i_atom, j_atom)) * & T_erf_coulomb(Rnij, sigma_ij) do_ewald = .false. end select if (grad_ij%dr_vdw) dT%dvdw = damp%beta * dT%dvdw if (do_ewald) then T = T & + T_erfc(Rnij, geom%gamm, dTew, grad_ij) & - T_bare(Rnij, dT0, grad_ij%dcoords) if (grad_ij%dcoords) dT%dr = dT%dr + dTew%dr - dT0%dr end if Tij = T if (grad_ij%dcoords) dTij%dr = dT%dr if (grad_ij%dr_vdw) dTij%dvdw = dT%dvdw if (grad_ij%dsigma) dTij%dsigma = dT%dsigma #ifdef DO_COMPLEX_TYPE exp_qR = exp(-IMI * (dot_product(q, Rnij))) Tij = T * exp_qR if (grad_ij%dcoords) then #ifndef WITHOUT_DO_CONCURRENT do concurrent(i=1:3) #else do i = 1, 3 #endif dTij%dr(:, :, i) = dT%dr(:, :, i) * exp_qR - IMI * q(i) * Tij end do end if if (grad_ij%dsigma) dTij%dsigma = dT%dsigma * exp_qR if (grad_ij%dr_vdw) dTij%dvdw = dT%dvdw * exp_qR if (grad_ij%dq) then do concurrent(i=1:3) dTij%dq(:, :, i) = -IMI * Rnij(i) * Tij end do end if #endif i = 3 * (my_i_atom - 1) j = 3 * (my_j_atom - 1) associate (T_sub => dipmat%val(i + 1:i + 3, j + 1:j + 3)) T_sub = T_sub + Tij end associate if (.not. present(grad)) cycle if (grad%dcoords .and. i_atom /= j_atom) then associate (dTdR_sub => ddipmat%dr(i + 1:i + 3, j + 1:j + 3, :)) dTdR_sub = dTdR_sub + dTij%dr end associate end if if (grad%dlattice) then do i_latt = 1, 3 associate ( & dTda_sub => ddipmat%dlattice(i + 1:i + 3, j + 1:j + 3, i_latt, :) & ) dTda_sub = dTda_sub - dTij%dr * (n(i_latt)) end associate end do end if if (grad%dr_vdw) then associate (dTdRvdw_sub => ddipmat%dvdw(i + 1:i + 3, j + 1:j + 3)) dTdRvdw_sub = dTdRvdw_sub + dTij%dvdw end associate end if if (grad%dsigma) then associate (dTdsigma_sub => ddipmat%dsigma(i + 1:i + 3, j + 1:j + 3)) dTdsigma_sub = dTdsigma_sub + dTij%dsigma end associate end if #ifdef DO_COMPLEX_TYPE if (grad%dq) then associate (dTdq_sub => ddipmat%dq(i + 1:i + 3, j + 1:j + 3, :)) dTdq_sub = dTdq_sub + dTij%dq end associate end if #endif end do each_atom_pair end do each_atom end do each_cell call geom%clock(-11) if (do_ewald) then #ifndef DO_COMPLEX_TYPE call add_ewald_dipole_parts_real(geom, dipmat, ddipmat, grad) #else call add_ewald_dipole_parts_complex(geom, dipmat, ddipmat, grad, q) #endif end if end function #ifndef DO_COMPLEX_TYPE subroutine add_ewald_dipole_parts_real(geom, dipmat, ddipmat, grad) type(matrix_re_t), intent(inout) :: dipmat type(grad_matrix_re_t), intent(inout), optional :: ddipmat #else subroutine add_ewald_dipole_parts_complex(geom, dipmat, ddipmat, grad, q) type(matrix_cplx_t), intent(inout) :: dipmat type(grad_matrix_cplx_t), intent(inout), optional :: ddipmat #endif type(geom_t), intent(inout) :: geom type(grad_request_t), intent(in), optional :: grad #ifdef DO_COMPLEX_TYPE real(dp), intent(in) :: q(3) #endif logical :: do_surface real(dp) :: rec_latt(3, 3), volume, G(3), Rij(3), k(3), & k_sq, G_Rij, latt_inv(3, 3), & dGdA(3), dk_sqdA, dkk_dA(3, 3), vol_prefactor, & k_otimes_k(3, 3), exp_k_sq_gamma, vol_kk_exp_ksq(3, 3) integer :: & i_atom, j_atom, i, j, i_xyz, m(3), i_m, & range_m(3), my_i_atom, my_j_atom, i_latt, a, b #ifndef DO_COMPLEX_TYPE real(dp) :: Tij(3, 3), exp_GR, vol_exp #else complex(dp) :: Tij(3, 3), exp_GR, vol_exp integer :: c real(dp) :: dkk_dq(3, 3, 3) #endif latt_inv = inverse(geom%lattice) rec_latt = 2 * pi * transpose(latt_inv) volume = abs(dble(product(eigvals(geom%lattice)))) vol_prefactor = 4 * pi / volume range_m = supercell_circum(rec_latt, geom%rec_space_cutoff) call geom%clock(12) m = [0, 0, -1] each_recip_vec: do i_m = 1, product(1 + 2 * range_m) call shift_idx(m, -range_m, range_m) G = matmul(rec_latt, m) #ifdef DO_COMPLEX_TYPE k = G + q #else k = G #endif k_sq = sum(k**2) if (sqrt(k_sq) > geom%rec_space_cutoff .or. sqrt(k_sq) < 1d-15) cycle exp_k_sq_gamma = exp(-k_sq / (4 * geom%gamm**2)) do concurrent(a=1:3, b=1:3) k_otimes_k(a, b) = k(a) * k(b) / k_sq end do each_atom: do my_i_atom = 1, size(dipmat%idx%i_atom) i_atom = dipmat%idx%i_atom(my_i_atom) each_atom_pair: do my_j_atom = 1, size(dipmat%idx%j_atom) j_atom = dipmat%idx%j_atom(my_j_atom) Rij = geom%coords(:, i_atom) - geom%coords(:, j_atom) G_Rij = dot_product(G, Rij) #ifdef DO_COMPLEX_TYPE exp_GR = exp(IMI * G_Rij) #else exp_GR = cos(G_Rij) #endif vol_kk_exp_ksq = vol_prefactor * k_otimes_k * exp_k_sq_gamma Tij = vol_kk_exp_ksq * exp_GR i = 3 * (my_i_atom - 1) j = 3 * (my_j_atom - 1) associate (T_sub => dipmat%val(i + 1:i + 3, j + 1:j + 3)) T_sub = T_sub + Tij end associate if (.not. present(grad)) cycle vol_exp = vol_prefactor * exp_k_sq_gamma * exp_GR if (grad%dcoords .and. i_atom /= j_atom) then associate (dTdR_sub => ddipmat%dr(i + 1:i + 3, j + 1:j + 3, :)) ! TODO should be do-concurrent, but this crashes IBM XL ! 16.1.1, see issue #16 do i_xyz = 1, 3 dTdR_sub(:, :, i_xyz) = dTdR_sub(:, :, i_xyz) & #ifdef DO_COMPLEX_TYPE + Tij * IMI * G(i_xyz) #else -vol_kk_exp_ksq * sin(G_Rij) * G(i_xyz) #endif end do end associate end if if (grad%dlattice) then do i_latt = 1, 3 do i_xyz = 1, 3 dGdA = -latt_inv(i_latt, :) * G(i_xyz) dk_sqdA = 2 * dot_product(k, dGdA) do concurrent(a=1:3, b=1:3) dkk_dA(a, b) = k(a) * dGdA(b) / k_sq & - k(a) * k(b) * dk_sqdA / (2 * k_sq**2) end do dkk_dA = dkk_dA + transpose(dkk_dA) ! Using associate here was causing weird seg faults ! with some Intel compilers, reporting i_xyz being ! zero in the index, even though it printed as 1 ! associate ( & ! dTda_sub => ddipmat%dlattice(i+1:i+3, j+1:j+3, i_latt, i_xyz) & ! ) ddipmat%dlattice(i + 1:i + 3, j + 1:j + 3, i_latt, i_xyz) = & ddipmat%dlattice(i + 1:i + 3, j + 1:j + 3, i_latt, i_xyz) & - Tij * latt_inv(i_latt, i_xyz) & + vol_exp * dkk_dA & - Tij * dk_sqdA / (4 * geom%gamm**2) & #ifdef DO_COMPLEX_TYPE + Tij * IMI * dot_product(dGdA, Rij) #else -vol_kk_exp_ksq * sin(G_Rij) * dot_product(dGdA, Rij) #endif ! end associate end do end do end if #ifdef DO_COMPLEX_TYPE if (grad%dq) then do concurrent(a=1:3, b=1:3, c=1:3) dkk_dq(a, b, c) = -2 * k(a) * k(b) * k(c) / k_sq**2 end do do concurrent(a=1:3, b=1:3) dkk_dq(b, a, a) = dkk_dq(b, a, a) + k(b) / k_sq end do do concurrent(a=1:3, b=1:3) dkk_dq(a, b, a) = dkk_dq(a, b, a) + k(b) / k_sq end do associate (dTdq_sub => ddipmat%dq(i + 1:i + 3, j + 1:j + 3, :)) dTdq_sub = dTdq_sub + vol_exp * dkk_dq ! TODO should be do-concurrent, but this crashes IBM XL ! 16.1.1, see issue #16 do a = 1, 3 dTdq_sub(:, :, a) = dTdq_sub(:, :, a) & - Tij * k(a) / (2 * geom%gamm**2) end do end associate end if #endif end do each_atom_pair end do each_atom end do each_recip_vec ! self energy call dipmat%add_diag_scalar(-4 * geom%gamm**3 / (3 * sqrt(pi))) ! surface term #ifdef DO_COMPLEX_TYPE do_surface = sqrt(sum(q**2)) < 1d-15 #else do_surface = .true. #endif if (do_surface) then do my_i_atom = 1, size(dipmat%idx%i_atom) do my_j_atom = 1, size(dipmat%idx%j_atom) do i_xyz = 1, 3 i = 3 * (my_i_atom - 1) + i_xyz j = 3 * (my_j_atom - 1) + i_xyz dipmat%val(i, j) = dipmat%val(i, j) + vol_prefactor / 3 if (.not. present(grad)) cycle if (grad%dlattice) then ddipmat%dlattice(i, j, :, :) = ddipmat%dlattice(i, j, :, :) & - vol_prefactor / 3 * latt_inv end if end do end do end do end if call geom%clock(-12) end subroutine #ifndef DO_COMPLEX_TYPE # define DO_COMPLEX_TYPE # include "mbd_dipole.F90" function T_bare(r, dT, grad) result(T) !! $$ !! T_{ab}(\mathbf r)=\frac{\partial^2}{\partial r_a\partial r_b}\frac1r= !! \frac{-3r_ar_b+r^2\delta_{ab}}{r^5},\qquad !! \frac{\partial T_{ab}(\mathbf r)}{\partial r_c}=-3\left( !! \frac{r_a\delta_{bc}+r_b\delta_{ca}+r_c\delta_{ab}}{r^5}- !! \frac{5r_ar_br_c}{r^7} !! \right) !! $$ real(dp), intent(in) :: r(3) type(grad_matrix_re_t), intent(out), optional :: dT logical, intent(in), optional :: grad real(dp) :: T(3, 3) integer :: a, b, c real(dp) :: r_1, r_2, r_5, r_7 r_2 = sum(r**2) r_1 = sqrt(r_2) r_5 = r_1**5 do concurrent(a=1:3) T(a, a) = (-3 * r(a)**2 + r_2) / r_5 do concurrent(b=a + 1:3) T(a, b) = -3 * r(a) * r(b) / r_5 T(b, a) = T(a, b) end do end do if (.not. present(grad)) return if (.not. grad) return allocate (dT%dr(3, 3, 3)) r_7 = r_1**7 do concurrent(a=1:3) dT%dr(a, a, a) = -3 * (3 * r(a) / r_5 - 5 * r(a)**3 / r_7) do concurrent(b=a + 1:3) dT%dr(a, a, b) = -3 * (r(b) / r_5 - 5 * r(a)**2 * r(b) / r_7) dT%dr(a, b, a) = dT%dr(a, a, b) dT%dr(b, a, a) = dT%dr(a, a, b) dT%dr(b, b, a) = -3 * (r(a) / r_5 - 5 * r(b)**2 * r(a) / r_7) dT%dr(b, a, b) = dT%dr(b, b, a) dT%dr(a, b, b) = dT%dr(b, b, a) do concurrent(c=b + 1:3) dT%dr(a, b, c) = 15 * r(a) * r(b) * r(c) / r_7 dT%dr(a, c, b) = dT%dr(a, b, c) dT%dr(b, a, c) = dT%dr(a, b, c) dT%dr(b, c, a) = dT%dr(a, b, c) dT%dr(c, a, b) = dT%dr(a, b, c) dT%dr(c, b, a) = dT%dr(a, b, c) end do end do end do end function real(dp) function B_erfc(r, gamm, dB, grad) result(B) !! $$ !! \begin{aligned} !! B(R,\gamma) !! &=\operatorname{erfc}(\gamma R) !! +\frac{2\gamma R}{\sqrt\pi}\mathrm e^{-(\gamma R)^2} !! \\ \partial B(R,\gamma) !! &=-\frac4{\sqrt\pi}(\gamma R)^2\mathrm e^{-(\gamma R)^2} !! (R\partial\gamma+\gamma\partial R) !! \end{aligned} !! $$ real(dp), intent(in) :: r real(dp), intent(in) :: gamm type(grad_scalar_t), intent(out), optional :: dB type(grad_request_t), intent(in), optional :: grad real(dp) :: tmp, gamma_r_sq gamma_r_sq = (gamm * r)**2 B = (erfc(gamm * r) + (2 * gamm * r / sqrt(pi)) * exp(-gamma_r_sq)) if (.not. present(grad)) return tmp = -4d0 / sqrt(pi) * gamma_r_sq * exp(-gamma_r_sq) if (grad%dcoords) dB%dr_1 = tmp * gamm if (grad%dgamma) dB%dgamma = tmp * r end function real(dp) function C_erfc(r, gamm, dC, grad) result(C) !! $$ !! \begin{aligned} !! C(r,\gamma) !! &=3\operatorname{erfc}(\gamma R) !! +\frac{2\gamma R}{\sqrt\pi}(3+2(\gamma R)^2)\mathrm e^{-(\gamma R)^2} !! \\ \partial C(R,\gamma) !! &=-\frac8{\sqrt\pi}(\gamma R)^4\mathrm e^{-(\gamma R)^2} !! (R\partial\gamma+\gamma\partial R) !! \end{aligned} !! $$ real(dp), intent(in) :: r real(dp), intent(in) :: gamm type(grad_scalar_t), intent(out), optional :: dC type(grad_request_t), intent(in), optional :: grad real(dp) :: tmp, gamma_r_sq gamma_r_sq = (gamm * r)**2 C = (3 * erfc(gamm * r) + (2 * gamm * r / sqrt(pi)) * (3d0 + 2 * gamma_r_sq) * exp(-gamma_r_sq)) if (.not. present(grad)) return tmp = -8d0 / sqrt(pi) * gamma_r_sq**2 * exp(-gamma_r_sq) if (grad%dcoords) dC%dr_1 = tmp * gamm if (grad%dgamma) dC%dgamma = tmp * r end function function T_erfc(r, gamm, dT, grad) result(T) !! $$ !! T_{ab}^\text{erfc}(\mathbf r,\gamma) !! =-3\frac{r_ar_b}{r^5}C(r,\gamma)+\frac{\delta_{ab}}{r^3}B(r,\gamma) !! $$ !! !! $$ !! \begin{aligned} !! \frac{\partial T_{ab}^\text{erfc}(\mathbf r,\gamma)}{\partial r_c} !! &=-\left( !! \frac{r_a\delta_{bc}+r_b\delta_{ca}}{r^5}- !! 5\frac{r_ar_br_c}{r^7} !! \right)C(r,\gamma)-3\frac{r_c\delta_{ab}}{r^5}B(r,\gamma) !! \\ &-\frac{r_ar_br_c}{r^6}\frac{\partial C(r,\gamma)}{\partial !! r}+\frac{r_c\delta_{ab}}{r^4}\frac{\partial B(r,\gamma)}{\partial r} !! \end{aligned} !! $$ real(dp), intent(in) :: r(3) real(dp), intent(in) :: gamm type(grad_matrix_re_t), intent(out), optional :: dT type(grad_request_t), intent(in), optional :: grad real(dp) :: T(3, 3) integer :: a, b, c real(dp) :: r_1, r_2, r_3, r_4, r_5, r_6, r_7, B_ew, C_ew type(grad_scalar_t) :: dB, dC r_2 = sum(r**2) r_1 = sqrt(r_2) r_3 = r_1 * r_2 r_5 = r_3 * r_2 B_ew = B_erfc(r_1, gamm, dB, grad) C_ew = C_erfc(r_1, gamm, dC, grad) do concurrent(a=1:3) T(a, a) = -C_ew * r(a)**2 / r_5 + B_ew / r_3 do concurrent(b=a + 1:3) T(a, b) = -C_ew * r(a) * r(b) / r_5 T(b, a) = T(a, b) end do end do if (.not. present(grad)) return if (grad%dcoords) then allocate (dT%dr(3, 3, 3)) r_7 = r_1**7 r_4 = r_2**2 r_6 = r_4 * r_2 #ifndef WITHOUT_DO_CONCURRENT do concurrent(c=1:3) #else do c = 1, 3 #endif dT%dr(c, c, c) = & -(2 * r(c) / r_5 - 5 * r(c)**3 / r_7) * C_ew - 3 * r(c) / r_5 * B_ew & - r(c)**3 / r_6 * dC%dr_1 + r(c) / r_4 * dB%dr_1 #ifndef WITHOUT_DO_CONCURRENT do concurrent(a=1:3, a /= c) #else do a = 1, 3 if (a == c) cycle #endif dT%dr(a, c, c) = & -(r(a) / r_5 - 5 * r(a) * r(c)**2 / r_7) * C_ew & - r(a) * r(c)**2 / r_6 * dC%dr_1 dT%dr(c, a, c) = dT%dr(a, c, c) dT%dr(a, a, c) = & 5 * r(a)**2 * r(c) / r_7 * C_ew - 3 * r(c) / r_5 * B_ew & - r(a)**2 * r(c) / r_6 * dC%dr_1 + r(c) / r_4 * dB%dr_1 #ifndef WITHOUT_DO_CONCURRENT do concurrent(b=a + 1:3, b /= c) #else do b = a + 1, 3 if (b == c) cycle #endif dT%dr(a, b, c) = & 5 * r(a) * r(b) * r(c) / r_7 * C_ew - r(a) * r(b) * r(c) / r_6 * dC%dr_1 dT%dr(b, a, c) = dT%dr(a, b, c) end do end do end do end if if (grad%dgamma) then allocate (dT%dgamma(3, 3)) do concurrent(a=1:3) dT%dgamma(a, a) = -dC%dgamma * r(a)**2 / r_5 + dB%dgamma / r_3 do concurrent(b=a + 1:3) dT%dgamma(a, b) = -dC%dgamma * r(a) * r(b) / r_5 dT%dgamma(b, a) = dT%dgamma(a, b) end do end do end if end function function T_erf_coulomb(r, sigma, dT, grad) result(T) !! $$ !! \begin{aligned} !! T^\text{GG}_{ab}(\mathbf r,\sigma)&= !! \frac{\partial^2}{\partial r_a\partial r_b}\frac{\operatorname{erf}(\zeta)}r= !! \big(\operatorname{erf}(\zeta)-\Theta(\zeta)\big)T_{ab}(\mathbf r)+ !! 2\zeta^2\Theta(\zeta)\frac{r_ar_b}{r^5} !! \\ \Theta(\zeta)&=\frac{2\zeta}{\sqrt\pi}\exp(-\zeta^2),\qquad !! \zeta=\frac r\sigma !! \\ \frac{\mathrm d T_{ab}^\text{GG}(\mathbf r,\sigma)}{\mathrm dr_c}&= !! 2\zeta\Theta(\zeta)\left(T_{ab}(\mathbf r)+(3-2\zeta^2)\frac{r_ar_b}{r^5}\right) !! \frac{\mathrm d\zeta}{\mathrm dr_c} !! \\ &+\big(\operatorname{erf}(\zeta)-\Theta(\zeta)\big) !! \frac{\partial T_{ab}(\mathbf r)}{\partial r_c}- !! 2\zeta^2\Theta(\zeta)\left( !! \frac13\frac{\partial T_{ab}(\mathbf r)}{\partial r_c}+ !! \frac{r_c\delta_{ab}}{r^5} !! \right) !! \\ \qquad\frac{\mathrm d\zeta}{\mathrm dr_c}&= !! \frac{r_c}{r\sigma}-\frac r{\sigma^2}\frac{\mathrm d\sigma}{\mathrm dr_c} !! \end{aligned} !! $$ real(dp), intent(in) :: r(3) real(dp), intent(in) :: sigma type(grad_matrix_re_t), intent(out), optional :: dT type(grad_request_t), intent(in), optional :: grad real(dp) :: T(3, 3) real(dp) :: theta, erf_theta, r_5, r_1, zeta, bare(3, 3) type(grad_matrix_re_t) :: dbare real(dp) :: tmp33(3, 3), tmp333(3, 3, 3), rr_r5(3, 3) integer :: a, c bare = T_bare(r, dbare, grad%dcoords) r_1 = sqrt(sum(r**2)) r_5 = r_1**5 rr_r5 = outer(r, r) / r_5 zeta = r_1 / sigma theta = 2 * zeta / sqrt(pi) * exp(-zeta**2) erf_theta = erf(zeta) - theta T = erf_theta * bare + 2 * (zeta**2) * theta * rr_r5 if (.not. present(grad)) return tmp33 = 2 * zeta * theta * (bare + (3 - 2 * zeta**2) * rr_r5) if (grad%dcoords) then allocate (dT%dr(3, 3, 3)) do concurrent(c=1:3) dT%dr(:, :, c) = tmp33 * r(c) / (r_1 * sigma) end do tmp333 = dbare%dr / 3 do concurrent(a=1:3, c=1:3) tmp333(a, a, c) = tmp333(a, a, c) + r(c) / r_5 end do dT%dr = dT%dr + erf_theta * dbare%dr - 2 * (zeta**2) * theta * tmp333 end if if (grad%dsigma) dT%dsigma = -tmp33 * r_1 / sigma**2 end function function T_1mexp_coulomb(rxyz, sigma, a) result(T) real(dp), intent(in) :: rxyz(3), sigma, a real(dp) :: T(3, 3) real(dp) :: r_sigma, zeta_1, zeta_2 r_sigma = (sqrt(sum(rxyz**2)) / sigma)**a zeta_1 = 1d0 - exp(-r_sigma) - a * r_sigma * exp(-r_sigma) zeta_2 = -r_sigma * a * exp(-r_sigma) * (1 + a * (-1 + r_sigma)) T = zeta_1 * T_bare(rxyz) - zeta_2 * outer(rxyz, rxyz) / sqrt(sum(rxyz**2))**5 end function function damping_grad(f, df, T, dT, dfT, grad) result(fT) real(dp), intent(in) :: f type(grad_scalar_t), intent(in) :: df real(dp), intent(in) :: T(3, 3) type(grad_matrix_re_t), intent(in) :: dT type(grad_matrix_re_t), intent(out) :: dfT type(grad_request_t), intent(in) :: grad real(dp) :: fT(3, 3) integer :: c fT = f * T if (grad%dcoords) then allocate (dfT%dr(3, 3, 3), source=0d0) if (allocated(df%dr)) then do concurrent(c=1:3) dfT%dr(:, :, c) = df%dr(c) * T end do end if if (allocated(dT%dr)) dfT%dr = dfT%dr + f * dT%dr end if if (grad%dr_vdw) then allocate (dfT%dvdw(3, 3), source=0d0) if (allocated(df%dvdw)) dfT%dvdw = df%dvdw * T if (allocated(dT%dvdw)) dfT%dvdw = dfT%dvdw + f * dT%dvdw end if if (grad%dsigma) dfT%dsigma = f * dT%dsigma end function end module #endif libmbd-libmbd-88d61bc/src/mbd_elsi.F90000066400000000000000000000057771452573331700174720ustar00rootroot00000000000000! This Source Code Form is subject to the terms of the Mozilla Public ! License, v. 2.0. If a copy of the MPL was not distributed with this ! file, You can obtain one at http://mozilla.org/MPL/2.0/. #ifndef DO_COMPLEX_TYPE module mbd_elsi use elsi, only: elsi_handle, elsi_init, elsi_set_mpi, elsi_set_blacs, & elsi_set_unit_ovlp, elsi_finalize, elsi_ev_real, elsi_ev_complex use mbd_constants use mbd_blacs, only: blacs_desc_t use mbd_utils, only: exception_t, is_true implicit none private public :: elsi_eigh, elsi_eigvalsh interface elsi_eigh module procedure elsi_eigh_real module procedure elsi_eigh_complex end interface interface elsi_eigvalsh module procedure elsi_eigvalsh_real module procedure elsi_eigvalsh_complex end interface contains #endif #ifndef DO_COMPLEX_TYPE subroutine elsi_eigh_real(A, blacs_desc, eigs, exc, src, vals_only) real(dp), intent(inout) :: A(:, :) real(dp), intent(in), optional :: src(:, :) #else subroutine elsi_eigh_complex(A, blacs_desc, eigs, exc, src, vals_only) complex(dp), intent(inout) :: A(:, :) complex(dp), intent(in), optional :: src(:, :) #endif type(blacs_desc_t), intent(in) :: blacs_desc real(dp), intent(out) :: eigs(:) type(exception_t), intent(out), optional :: exc logical, intent(in), optional :: vals_only integer :: n_vecs, n type(elsi_handle) :: handle #ifndef DO_COMPLEX_TYPE real(dp) :: DUMMY_MATRIX(1, 1) real(dp), allocatable :: vecs(:, :) #else complex(dp) :: DUMMY_MATRIX(1, 1) complex(dp), allocatable :: vecs(:, :) #endif n = 3 * blacs_desc%n_atoms if (present(src)) A = src if (is_true(vals_only)) then n_vecs = 0 else n_vecs = n end if call elsi_init(handle, 1, 1, 0, n, 0d0, n_vecs) call elsi_set_mpi(handle, blacs_desc%comm) call elsi_set_blacs(handle, blacs_desc%ctx, blacs_desc%blocksize) call elsi_set_unit_ovlp(handle, 1) allocate (vecs(size(A, 1), size(A, 2))) #ifndef DO_COMPLEX_TYPE call elsi_ev_real(handle, A, DUMMY_MATRIX, eigs, vecs) #else call elsi_ev_complex(handle, A, DUMMY_MATRIX, eigs, vecs) #endif A = vecs call elsi_finalize(handle) end subroutine #ifndef DO_COMPLEX_TYPE function elsi_eigvalsh_real(A, blacs_desc, exc, destroy) result(eigs) real(dp), allocatable, intent(inout) :: A(:, :) #else function elsi_eigvalsh_complex(A, blacs_desc, exc, destroy) result(eigs) complex(dp), allocatable, intent(inout) :: A(:, :) #endif type(blacs_desc_t), intent(in) :: blacs_desc type(exception_t), intent(out), optional :: exc logical, intent(in), optional :: destroy real(dp) :: eigs(3 * blacs_desc%n_atoms) #ifndef DO_COMPLEX_TYPE real(dp), allocatable :: A_(:, :) #else complex(dp), allocatable :: A_(:, :) #endif if (is_true(destroy)) then call move_alloc(A, A_) else A_ = A end if call elsi_eigh(A_, blacs_desc, eigs, exc, vals_only=.true.) end function #ifndef DO_COMPLEX_TYPE # define DO_COMPLEX_TYPE # include "mbd_elsi.F90" end module #endif libmbd-libmbd-88d61bc/src/mbd_formulas.f90000066400000000000000000000113311452573331700204050ustar00rootroot00000000000000! This Source Code Form is subject to the terms of the Mozilla Public ! License, v. 2.0. If a copy of the MPL was not distributed with this ! file, You can obtain one at http://mozilla.org/MPL/2.0/. module mbd_formulas !! Common formulas used at multiple places. use mbd_constants use mbd_gradients, only: grad_t, grad_request_t use mbd_utils, only: quad_pt_t, tostr implicit none private public :: omega_qho, alpha_dyn_qho, C6_from_alpha, sigma_selfint, scale_with_ratio contains function omega_qho(C6, alpha, domega, grad) result(omega) !! $$ !! \omega=\frac{4C_6}{3\alpha_{0}^2},\qquad !! \partial\omega=\omega\left( !! \frac{\partial C_6}{C_6}-\frac{2\partial\alpha_0}{\alpha_0} !! \right) !! $$ real(dp), intent(in) :: C6(:) real(dp), intent(in) :: alpha(:) type(grad_t), intent(out), optional :: domega type(grad_request_t), intent(in), optional :: grad real(dp) :: omega(size(C6)) omega = 4d0 / 3 * C6 / alpha**2 if (.not. present(grad)) return if (grad%dC6) domega%dC6 = omega / C6 if (grad%dalpha) domega%dalpha = -2 * omega / alpha end function function alpha_dyn_qho(alpha_0, omega, freq, dalpha, grad) result(alpha) !! $$ !! \alpha(\mathrm iu)=\frac{\alpha_0}{1+u^2/\omega^2},\qquad !! \partial\alpha(\mathrm iu)=\alpha(\mathrm iu)\left( !! \frac{\partial\alpha_0}{\alpha_0}+ !! \frac2\omega\frac{\partial\omega}{1+\omega^2/u^2} !! \right) !! $$ real(dp), intent(in) :: alpha_0(:) real(dp), intent(in) :: omega(:) type(quad_pt_t), intent(in) :: freq(0:) type(grad_t), allocatable, intent(out) :: dalpha(:) type(grad_request_t), intent(in) :: grad real(dp) :: alpha(size(alpha_0), 0:ubound(freq, 1)) integer :: i_freq, n_atoms n_atoms = size(alpha_0) allocate (dalpha(0:ubound(alpha, 2))) do i_freq = 0, ubound(alpha, 2) associate (alpha => alpha(:, i_freq), u => freq(i_freq)%val) alpha = alpha_0 / (1 + (u / omega)**2) if (grad%dalpha) dalpha(i_freq)%dalpha = alpha / alpha_0 if (grad%domega) then if (u <= 0d0) then allocate (dalpha(i_freq)%domega(size(omega)), source=0d0) else dalpha(i_freq)%domega = alpha * 2d0 / omega / (1d0 + (omega / u)**2) end if end if end associate end do end function function C6_from_alpha(alpha, freq, dC6_dalpha, grad) result(C6) !! $$ !! \bar C_6=\frac3\pi\int_0^\infty\mathrm du\,\bar\alpha(u)^2,\qquad !! \partial\bar C_6=\frac6\pi\int_0^\infty\mathrm du !! \bar\alpha(u)\partial\bar\alpha(u) !! $$ real(dp), intent(in) :: alpha(:, 0:) type(quad_pt_t), intent(in) :: freq(0:) real(dp), allocatable, intent(out), optional :: dC6_dalpha(:, :) logical, intent(in), optional :: grad real(dp) :: C6(size(alpha, 1)) integer :: i_freq, n_atoms n_atoms = size(alpha, 1) C6 = 0d0 do i_freq = 0, ubound(alpha, 2) C6 = C6 + 3d0 / pi * alpha(:, i_freq)**2 * freq(i_freq)%weight end do if (.not. present(grad)) return if (.not. grad) return allocate (dC6_dalpha(n_atoms, 0:ubound(alpha, 2)), source=0d0) do i_freq = 0, ubound(alpha, 2) dC6_dalpha(:, i_freq) = dC6_dalpha(:, i_freq) + 6d0 / pi * alpha(:, i_freq) end do end function function sigma_selfint(alpha, dsigma_dalpha, grad) result(sigma) !! $$ !! \begin{gathered} !! \sigma_i(u)=\left(\frac13\sqrt{\frac2\pi}\alpha_i(u)\right)^{\frac13},\qquad !! \partial\sigma_i=\sigma_i\frac{\partial\alpha_i}{3\alpha_i} !! \\ \sigma_{ij}(u)=\sqrt{\sigma_i(u)^2+\sigma_j(u)^2},\qquad !! \partial\sigma_{ij}= !! \frac{\sigma_i\partial\sigma_i+\sigma_j\partial\sigma_j}{\sigma_{ij}} !! \end{gathered} !! $$ real(dp), intent(in) :: alpha(:) real(dp), allocatable, intent(out), optional :: dsigma_dalpha(:) logical, intent(in), optional :: grad real(dp) :: sigma(size(alpha)) sigma = (sqrt(2d0 / pi) * alpha / 3d0)**(1d0 / 3) if (.not. present(grad)) return if (grad) dsigma_dalpha = sigma / (3 * alpha) end function function scale_with_ratio(x, yp, y, q, dx, grad) result(xp) !! $$ !! x'=x\left(\frac{y'}y\right)^q,\qquad !! \partial x'=x\left( !! \frac{\partial x}x+ !! q\frac{\partial y'}{y'}- !! q\frac{\partial y}{y} !! \right) !! $$ real(dp), intent(in) :: x(:), yp(:), y(:) real(dp), intent(in) :: q type(grad_t), intent(out), optional :: dx type(grad_request_t), intent(in), optional :: grad real(dp) :: xp(size(x)) xp = x * (yp / y)**q if (.not. present(grad)) return if (grad%dX_free) dx%dX_free = xp / x if (grad%dV) dx%dV = xp * q / yp if (grad%dV_free) dx%dV_free = -xp * q / y end function end module libmbd-libmbd-88d61bc/src/mbd_geom.F90000066400000000000000000000264301452573331700174520ustar00rootroot00000000000000! This Source Code Form is subject to the terms of the Mozilla Public ! License, v. 2.0. If a copy of the MPL was not distributed with this ! file, You can obtain one at http://mozilla.org/MPL/2.0/. #ifndef LEGENDRE_PREC #define LEGENDRE_PREC 15 #endif module mbd_geom !! Representing a molecule or a crystal unit cell. use mbd_constants use mbd_defaults use mbd_formulas, only: alpha_dyn_qho, C6_from_alpha, omega_qho use mbd_gradients, only: grad_t, grad_request_t use mbd_lapack, only: eigvals, inverse use mbd_utils, only: & shift_idx, atom_index_t, quad_pt_t, exception_t, tostr, clock_t, printer, & printer_i, logger_t use mbd_vdw_param, only: ts_vdw_params #ifdef WITH_SCALAPACK use mbd_blacs, only: blacs_desc_t, blacs_grid_t #endif #ifdef WITH_MPI use mbd_mpi #endif implicit none private public :: supercell_circum, get_freq_grid type, public :: param_t !! Calculation-wide paramters. real(dp) :: dipole_cutoff = 400d0 * ang ! used only when Ewald is off real(dp) :: ewald_real_cutoff_scaling = 1d0 real(dp) :: ewald_rec_cutoff_scaling = 1d0 real(dp) :: k_grid_shift = K_GRID_SHIFT logical :: ewald_on = .true. logical :: zero_negative_eigvals = .false. logical :: rpa_rescale_eigs = .false. integer :: rpa_order_max = 10 integer :: n_freq = N_FREQUENCY_GRID end type type, public :: geom_t !! Represents a molecule or a crystal unit cell. !! !! The documented variables should be set before calling the initializer. real(dp), allocatable :: coords(:, :) !! (\(3\times N\), a.u.) Atomic coordinates. real(dp), allocatable :: lattice(:, :) !! (\(3\times 3\), a.u.) Lattice vectors in columns, unallocated if not !! periodic. integer, allocatable :: k_grid(:) !! Number of \(k\)-points along reciprocal axes. real(dp), allocatable :: custom_k_pts(:, :) !! Custom \(k\)-point grid. character(len=10) :: parallel_mode = 'auto' !! Type of parallelization: !! !! - `atoms`: distribute matrices over all MPI tasks using ScaLAPACK, !! solve eigenproblems sequentialy. !! - `k_points`: parallelize over k-points (each MPI task solves entire !! eigenproblems for its k-points) logical :: get_eigs = .false. !! Whether to keep MBD eigenvalues logical :: get_modes = .false. !! Whether to calculate MBD eigenvectors logical :: do_rpa = .false. !! Whether to calculate MBD energy by frequency integration logical :: get_rpa_orders = .false. !! Whether to calculate RPA orders type(logger_t) :: log !! Used for logging #ifdef WITH_MPI # ifdef WITH_MPIF08 type(MPI_Comm) :: mpi_comm = MPI_COMM_WORLD # else integer :: mpi_comm = MPI_COMM_WORLD # endif !! MPI communicator #endif #ifdef WITH_SCALAPACK integer :: max_atoms_per_block = MAX_ATOMS_PER_BLOCK #endif ! The following components are set by the initializer and should be ! considered read-only type(clock_t) :: timer type(exception_t) :: exc type(quad_pt_t), allocatable :: freq(:) real(dp) :: gamm = 0d0 real(dp) :: real_space_cutoff real(dp) :: rec_space_cutoff type(param_t) :: param type(atom_index_t) :: idx #ifdef WITH_SCALAPACK ! TODO makes these two private (see use in mbd_methods, mbd_dipole) type(blacs_desc_t) :: blacs type(blacs_grid_t) :: blacs_grid #endif #ifdef WITH_MPI integer :: mpi_size = -1 integer :: mpi_rank = -1 #endif contains procedure :: init => geom_init procedure :: destroy => geom_destroy procedure :: siz => geom_siz procedure :: has_exc => geom_has_exc #ifdef WITH_MPI procedure :: sync_exc => geom_sync_exc #endif procedure :: clock => geom_clock end type contains subroutine geom_init(this) class(geom_t), intent(inout) :: this integer :: i_atom real(dp) :: volume, freq_grid_err logical :: is_parallel character(len=10) :: log_level_str #ifdef WITH_MPI logical :: can_parallel_kpts integer :: ierr, n_kpts #endif if (.not. associated(this%log%printer)) this%log%printer => printer call get_environment_variable('LIBMBD_LOG_LEVEL', log_level_str) if (log_level_str /= '') read (log_level_str, *) this%log%level associate (n => this%param%n_freq) allocate (this%freq(0:n)) call get_freq_grid(n, this%freq(1:n)%val, this%freq(1:n)%weight) end associate this%freq(0)%val = 0d0 this%freq(0)%weight = 0d0 freq_grid_err = test_frequency_grid(this%freq) call this%log%info('Frequency grid relative error: '//tostr(freq_grid_err)) call this%timer%init(100) if (allocated(this%lattice)) then volume = abs(dble(product(eigvals(this%lattice)))) if (this%param%ewald_on) then this%gamm = 2.5d0 / volume**(1d0 / 3) this%real_space_cutoff = 6d0 / this%gamm * this%param%ewald_real_cutoff_scaling this%rec_space_cutoff = 10d0 * this%gamm * this%param%ewald_rec_cutoff_scaling else this%real_space_cutoff = this%param%dipole_cutoff end if end if #ifdef WITH_MPI call MPI_COMM_SIZE(this%mpi_comm, this%mpi_size, ierr) call MPI_COMM_RANK(this%mpi_comm, this%mpi_rank, ierr) if (allocated(this%custom_k_pts)) then n_kpts = size(this%custom_k_pts, 2) else if (allocated(this%k_grid)) then n_kpts = product(this%k_grid) else n_kpts = -1 end if can_parallel_kpts = allocated(this%lattice) .and. n_kpts > 0 .and. this%mpi_size > 1 if (this%parallel_mode == 'auto' .and. can_parallel_kpts .and. this%siz()**2 < n_kpts) then this%parallel_mode = 'k_points' end if #endif #ifdef WITH_SCALAPACK this%idx%parallel = .false. if (this%parallel_mode == 'auto' .or. this%parallel_mode == 'atoms') then # ifdef WITH_MPI # ifdef WITH_MPIF08 call this%blacs_grid%init(this%mpi_comm%mpi_val) # else call this%blacs_grid%init(this%mpi_comm) # endif # else call this%blacs_grid%init() # endif call this%blacs%init(this%siz(), this%blacs_grid, this%max_atoms_per_block) if (allocated(this%blacs%i_atom)) then this%parallel_mode = 'atoms' this%idx%parallel = .true. this%idx%i_atom = this%blacs%i_atom this%idx%j_atom = this%blacs%j_atom else call this%blacs_grid%destroy() end if end if #endif #ifdef WITH_MPI if (this%parallel_mode == 'auto' .and. can_parallel_kpts) then this%parallel_mode = 'k_points' end if #endif if (this%parallel_mode == 'auto') this%parallel_mode = 'none' #ifdef WITH_SCALAPACK is_parallel = this%idx%parallel #else is_parallel = .false. #endif if (.not. is_parallel) then this%idx%i_atom = [(i_atom, i_atom=1, this%siz())] this%idx%j_atom = this%idx%i_atom end if this%idx%n_atoms = this%siz() call this%log%info('Will use parallel mode: '//this%parallel_mode) #ifdef WITH_SCALAPACK if (this%idx%parallel) then call this%log%info( & 'BLACS grid: '//trim(tostr(this%blacs_grid%nprows))//' x ' & //trim(tostr(this%blacs_grid%npcols)) & ) call this%log%info('BLACS block size: '//tostr(this%blacs%blocksize)) end if #endif end subroutine subroutine geom_destroy(this) class(geom_t), intent(inout) :: this #ifdef WITH_SCALAPACK if (this%idx%parallel) call this%blacs_grid%destroy() #endif deallocate (this%freq) deallocate (this%timer%timestamps) deallocate (this%timer%counts) end subroutine integer function geom_siz(this) result(siz) class(geom_t), intent(in) :: this if (allocated(this%coords)) then siz = size(this%coords, 2) else siz = 0 end if end function logical function geom_has_exc(this) result(has_exc) class(geom_t), intent(in) :: this has_exc = this%exc%code /= 0 end function #ifdef WITH_MPI subroutine geom_sync_exc(this) class(geom_t), intent(inout) :: this integer, allocatable :: codes(:) integer :: err, rank allocate (codes(this%mpi_size)) call MPI_ALLGATHER(this%exc%code, 1, MPI_INTEGER, codes, 1, MPI_INTEGER, this%mpi_comm, err) do rank = 0, size(codes) - 1 if (codes(rank + 1) /= 0) then call MPI_BCAST(this%exc%code, 1, MPI_INTEGER, rank, this%mpi_comm, err) call MPI_BCAST( & this%exc%msg, len(this%exc%msg), MPI_CHARACTER, rank, this%mpi_comm, err & ) call MPI_BCAST( & this%exc%origin, len(this%exc%origin), MPI_CHARACTER, rank, this%mpi_comm, err & ) exit end if end do end subroutine #endif function supercell_circum(lattice, radius) result(sc) real(dp), intent(in) :: lattice(3, 3) real(dp), intent(in) :: radius integer :: sc(3) real(dp) :: ruc(3, 3), layer_sep(3) integer :: i ruc = 2 * pi * inverse(transpose(lattice)) do concurrent(i=1:3) layer_sep(i) = sum(lattice(:, i) * ruc(:, i) / sqrt(sum(ruc(:, i)**2))) end do sc = ceiling(radius / layer_sep + 0.5d0) end function subroutine geom_clock(this, id) class(geom_t), intent(inout) :: this integer, intent(in) :: id call this%timer%clock(id) end subroutine subroutine get_freq_grid(n, x, w, L) integer, intent(in) :: n real(dp), intent(out) :: x(n), w(n) real(dp), intent(in), optional :: L real(dp) :: L_ if (present(L)) then L_ = L else L_ = 0.6d0 end if call gauss_legendre(n, x, w) w = 2 * L_ / (1 - x)**2 * w x = L_ * (1 + x) / (1 - x) w = w(n:1:-1) x = x(n:1:-1) end subroutine subroutine gauss_legendre(n, r, w) integer, intent(in) :: n real(dp), intent(out) :: r(n), w(n) integer, parameter :: q = selected_real_kind(LEGENDRE_PREC) integer, parameter :: n_iter = 1000 real(q) :: x, f, df, dx integer :: k, iter, i real(q) :: Pk(0:n), Pk1(0:n - 1), Pk2(0:n - 2) if (n == 1) then r(1) = 0d0 w(1) = 2d0 return end if Pk2(0) = 1._q ! k = 0 Pk1(0:1) = [0._q, 1._q] ! k = 1 do k = 2, n Pk(0:k) = ((2 * k - 1)* & [0._q, Pk1(0:k - 1)] - (k - 1)*[Pk2(0:k - 2), 0._q, 0._q]) / k if (k < n) then Pk2(0:k - 1) = Pk1(0:k - 1) Pk1(0:k) = Pk(0:k) end if end do ! now Pk contains k-th Legendre polynomial do i = 1, n x = cos(pi * (i - 0.25_q) / (n + 0.5_q)) do iter = 1, n_iter df = 0._q f = Pk(n) do k = n - 1, 0, -1 df = f + x * df f = Pk(k) + x * f end do dx = f / df x = x - dx if (abs(dx) < 10 * epsilon(dx)) exit end do r(i) = dble(x) w(i) = dble(2 / ((1 - x**2) * df**2)) end do end subroutine real(dp) function test_frequency_grid(freq) result(error) !! Calculate relative quadrature error in C6 of a carbon atom type(quad_pt_t), intent(in) :: freq(0:) real(dp) :: alpha(1, 0:ubound(freq, 1)), C6(1), C6_ref(1), w(1), a0(1) type(grad_t), allocatable :: dalpha(:) type(grad_request_t) :: grad a0(1) = ts_vdw_params(1, 6) C6_ref(1) = ts_vdw_params(2, 6) w = omega_qho(C6_ref, a0) alpha = alpha_dyn_qho(a0, w, freq, dalpha, grad) C6 = C6_from_alpha(alpha, freq) error = abs(C6(1) / C6_ref(1) - 1d0) end function end module libmbd-libmbd-88d61bc/src/mbd_gradients.f90000066400000000000000000000060361452573331700205430ustar00rootroot00000000000000! This Source Code Form is subject to the terms of the Mozilla Public ! License, v. 2.0. If a copy of the MPL was not distributed with this ! file, You can obtain one at http://mozilla.org/MPL/2.0/. module mbd_gradients !! Derivatives. use mbd_constants implicit none private type, public :: grad_t !! Derivatives with respect to various quantities real(dp), allocatable :: dcoords(:, :) ! n_atoms by 3 real(dp), allocatable :: dlattice(:, :) ! n_vectors by 3 real(dp), allocatable :: dalpha(:) real(dp), allocatable :: dalpha_dyn(:, :) ! n_atoms by 0:n_freq real(dp), allocatable :: dC6(:) real(dp), allocatable :: dq(:) real(dp), allocatable :: dr_vdw(:) real(dp), allocatable :: domega(:) real(dp), allocatable :: dV(:) real(dp), allocatable :: dV_free(:) real(dp), allocatable :: dX_free(:) end type type, public :: grad_matrix_re_t !! Derivatives of a real dipole matrix with respect to various quantities real(dp), allocatable :: dr(:, :, :) real(dp), allocatable :: dlattice(:, :, :, :) real(dp), allocatable :: dvdw(:, :) real(dp), allocatable :: dsigma(:, :) real(dp), allocatable :: dgamma(:, :) end type type, public :: grad_matrix_cplx_t !! Derivatives of a compelx dipole matrix with respect to various quantities complex(dp), allocatable :: dr(:, :, :) complex(dp), allocatable :: dlattice(:, :, :, :) complex(dp), allocatable :: dq(:, :, :) complex(dp), allocatable :: dvdw(:, :) complex(dp), allocatable :: dsigma(:, :) complex(dp), allocatable :: dgamma(:, :) end type type, public :: grad_scalar_t !! Derivatives of a scalar with respect to various quantities real(dp), allocatable :: dr(:) real(dp), allocatable :: dr_1 real(dp), allocatable :: dk_1 real(dp), allocatable :: dvdw real(dp), allocatable :: dgamma real(dp), allocatable :: dC6 real(dp), allocatable :: dC6i real(dp), allocatable :: dC6j real(dp), allocatable :: da0i real(dp), allocatable :: da0j end type type, public :: grad_request_t !! Used to request derivatives with respect to function arguments logical :: dcoords = .false. logical :: dalpha = .false. logical :: dalpha_dyn = .false. logical :: dC6 = .false. logical :: dr_vdw = .false. logical :: domega = .false. logical :: dsigma = .false. logical :: dgamma = .false. logical :: dq = .false. logical :: dlattice = .false. logical :: dV = .false. logical :: dV_free = .false. logical :: dX_free = .false. contains procedure :: any => grad_request_any end type contains logical function grad_request_any(this) result(any) class(grad_request_t), intent(in) :: this any = this%dcoords & .or. this%dalpha & .or. this%dalpha_dyn & .or. this%dC6 & .or. this%dr_vdw & .or. this%domega & .or. this%dsigma & .or. this%dgamma & .or. this%dq & .or. this%dlattice & .or. this%dV & .or. this%dV_free & .or. this%dX_free end function end module libmbd-libmbd-88d61bc/src/mbd_hamiltonian.F90000066400000000000000000000166571452573331700210400ustar00rootroot00000000000000! This Source Code Form is subject to the terms of the Mozilla Public ! License, v. 2.0. If a copy of the MPL was not distributed with this ! file, You can obtain one at http://mozilla.org/MPL/2.0/. #ifndef DO_COMPLEX_TYPE module mbd_hamiltonian !! Forming and solving MBD Hamiltonian. use mbd_constants use mbd_damping, only: damping_t use mbd_dipole, only: dipole_matrix use mbd_geom, only: geom_t use mbd_gradients, only: grad_t, grad_matrix_re_t, grad_matrix_cplx_t, grad_request_t use mbd_matrix, only: matrix_re_t, matrix_cplx_t use mbd_utils, only: result_t, tostr implicit none private public :: get_mbd_hamiltonian_energy interface get_mbd_hamiltonian_energy !! Form and solve either a real or a complex MBD Hamiltonian. !! !! The real-typed version is equivalent to \(\mathbf q=0\). !! !! $$ !! \begin{gathered} !! E_\text{MBD}(\mathbf q)=\frac12\operatorname{Tr}\big(\sqrt{\mathbf Q(\mathbf !! q)}\big)- 3\sum_i\frac{\omega_i}2,\qquad !! \mathbf Q_{ij}(\mathbf q)=\omega_i^2\delta_{ij}\mathbf I+ !! \omega_i\omega_j\sqrt{\alpha_{0,i}\alpha_{0,j}}\mathbf T_{ij}(\mathbf q) !! \\ \mathbf Q(\mathbf q)\equiv !! \mathbf C(\mathbf q)\boldsymbol\Lambda(\mathbf q)\mathbf C(\mathbf !! q)^\dagger,\qquad !! \boldsymbol\Lambda(\mathbf q) !! \equiv\operatorname{diag}(\{\tilde\omega_i(\mathbf q)^2\}),\qquad !! \operatorname{Tr}\big(\sqrt{\mathbf Q(\mathbf q)}\big) !! =\sum_i\tilde\omega_i(\mathbf q) !! \end{gathered} !! $$ !! !! $$ !! \begin{aligned} !! \partial E_\text{MBD}&=\frac14\operatorname{Tr}\big( !! \mathbf C\boldsymbol\Lambda^{-\frac12}\mathbf C^\dagger !! \partial\mathbf Q !! \big)- !! 3\sum_i\frac{\partial\omega_i}2 !! \\ \frac{\partial E_\text{MBD}}{\partial X_i}&= !! \operatorname{Re}\frac12\sum_{p\zeta}( !! \mathbf C\boldsymbol\Lambda^{-\frac12}\mathbf C^\dagger !! )_{i\zeta,p} !! \frac{\partial Q_{p,i\zeta}}{\partial X_i}- !! \frac32\frac{\partial\omega_i}{\partial X_i} !! \end{aligned} !! $$ !! !! $$ !! \begin{aligned} !! \partial\mathbf Q_{ij}=& !! 2\delta_{ij}\omega_i\partial\omega_i\mathbf I+ !! \omega_i\omega_j\sqrt{\alpha_{0,i}\alpha_{0,j}}\mathbf T_{ij}\left( !! \frac{\partial\omega_i}{\omega_i}+ !! \frac{\partial\omega_j}{\omega_j}+ !! \frac12\frac{\partial\alpha_{0,i}}{\alpha_{0,i}}+ !! \frac12\frac{\partial\alpha_{0,j}}{\alpha_{0,j}} !! \right) !! \\ &+\omega_i\omega_j\sqrt{\alpha_{0,i}\alpha_{0,j}} !! \partial\mathbf T_{ij} !! \end{aligned} !! $$ module procedure get_mbd_hamiltonian_energy_real module procedure get_mbd_hamiltonian_energy_complex end interface contains #endif #ifndef DO_COMPLEX_TYPE type(result_t) function get_mbd_hamiltonian_energy_real( & geom, alpha_0, omega, damp, grad) result(res) #else type(result_t) function get_mbd_hamiltonian_energy_complex( & geom, alpha_0, omega, damp, grad, q) result(res) #endif type(geom_t), intent(inout) :: geom real(dp), intent(in) :: alpha_0(:) real(dp), intent(in) :: omega(:) type(damping_t), intent(in) :: damp type(grad_request_t), intent(in) :: grad #ifdef DO_COMPLEX_TYPE real(dp), intent(in) :: q(3) #endif #ifndef DO_COMPLEX_TYPE type(matrix_re_t) :: relay, dQ, T, modes, c_lambda12i_c type(grad_matrix_re_t) :: dT #else type(matrix_cplx_t) :: relay, dQ, T, modes, c_lambda12i_c type(grad_matrix_cplx_t) :: dT #endif real(dp), allocatable :: eigs(:) integer :: n_negative_eigs, n_atoms, i_xyz, i_latt character(120) :: msg n_atoms = geom%siz() call geom%clock(20) #ifndef DO_COMPLEX_TYPE T = dipole_matrix(geom, damp, dT, grad) #else T = dipole_matrix(geom, damp, dT, grad, q) #endif call geom%clock(-20) if (geom%has_exc()) return if (grad%any()) then call relay%copy_from(T) else call relay%move_from(T) end if call relay%mult_cross(omega * sqrt(alpha_0)) call relay%add_diag(omega**2) call geom%clock(21) if (geom%get_modes .or. grad%any()) then call modes%alloc_from(relay) allocate (eigs(3 * n_atoms)) call modes%eigh(eigs, geom%exc, src=relay, clock=geom%timer) if (geom%get_modes) then #ifndef DO_COMPLEX_TYPE call move_alloc(modes%val, res%modes) #else call move_alloc(modes%val, res%modes_k_single) #endif end if else eigs = relay%eigvalsh(geom%exc, destroy=.true., clock=geom%timer) end if if (geom%has_exc()) return call geom%clock(-21) if (geom%get_eigs) res%mode_eigs = eigs n_negative_eigs = count(eigs(:) < 0) if (n_negative_eigs > 0) then msg = "CDM Hamiltonian has "//trim(tostr(n_negative_eigs))// & " negative eigenvalues" if (geom%param%zero_negative_eigvals) then where (eigs < 0) eigs = 0d0 call geom%log%warn(msg) else geom%exc%code = MBD_EXC_NEG_EIGVALS geom%exc%msg = msg return end if end if res%energy = 1d0 / 2 * sum(sqrt(eigs)) - 3d0 / 2 * sum(omega) if (.not. grad%any()) return call geom%clock(22) call c_lambda12i_c%copy_from(modes) call c_lambda12i_c%mult_cols_3n(eigs**(-1d0 / 4)) call geom%clock(14) c_lambda12i_c = c_lambda12i_c%mmul(c_lambda12i_c, transB='C') call geom%clock(-14) #ifdef DO_COMPLEX_TYPE c_lambda12i_c%val = conjg(c_lambda12i_c%val) #endif call dQ%init_from(T) call geom%clock(15) if (grad%dcoords) then allocate (res%dE%dcoords(n_atoms, 3)) do i_xyz = 1, 3 dQ%val = dT%dr(:, :, i_xyz) call dQ%mult_cross(omega * sqrt(alpha_0)) dQ%val = c_lambda12i_c%val * dQ%val res%dE%dcoords(:, i_xyz) = 1d0 / 2 * dble(dQ%contract_n33_rows()) end do end if if (grad%dlattice) then allocate (res%dE%dlattice(3, 3)) do i_latt = 1, 3 do i_xyz = 1, 3 dQ%val = dT%dlattice(:, :, i_latt, i_xyz) call dQ%mult_cross(omega * sqrt(alpha_0)) dQ%val = c_lambda12i_c%val * dQ%val res%dE%dlattice(i_latt, i_xyz) = 1d0 / 4 * dble(dQ%sum_all()) end do end do end if if (grad%dalpha) then dQ%val = T%val call dQ%mult_cross(omega * sqrt(alpha_0)) call dQ%mult_rows(1d0 / (2 * alpha_0)) dQ%val = c_lambda12i_c%val * dQ%val res%dE%dalpha = 1d0 / 2 * dble(dQ%contract_n33_rows()) end if if (grad%domega) then dQ%val = T%val call dQ%mult_cross(omega * sqrt(alpha_0)) call dQ%mult_rows(1d0 / omega) call dQ%add_diag(omega) dQ%val = c_lambda12i_c%val * dQ%val res%dE%domega = 1d0 / 2 * dble(dQ%contract_n33_rows()) - 3d0 / 2 end if if (grad%dr_vdw) then dQ%val = dT%dvdw call dQ%mult_cross(omega * sqrt(alpha_0)) dQ%val = c_lambda12i_c%val * dQ%val res%dE%dr_vdw = 1d0 / 2 * dble(dQ%contract_n33_rows()) end if #ifdef DO_COMPLEX_TYPE if (grad%dq) then allocate (res%dE%dq(3)) do i_latt = 1, 3 dQ%val = dT%dq(:, :, i_latt) call dQ%mult_cross(omega * sqrt(alpha_0)) dQ%val = c_lambda12i_c%val * dQ%val res%dE%dq(i_latt) = 1d0 / 4 * dble(dQ%sum_all()) end do end if #endif call geom%clock(-15) call geom%clock(-22) end function #ifndef DO_COMPLEX_TYPE # define DO_COMPLEX_TYPE # include "mbd_hamiltonian.F90" end module #endif libmbd-libmbd-88d61bc/src/mbd_lapack.f90000066400000000000000000000316201452573331700200130ustar00rootroot00000000000000! This Source Code Form is subject to the terms of the Mozilla Public ! License, v. 2.0. If a copy of the MPL was not distributed with this ! file, You can obtain one at http://mozilla.org/MPL/2.0/. module mbd_lapack use mbd_constants use mbd_utils, only: exception_t, tostr implicit none private public :: mmul, inv, invh, inverse, eig, eigh, eigvals, eigvalsh, det, mode interface mmul module procedure mmul_real module procedure mmul_complex end interface interface inv module procedure inv_real end interface interface invh module procedure invh_real end interface interface eig module procedure eig_real end interface interface eigh module procedure eigh_real module procedure eigh_complex end interface interface eigvals module procedure eigvals_real end interface interface eigvalsh module procedure eigvalsh_real module procedure eigvalsh_complex end interface interface ! The followinbg interfaces were taken straight from the LAPACK codebase, ! replacing COMPLEX*16 for COMPLEX(dp) SUBROUTINE ZHEEV(JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, INFO) import :: dp CHARACTER JOBZ, UPLO INTEGER INFO, LDA, LWORK, N DOUBLE PRECISION RWORK(*), W(*) COMPLEX(dp) A(LDA, *), WORK(*) END SUBROUTINE DGEEV(JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, LDVR, WORK, LWORK, INFO) CHARACTER JOBVL, JOBVR INTEGER INFO, LDA, LDVL, LDVR, LWORK, N DOUBLE PRECISION A(LDA, *), VL(LDVL, *), VR(LDVR, *), WI(*), WORK(*), WR(*) END SUBROUTINE DSYEV(JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO) CHARACTER JOBZ, UPLO INTEGER INFO, LDA, LWORK, N DOUBLE PRECISION A(LDA, *), W(*), WORK(*) END SUBROUTINE DGETRF(M, N, A, LDA, IPIV, INFO) INTEGER INFO, LDA, M, N INTEGER IPIV(*) DOUBLE PRECISION A(LDA, *) END SUBROUTINE DGETRI(N, A, LDA, IPIV, WORK, LWORK, INFO) INTEGER INFO, LDA, LWORK, N INTEGER IPIV(*) DOUBLE PRECISION A(LDA, *), WORK(*) END SUBROUTINE DGESV(N, NRHS, A, LDA, IPIV, B, LDB, INFO) INTEGER INFO, LDA, LDB, N, NRHS INTEGER IPIV(*) DOUBLE PRECISION A(LDA, *), B(LDB, *) END SUBROUTINE ZGETRF(M, N, A, LDA, IPIV, INFO) import :: dp INTEGER INFO, LDA, M, N INTEGER IPIV(*) COMPLEX(dp) A(LDA, *) END SUBROUTINE ZGETRI(N, A, LDA, IPIV, WORK, LWORK, INFO) import :: dp INTEGER INFO, LDA, LWORK, N INTEGER IPIV(*) COMPLEX(dp) A(LDA, *), WORK(*) END SUBROUTINE ZGEEV(JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO) import :: dp CHARACTER JOBVL, JOBVR INTEGER INFO, LDA, LDVL, LDVR, LWORK, N DOUBLE PRECISION RWORK(*) COMPLEX(dp) A(LDA, *), VL(LDVL, *), VR(LDVR, *), W(*), WORK(*) END SUBROUTINE DSYTRI(UPLO, N, A, LDA, IPIV, WORK, INFO) CHARACTER UPLO INTEGER INFO, LDA, N INTEGER IPIV(*) DOUBLE PRECISION A(LDA, *), WORK(*) END SUBROUTINE DSYTRF(UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO) CHARACTER UPLO INTEGER INFO, LDA, LWORK, N INTEGER IPIV(*) DOUBLE PRECISION A(LDA, *), WORK(*) END SUBROUTINE DGEMM(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC) DOUBLE PRECISION ALPHA, BETA INTEGER K, LDA, LDB, LDC, M, N CHARACTER TRANSA, TRANSB DOUBLE PRECISION A(LDA, *), B(LDB, *), C(LDC, *) END SUBROUTINE ZGEMM(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC) import :: dp COMPLEX(dp) ALPHA, BETA INTEGER K, LDA, LDB, LDC, M, N CHARACTER TRANSA, TRANSB COMPLEX(dp) A(LDA, *), B(LDB, *), C(LDC, *) END end interface contains function inverse(A, exc) real(dp), intent(in) :: A(:, :) type(exception_t), intent(out), optional :: exc real(dp) :: inverse(size(A, 1), size(A, 2)) call inv_real(inverse, exc, src=A) end function function eigvalsh_real(A, exc, destroy) result(eigvals) real(dp), target, intent(in) :: A(:, :) type(exception_t), intent(out), optional :: exc logical, intent(in), optional :: destroy real(dp) :: eigvals(size(A, 1)) real(dp), allocatable, target :: A_work(:, :) real(dp), pointer :: A_p(:, :) nullify (A_p) if (present(destroy)) then if (destroy) then A_p => A end if end if if (.not. associated(A_p)) then allocate (A_work(size(A, 1), size(A, 1)), source=A) A_p => A_work end if call eigh_real(A_p, eigvals, exc, vals_only=.true.) end function function eigvalsh_complex(A, exc, destroy) result(eigvals) complex(dp), target, intent(in) :: A(:, :) type(exception_t), intent(out), optional :: exc logical, intent(in), optional :: destroy real(dp) :: eigvals(size(A, 1)) complex(dp), allocatable, target :: A_work(:, :) complex(dp), pointer :: A_p(:, :) nullify (A_p) if (present(destroy)) then if (destroy) then A_p => A end if end if if (.not. associated(A_p)) then allocate (A_work(size(A, 1), size(A, 1)), source=A) A_p => A_work end if call eigh_complex(A_p, eigvals, exc, vals_only=.true.) end function function eigvals_real(A, exc, destroy) result(eigvals) real(dp), target, intent(in) :: A(:, :) type(exception_t), intent(out), optional :: exc logical, intent(in), optional :: destroy complex(dp) :: eigvals(size(A, 1)) real(dp), allocatable, target :: A_work(:, :) real(dp), pointer :: A_p(:, :) nullify (A_p) if (present(destroy)) then if (destroy) then A_p => A end if end if if (.not. associated(A_p)) then allocate (A_work(size(A, 1), size(A, 1)), source=A) A_p => A_work end if call eig_real(A_p, eigvals, exc, vals_only=.true.) end function function mmul_real(A, B, transA, transB) result(C) real(dp), intent(in) :: A(:, :), B(:, :) character, intent(in), optional :: transA, transB real(dp) :: C(size(A, 1), size(B, 2)) character :: transA_, transB_ integer :: n transA_ = 'N' transB_ = 'N' if (present(transA)) transA_ = transA if (present(transB)) transB_ = transB n = size(A, 1) call DGEMM(transA_, transB_, n, n, n, 1d0, A, n, B, n, 0d0, C, n) end function function mmul_complex(A, B, transA, transB) result(C) complex(dp), intent(in) :: A(:, :), B(:, :) character, intent(in), optional :: transA, transB complex(dp) :: C(size(A, 1), size(B, 2)) character :: transA_, transB_ integer :: n transA_ = 'N' transB_ = 'N' if (present(transA)) transA_ = transA if (present(transB)) transB_ = transB n = size(A, 1) call ZGEMM(transA_, transB_, n, n, n, (1d0, 0d0), A, n, B, n, (0d0, 0d0), C, n) end function subroutine inv_real(A, exc, src) real(dp), intent(inout) :: A(:, :) type(exception_t), intent(out), optional :: exc real(dp), intent(in), optional :: src(:, :) real(dp), allocatable :: work_arr(:) integer, allocatable :: i_pivot(:) integer :: n, n_work_arr, error_flag real(dp) :: n_work_arr_optim(1) n = size(A, 1) if (n == 0) return if (present(src)) A = src allocate (i_pivot(n)) call DGETRF(n, n, A, n, i_pivot, error_flag) if (error_flag /= 0) then if (present(exc)) then exc%code = MBD_EXC_LINALG exc%origin = 'DGETRF' exc%msg = 'Failed with code '//trim(tostr(error_flag)) end if return end if call DGETRI(n, A, n, i_pivot, n_work_arr_optim, -1, error_flag) n_work_arr = nint(n_work_arr_optim(1)) allocate (work_arr(n_work_arr)) call DGETRI(n, A, n, i_pivot, work_arr(1), n_work_arr, error_flag) if (error_flag /= 0) then if (present(exc)) then exc%code = MBD_EXC_LINALG exc%origin = 'DGETRI' exc%msg = 'Failed with code '//trim(tostr(error_flag)) end if return end if end subroutine subroutine invh_real(A, exc, src) real(dp), intent(inout) :: A(:, :) type(exception_t), intent(out), optional :: exc real(dp), intent(in), optional :: src(:, :) integer, allocatable :: i_pivot(:) real(dp), allocatable :: work_arr(:) integer :: n, n_work_arr, error_flag real(dp) :: n_work_arr_optim(1) n = size(A, 1) if (n == 0) return if (present(src)) A = src allocate (i_pivot(n)) call DSYTRF('U', n, A, n, i_pivot, n_work_arr_optim, -1, error_flag) n_work_arr = nint(n_work_arr_optim(1)) allocate (work_arr(n_work_arr)) call DSYTRF('U', n, A, n, i_pivot, work_arr(1), n_work_arr, error_flag) if (error_flag /= 0) then if (present(exc)) then exc%code = MBD_EXC_LINALG exc%origin = 'DSYTRF' exc%msg = 'Failed with code '//trim(tostr(error_flag)) end if return end if deallocate (work_arr) allocate (work_arr(n)) call DSYTRI('U', n, A, n, i_pivot, work_arr, error_flag) if (error_flag /= 0) then if (present(exc)) then exc%code = MBD_EXC_LINALG exc%origin = 'DSYTRI' exc%msg = 'Failed with code '//trim(tostr(error_flag)) end if return end if call fill_tril(A) end subroutine subroutine eigh_real(A, eigs, exc, src, vals_only) real(dp), intent(inout) :: A(:, :) real(dp), intent(out) :: eigs(:) type(exception_t), intent(out), optional :: exc real(dp), intent(in), optional :: src(:, :) logical, intent(in), optional :: vals_only real(dp), allocatable :: work_arr(:) real(dp) :: n_work_arr(1) integer :: error_flag, n n = size(A, 1) if (present(src)) A = src call DSYEV(mode(vals_only), 'U', n, A, n, eigs, n_work_arr, -1, error_flag) allocate (work_arr(nint(n_work_arr(1)))) call DSYEV(mode(vals_only), 'U', n, A, n, eigs, work_arr(1), size(work_arr), error_flag) if (error_flag /= 0) then if (present(exc)) then exc%code = MBD_EXC_LINALG exc%origin = 'DSYEV' exc%msg = 'Failed with code '//trim(tostr(error_flag)) end if return end if end subroutine subroutine eig_real(A, eigs, exc, src, vals_only) real(dp), intent(inout) :: A(:, :) complex(dp), intent(out) :: eigs(:) type(exception_t), intent(out), optional :: exc real(dp), intent(in), optional :: src(:, :) logical, intent(in), optional :: vals_only real(dp) :: n_work_arr(1), dummy(1) integer :: error_flag, n real(dp), allocatable :: eigs_r(:), eigs_i(:), vectors(:, :), work_arr(:) n = size(A, 1) if (present(src)) A = src allocate (eigs_r(n), eigs_i(n)) if (mode(vals_only) == 'V') then allocate (vectors(n, n)) else allocate (vectors(1, 1)) end if call DGEEV( & 'N', mode(vals_only), n, A, n, eigs_r, eigs_i, dummy, 1, & vectors, n, n_work_arr, -1, error_flag & ) allocate (work_arr(nint(n_work_arr(1)))) call DGEEV( & 'N', mode(vals_only), n, A, n, eigs_r, eigs_i, dummy, 1, & vectors, n, work_arr(1), size(work_arr), error_flag & ) if (error_flag /= 0) then if (present(exc)) then exc%code = MBD_EXC_LINALG exc%origin = 'DGEEV' exc%msg = 'Failed with code '//trim(tostr(error_flag)) end if return end if eigs = cmplx(eigs_r, eigs_i, dp) if (mode(vals_only) == 'V') A = vectors end subroutine subroutine eigh_complex(A, eigs, exc, src, vals_only) complex(dp), intent(inout) :: A(:, :) real(dp), intent(out) :: eigs(:) type(exception_t), intent(out), optional :: exc complex(dp), intent(in), optional :: src(:, :) logical, intent(in), optional :: vals_only complex(dp), allocatable :: work(:) complex(dp) :: lwork_cmplx(1) real(dp), allocatable :: rwork(:) integer :: n, lwork, error_flag n = size(A, 1) if (present(src)) A = src allocate (rwork(max(1, 3 * n - 2))) call ZHEEV(mode(vals_only), 'U', n, A, n, eigs, lwork_cmplx, -1, rwork, error_flag) lwork = nint(dble(lwork_cmplx(1))) allocate (work(lwork)) call ZHEEV(mode(vals_only), 'U', n, A, n, eigs, work(1), lwork, rwork, error_flag) if (error_flag /= 0) then if (present(exc)) then exc%code = MBD_EXC_LINALG exc%origin = 'ZHEEV' exc%msg = 'Failed with code '//trim(tostr(error_flag)) end if return end if end subroutine real(dp) function det(A) result(D) real(dp), intent(in) :: A(:, :) integer :: n, i, info real(dp), allocatable :: LU(:, :) integer, allocatable :: ipiv(:) n = size(A, 1) allocate (ipiv(n)) LU = A call DGETRF(n, n, LU, n, ipiv, info) D = product([(LU(i, i), i=1, n)]) end function subroutine fill_tril(A) real(dp), intent(inout) :: A(:, :) integer :: i, j do i = 1, size(A, 1) do j = i + 1, size(A, 1) A(j, i) = A(i, j) end do end do end subroutine character(len=1) function mode(vals_only) logical, intent(in), optional :: vals_only mode = 'V' if (present(vals_only)) then if (vals_only) mode = 'N' end if end function end module libmbd-libmbd-88d61bc/src/mbd_linalg.F90000066400000000000000000000027661452573331700177770ustar00rootroot00000000000000! This Source Code Form is subject to the terms of the Mozilla Public ! License, v. 2.0. If a copy of the MPL was not distributed with this ! file, You can obtain one at http://mozilla.org/MPL/2.0/. module mbd_linalg use mbd_constants implicit none private public :: outer, eye, diag interface diag module procedure get_diag_real module procedure get_diag_complex module procedure make_diag_real end interface contains function outer(a, b) result(c) real(dp), intent(in) :: a(:), b(:) real(dp) :: c(size(a), size(b)) integer :: i, j do i = 1, size(a) do j = 1, size(b) c(i, j) = a(i) * b(j) end do end do end function function eye(n) result(A) integer, intent(in) :: n real(dp) :: A(n, n) integer :: i A(:, :) = 0.d0 do concurrent(i=1:n) A(i, i) = 1.d0 end do end function function get_diag_real(A) result(d) real(dp), intent(in) :: A(:, :) real(dp) :: d(size(A, 1)) integer :: i do concurrent(i=1:size(A, 1)) d(i) = A(i, i) end do end function function get_diag_complex(A) result(d) complex(dp), intent(in) :: A(:, :) complex(dp) :: d(size(A, 1)) integer :: i do concurrent(i=1:size(A, 1)) d(i) = A(i, i) end do end function function make_diag_real(d) result(A) real(dp), intent(in) :: d(:) real(dp) :: A(size(d), size(d)) integer :: i A(:, :) = 0.d0 do concurrent(i=1:size(d)) A(i, i) = d(i) end do end function end module libmbd-libmbd-88d61bc/src/mbd_matrix.F90000066400000000000000000000446771452573331700200440ustar00rootroot00000000000000! This Source Code Form is subject to the terms of the Mozilla Public ! License, v. 2.0. If a copy of the MPL was not distributed with this ! file, You can obtain one at http://mozilla.org/MPL/2.0/. #ifndef DO_COMPLEX_TYPE module mbd_matrix use mbd_constants use mbd_lapack, only: mmul, invh, invh, eigh, eigvals, eigvalsh use mbd_utils, only: findval, exception_t, atom_index_t, is_true, clock_t # ifdef WITH_SCALAPACK use mbd_blacs, only: blacs_desc_t, blacs_all_reduce use mbd_scalapack, only: pmmul, pinvh, pinvh, peigh, peigvalsh # endif # ifdef WITH_ELSI use mbd_elsi, only: elsi_eigh, elsi_eigvalsh # endif implicit none private public :: contract_cross_33 type, public :: matrix_re_t real(dp), allocatable :: val(:, :) type(atom_index_t) :: idx # ifdef WITH_SCALAPACK type(blacs_desc_t) :: blacs # endif contains procedure :: siz => matrix_re_siz procedure :: init => matrix_re_init procedure :: add_diag => matrix_re_add_diag procedure :: add_diag_scalar => matrix_re_add_diag_scalar procedure :: mult_cross => matrix_re_mult_cross procedure :: mult_rows => matrix_re_mult_rows procedure :: mult_cols_3n => matrix_re_mult_cols_3n procedure :: mult_col => matrix_re_mult_col procedure :: mmul => matrix_re_mmul procedure :: invh => matrix_re_invh procedure :: eigh => matrix_re_eigh procedure :: eigvals => matrix_re_eigvals procedure :: eigvalsh => matrix_re_eigvalsh procedure :: sum_all => matrix_re_sum_all procedure :: contract_n_transp => matrix_re_contract_n_transp procedure :: contract_n33diag_cols => matrix_re_contract_n33diag_cols procedure :: contract_n33_rows => matrix_re_contract_n33_rows procedure :: copy_from => matrix_re_copy_from procedure :: move_from => matrix_re_move_from procedure :: init_from => matrix_re_init_from procedure :: alloc_from => matrix_re_alloc_from end type type, public :: matrix_cplx_t complex(dp), allocatable :: val(:, :) type(atom_index_t) :: idx # ifdef WITH_SCALAPACK type(blacs_desc_t) :: blacs # endif contains procedure :: siz => matrix_cplx_siz procedure :: init => matrix_cplx_init procedure :: add_diag => matrix_cplx_add_diag procedure :: add_diag_scalar => matrix_cplx_add_diag_scalar procedure :: mult_cross => matrix_cplx_mult_cross procedure :: mult_rows => matrix_cplx_mult_rows procedure :: mult_cols_3n => matrix_cplx_mult_cols_3n procedure :: mult_col => matrix_cplx_mult_col procedure :: mmul => matrix_cplx_mmul procedure :: eigh => matrix_cplx_eigh procedure :: eigvalsh => matrix_cplx_eigvalsh procedure :: sum_all => matrix_cplx_sum_all procedure :: contract_n_transp => matrix_cplx_contract_n_transp procedure :: contract_n33diag_cols => matrix_cplx_contract_n33diag_cols procedure :: contract_n33_rows => matrix_cplx_contract_n33_rows procedure :: copy_from => matrix_cplx_copy_from procedure :: move_from => matrix_cplx_move_from procedure :: init_from => matrix_cplx_init_from procedure :: alloc_from => matrix_cplx_alloc_from end type interface contract_cross_33 module procedure contract_cross_33_real module procedure contract_cross_33_complex end interface contains #endif #ifndef DO_COMPLEX_TYPE integer function matrix_re_siz(this, ndim) result(siz) class(matrix_re_t), intent(in) :: this #else integer function matrix_cplx_siz(this, ndim) result(siz) class(matrix_cplx_t), intent(in) :: this #endif integer, intent(in) :: ndim siz = size(this%val, ndim) end function #ifndef DO_COMPLEX_TYPE # ifdef WITH_SCALAPACK subroutine matrix_re_init(this, idx, blacs) # else subroutine matrix_re_init(this, idx) # endif class(matrix_re_t), intent(out) :: this #else # ifdef WITH_SCALAPACK subroutine matrix_cplx_init(this, idx, blacs) # else subroutine matrix_cplx_init(this, idx) # endif class(matrix_cplx_t), intent(out) :: this #endif type(atom_index_t), intent(in) :: idx #ifdef WITH_SCALAPACK type(blacs_desc_t), intent(in) :: blacs #endif this%idx = idx #ifdef WITH_SCALAPACK this%blacs = blacs #endif end subroutine #ifndef DO_COMPLEX_TYPE subroutine matrix_re_init_from(this, other) class(matrix_re_t), intent(out) :: this type(matrix_re_t), intent(in) :: other #else subroutine matrix_cplx_init_from(this, other) class(matrix_cplx_t), intent(out) :: this type(matrix_cplx_t), intent(in) :: other #endif this%idx = other%idx #ifdef WITH_SCALAPACK this%blacs = other%blacs #endif end subroutine #ifndef DO_COMPLEX_TYPE subroutine matrix_re_copy_from(this, other) class(matrix_re_t), intent(out) :: this type(matrix_re_t), intent(in) :: other #else subroutine matrix_cplx_copy_from(this, other) class(matrix_cplx_t), intent(out) :: this type(matrix_cplx_t), intent(in) :: other #endif call this%init_from(other) this%val = other%val end subroutine #ifndef DO_COMPLEX_TYPE subroutine matrix_re_move_from(this, other) class(matrix_re_t), intent(out) :: this type(matrix_re_t), intent(inout) :: other #else subroutine matrix_cplx_move_from(this, other) class(matrix_cplx_t), intent(out) :: this type(matrix_cplx_t), intent(inout) :: other #endif call this%init_from(other) call move_alloc(other%val, this%val) end subroutine #ifndef DO_COMPLEX_TYPE subroutine matrix_re_alloc_from(this, other) class(matrix_re_t), intent(out) :: this type(matrix_re_t), intent(in) :: other #else subroutine matrix_cplx_alloc_from(this, other) class(matrix_cplx_t), intent(out) :: this type(matrix_cplx_t), intent(in) :: other #endif integer :: n1, n2 call this%init_from(other) n1 = other%siz(1) n2 = other%siz(2) allocate (this%val(n1, n2)) end subroutine #ifndef DO_COMPLEX_TYPE subroutine matrix_re_add_diag_scalar(this, d) class(matrix_re_t), intent(inout) :: this #else subroutine matrix_cplx_add_diag_scalar(this, d) class(matrix_cplx_t), intent(inout) :: this #endif real(dp), intent(in) :: d integer :: i call this%add_diag([(d, i=1, this%idx%n_atoms)]) end subroutine #ifndef DO_COMPLEX_TYPE subroutine matrix_re_add_diag(this, d) class(matrix_re_t), intent(inout) :: this #else subroutine matrix_cplx_add_diag(this, d) class(matrix_cplx_t), intent(inout) :: this #endif real(dp), intent(in) :: d(:) integer :: my_i_atom, my_j_atom, i do my_i_atom = 1, size(this%idx%i_atom) do my_j_atom = 1, size(this%idx%j_atom) associate ( & i_atom => this%idx%i_atom(my_i_atom), & j_atom => this%idx%j_atom(my_j_atom), & this_diag => this%val(3 * (my_i_atom - 1) + 1:, 3 * (my_j_atom - 1) + 1:) & ) if (i_atom /= j_atom) cycle do i = 1, 3 this_diag(i, i) = this_diag(i, i) + d(i_atom) end do end associate end do end do end subroutine #ifndef DO_COMPLEX_TYPE subroutine matrix_re_mult_cross(this, b, c) class(matrix_re_t), intent(inout) :: this #else subroutine matrix_cplx_mult_cross(this, b, c) class(matrix_cplx_t), intent(inout) :: this #endif real(dp), intent(in) :: b(:) real(dp), intent(in), optional :: c(:) integer :: my_i_atom, my_j_atom do my_i_atom = 1, size(this%idx%i_atom) do my_j_atom = 1, size(this%idx%j_atom) associate ( & i_atom => this%idx%i_atom(my_i_atom), & j_atom => this%idx%j_atom(my_j_atom), & this_sub => this%val(3 * (my_i_atom - 1) + 1:, 3 * (my_j_atom - 1) + 1:) & ) if (present(c)) then this_sub(:3, :3) = this_sub(:3, :3) * & (b(i_atom) * c(j_atom) + c(i_atom) * b(j_atom)) else this_sub(:3, :3) = this_sub(:3, :3) * b(i_atom) * b(j_atom) end if end associate end do end do end subroutine #ifndef DO_COMPLEX_TYPE subroutine matrix_re_mult_rows(this, b) class(matrix_re_t), intent(inout) :: this #else subroutine matrix_cplx_mult_rows(this, b) class(matrix_cplx_t), intent(inout) :: this #endif real(dp), intent(in) :: b(:) integer :: my_i_atom do my_i_atom = 1, size(this%idx%i_atom) associate ( & i_atom => this%idx%i_atom(my_i_atom), & this_sub => this%val(3 * (my_i_atom - 1) + 1:, :) & ) this_sub(:3, :) = this_sub(:3, :) * b(i_atom) end associate end do end subroutine #ifndef DO_COMPLEX_TYPE subroutine matrix_re_mult_cols_3n(this, b) class(matrix_re_t), intent(inout) :: this #else subroutine matrix_cplx_mult_cols_3n(this, b) class(matrix_cplx_t), intent(inout) :: this #endif real(dp), intent(in) :: b(:) integer :: my_j_atom, i do my_j_atom = 1, size(this%idx%j_atom) associate ( & b_sub => b(3 * (this%idx%j_atom(my_j_atom) - 1) + 1:), & this_sub => this%val(:, 3 * (my_j_atom - 1) + 1:) & ) ! TODO should be do-concurrent, but this crashes IBM XL 16.1.1, ! see issue #16 do i = 1, 3 this_sub(:, i) = this_sub(:, i) * b_sub(i) end do end associate end do end subroutine #ifndef DO_COMPLEX_TYPE subroutine matrix_re_mult_col(this, idx, a) class(matrix_re_t), intent(inout) :: this #else subroutine matrix_cplx_mult_col(this, idx, a) class(matrix_cplx_t), intent(inout) :: this #endif integer, intent(in) :: idx real(dp), intent(in) :: a(:) integer :: my_i_atom, my_j_atom do my_j_atom = 1, size(this%idx%j_atom) if (this%idx%j_atom(my_j_atom) /= idx) cycle do my_i_atom = 1, size(this%idx%i_atom) associate ( & i_atom => this%idx%i_atom(my_i_atom), & this_sub => this%val(3 * (my_i_atom - 1) + 1:, 3 * (my_j_atom - 1) + 1:) & ) this_sub(:3, :3) = this_sub(:3, :3) * a(i_atom) end associate end do end do end subroutine #ifndef DO_COMPLEX_TYPE subroutine matrix_re_eigh(A, eigs, exc, src, vals_only, clock) class(matrix_re_t), intent(inout) :: A type(matrix_re_t), intent(in), optional :: src #else subroutine matrix_cplx_eigh(A, eigs, exc, src, vals_only, clock) class(matrix_cplx_t), intent(inout) :: A type(matrix_cplx_t), intent(in), optional :: src #endif real(dp), intent(out) :: eigs(:) type(exception_t), intent(out), optional :: exc logical, intent(in), optional :: vals_only type(clock_t), intent(inout), optional :: clock #ifdef WITH_SCALAPACK if (A%idx%parallel) then # ifdef WITH_ELSI if (present(clock)) call clock%clock(18) call elsi_eigh(A%val, A%blacs, eigs, exc, src%val, vals_only) if (present(clock)) call clock%clock(-18) # else call peigh(A%val, A%blacs, eigs, exc, src%val, vals_only, clock) # endif return end if #endif call eigh(A%val, eigs, exc, src%val, vals_only) end subroutine #ifndef DO_COMPLEX_TYPE function matrix_re_eigvalsh(A, exc, destroy, clock) result(eigs) class(matrix_re_t), intent(inout) :: A #else function matrix_cplx_eigvalsh(A, exc, destroy, clock) result(eigs) class(matrix_cplx_t), intent(inout) :: A #endif type(exception_t), intent(out), optional :: exc logical, intent(in), optional :: destroy real(dp) :: eigs(3 * A%idx%n_atoms) type(clock_t), intent(inout), optional :: clock #ifdef WITH_SCALAPACK if (A%idx%parallel) then # ifdef WITH_ELSI eigs = elsi_eigvalsh(A%val, A%blacs, exc, destroy) # else eigs = peigvalsh(A%val, A%blacs, exc, destroy, clock) # endif return end if #endif eigs = eigvalsh(A%val, exc, destroy) end function #ifndef DO_COMPLEX_TYPE real(dp) function matrix_re_sum_all(this) result(res) class(matrix_re_t), intent(in) :: this #else complex(dp) function matrix_cplx_sum_all(this) result(res) class(matrix_cplx_t), intent(in) :: this #endif res = sum(this%val) #ifdef WITH_SCALAPACK if (this%idx%parallel) call blacs_all_reduce(res, this%blacs) #endif end function #ifndef DO_COMPLEX_TYPE subroutine matrix_re_contract_n_transp(this, dir, res) class(matrix_re_t), intent(in) :: this real(dp), intent(out), target :: res(:, :) #else subroutine matrix_cplx_contract_n_transp(this, dir, res) class(matrix_cplx_t), intent(in) :: this complex(dp), intent(out), target :: res(:, :) #endif character(len=*), intent(in) :: dir integer :: my_i_atom, my_j_atom #ifndef DO_COMPLEX_TYPE real(dp), pointer :: res_sub(:, :) #else complex(dp), pointer :: res_sub(:, :) #endif res(:, :) = 0d0 do my_i_atom = 1, size(this%idx%i_atom) do my_j_atom = 1, size(this%idx%j_atom) select case (dir(1:1)) case ('R') res_sub => res(:, 3 * (this%idx%i_atom(my_i_atom) - 1) + 1:) case ('C') res_sub => res(3 * (this%idx%j_atom(my_j_atom) - 1) + 1:, :) end select associate ( & this_sub => this%val(3 * (my_i_atom - 1) + 1:, 3 * (my_j_atom - 1) + 1:) & ) res_sub(:3, :3) = res_sub(:3, :3) + transpose(this_sub(:3, :3)) end associate end do end do #ifdef WITH_SCALAPACK if (this%idx%parallel) call blacs_all_reduce(res, this%blacs) #endif end subroutine #ifndef DO_COMPLEX_TYPE function contract_cross_33_real(k_atom, A, A_prime, B, B_prime) result(res) type(matrix_re_t), intent(in) :: A, B real(dp), intent(in) :: A_prime(:, :), B_prime(:, :) real(dp) :: res(A%idx%n_atoms) #else function contract_cross_33_complex(k_atom, A, A_prime, B, B_prime) result(res) type(matrix_cplx_t), intent(in) :: A, B complex(dp), intent(in) :: A_prime(:, :), B_prime(:, :) complex(dp) :: res(A%idx%n_atoms) #endif integer, intent(in) :: k_atom integer :: my_i_atom, my_j_atom, i_atom, j_atom res(:) = 0d0 my_i_atom = findval(A%idx%i_atom, k_atom) if (my_i_atom > 0) then do my_j_atom = 1, size(A%idx%j_atom) j_atom = A%idx%j_atom(my_j_atom) associate ( & A_sub => A%val(3 * (my_i_atom - 1) + 1:, 3 * (my_j_atom - 1) + 1:), & A_prime_sub => A_prime(:, 3 * (j_atom - 1) + 1:) & ) res(j_atom) = -1d0 / 3 * sum(A_sub(:3, :3) * A_prime_sub(:, :3)) end associate end do end if my_j_atom = findval(A%idx%j_atom, k_atom) if (my_j_atom > 0) then do my_i_atom = 1, size(A%idx%i_atom) i_atom = A%idx%i_atom(my_i_atom) associate ( & B_sub => B%val(3 * (my_i_atom - 1) + 1:, 3 * (my_j_atom - 1) + 1:), & B_prime_sub => B_prime(3 * (i_atom - 1) + 1:, :) & ) res(i_atom) = res(i_atom) + & (-1d0 / 3) * sum(B_prime_sub(:3, :) * B_sub(:3, :3)) end associate end do end if #ifdef WITH_SCALAPACK if (A%idx%parallel) call blacs_all_reduce(res, A%blacs) #endif end function #ifndef DO_COMPLEX_TYPE function matrix_re_contract_n33diag_cols(A) result(res) class(matrix_re_t), intent(in) :: A real(dp) :: res(A%idx%n_atoms) #else function matrix_cplx_contract_n33diag_cols(A) result(res) class(matrix_cplx_t), intent(in) :: A complex(dp) :: res(A%idx%n_atoms) #endif integer :: i_xyz, my_j_atom, j_atom res(:) = 0d0 do my_j_atom = 1, size(A%idx%j_atom) j_atom = A%idx%j_atom(my_j_atom) do i_xyz = 1, 3 res(j_atom) = res(j_atom) + & sum(A%val(i_xyz::3, 3 * (my_j_atom - 1) + i_xyz)) end do end do res = res / 3 #ifdef WITH_SCALAPACK if (A%idx%parallel) call blacs_all_reduce(res, A%blacs) #endif end function #ifndef DO_COMPLEX_TYPE function matrix_re_contract_n33_rows(A) result(res) class(matrix_re_t), intent(in) :: A real(dp) :: res(A%idx%n_atoms) #else function matrix_cplx_contract_n33_rows(A) result(res) class(matrix_cplx_t), intent(in) :: A complex(dp) :: res(A%idx%n_atoms) #endif integer :: my_i_atom, i_atom res(:) = 0d0 do my_i_atom = 1, size(A%idx%i_atom) i_atom = A%idx%i_atom(my_i_atom) associate (A_sub => A%val(3 * (my_i_atom - 1) + 1:, :)) res(i_atom) = res(i_atom) + sum(A_sub(:3, :)) end associate end do #ifdef WITH_SCALAPACK if (A%idx%parallel) call blacs_all_reduce(res, A%blacs) #endif end function #ifndef DO_COMPLEX_TYPE type(matrix_re_t) function matrix_re_mmul( & A, B, transA, transB) result(C) class(matrix_re_t), intent(in) :: A type(matrix_re_t), intent(in) :: B #else type(matrix_cplx_t) function matrix_cplx_mmul( & A, B, transA, transB) result(C) class(matrix_cplx_t), intent(in) :: A type(matrix_cplx_t), intent(in) :: B #endif character, intent(in), optional :: transA, transB C%idx = A%idx #ifdef WITH_SCALAPACK C%blacs = A%blacs if (.not. A%idx%parallel) then C%val = mmul(A%val, B%val, transA, transB) else C%val = pmmul(A%val, A%blacs, B%val, B%blacs, transA, transB, C%blacs) end if #else C%val = mmul(A%val, B%val, transA, transB) #endif end function #ifndef DO_COMPLEX_TYPE # define DO_COMPLEX_TYPE #include "mbd_matrix.F90" subroutine matrix_re_invh(A, exc, src, clock) class(matrix_re_t), intent(inout) :: A type(matrix_re_t), intent(in), optional :: src type(exception_t), intent(out), optional :: exc type(clock_t), intent(inout), optional :: clock #ifdef WITH_SCALAPACK if (.not. A%idx%parallel) then if (present(src)) then call invh(A%val, exc, src%val) else call invh(A%val, exc) end if else if (present(src)) then call pinvh(A%val, A%blacs, exc, src%val, clock=clock) else call pinvh(A%val, A%blacs, exc, clock=clock) end if end if #else if (present(src)) then call invh(A%val, exc, src%val) else call invh(A%val, exc) end if #endif end subroutine function matrix_re_eigvals(A, exc, destroy) result(eigs) class(matrix_re_t), target, intent(in) :: A type(exception_t), intent(out), optional :: exc logical, intent(in), optional :: destroy complex(dp) :: eigs(3 * A%idx%n_atoms) #ifdef WITH_SCALAPACK if (A%idx%parallel) then exc%code = MBD_EXC_UNIMPL exc%msg = 'Complex general matrix diagonalization not implemented for scalapack' else eigs = eigvals(A%val, exc, destroy) end if #else eigs = eigvals(A%val, exc, destroy) #endif end function end module #endif libmbd-libmbd-88d61bc/src/mbd_methods.F90000066400000000000000000000344151452573331700201700ustar00rootroot00000000000000! This Source Code Form is subject to the terms of the Mozilla Public ! License, v. 2.0. If a copy of the MPL was not distributed with this ! file, You can obtain one at http://mozilla.org/MPL/2.0/. module mbd_methods !! Obtaining MBD energies. use mbd_constants use mbd_damping, only: damping_t use mbd_formulas, only: omega_qho, alpha_dyn_qho, scale_with_ratio, C6_from_alpha use mbd_geom, only: geom_t use mbd_gradients, only: grad_t, grad_request_t use mbd_hamiltonian, only: get_mbd_hamiltonian_energy use mbd_lapack, only: eigvals, inverse use mbd_rpa, only: get_mbd_rpa_energy use mbd_scs, only: run_scs use mbd_utils, only: result_t, tostr, shift_idx #ifdef WITH_SCALAPACK use mbd_blacs, only: blacs_all_reduce #endif #ifdef WITH_MPI use mbd_mpi, only: mpi_all_reduce #endif implicit none private public :: get_mbd_energy, get_mbd_scs_energy contains type(result_t) function get_mbd_energy(geom, alpha_0, C6, damp, grad) result(res) !! Get MBD energy. !! !! For a nonperiodic system, the method just transforms \(C_6\) coefficients !! to frequencies, and performs a single call to !! [[get_mbd_hamiltonian_energy]]. For a periodic system, the method !! integrates the energy over the frist Brillouin zone. !! !! $$ !! E=\int_\text{FBZ}\mathrm d\mathbf q\,E(\mathbf !! q)\approx\frac1{N_k}\sum_i^{N_k}E(\mathbf q_i) !! \\ \mathbf q_i=\boldsymbol{\mathcal B}\mathbf n_i,\qquad\partial\mathbf !! q_i=-\big((\partial\boldsymbol{\mathcal !! A})\boldsymbol{\mathcal A}^{-1}\big)^\mathrm T\mathbf q_i !! $$ type(geom_t), intent(inout) :: geom real(dp), intent(in) :: alpha_0(:) real(dp), intent(in) :: C6(:) type(damping_t), intent(in) :: damp type(grad_request_t), intent(in) :: grad real(dp), allocatable :: alpha(:, :), omega(:), k_pts(:, :), dkdlattice(:, :, :, :) type(grad_t), allocatable :: dalpha(:) integer :: n_kpts, i_kpt, a type(result_t) :: res_k type(grad_t) :: domega type(grad_request_t) :: grad_ham omega = omega_qho(C6, alpha_0, domega, grad) if (geom%do_rpa) then alpha = alpha_dyn_qho(alpha_0, omega, geom%freq, dalpha, grad_request_t()) end if grad_ham = grad if (grad%dC6 .or. grad%dalpha) grad_ham%domega = .true. if (grad%dlattice) grad_ham%dq = .true. if (.not. allocated(geom%lattice)) then if (.not. geom%do_rpa) then call geom%clock(52) res = get_mbd_hamiltonian_energy(geom, alpha_0, omega, damp, grad_ham) call geom%clock(-52) if (grad%dC6) res%dE%dC6 = res%dE%domega * domega%dC6 if (grad%dalpha) res%dE%dalpha = res%dE%dalpha + res%dE%domega * domega%dalpha if (allocated(res%dE%domega)) deallocate (res%dE%domega) else res = get_mbd_rpa_energy(geom, alpha, damp) ! TODO gradients end if else if (allocated(geom%custom_k_pts)) then k_pts = geom%custom_k_pts else call make_k_pts( & k_pts, geom%k_grid, geom%lattice, geom%param%k_grid_shift, & dkdlattice, grad%dlattice & ) end if n_kpts = size(k_pts, 2) res%energy = 0d0 if (geom%get_eigs) & allocate (res%mode_eigs_k(3 * geom%siz(), n_kpts), source=0d0) if (geom%get_modes) & allocate (res%modes_k(3 * geom%siz(), 3 * geom%siz(), n_kpts), source=(0d0, 0d0)) if (geom%get_rpa_orders) allocate ( & res%rpa_orders_k(geom%param%rpa_order_max, n_kpts), source=0d0 & ) if (grad%dcoords) allocate (res%dE%dcoords(geom%siz(), 3), source=0d0) if (grad%dlattice) allocate (res%dE%dlattice(3, 3), source=0d0) if (grad%dalpha) allocate (res%dE%dalpha(geom%siz()), source=0d0) if (grad%dC6) allocate (res%dE%dC6(geom%siz()), source=0d0) if (grad%dR_vdw) allocate (res%dE%dR_vdw(geom%siz()), source=0d0) do i_kpt = 1, n_kpts #ifdef WITH_MPI if (geom%parallel_mode == 'k_points') then if (modulo(i_kpt, geom%mpi_size) /= geom%mpi_rank) cycle end if #endif call geom%clock(51) associate (k_pt => k_pts(:, i_kpt)) if (.not. geom%do_rpa) then res_k = get_mbd_hamiltonian_energy( & geom, alpha_0, omega, damp, grad_ham, k_pt & ) else res_k = get_mbd_rpa_energy(geom, alpha, damp, k_pt) end if end associate call geom%clock(-51) if (geom%has_exc()) exit if (geom%get_eigs) then res%mode_eigs_k(:, i_kpt) = res_k%mode_eigs end if if (geom%get_modes) then res%modes_k(:, :, i_kpt) = res_k%modes_k_single end if if (geom%get_rpa_orders) then res%rpa_orders_k(:, i_kpt) = res_k%rpa_orders end if res%energy = res%energy + res_k%energy / n_kpts if (grad%dcoords) res%dE%dcoords = res%dE%dcoords + res_k%dE%dcoords / n_kpts if (grad%dlattice) then res%dE%dlattice = res%dE%dlattice + res_k%dE%dlattice / n_kpts do a = 1, 3 res%dE%dlattice = res%dE%dlattice & + res_k%dE%dq(a) * dkdlattice(a, i_kpt, :, :) / n_kpts end do end if if (grad%dalpha) then res%dE%dalpha = res%dE%dalpha & + (res_k%dE%dalpha + res_k%dE%domega * domega%dalpha) / n_kpts end if if (grad%dC6) res%dE%dC6 = res%dE%dC6 + res_k%dE%domega * domega%dC6 / n_kpts if (grad%dR_vdw) res%dE%dR_vdw = res%dE%dR_vdw + res_k%dE%dR_vdw / n_kpts end do #ifdef WITH_MPI if (geom%parallel_mode == 'k_points') then call geom%sync_exc() call mpi_all_reduce(res%energy, geom%mpi_comm) if (grad%dcoords) call mpi_all_reduce(res%dE%dcoords, geom%mpi_comm) if (grad%dlattice) call mpi_all_reduce(res%dE%dlattice, geom%mpi_comm) if (grad%dalpha) call mpi_all_reduce(res%dE%dalpha, geom%mpi_comm) if (grad%dC6) call mpi_all_reduce(res%dE%dC6, geom%mpi_comm) if (grad%dR_vdw) call mpi_all_reduce(res%dE%dR_vdw, geom%mpi_comm) end if #endif end if end function type(result_t) function get_mbd_scs_energy(geom, variant, alpha_0, C6, damp, grad) result(res) !! Get screened MBD energy. type(geom_t), intent(inout) :: geom character(len=*), intent(in) :: variant real(dp), intent(in) :: alpha_0(:) real(dp), intent(in) :: C6(:) type(damping_t), intent(in) :: damp type(grad_request_t), intent(in) :: grad real(dp), allocatable :: alpha_dyn(:, :), alpha_dyn_scs(:, :), & dC6_scs_dalpha_dyn_scs(:, :), dene_dalpha_scs_dyn(:, :), freq_w(:), omega(:) real(dp) :: C6_scs(size(alpha_0)) ! circumventing PGI 19 compiler bug type(grad_t), allocatable :: dalpha_dyn(:), dalpha_dyn_scs(:, :) type(grad_t) :: dE, dr_vdw_scs, domega type(grad_request_t) :: grad_scs type(damping_t) :: damp_scs, damp_mbd integer :: n_freq, i_freq, n_atoms, i_atom, my_i_atom character(len=15) :: damping_types(2) call geom%clock(90) select case (variant) case ('scs') damping_types = [character(len=15) :: 'dip,gg', 'dip,1mexp'] case ('rsscs') damping_types = [character(len=15) :: 'fermi,dip,gg', 'fermi,dip'] end select n_freq = ubound(geom%freq, 1) n_atoms = geom%siz() allocate (alpha_dyn(n_atoms, 0:n_freq)) allocate (alpha_dyn_scs(n_atoms, 0:n_freq)) allocate (dalpha_dyn_scs(size(geom%idx%i_atom), 0:n_freq)) if (grad%any()) allocate (dene_dalpha_scs_dyn(n_atoms, 0:n_freq)) omega = omega_qho(C6, alpha_0, domega, grad) alpha_dyn = alpha_dyn_qho( & alpha_0, omega, geom%freq, dalpha_dyn, & grad_request_t(dalpha=grad%dalpha, domega=grad%dalpha .or. grad%dC6) & ) grad_scs = grad_request_t( & dcoords=grad%dcoords, & dlattice=grad%dlattice, & dalpha=grad%dalpha .or. grad%dC6, & dr_vdw=grad%dr_vdw & ) damp_scs = damp damp_scs%version = damping_types(1) call geom%clock(50) do i_freq = 0, n_freq alpha_dyn_scs(:, i_freq) = run_scs( & geom, alpha_dyn(:, i_freq), damp_scs, dalpha_dyn_scs(:, i_freq), grad_scs & ) if (geom%has_exc()) return end do call geom%clock(-50) C6_scs = C6_from_alpha(alpha_dyn_scs, geom%freq, dC6_scs_dalpha_dyn_scs, grad%any()) damp_mbd = damp damp_mbd%r_vdw = scale_with_ratio( & damp%r_vdw, alpha_dyn_scs(:, 0), alpha_dyn(:, 0), 1d0 / 3, dr_vdw_scs, & grad_request_t(dV=grad%any(), dV_free=grad%dalpha, dX_free=grad%dr_vdw) & ) damp_mbd%version = damping_types(2) res = get_mbd_energy(geom, alpha_dyn_scs(:, 0), C6_scs, damp_mbd, & grad_request_t( & dcoords=grad%dcoords, dlattice=grad%dlattice, & dalpha=grad%any(), dC6=grad%any(), dr_vdw=grad%any() & ) & ) res%alpha_0 = alpha_dyn_scs(:, 0) res%C6 = C6_scs call geom%clock(-90) if (geom%has_exc()) return if (.not. grad%any()) return call geom%clock(91) allocate (freq_w(0:ubound(geom%freq, 1))) freq_w = geom%freq%weight freq_w(0) = 1d0 dene_dalpha_scs_dyn(:, 0) = res%dE%dalpha + res%dE%dr_vdw * dr_vdw_scs%dV do i_freq = 1, n_freq dene_dalpha_scs_dyn(:, i_freq) = & res%dE%dC6 * dC6_scs_dalpha_dyn_scs(:, i_freq) end do if (grad%dcoords) then allocate (dE%dcoords(n_atoms, 3), source=0d0) do my_i_atom = 1, size(dalpha_dyn_scs, 1) i_atom = geom%idx%i_atom(my_i_atom) do i_freq = 0, n_freq dE%dcoords(geom%idx%j_atom, :) & = dE%dcoords(geom%idx%j_atom, :) & + freq_w(i_freq) * dene_dalpha_scs_dyn(i_atom, i_freq) & * dalpha_dyn_scs(my_i_atom, i_freq)%dcoords end do end do #ifdef WITH_SCALAPACK if (geom%idx%parallel) call blacs_all_reduce(dE%dcoords, geom%blacs) #endif dE%dcoords = dE%dcoords + res%dE%dcoords end if if (grad%dlattice) then allocate (dE%dlattice(3, 3), source=0d0) do my_i_atom = 1, size(dalpha_dyn_scs, 1) i_atom = geom%idx%i_atom(my_i_atom) if (.not. any(i_atom == geom%idx%j_atom)) cycle do i_freq = 0, n_freq dE%dlattice = dE%dlattice & + freq_w(i_freq) * dene_dalpha_scs_dyn(i_atom, i_freq) & * dalpha_dyn_scs(my_i_atom, i_freq)%dlattice end do end do #ifdef WITH_SCALAPACK if (geom%idx%parallel) call blacs_all_reduce(dE%dlattice, geom%blacs) #endif dE%dlattice = dE%dlattice + res%dE%dlattice end if if (grad%dalpha) then allocate (dE%dalpha(n_atoms), source=0d0) do my_i_atom = 1, size(dalpha_dyn_scs, 1) i_atom = geom%idx%i_atom(my_i_atom) do i_freq = 0, n_freq dE%dalpha(geom%idx%j_atom) = dE%dalpha(geom%idx%j_atom) + & freq_w(i_freq) * dene_dalpha_scs_dyn(i_atom, i_freq) * & dalpha_dyn_scs(my_i_atom, i_freq)%dalpha * ( & dalpha_dyn(i_freq)%dalpha(geom%idx%j_atom) & + dalpha_dyn(i_freq)%domega(geom%idx%j_atom) & * domega%dalpha(geom%idx%j_atom) & ) end do end do #ifdef WITH_SCALAPACK if (geom%idx%parallel) call blacs_all_reduce(dE%dalpha, geom%blacs) #endif dE%dalpha = dE%dalpha + res%dE%dr_vdw * dr_vdw_scs%dV_free end if if (grad%dC6) then allocate (dE%dC6(n_atoms), source=0d0) do my_i_atom = 1, size(dalpha_dyn_scs, 1) i_atom = geom%idx%i_atom(my_i_atom) do i_freq = 0, n_freq dE%dC6(geom%idx%j_atom) = dE%dC6(geom%idx%j_atom) + & freq_w(i_freq) * dene_dalpha_scs_dyn(i_atom, i_freq) * & dalpha_dyn_scs(my_i_atom, i_freq)%dalpha * & dalpha_dyn(i_freq)%domega(geom%idx%j_atom) & * domega%dC6(geom%idx%j_atom) end do end do #ifdef WITH_SCALAPACK if (geom%idx%parallel) call blacs_all_reduce(dE%dC6, geom%blacs) #endif end if if (grad%dr_vdw) then allocate (dE%dr_vdw(n_atoms), source=0d0) do my_i_atom = 1, size(dalpha_dyn_scs, 1) i_atom = geom%idx%i_atom(my_i_atom) do i_freq = 0, n_freq dE%dr_vdw(geom%idx%j_atom) = dE%dr_vdw(geom%idx%j_atom) + & freq_w(i_freq) * dene_dalpha_scs_dyn(i_atom, i_freq) * & dalpha_dyn_scs(my_i_atom, i_freq)%dr_vdw end do end do #ifdef WITH_SCALAPACK if (geom%idx%parallel) call blacs_all_reduce(dE%dr_vdw, geom%blacs) #endif dE%dr_vdw = dE%dr_vdw + res%dE%dr_vdw * dr_vdw_scs%dX_free end if res%dE = dE call geom%clock(-91) end function ! This used to be a function returning the k_pts array, but that was causing ! segfaults with some compilers. I suspect some combination of the product() ! in the dimension specification and assignemnt to allocatable array. subroutine make_k_pts(k_pts, k_grid, lattice, shift, dkdlattice, grad) real(dp), allocatable, intent(out) :: k_pts(:, :) integer, intent(in) :: k_grid(3) real(dp), intent(in) :: lattice(3, 3) real(dp), intent(in) :: shift real(dp), allocatable, intent(out) :: dkdlattice(:, :, :, :) logical, intent(in) :: grad integer :: n_kpt(3), i_kpt, i_latt, a, n_kpts real(dp) :: n_kpt_shifted(3), latt_inv(3, 3) n_kpts = product(k_grid) allocate (k_pts(3, n_kpts)) n_kpt = [0, 0, -1] do i_kpt = 1, n_kpts call shift_idx(n_kpt, [0, 0, 0], k_grid - 1) n_kpt_shifted = dble(n_kpt) + shift where (2 * n_kpt_shifted > k_grid) n_kpt_shifted = n_kpt_shifted - dble(k_grid) k_pts(:, i_kpt) = n_kpt_shifted / k_grid end do latt_inv = inverse(lattice) k_pts = matmul(2 * pi * transpose(latt_inv), k_pts) if (grad) then allocate (dkdlattice(3, n_kpts, 3, 3)) do concurrent(i_kpt=1:n_kpts, i_latt=1:3, a=1:3) dkdlattice(:, i_kpt, i_latt, a) = & -latt_inv(i_latt, :) * k_pts(a, i_kpt) end do end if end subroutine end module libmbd-libmbd-88d61bc/src/mbd_mpi.F90000066400000000000000000000034421452573331700173060ustar00rootroot00000000000000! This Source Code Form is subject to the terms of the Mozilla Public ! License, v. 2.0. If a copy of the MPL was not distributed with this ! file, You can obtain one at http://mozilla.org/MPL/2.0/. module mbd_mpi use mbd_constants, only: dp #ifndef WITH_MPIFH # ifndef WITH_MPIF08 use mpi # else use mpi_f08 # endif #endif implicit none #ifdef WITH_MPIFH include 'mpif.h' #endif private :: dp interface mpi_all_reduce module procedure mpi_all_reduce_real_0d module procedure mpi_all_reduce_real_1d module procedure mpi_all_reduce_real_2d end interface contains subroutine mpi_all_reduce_real_0d(x, comm) real(dp), intent(inout) :: x #ifdef WITH_MPIF08 type(MPI_Comm), intent(in) :: comm #else integer, intent(in) :: comm #endif real(dp) :: x_arr(1), x_buffer(1) integer :: ierr x_arr(1) = x call MPI_ALLREDUCE(x_arr, x_buffer, 1, MPI_DOUBLE_PRECISION, MPI_SUM, comm, ierr) x = x_buffer(1) end subroutine subroutine mpi_all_reduce_real_1d(x, comm) real(dp), intent(inout) :: x(:) #ifdef WITH_MPIF08 type(MPI_Comm), intent(in) :: comm #else integer, intent(in) :: comm #endif real(dp), allocatable :: x_buffer(:) integer :: ierr allocate (x_buffer(size(x))) call MPI_ALLREDUCE(x, x_buffer, size(x), MPI_DOUBLE_PRECISION, MPI_SUM, comm, ierr) x = x_buffer end subroutine subroutine mpi_all_reduce_real_2d(x, comm) real(dp), contiguous, target, intent(inout) :: x(:, :) #ifdef WITH_MPIF08 type(MPI_Comm), intent(in) :: comm #else integer, intent(in) :: comm #endif real(dp), pointer :: x_p(:) x_p(1:size(x)) => x call mpi_all_reduce_real_1d(x_p, comm) end subroutine integer function mpi_get_rank() result(rank) integer :: err call MPI_COMM_RANK(MPI_COMM_WORLD, rank, err) end function end module libmbd-libmbd-88d61bc/src/mbd_rpa.F90000066400000000000000000000073761452573331700173150ustar00rootroot00000000000000! This Source Code Form is subject to the terms of the Mozilla Public ! License, v. 2.0. If a copy of the MPL was not distributed with this ! file, You can obtain one at http://mozilla.org/MPL/2.0/. #ifndef DO_COMPLEX_TYPE module mbd_rpa use mbd_constants use mbd_damping, only: damping_t use mbd_dipole, only: dipole_matrix use mbd_formulas, only: sigma_selfint use mbd_geom, only: geom_t use mbd_matrix, only: matrix_re_t, matrix_cplx_t use mbd_utils, only: result_t, tostr implicit none private public :: get_mbd_rpa_energy interface get_mbd_rpa_energy module procedure get_mbd_rpa_energy_real module procedure get_mbd_rpa_energy_complex end interface contains #endif #ifndef DO_COMPLEX_TYPE type(result_t) function get_mbd_rpa_energy_real( & geom, alpha, damp) result(res) #else type(result_t) function get_mbd_rpa_energy_complex( & geom, alpha, damp, q) result(res) #endif type(geom_t), intent(inout) :: geom real(dp), intent(in) :: alpha(:, 0:) type(damping_t), intent(in) :: damp #ifdef DO_COMPLEX_TYPE real(dp), intent(in) :: q(3) #endif #ifndef DO_COMPLEX_TYPE type(matrix_re_t) :: relay, AT #else type(matrix_cplx_t) :: relay, AT #endif real(dp), allocatable :: eigs(:), log_eigs(:) integer :: i_freq, my_i_atom, n_order, n_negative_eigs, my_j_atom type(damping_t) :: damp_alpha res%energy = 0d0 damp_alpha = damp ! implicit allocation doesn't work here in gfortran 4.9 allocate (eigs(3 * geom%siz()), log_eigs(3 * geom%siz())) if (geom%get_rpa_orders) allocate (res%rpa_orders(geom%param%rpa_order_max), source=0d0) do i_freq = 0, ubound(geom%freq, 1) damp_alpha%sigma = sigma_selfint(alpha(:, i_freq)) #ifndef DO_COMPLEX_TYPE relay = dipole_matrix(geom, damp_alpha) #else relay = dipole_matrix(geom, damp_alpha, q=q) #endif do my_i_atom = 1, size(relay%idx%i_atom) do my_j_atom = 1, size(relay%idx%j_atom) associate ( & i_atom => relay%idx%i_atom(my_i_atom), & j_atom => relay%idx%j_atom(my_j_atom), & relay_sub => relay%val( & 3 * (my_i_atom - 1) + 1:, & 3 * (my_j_atom - 1) + 1: & ) & ) relay_sub(:3, :3) = relay_sub(:3, :3) & * sqrt(alpha(i_atom, i_freq) * alpha(j_atom, i_freq)) end associate end do end do call AT%move_from(relay) call geom%clock(23) eigs = AT%eigvalsh(geom%exc, destroy=.true.) call geom%clock(-23) if (geom%has_exc()) return if (geom%param%rpa_rescale_eigs) then where (eigs < 0) eigs = -erf(sqrt(pi) / 2 * eigs**4)**(1d0 / 4) end if n_negative_eigs = count(eigs(:) <= -1) if (n_negative_eigs > 0) then geom%exc%code = MBD_EXC_NEG_EIGVALS geom%exc%msg = "1+AT matrix has "// & trim(tostr(n_negative_eigs))//" negative eigenvalues" return end if log_eigs = log(1 + eigs) if (geom%param%rpa_rescale_eigs) then log_eigs = log_eigs - eigs end if res%energy = res%energy + & 1d0 / (2 * pi) * sum(log_eigs) * geom%freq(i_freq)%weight if (geom%get_rpa_orders) then do n_order = 2, geom%param%rpa_order_max res%rpa_orders(n_order) = res%rpa_orders(n_order) & + (-1d0 / (2 * pi) * (-1)**n_order & * sum(eigs**n_order) / n_order) & * geom%freq(i_freq)%weight end do end if end do end function #ifndef DO_COMPLEX_TYPE # define DO_COMPLEX_TYPE # include "mbd_rpa.F90" end module #endif libmbd-libmbd-88d61bc/src/mbd_scalapack.f90000066400000000000000000000244661452573331700205140ustar00rootroot00000000000000! This Source Code Form is subject to the terms of the Mozilla Public ! License, v. 2.0. If a copy of the MPL was not distributed with this ! file, You can obtain one at http://mozilla.org/MPL/2.0/. module mbd_scalapack use mbd_constants use mbd_lapack, only: mode use mbd_blacs, only: blacs_desc_t use mbd_utils, only: exception_t, tostr, clock_t implicit none private public :: pmmul, pinvh, peigh, peigvalsh interface pmmul module procedure pmmul_real module procedure pmmul_complex end interface interface pinvh module procedure pinvh_real end interface interface peigh module procedure peigh_real module procedure peigh_complex end interface interface peigvalsh module procedure peigvalsh_real module procedure peigvalsh_complex end interface interface ! The following interfaces were taken straight from the ScaLAPACK codebase, ! replacing COMPLEX*16 for COMPLEX(dp) SUBROUTINE PDSYEV(JOBZ, UPLO, N, A, IA, JA, DESCA, W, Z, IZ, JZ, DESCZ, WORK, LWORK, INFO) CHARACTER JOBZ, UPLO INTEGER IA, INFO, IZ, JA, JZ, LWORK, N INTEGER DESCA(*), DESCZ(*) DOUBLE PRECISION A(*), W(*), WORK(*), Z(*) END SUBROUTINE PZHEEV(JOBZ, UPLO, N, A, IA, JA, DESCA, W, Z, IZ, JZ, DESCZ, WORK, & LWORK, RWORK, LRWORK, INFO) import :: dp CHARACTER JOBZ, UPLO INTEGER IA, INFO, IZ, JA, JZ, LRWORK, LWORK, N INTEGER DESCA(*), DESCZ(*) DOUBLE PRECISION RWORK(*), W(*) COMPLEX(dp) A(*), WORK(*), Z(*) END SUBROUTINE PDGETRF(M, N, A, IA, JA, DESCA, IPIV, INFO) INTEGER IA, INFO, JA, M, N INTEGER DESCA(*), IPIV(*) DOUBLE PRECISION A(*) END SUBROUTINE PDGETRI(N, A, IA, JA, DESCA, IPIV, WORK, LWORK, IWORK, LIWORK, INFO) INTEGER IA, INFO, JA, LIWORK, LWORK, N INTEGER DESCA(*), IPIV(*), IWORK(*) DOUBLE PRECISION A(*), WORK(*) END ! The following interfaces were written by hand based on https://www.ibm.com/docs/ subroutine PDGEMM(transa, transb, m, n, k, alpha, a, ia, ja, desc_a, b, & ib, jb, desc_b, beta, c, ic, jc, desc_c) character :: transa, transb integer :: m, n, k, ia, ja, desc_a(*), ib, jb, desc_b(*), ic, jc, desc_c(*) double precision :: alpha, a(*), b(*), beta, c(*) end subroutine PZGEMM(transa, transb, m, n, k, alpha, a, ia, ja, desc_a, b, & ib, jb, desc_b, beta, c, ic, jc, desc_c) import :: dp character :: transa, transb integer :: m, n, k, ia, ja, desc_a(*), ib, jb, desc_b(*), ic, jc, desc_c(*) complex(dp) :: alpha, a(*), b(*), beta, c(*) end end interface contains subroutine pinvh_real(A, blacs, exc, src, clock) real(dp), intent(inout) :: A(:, :) type(blacs_desc_t), intent(in) :: blacs type(exception_t), intent(out), optional :: exc real(dp), intent(in), optional :: src(:, :) type(clock_t), intent(inout), optional :: clock integer, allocatable :: i_pivot(:), iwork_arr(:) real(dp), allocatable :: work_arr(:) integer :: n, n_work_arr, error_flag, n_iwork_arr(1) real(dp) :: n_work_arr_optim(1) n = 3 * blacs%n_atoms if (n == 0) return if (present(src)) A = src allocate (i_pivot(n)) if (present(clock)) call clock%clock(16) call PDGETRF(n, n, A, 1, 1, blacs%desc, i_pivot, error_flag) if (present(clock)) call clock%clock(-16) if (error_flag /= 0) then if (present(exc)) then exc%code = MBD_EXC_LINALG exc%origin = 'PDGETRF' exc%msg = 'Failed with code '//trim(tostr(error_flag)) end if return end if call PDGETRI( & n, A, 1, 1, blacs%desc, i_pivot, & n_work_arr_optim, -1, n_iwork_arr, -1, error_flag & ) n_work_arr = nint(n_work_arr_optim(1)) allocate (work_arr(n_work_arr), iwork_arr(n_iwork_arr(1))) if (present(clock)) call clock%clock(17) call PDGETRI( & n, A, 1, 1, blacs%desc, i_pivot, & work_arr, n_work_arr, iwork_arr, n_iwork_arr(1), error_flag & ) if (present(clock)) call clock%clock(-17) if (error_flag /= 0) then if (present(exc)) then exc%code = MBD_EXC_LINALG exc%origin = 'PDSYTRI' exc%msg = 'Failed with code '//trim(tostr(error_flag)) end if return end if end subroutine function pmmul_real(A, blacsA, B, blacsB, transA, transB, blacsC) result(C) real(dp), intent(in) :: A(:, :), B(:, :) type(blacs_desc_t), intent(in) :: blacsA, blacsB, blacsC character, intent(in), optional :: transA, transB real(dp) :: C(size(A, 1), size(B, 2)) character :: transA_, transB_ integer :: n transA_ = 'N' transB_ = 'N' if (present(transA)) transA_ = transA if (present(transB)) transB_ = transB n = 3 * blacsA%n_atoms call PDGEMM( & transA_, transB_, n, n, n, 1d0, A, 1, 1, blacsA%desc, & B, 1, 1, blacsB%desc, 0d0, C, 1, 1, blacsC%desc & ) end function function pmmul_complex(A, blacsA, B, blacsB, transA, transB, blacsC) result(C) complex(dp), intent(in) :: A(:, :), B(:, :) type(blacs_desc_t), intent(in) :: blacsA, blacsB, blacsC character, intent(in), optional :: transA, transB complex(dp) :: C(size(A, 1), size(B, 2)) character :: transA_, transB_ integer :: n transA_ = 'N' transB_ = 'N' if (present(transA)) transA_ = transA if (present(transB)) transB_ = transB n = 3 * blacsA%n_atoms call PZGEMM( & transA_, transB_, n, n, n, (1d0, 0d0), A, 1, 1, blacsA%desc, & B, 1, 1, blacsB%desc, (0d0, 0d0), C, 1, 1, blacsC%desc & ) end function subroutine peigh_real(A, blacs, eigs, exc, src, vals_only, clock) real(dp), intent(inout) :: A(:, :) type(blacs_desc_t), intent(in) :: blacs real(dp), intent(out) :: eigs(:) type(exception_t), intent(out), optional :: exc real(dp), intent(in), optional :: src(:, :) logical, intent(in), optional :: vals_only type(clock_t), intent(inout), optional :: clock real(dp), allocatable :: work_arr(:), vectors(:, :) real(dp) :: n_work_arr(1) integer :: error_flag, n n = 3 * blacs%n_atoms if (present(src)) A = src if (mode(vals_only) == 'V') then allocate (vectors(size(A, 1), size(A, 2))) else allocate (vectors(1, 1)) end if call PDSYEV( & mode(vals_only), 'U', n, A, 1, 1, blacs%desc, eigs, vectors, & 1, 1, blacs%desc, n_work_arr, -1, error_flag & ) allocate (work_arr(nint(n_work_arr(1)))) if (present(clock)) call clock%clock(13) call PDSYEV( & mode(vals_only), 'U', n, A, 1, 1, blacs%desc, eigs, vectors, & 1, 1, blacs%desc, work_arr(1), size(work_arr), error_flag & ) if (present(clock)) call clock%clock(-13) if (error_flag /= 0) then if (present(exc)) then exc%code = MBD_EXC_LINALG exc%origin = 'PDSYEV' exc%msg = 'Failed with code '//trim(tostr(error_flag)) end if return end if if (mode(vals_only) == 'V') A = vectors end subroutine subroutine peigh_complex(A, blacs, eigs, exc, src, vals_only, clock) complex(dp), intent(inout) :: A(:, :) type(blacs_desc_t), intent(in) :: blacs real(dp), intent(out) :: eigs(:) type(exception_t), intent(out), optional :: exc complex(dp), intent(in), optional :: src(:, :) logical, intent(in), optional :: vals_only type(clock_t), intent(inout), optional :: clock complex(dp), allocatable :: work_arr(:), vectors(:, :) integer :: n_work_arr, n_rwork_arr real(dp), allocatable :: rwork_arr(:) integer :: error_flag, n n = 3 * blacs%n_atoms if (present(src)) A = src if (mode(vals_only) == 'V') then allocate (vectors(size(A, 1), size(A, 2))) else allocate (vectors(1, 1)) end if allocate (work_arr(1), rwork_arr(1)) call PZHEEV( & mode(vals_only), 'U', n, A, 1, 1, blacs%desc, eigs, vectors, & 1, 1, blacs%desc, work_arr, -1, rwork_arr, -1, error_flag & ) n_work_arr = nint(dble(work_arr(1))) n_rwork_arr = nint(rwork_arr(1)) deallocate (work_arr, rwork_arr) if (mode(vals_only) == 'N') then n_rwork_arr = max(2 * n, n_rwork_arr) else n_rwork_arr = max(4 * n - 2, n_rwork_arr) end if allocate (work_arr(n_work_arr), source=(0d0, 0d0)) allocate (rwork_arr(n_rwork_arr), source=0d0) if (present(clock)) call clock%clock(13) call PZHEEV( & mode(vals_only), 'U', n, A, 1, 1, blacs%desc, eigs, vectors, & 1, 1, blacs%desc, work_arr, n_work_arr, rwork_arr, n_rwork_arr, & error_flag & ) if (present(clock)) call clock%clock(-13) if (error_flag /= 0) then if (present(exc)) then exc%code = MBD_EXC_LINALG exc%origin = 'PZHEEV' exc%msg = 'Failed with code '//trim(tostr(error_flag)) end if return end if if (mode(vals_only) == 'V') A = vectors end subroutine function peigvalsh_real(A, blacs, exc, destroy, clock) result(eigs) real(dp), target, intent(in) :: A(:, :) type(blacs_desc_t), intent(in) :: blacs type(exception_t), intent(out), optional :: exc logical, intent(in), optional :: destroy real(dp) :: eigs(3 * blacs%n_atoms) type(clock_t), intent(inout), optional :: clock real(dp), allocatable, target :: A_work(:, :) real(dp), pointer :: A_p(:, :) nullify (A_p) if (present(destroy)) then if (destroy) then A_p => A end if end if if (.not. associated(A_p)) then allocate (A_work(size(A, 1), size(A, 1)), source=A) A_p => A_work end if call peigh_real(A_p, blacs, eigs, exc, vals_only=.true., clock=clock) end function function peigvalsh_complex(A, blacs, exc, destroy, clock) result(eigs) complex(dp), target, intent(in) :: A(:, :) type(blacs_desc_t), intent(in) :: blacs type(exception_t), intent(out), optional :: exc logical, intent(in), optional :: destroy real(dp) :: eigs(3 * blacs%n_atoms) type(clock_t), intent(inout), optional :: clock complex(dp), allocatable, target :: A_work(:, :) complex(dp), pointer :: A_p(:, :) nullify (A_p) if (present(destroy)) then if (destroy) then A_p => A end if end if if (.not. associated(A_p)) then allocate (A_work(size(A, 1), size(A, 1)), source=A) A_p => A_work end if call peigh_complex(A_p, blacs, eigs, exc, vals_only=.true.) end function end module libmbd-libmbd-88d61bc/src/mbd_scs.f90000066400000000000000000000152461452573331700173560ustar00rootroot00000000000000! This Source Code Form is subject to the terms of the Mozilla Public ! License, v. 2.0. If a copy of the MPL was not distributed with this ! file, You can obtain one at http://mozilla.org/MPL/2.0/. module mbd_scs !! Performing self-consistent screening. use mbd_constants use mbd_damping, only: damping_t use mbd_dipole, only: dipole_matrix use mbd_formulas, only: sigma_selfint use mbd_geom, only: geom_t use mbd_gradients, only: grad_t, grad_matrix_re_t, grad_request_t use mbd_matrix, only: matrix_re_t, contract_cross_33 use mbd_utils, only: findval implicit none private public :: run_scs contains function run_scs(geom, alpha, damp, dalpha_scs, grad) result(alpha_scs) !! $$ !! \begin{gathered} !! \bar\alpha_i=\tfrac13\operatorname{Tr} !! \big(\textstyle\sum_j\boldsymbol{\bar\alpha}_{ij}\big),\qquad !! \boldsymbol{\bar\alpha}=(\boldsymbol\alpha^{-1}+\mathbf T_\text{GG})^{-1} !! \\ \partial\boldsymbol{\bar\alpha}= !! -\boldsymbol{\bar\alpha}( !! \partial\boldsymbol\alpha^{-1}+\partial\mathbf T_\text{GG} !! )\boldsymbol{\bar\alpha},\qquad !! \frac{\partial\bar\alpha_i}{\partial X_j}= !! -\frac13\sum_{\zeta\eta}\big( !! B_{i\zeta,j\eta}\bar\alpha'_{\zeta,j\eta}+ !! B'_{j\eta,\zeta}\bar\alpha_{j\eta,i\zeta} !! \big) !! \\ \mathbf B=\boldsymbol{\bar\alpha}\mathbf A, !! \quad A_{i\zeta,j\eta}= !! \frac{\partial(\alpha_i^{-1})}{\partial X_i} !! \delta_{ij}\delta_{\zeta\eta}+ !! \frac{\partial T^\text{GG}_{i\zeta,j\eta}}{\partial X_i},\quad !! \bar\alpha'_{\zeta,p}=\sum_i\bar\alpha_{i\zeta,p},\quad !! B'_{p,\zeta}=\sum_iB_{p,i\zeta} !! \end{gathered} !! $$ type(geom_t), intent(inout) :: geom real(dp), intent(in) :: alpha(:) type(damping_t), intent(in) :: damp type(grad_t), intent(out) :: dalpha_scs(:) type(grad_request_t), intent(in) :: grad real(dp) :: alpha_scs(size(alpha)) type(matrix_re_t) :: alpha_full, dQ, T integer :: n_atoms, i_xyz, i_atom, my_i_atom, i_latt type(damping_t) :: damp_local real(dp), allocatable :: dsij_dsi(:), dsigma_dalpha(:), & alpha_prime(:, :), B_prime(:, :), grads_i(:), dalphadA(:) real(dp) :: sigma_tmp(size(alpha)) ! circumventing PGI 19 compiler bug type(grad_matrix_re_t) :: dT type(grad_request_t) :: grad_req n_atoms = geom%siz() damp_local = damp sigma_tmp = sigma_selfint(alpha, dsigma_dalpha, grad%dalpha) damp_local%sigma = sigma_tmp grad_req = grad_request_t( & dcoords=grad%dcoords, & dlattice=grad%dlattice, & dsigma=grad%dalpha, & dr_vdw=grad%dr_vdw & ) call geom%clock(30) T = dipole_matrix(geom, damp_local, dT, grad_req) call geom%clock(-30) if (geom%has_exc()) return if (grad%any()) then call alpha_full%copy_from(T) else call alpha_full%move_from(T) end if call alpha_full%add_diag(1d0 / alpha) call geom%clock(32) call alpha_full%invh(geom%exc, clock=geom%timer) if (geom%has_exc()) return call geom%clock(-32) alpha_scs = alpha_full%contract_n33diag_cols() if (any(alpha_scs < 0)) then geom%exc%code = MBD_EXC_NEG_POL geom%exc%msg = 'Screening leads to negative polarizability' return end if if (.not. grad%any()) return call geom%clock(33) allocate (alpha_prime(3, 3 * n_atoms), source=0d0) allocate (B_prime(3 * n_atoms, 3), source=0d0) allocate (grads_i(n_atoms)) call alpha_full%contract_n_transp('R', alpha_prime) call dQ%init_from(T) if (grad%dcoords) then do my_i_atom = 1, size(geom%idx%i_atom) allocate (dalpha_scs(my_i_atom)%dcoords(size(geom%idx%j_atom), 3)) end do do i_xyz = 1, 3 dQ%val = -dT%dr(:, :, i_xyz) call geom%clock(14) dQ = alpha_full%mmul(dQ) call geom%clock(-14) call geom%clock(15) call dQ%contract_n_transp('C', B_prime) do i_atom = 1, n_atoms grads_i = contract_cross_33( & i_atom, dQ, alpha_prime, alpha_full, B_prime & ) my_i_atom = findval(geom%idx%i_atom, i_atom) if (my_i_atom > 0) then dalpha_scs(my_i_atom)%dcoords(:, i_xyz) = & grads_i(geom%idx%j_atom) end if end do call geom%clock(-15) end do end if if (grad%dlattice) then do my_i_atom = 1, size(geom%idx%i_atom) allocate (dalpha_scs(my_i_atom)%dlattice(3, 3)) end do do i_latt = 1, 3 do i_xyz = 1, 3 dQ%val = -dT%dlattice(:, :, i_latt, i_xyz) call geom%clock(14) dQ = alpha_full%mmul(dQ) dQ = dQ%mmul(alpha_full) call geom%clock(-14) call geom%clock(15) dalphadA = dQ%contract_n33diag_cols() do concurrent(my_i_atom=1:size(geom%idx%i_atom)) dalpha_scs(my_i_atom)%dlattice(i_latt, i_xyz) & = dalphadA(geom%idx%i_atom(my_i_atom)) end do call geom%clock(-15) end do end do end if if (grad%dalpha) then dQ%val = dT%dsigma do i_atom = 1, n_atoms dsij_dsi = damp_local%sigma(i_atom) * dsigma_dalpha(i_atom) / & sqrt(damp_local%sigma(i_atom)**2 + damp_local%sigma**2) call dQ%mult_col(i_atom, dsij_dsi) end do call dQ%add_diag(-0.5d0 / alpha**2) call geom%clock(14) dQ = alpha_full%mmul(dQ) call geom%clock(-14) call geom%clock(15) call dQ%contract_n_transp('C', B_prime) do i_atom = 1, n_atoms grads_i = contract_cross_33( & i_atom, dQ, alpha_prime, alpha_full, B_prime & ) my_i_atom = findval(geom%idx%i_atom, i_atom) if (my_i_atom > 0) then dalpha_scs(my_i_atom)%dalpha = grads_i(geom%idx%j_atom) end if end do call geom%clock(-15) end if if (grad%dr_vdw) then dQ%val = dT%dvdw call geom%clock(14) dQ = alpha_full%mmul(dQ) call geom%clock(-14) call geom%clock(15) call dQ%contract_n_transp('C', B_prime) do i_atom = 1, n_atoms grads_i = contract_cross_33( & i_atom, dQ, alpha_prime, alpha_full, B_prime & ) my_i_atom = findval(geom%idx%i_atom, i_atom) if (my_i_atom > 0) then dalpha_scs(my_i_atom)%dr_vdw = grads_i(geom%idx%j_atom) end if end do call geom%clock(-15) end if call geom%clock(-33) end function end module libmbd-libmbd-88d61bc/src/mbd_ts.F90000066400000000000000000000271311452573331700171500ustar00rootroot00000000000000! This Source Code Form is subject to the terms of the Mozilla Public ! License, v. 2.0. If a copy of the MPL was not distributed with this ! file, You can obtain one at http://mozilla.org/MPL/2.0/. module mbd_ts !! Obtaining TS energies. use mbd_constants use mbd_utils, only: shift_idx, tostr, result_t, diff3 use mbd_damping, only: damping_t, damping_fermi use mbd_geom, only: geom_t, supercell_circum use mbd_gradients, only: grad_request_t, grad_scalar_t use mbd_lapack, only: eigvals, inverse #ifdef WITH_MPI use mbd_mpi, only: mpi_all_reduce #endif implicit none private public :: get_ts_energy contains type(result_t) function get_ts_energy(geom, alpha_0, C6, damp, grad) result(res) !! Get TS energy. type(geom_t), intent(inout) :: geom real(dp), intent(in) :: alpha_0(:) real(dp), intent(in) :: C6(:) type(damping_t), intent(in) :: damp type(grad_request_t), intent(in) :: grad real(dp) :: C6_ij, Rnij(3), Rnij_norm, R_vdw_ij, ene_ij, Rn(3), f_damp integer :: i_cell, i_atom, j_atom, range_n(3), n(3), n_atoms, i_latt logical :: is_periodic, do_ewald type(grad_request_t) :: grad_ij type(grad_scalar_t) :: df, dC6, dphi, dene_ij do_ewald = .false. is_periodic = allocated(geom%lattice) n_atoms = geom%siz() grad_ij = grad grad_ij%dcoords = grad%dcoords .or. grad%dlattice if (is_periodic) then do_ewald = geom%gamm > 0d0 range_n = supercell_circum(geom%lattice, geom%real_space_cutoff) else range_n(:) = 0 end if if (grad%dcoords) allocate (res%dE%dcoords(n_atoms, 3), source=0d0) if (grad%dlattice) allocate (res%dE%dlattice(3, 3), source=0d0) if (grad%dC6) allocate (res%dE%dC6(n_atoms), source=0d0) if (grad%dalpha) allocate (res%dE%dalpha(n_atoms), source=0d0) if (grad%dr_vdw) allocate (res%dE%dr_vdw(n_atoms), source=0d0) res%energy = 0d0 n = [0, 0, -1] each_cell: do i_cell = 1, product(1 + 2 * range_n) call shift_idx(n, -range_n, range_n) if (is_periodic) then Rn = matmul(geom%lattice, n) else Rn(:) = 0d0 end if each_atom: do i_atom = 1, geom%siz() #ifdef WITH_MPI if (modulo(i_atom, geom%mpi_size) /= geom%mpi_rank) cycle #endif each_atom_pair: do j_atom = 1, i_atom if (i_cell == 1) then if (i_atom == j_atom) cycle end if Rnij = geom%coords(:, i_atom) - geom%coords(:, j_atom) - Rn Rnij_norm = sqrt(sum(Rnij**2)) if (is_periodic .and. Rnij_norm > geom%real_space_cutoff) cycle C6_ij = combine_C6( & C6(i_atom), C6(j_atom), alpha_0(i_atom), alpha_0(j_atom), dC6, grad & ) if (allocated(damp%r_vdw)) then R_vdw_ij = damp%r_vdw(i_atom) + damp%r_vdw(j_atom) end if select case (damp%version) case ("fermi") f_damp = damping_fermi( & Rnij, damp%ts_sr * R_vdw_ij, damp%ts_d, df, grad_ij & ) case ("fermi2") f_damp = damping_fermi(Rnij, damp%ts_sr * R_vdw_ij, damp%ts_d)**2 case ("custom") f_damp = damp%damping_custom(i_atom, j_atom) end select ene_ij = -C6_ij * f_damp / Rnij_norm**6 if (grad_ij%dcoords) & dene_ij%dr = ene_ij * (df%dr / f_damp - 6 * Rnij / Rnij_norm**2) if (grad_ij%dr_vdw) dene_ij%dvdw = ene_ij / f_damp * df%dvdw * damp%ts_sr if (do_ewald) then ene_ij = ene_ij - C6_ij * ( & disp_real(Rnij_norm, geom%gamm, dphi, grad_ij) & - 1d0 / Rnij_norm**6 & ) if (grad_ij%dcoords) dene_ij%dr = dene_ij%dr & - C6_ij * (dphi%dr_1 + 6 / Rnij_norm**7) * Rnij / Rnij_norm end if if (i_atom == j_atom) then ene_ij = ene_ij / 2 if (grad_ij%dcoords) dene_ij%dr = dene_ij%dr / 2 if (grad_ij%dr_vdw) dene_ij%dvdw = dene_ij%dvdw / 2 end if res%energy = res%energy + ene_ij if (.not. grad%any()) cycle if (grad%dcoords) then res%dE%dcoords(i_atom, :) = res%dE%dcoords(i_atom, :) + dene_ij%dr res%dE%dcoords(j_atom, :) = res%dE%dcoords(j_atom, :) - dene_ij%dr end if if (grad%dlattice) then do concurrent(i_latt=1:3) res%dE%dlattice(i_latt, :) = res%dE%dlattice(i_latt, :) & - dene_ij%dr * n(i_latt) end do end if if (grad%dC6) then res%dE%dC6(i_atom) = res%dE%dC6(i_atom) + ene_ij / C6_ij * dC6%dC6i res%dE%dC6(j_atom) = res%dE%dC6(j_atom) + ene_ij / C6_ij * dC6%dC6j end if if (grad%dalpha) then res%dE%dalpha(i_atom) = res%dE%dalpha(i_atom) + ene_ij / C6_ij * dC6%da0i res%dE%dalpha(j_atom) = res%dE%dalpha(j_atom) + ene_ij / C6_ij * dC6%da0j end if if (grad%dr_vdw) then res%dE%dr_vdw(i_atom) = res%dE%dr_vdw(i_atom) + dene_ij%dvdw res%dE%dr_vdw(j_atom) = res%dE%dr_vdw(j_atom) + dene_ij%dvdw end if end do each_atom_pair end do each_atom end do each_cell if (do_ewald) call add_ewald_ts_parts(geom, alpha_0, C6, res, grad) #ifdef WITH_MPI call mpi_all_reduce(res%energy, geom%mpi_comm) if (grad%dcoords) call mpi_all_reduce(res%dE%dcoords, geom%mpi_comm) if (grad%dlattice) call mpi_all_reduce(res%dE%dlattice, geom%mpi_comm) if (grad%dalpha) call mpi_all_reduce(res%dE%dalpha, geom%mpi_comm) if (grad%dC6) call mpi_all_reduce(res%dE%dC6, geom%mpi_comm) if (grad%dR_vdw) call mpi_all_reduce(res%dE%dR_vdw, geom%mpi_comm) #endif end function subroutine add_ewald_ts_parts(geom, alpha_0, C6, res, grad) type(geom_t), intent(in) :: geom real(dp), intent(in) :: alpha_0(:) real(dp), intent(in) :: C6(:) type(result_t), intent(inout) :: res type(grad_request_t), intent(in) :: grad real(dp) :: rec_latt(3, 3), volume, Rij(3), k(3), phi, dkdAk_proj, & k_norm, k_Rij, latt_inv(3, 3), C6_ij, exp_kR, ene_ij, dkdA(3) integer :: i_atom, j_atom, m(3), i_m, range_m(3), i_latt, i_xyz type(grad_scalar_t) :: dC6, dphi, dene_ij latt_inv = inverse(geom%lattice) rec_latt = 2 * pi * transpose(latt_inv) volume = abs(dble(product(eigvals(geom%lattice)))) range_m = supercell_circum(rec_latt, geom%rec_space_cutoff) m = [0, 0, -1] each_recip_vec: do i_m = 1, product(1 + 2 * range_m) call shift_idx(m, -range_m, range_m) k = matmul(rec_latt, m) k_norm = sqrt(sum(k**2)) if (k_norm > geom%rec_space_cutoff) cycle each_atom: do i_atom = 1, geom%siz() #ifdef WITH_MPI if (modulo(i_atom, geom%mpi_size) /= geom%mpi_rank) cycle #endif each_atom_pair: do j_atom = 1, i_atom C6_ij = combine_C6( & C6(i_atom), C6(j_atom), alpha_0(i_atom), alpha_0(j_atom), dC6, grad & ) Rij = geom%coords(:, i_atom) - geom%coords(:, j_atom) k_Rij = dot_product(k, Rij) exp_kR = cos(k_Rij) phi = disp_rec(k_norm, geom%gamm, dphi, grad) ene_ij = -C6_ij * phi / volume * exp_kR if (i_atom == j_atom) ene_ij = ene_ij / 2 res%energy = res%energy + ene_ij if (grad%dcoords .and. i_atom /= j_atom) then dene_ij%dr = ene_ij / exp_kR * sin(k_Rij) * k res%dE%dcoords(i_atom, :) = res%dE%dcoords(i_atom, :) - dene_ij%dr res%dE%dcoords(j_atom, :) = res%dE%dcoords(j_atom, :) + dene_ij%dr end if if (grad%dlattice) then #ifndef WITHOUT_DO_CONCURRENT do concurrent(i_latt=1:3, i_xyz=1:3) #else do i_latt = 1, 3 do i_xyz = 1, 3 #endif dkdA = -latt_inv(i_latt, :) * k(i_xyz) if (k_norm > 0d0) then dkdAk_proj = dot_product(dkdA, k) / k_norm else dkdAk_proj = 0d0 end if res%dE%dlattice(i_latt, i_xyz) = res%dE%dlattice(i_latt, i_xyz) & - ene_ij * latt_inv(i_latt, i_xyz) & - ene_ij / exp_kR * sin(k_Rij) * dot_product(dkdA, Rij) & + ene_ij / phi * dphi%dk_1 * dkdAk_proj #ifdef WITHOUT_DO_CONCURRENT end do #endif end do end if if (grad%dC6) then res%dE%dC6(i_atom) = res%dE%dC6(i_atom) + ene_ij / C6_ij * dC6%dC6i res%dE%dC6(j_atom) = res%dE%dC6(j_atom) + ene_ij / C6_ij * dC6%dC6j end if if (grad%dalpha) then res%dE%dalpha(i_atom) = res%dE%dalpha(i_atom) + ene_ij / C6_ij * dC6%da0i res%dE%dalpha(j_atom) = res%dE%dalpha(j_atom) + ene_ij / C6_ij * dC6%da0j end if end do each_atom_pair end do each_atom end do each_recip_vec do i_atom = 1, geom%siz() #ifdef WITH_MPI if (modulo(i_atom, geom%mpi_size) /= geom%mpi_rank) cycle #endif res%energy = res%energy + geom%gamm**6 / 12 * C6(i_atom) ! self energy if (grad%dC6) then res%dE%dC6(i_atom) = res%dE%dC6(i_atom) + geom%gamm**6 / 12 end if end do end subroutine real(dp) function combine_C6( & C6_i, C6_j, alpha_0_i, alpha_0_j, dC6, grad) result(C6_ij) real(dp), intent(in) :: C6_i, C6_j, alpha_0_i, alpha_0_j type(grad_scalar_t), intent(out) :: dC6 type(grad_request_t), intent(in) :: grad C6_ij = 2 * C6_i * C6_j & / (alpha_0_j / alpha_0_i * C6_i + alpha_0_i / alpha_0_j * C6_j) if (grad%dC6) then dC6%dC6i = C6_ij**2 * alpha_0_i / (2 * C6_i**2 * alpha_0_j) dC6%dC6j = C6_ij**2 * alpha_0_j / (2 * C6_j**2 * alpha_0_i) end if if (grad%dalpha) then dC6%da0i = C6_ij * (1 / alpha_0_i - C6_ij / (C6_i * alpha_0_j)) dC6%da0j = C6_ij * (1 / alpha_0_j - C6_ij / (C6_j * alpha_0_i)) end if end function real(dp) function disp_real(r, gamm, dphi, grad) result(phi) real(dp), intent(in) :: r, gamm type(grad_scalar_t), intent(out) :: dphi type(grad_request_t), intent(in) :: grad real(dp) :: gamm_r gamm_r = gamm * r phi = (2 + 2 * gamm_r**2 + gamm_r**4) * gamm**6 & / (2 * exp(gamm_r**2) * gamm_r**6) if (grad%dcoords) then dphi%dr_1 = -gamm**7 * (6 + 6 * gamm_r**2 + 3 * gamm_r**4 + gamm_r**6) & / (exp(gamm_r**2) * gamm_r**7) end if end function real(dp) function disp_rec(k, gamm, dphi, grad) result(phi) real(dp), intent(in) :: k, gamm type(grad_scalar_t), intent(out) :: dphi type(grad_request_t), intent(in) :: grad real(dp) :: k_gamm k_gamm = k / gamm phi = pi**1.5d0 * gamm**3 / 12 * ( & (-2 * (-2 + k_gamm**2)) / exp(k_gamm**2 / 4) & + k_gamm**3 * sqrt(pi) * erfc(k_gamm / 2) & ) if (grad%dlattice) then dphi%dk_1 = k_gamm * pi**1.5d0 * gamm**2 / 4 * ( & -2 / exp(k_gamm**2 / 4) + k_gamm * sqrt(pi) * erfc(k_gamm / 2) & ) end if end function end module libmbd-libmbd-88d61bc/src/mbd_utils.F90000066400000000000000000000201531452573331700176570ustar00rootroot00000000000000! This Source Code Form is subject to the terms of the Mozilla Public ! License, v. 2.0. If a copy of the MPL was not distributed with this ! file, You can obtain one at http://mozilla.org/MPL/2.0/. module mbd_utils !! Utility types, interfaces, and procedures. use mbd_constants use mbd_gradients, only: grad_t #ifdef WITH_MPI use mbd_mpi #endif implicit none private public :: tostr, diff3, diff5, lower, diff7, findval, shift_idx, & is_true, printer_i, printer integer, parameter :: i8 = selected_int_kind(18) interface tostr module procedure tostr_int module procedure tostr_real end interface interface findval module procedure findval_int end interface abstract interface subroutine printer_i(str) character(len=*), intent(in) :: str end subroutine end interface type, public :: logger_t integer :: level = MBD_LOG_LVL_WARN ! TODO cannot use printer() as default because of PGI 19.4 procedure(printer_i), nopass, pointer :: printer => null() contains procedure :: info => logger_info procedure :: debug => logger_debug procedure :: warn => logger_warn procedure :: error => logger_error end type type, public :: exception_t !! Represents an exception. integer :: code = 0 character(50) :: origin = '(unknown)' character(150) :: msg = '' end type type, public :: result_t !! Stores results from an MBD calculation real(dp) :: energy type(grad_t) :: dE real(dp), allocatable :: mode_eigs(:) real(dp), allocatable :: modes(:, :) real(dp), allocatable :: rpa_orders(:) real(dp), allocatable :: mode_eigs_k(:, :) complex(dp), allocatable :: modes_k(:, :, :) complex(dp), allocatable :: modes_k_single(:, :) real(dp), allocatable :: rpa_orders_k(:, :) real(dp), allocatable :: alpha_0(:) real(dp), allocatable :: C6(:) end type type, public :: atom_index_t !! Maps from atom indexes to positions in matrices. integer, allocatable :: i_atom(:) integer, allocatable :: j_atom(:) integer :: n_atoms # ifdef WITH_SCALAPACK logical :: parallel # endif end type type, public :: clock_t !! Used for measuring performance. logical :: active = .true. integer :: level = 0 integer(i8), allocatable :: timestamps(:), counts(:) integer, allocatable :: levels(:) contains procedure :: init => clock_init procedure :: clock => clock_clock procedure :: print => clock_print end type type, public :: quad_pt_t !! Represents a 1D quadrature point real(dp) :: val real(dp) :: weight end type contains character(len=50) elemental function tostr_int(k, format) result(s) integer, intent(in) :: k character(len=*), intent(in), optional :: format if (present(format)) then write (s, format) k else write (s, "(i20)") k end if s = adjustl(s) end function character(len=50) elemental function tostr_real(x, format) result(s) real(dp), intent(in) :: x character(*), intent(in), optional :: format if (present(format)) then write (s, format) x else write (s, "(g50.17e3)") x end if s = adjustl(s) end function real(dp) pure function diff3(x, delta) real(dp), intent(in) :: x(-1:) real(dp), intent(in) :: delta diff3 = (x(1) - x(-1)) / (2 * delta) end function real(dp) pure function diff5(x, delta) real(dp), intent(in) :: x(-2:) real(dp), intent(in) :: delta diff5 = (1.d0 / 12 * x(-2) - 2.d0 / 3 * x(-1) + 2.d0 / 3 * x(1) - 1.d0 / 12 * x(2)) / delta end function real(dp) pure function diff7(x, delta) real(dp), intent(in) :: x(-3:) real(dp), intent(in) :: delta diff7 = ( & -1.d0 / 60 * x(-3) & + 3.d0 / 20 * x(-2) & - 3.d0 / 4 * x(-1) & + 3.d0 / 4 * x(1) & - 3.d0 / 20 * x(2) & + 1.d0 / 60 * x(3) & ) / delta end function pure function lower(str) character(len=*), intent(in) :: str character(len=len(str)) :: lower integer :: i do i = 1, len(str) select case (str(i:i)) case ('A':'Z') lower(i:i) = achar(iachar(str(i:i)) + 32) case default lower(i:i) = str(i:i) end select end do end function integer pure function findval_int(array, val) result(idx) integer, intent(in) :: array(:), val integer :: i idx = 0 do i = 1, size(array) if (val == array(i)) then idx = i return end if end do end function subroutine shift_idx(idx, start, finish) integer, intent(inout) :: idx(:) integer, intent(in) :: start(:), finish(:) integer :: i_dim, i do i_dim = size(idx), 1, -1 i = idx(i_dim) + 1 if (i <= finish(i_dim)) then idx(i_dim) = i return else idx(i_dim) = start(i_dim) end if end do end subroutine subroutine clock_init(this, n) class(clock_t), intent(inout) :: this integer, intent(in) :: n allocate (this%timestamps(n), source=0_i8) allocate (this%counts(n), source=0_i8) allocate (this%levels(n), source=0) end subroutine subroutine clock_clock(this, id) class(clock_t), intent(inout) :: this integer, intent(in) :: id integer(i8) :: cnt, rate, cnt_max integer :: id_ if (.not. this%active) return call system_clock(cnt, rate, cnt_max) id_ = abs(id) if (id > 0) then this%timestamps(id_) = this%timestamps(id_) - cnt this%levels(id_) = this%level this%level = this%level + 1 else this%timestamps(id_) = this%timestamps(id_) + cnt this%counts(id_) = this%counts(id_) + 1 this%level = this%level - 1 end if end subroutine subroutine clock_print(this) class(clock_t), intent(inout) :: this integer(i8) :: cnt, rate, cnt_max integer :: i character(len=20) :: label #ifdef WITH_MPI if (mpi_get_rank() /= 0) return #endif call system_clock(cnt, rate, cnt_max) print '(A5,A7,A20,A10,A16)', 'id', 'level', 'label', 'count', 'time (s)' do i = 1, size(this%counts) if (this%counts(i) == 0) cycle select case (i) case (11); label = 'dipmat real' case (12); label = 'dipmat rec' case (13); label = 'P_EVR' case (14); label = 'mmul' case (15); label = 'force contractions' case (16); label = 'PDGETRF' case (17); label = 'PDGETRI' case (18); label = 'ELSI ev' case (20); label = 'MBD dipole' case (21); label = 'MBD eig' case (22); label = 'MBD forces' case (23); label = 'RPA eig' case (30); label = 'SCS dipole' case (32); label = 'SCS inv' case (33); label = 'SCS forces' case (50); label = 'SCS' case (51); label = 'MBD k-point' case (52); label = 'MBD' case (90); label = 'MBD@rsSCS' case (91); label = 'MBD@rsSCS forces' case default label = '('//trim(tostr(i))//')' end select print '(I5,I7," ",A20,I10,F16.6)', i, this%levels(i), label, this%counts(i), & dble(this%timestamps(i)) / rate end do end subroutine subroutine printer(str) character(len=*), intent(in) :: str #ifdef WITH_MPI if (mpi_get_rank() /= 0) return #endif print *, str end subroutine subroutine logger_debug(this, str) class(logger_t), intent(in) :: this character(len=*), intent(in) :: str if (this%level <= MBD_LOG_LVL_DEBUG) call this%printer(str) end subroutine subroutine logger_info(this, str) class(logger_t), intent(in) :: this character(len=*), intent(in) :: str if (this%level <= MBD_LOG_LVL_INFO) call this%printer(str) end subroutine subroutine logger_warn(this, str) class(logger_t), intent(in) :: this character(len=*), intent(in) :: str if (this%level <= MBD_LOG_LVL_WARN) call this%printer(str) end subroutine subroutine logger_error(this, str) class(logger_t), intent(in) :: this character(len=*), intent(in) :: str if (this%level <= MBD_LOG_LVL_ERROR) call this%printer(str) end subroutine logical function is_true(val) result(res) logical, intent(in), optional :: val res = .false. if (present(val)) res = val end function end module libmbd-libmbd-88d61bc/src/mbd_vdw_param.f90000066400000000000000000000256141452573331700205460ustar00rootroot00000000000000! This Source Code Form is subject to the terms of the Mozilla Public ! License, v. 2.0. If a copy of the MPL was not distributed with this ! file, You can obtain one at http://mozilla.org/MPL/2.0/. module mbd_vdw_param use mbd_constants use mbd_utils, only: lower implicit none private public :: ts_vdw_params, tssurf_vdw_params, species_index real(dp), parameter :: ts_vdw_params(3, 102) = reshape([ & 4.5d0, 6.5d0, 3.1d0, & ! H 1.38d0, 1.46d0, 2.65d0, & ! He 164.2d0, 1387.0d0, 4.16d0, & ! Li 38.0d0, 214.0d0, 4.17d0, & ! Be 21.0d0, 99.5d0, 3.89d0, & ! B 12.0d0, 46.6d0, 3.59d0, & ! C 7.4d0, 24.2d0, 3.34d0, & ! N 5.4d0, 15.6d0, 3.19d0, & ! O 3.8d0, 9.52d0, 3.04d0, & ! F 2.67d0, 6.38d0, 2.91d0, & ! Ne 162.7d0, 1556.0d0, 3.73d0, & ! Na 71.0d0, 627.0d0, 4.27d0, & ! Mg 60.0d0, 528.0d0, 4.33d0, & ! Al 37.0d0, 305.0d0, 4.2d0, & ! Si 25.0d0, 185.0d0, 4.01d0, & ! P 19.6d0, 134.0d0, 3.86d0, & ! S 15.0d0, 94.6d0, 3.71d0, & ! Cl 11.1d0, 64.3d0, 3.55d0, & ! Ar 292.9d0, 3897.0d0, 3.71d0, & ! K 160.0d0, 2221.0d0, 4.65d0, & ! Ca 120.0d0, 1383.0d0, 4.59d0, & ! Sc 98.0d0, 1044.0d0, 4.51d0, & ! Ti 84.0d0, 832.0d0, 4.44d0, & ! V 78.0d0, 602.0d0, 3.99d0, & ! Cr 63.0d0, 552.0d0, 3.97d0, & ! Mn 56.0d0, 482.0d0, 4.23d0, & ! Fe 50.0d0, 408.0d0, 4.18d0, & ! Co 48.0d0, 373.0d0, 3.82d0, & ! Ni 42.0d0, 253.0d0, 3.76d0, & ! Cu 40.0d0, 284.0d0, 4.02d0, & ! Zn 60.0d0, 498.0d0, 4.19d0, & ! Ga 41.0d0, 354.0d0, 4.2d0, & ! Ge 29.0d0, 246.0d0, 4.11d0, & ! As 25.0d0, 210.0d0, 4.04d0, & ! Se 20.0d0, 162.0d0, 3.93d0, & ! Br 16.8d0, 129.6d0, 3.82d0, & ! Kr 319.2d0, 4691.0d0, 3.72d0, & ! Rb 199.0d0, 3170.0d0, 4.54d0, & ! Sr 126.737d0, 1968.58d0, 4.8151d0, & ! Y 119.97d0, 1677.91d0, 4.53d0, & ! Zr 101.603d0, 1263.61d0, 4.2365d0, & ! Nb 88.4225785d0, 1028.73d0, 4.099d0, & ! Mo 80.083d0, 1390.87d0, 4.076d0, & ! Tc 65.895d0, 609.754d0, 3.9953d0, & ! Ru 56.1d0, 469.0d0, 3.95d0, & ! Rh 23.68d0, 157.5d0, 3.66d0, & ! Pd 50.6d0, 339.0d0, 3.82d0, & ! Ag 39.7d0, 452.0d0, 3.99d0, & ! Cd 70.22d0, 707.046d0, 4.23198d0, & ! In 55.95d0, 587.417d0, 4.303d0, & ! Sn 43.67197d0, 459.322d0, 4.276d0, & ! Sb 37.65d0, 396.0d0, 4.22d0, & ! Te 35.0d0, 385.0d0, 4.17d0, & ! I 27.3d0, 285.9d0, 4.08d0, & ! Xe 427.12d0, 6582.08d0, 3.78d0, & ! Cs 275.0d0, 5727.0d0, 4.77d0, & ! Ba 213.7d0, 3884.5d0, 3.14d0, & ! La 204.7d0, 3708.33d0, 3.26d0, & ! Ce 215.8d0, 3911.84d0, 3.28d0, & ! Pr 208.4d0, 3908.75d0, 3.3d0, & ! Nd 200.2d0, 3847.68d0, 3.27d0, & ! Pm 192.1d0, 3708.69d0, 3.32d0, & ! Sm 184.2d0, 3511.71d0, 3.4d0, & ! Eu 158.3d0, 2781.53d0, 3.62d0, & ! Gd 169.5d0, 3124.41d0, 3.42d0, & ! Tb 164.64d0, 2984.29d0, 3.26d0, & ! Dy 156.3d0, 2839.95d0, 3.24d0, & ! Ho 150.2d0, 2724.12d0, 3.3d0, & ! Er 144.3d0, 2576.78d0, 3.26d0, & ! Tm 138.9d0, 2387.53d0, 3.22d0, & ! Yb 137.2d0, 2371.8d0, 3.2d0, & ! Lu 99.52d0, 1274.8d0, 4.21d0, & ! Hf 82.53d0, 1019.92d0, 4.15d0, & ! Ta 71.041d0, 847.93d0, 4.08d0, & ! W 63.04d0, 710.2d0, 4.02d0, & ! Re 55.055d0, 596.67d0, 3.84d0, & ! Os 42.51d0, 359.1d0, 4.0d0, & ! Ir 39.68d0, 347.1d0, 3.92d0, & ! Pt 36.5d0, 298.0d0, 3.86d0, & ! Au 33.9d0, 392.0d0, 3.98d0, & ! Hg 69.92d0, 717.44d0, 3.91d0, & ! Tl 61.8d0, 697.0d0, 4.31d0, & ! Pb 49.02d0, 571.0d0, 4.32d0, & ! Bi 45.013d0, 530.92d0, 4.097d0, & ! Po 38.93d0, 457.53d0, 4.07d0, & ! At 33.54d0, 390.63d0, 4.23d0, & ! Rn 317.8d0, 4224.44d0, 3.9d0, & ! Fr 246.2d0, 4851.32d0, 4.98d0, & ! Ra 203.3d0, 3604.41d0, 2.75d0, & ! Ac 217.0d0, 4047.54d0, 2.85d0, & ! Th 154.4d0, 2367.42d0, 2.71d0, & ! Pa 127.8d0, 1877.1d0, 3.0d0, & ! U 150.5d0, 2507.88d0, 3.28d0, & ! Np 132.2d0, 2117.27d0, 3.45d0, & ! Pu 131.2d0, 2110.98d0, 3.51d0, & ! Am 143.6d0, 2403.22d0, 3.47d0, & ! Cm 125.3d0, 1985.82d0, 3.56d0, & ! Bk 121.5d0, 1891.92d0, 3.55d0, & ! Cf 117.5d0, 1851.1d0, 3.76d0, & ! Es 113.4d0, 1787.07d0, 3.89d0, & ! Fm 109.4d0, 1701.0d0, 3.93d0, & ! Md 105.4d0, 1578.18d0, 3.78d0 & ! No ], [3, 102]) real(dp), parameter :: tssurf_vdw_params(3, 102) = reshape([ & 4.5d0, 6.5d0, 3.1d0, & ! H 1.38d0, 1.46d0, 2.65d0, & ! He 164.2d0, 1387.0d0, 4.16d0, & ! Li 38.0d0, 214.0d0, 4.17d0, & ! Be 21.0d0, 99.5d0, 3.89d0, & ! B 12.0d0, 46.6d0, 3.59d0, & ! C 7.4d0, 24.2d0, 3.34d0, & ! N 5.4d0, 15.6d0, 3.19d0, & ! O 3.8d0, 9.52d0, 3.04d0, & ! F 2.67d0, 6.38d0, 2.91d0, & ! Ne 162.7d0, 1556.0d0, 3.73d0, & ! Na 71.0d0, 627.0d0, 4.27d0, & ! Mg 60.0d0, 528.0d0, 4.33d0, & ! Al 37.0d0, 305.0d0, 4.2d0, & ! Si 25.0d0, 185.0d0, 4.01d0, & ! P 19.6d0, 134.0d0, 3.86d0, & ! S 15.0d0, 94.6d0, 3.71d0, & ! Cl 11.1d0, 64.3d0, 3.55d0, & ! Ar 292.9d0, 3897.0d0, 3.71d0, & ! K 160.0d0, 2221.0d0, 4.65d0, & ! Ca 120.0d0, 1383.0d0, 4.59d0, & ! Sc 98.0d0, 1044.0d0, 4.51d0, & ! Ti 84.0d0, 832.0d0, 4.44d0, & ! V 78.0d0, 602.0d0, 3.99d0, & ! Cr 63.0d0, 552.0d0, 3.97d0, & ! Mn 56.0d0, 482.0d0, 4.23d0, & ! Fe 50.0d0, 408.0d0, 4.18d0, & ! Co 10.22d0, 59.2d0, 2.28d0, & ! Ni 10.88d0, 58.9d0, 2.4d0, & ! Cu 13.77d0, 46.0d0, 2.82d0, & ! Zn 60.0d0, 498.0d0, 4.19d0, & ! Ga 41.0d0, 354.0d0, 4.2d0, & ! Ge 29.0d0, 246.0d0, 4.11d0, & ! As 25.0d0, 210.0d0, 4.04d0, & ! Se 20.0d0, 162.0d0, 3.93d0, & ! Br 16.8d0, 129.6d0, 3.82d0, & ! Kr 319.2d0, 4691.0d0, 3.72d0, & ! Rb 199.0d0, 3170.0d0, 4.54d0, & ! Sr 126.737d0, 1968.58d0, 4.8151d0, & ! Y 119.97d0, 1677.91d0, 4.53d0, & ! Zr 101.603d0, 1263.61d0, 4.2365d0, & ! Nb 88.4225785d0, 1028.73d0, 4.099d0, & ! Mo 80.083d0, 1390.87d0, 4.076d0, & ! Tc 65.895d0, 609.754d0, 3.9953d0, & ! Ru 56.1d0, 469.0d0, 3.95d0, & ! Rh 13.9d0, 102.0d0, 3.06d0, & ! Pd 15.36d0, 122.0d0, 2.57d0, & ! Ag 39.7d0, 452.0d0, 3.99d0, & ! Cd 70.22d0, 707.046d0, 4.23198d0, & ! In 55.95d0, 587.417d0, 4.303d0, & ! Sn 43.67197d0, 459.322d0, 4.276d0, & ! Sb 37.65d0, 396.0d0, 4.22d0, & ! Te 35.0d0, 385.0d0, 4.17d0, & ! I 27.3d0, 285.9d0, 4.08d0, & ! Xe 427.12d0, 6582.08d0, 3.78d0, & ! Cs 275.0d0, 5727.0d0, 4.77d0, & ! Ba 213.7d0, 3884.5d0, 3.14d0, & ! La 204.7d0, 3708.33d0, 3.26d0, & ! Ce 215.8d0, 3911.84d0, 3.28d0, & ! Pr 208.4d0, 3908.75d0, 3.3d0, & ! Nd 200.2d0, 3847.68d0, 3.27d0, & ! Pm 192.1d0, 3708.69d0, 3.32d0, & ! Sm 184.2d0, 3511.71d0, 3.4d0, & ! Eu 158.3d0, 2781.53d0, 3.62d0, & ! Gd 169.5d0, 3124.41d0, 3.42d0, & ! Tb 164.64d0, 2984.29d0, 3.26d0, & ! Dy 156.3d0, 2839.95d0, 3.24d0, & ! Ho 150.2d0, 2724.12d0, 3.3d0, & ! Er 144.3d0, 2576.78d0, 3.26d0, & ! Tm 138.9d0, 2387.53d0, 3.22d0, & ! Yb 137.2d0, 2371.8d0, 3.2d0, & ! Lu 99.52d0, 1274.8d0, 4.21d0, & ! Hf 82.53d0, 1019.92d0, 4.15d0, & ! Ta 71.041d0, 847.93d0, 4.08d0, & ! W 63.04d0, 710.2d0, 4.02d0, & ! Re 55.055d0, 596.67d0, 3.84d0, & ! Os 42.51d0, 359.1d0, 4.0d0, & ! Ir 14.45d0, 120.5d0, 2.8d0, & ! Pt 15.62d0, 133.9d0, 2.91d0, & ! Au 33.9d0, 392.0d0, 3.98d0, & ! Hg 69.92d0, 717.44d0, 3.91d0, & ! Tl 61.8d0, 697.0d0, 4.31d0, & ! Pb 49.02d0, 571.0d0, 4.32d0, & ! Bi 45.013d0, 530.92d0, 4.097d0, & ! Po 38.93d0, 457.53d0, 4.07d0, & ! At 33.54d0, 390.63d0, 4.23d0, & ! Rn 317.8d0, 4224.44d0, 3.9d0, & ! Fr 246.2d0, 4851.32d0, 4.98d0, & ! Ra 203.3d0, 3604.41d0, 2.75d0, & ! Ac 217.0d0, 4047.54d0, 2.85d0, & ! Th 154.4d0, 2367.42d0, 2.71d0, & ! Pa 127.8d0, 1877.1d0, 3.0d0, & ! U 150.5d0, 2507.88d0, 3.28d0, & ! Np 132.2d0, 2117.27d0, 3.45d0, & ! Pu 131.2d0, 2110.98d0, 3.51d0, & ! Am 143.6d0, 2403.22d0, 3.47d0, & ! Cm 125.3d0, 1985.82d0, 3.56d0, & ! Bk 121.5d0, 1891.92d0, 3.55d0, & ! Cf 117.5d0, 1851.1d0, 3.76d0, & ! Es 113.4d0, 1787.07d0, 3.89d0, & ! Fm 109.4d0, 1701.0d0, 3.93d0, & ! Md 105.4d0, 1578.18d0, 3.78d0 & ! No ], [3, 102]) contains integer elemental function species_index(species) character(len=*), intent(in) :: species integer :: i select case (lower(trim(species))) case ('h'); i = 1; case ('he'); i = 2; case ('li'); i = 3 case ('be'); i = 4; case ('b'); i = 5; case ('c'); i = 6 case ('n'); i = 7; case ('o'); i = 8; case ('f'); i = 9 case ('ne'); i = 10; case ('na'); i = 11; case ('mg'); i = 12 case ('al'); i = 13; case ('si'); i = 14; case ('p'); i = 15 case ('s'); i = 16; case ('cl'); i = 17; case ('ar'); i = 18 case ('k'); i = 19; case ('ca'); i = 20; case ('sc'); i = 21 case ('ti'); i = 22; case ('v'); i = 23; case ('cr'); i = 24 case ('mn'); i = 25; case ('fe'); i = 26; case ('co'); i = 27 case ('ni'); i = 28; case ('cu'); i = 29; case ('zn'); i = 30 case ('ga'); i = 31; case ('ge'); i = 32; case ('as'); i = 33 case ('se'); i = 34; case ('br'); i = 35; case ('kr'); i = 36 case ('rb'); i = 37; case ('sr'); i = 38; case ('y'); i = 39 case ('zr'); i = 40; case ('nb'); i = 41; case ('mo'); i = 42 case ('tc'); i = 43; case ('ru'); i = 44; case ('rh'); i = 45 case ('pd'); i = 46; case ('ag'); i = 47; case ('cd'); i = 48 case ('in'); i = 49; case ('sn'); i = 50; case ('sb'); i = 51 case ('te'); i = 52; case ('i'); i = 53; case ('xe'); i = 54 case ('cs'); i = 55; case ('ba'); i = 56; case ('la'); i = 57 case ('ce'); i = 58; case ('pr'); i = 59; case ('nd'); i = 60 case ('pm'); i = 61; case ('sm'); i = 62; case ('eu'); i = 63 case ('gd'); i = 64; case ('tb'); i = 65; case ('dy'); i = 66 case ('ho'); i = 67; case ('er'); i = 68; case ('tm'); i = 69 case ('yb'); i = 70; case ('lu'); i = 71; case ('hf'); i = 72 case ('ta'); i = 73; case ('w'); i = 74; case ('re'); i = 75 case ('os'); i = 76; case ('ir'); i = 77; case ('pt'); i = 78 case ('au'); i = 79; case ('hg'); i = 80; case ('tl'); i = 81 case ('pb'); i = 82; case ('bi'); i = 83; case ('po'); i = 84 case ('at'); i = 85; case ('rn'); i = 86; case ('fr'); i = 87 case ('ra'); i = 88; case ('ac'); i = 89; case ('th'); i = 90 case ('pa'); i = 91; case ('u'); i = 92; case ('np'); i = 93 case ('pu'); i = 94; case ('am'); i = 95; case ('cm'); i = 96 case ('bk'); i = 97; case ('cf'); i = 98; case ('es'); i = 99 case ('fm'); i = 100; case ('md'); i = 101; case ('no'); i = 102 case ('lr'); i = 103; case ('rf'); i = 104; case ('db'); i = 105 case ('sg'); i = 106; case ('bh'); i = 107; case ('hs'); i = 108 case ('mt'); i = 109; case ('ds'); i = 110; case ('rg'); i = 111 case ('cn'); i = 112 case default i = -1 end select species_index = i end function end module libmbd-libmbd-88d61bc/src/mbd_version.f90.in000066400000000000000000000010541452573331700206500ustar00rootroot00000000000000! This Source Code Form is subject to the terms of the Mozilla Public ! License, v. 2.0. If a copy of the MPL was not distributed with this ! file, You can obtain one at http://mozilla.org/MPL/2.0/. module mbd_version implicit none integer, parameter, public :: MBD_VERSION_MAJOR = @PROJECT_VERSION_MAJOR@ integer, parameter, public :: MBD_VERSION_MINOR = @PROJECT_VERSION_MINOR@ integer, parameter, public :: MBD_VERSION_PATCH = @PROJECT_VERSION_PATCH@ character(len=30), parameter, public :: MBD_VERSION_SUFFIX = '@PROJECT_VERSION_SUFFIX@' end module libmbd-libmbd-88d61bc/src/pymbd/000077500000000000000000000000001452573331700165275ustar00rootroot00000000000000libmbd-libmbd-88d61bc/src/pymbd/__init__.py000066400000000000000000000007131452573331700206410ustar00rootroot00000000000000import re import pkg_resources from .pymbd import ang, from_volumes, mbd_energy, mbd_energy_species, screening __all__ = ['mbd_energy', 'mbd_energy_species', 'screening', 'ang', 'from_volumes'] try: __version__ = pkg_resources.get_distribution('pymbd').version __version__ = re.split('[.-]', __version__, maxsplit=3) __version__ = (*map(int, __version__[:3]), *__version__[3:]) except pkg_resources.DistributionNotFound: __version__ = None libmbd-libmbd-88d61bc/src/pymbd/__main__.py000066400000000000000000000012231452573331700206170ustar00rootroot00000000000000# This Source Code Form is subject to the terms of the Mozilla Public # License, v. 2.0. If a copy of the MPL was not distributed with this # file, You can obtain one at http://mozilla.org/MPL/2.0/. import sys from pymbd import ang from pymbd.fortran import MBDGeom, with_mpi if with_mpi: from mpi4py import MPI rank = MPI.COMM_WORLD.Get_rank() else: rank = 0 ene_expected = -0.0002462647623815428 ene = MBDGeom([(0, 0, 0), (0, 0, 4 * ang)]).mbd_energy_species( ['Ar', 'Ar'], [1, 1], 0.83 ) if rank == 0: print(f'Expected energy: {ene_expected}') print(f'Calculated energy: {ene}') if ene - ene_expected > 1e-10: sys.exit(1) libmbd-libmbd-88d61bc/src/pymbd/benchmark.py000077500000000000000000000127341452573331700210450ustar00rootroot00000000000000#!/usr/bin/env python3 import sys from argparse import ArgumentParser from functools import partial import numpy as np from pymbd import __version__ as _version, ang from pymbd.fortran import LIBMBD_VERSION, MBDGeom, with_mpi __all__ = () # fmt: off unit_cell = ( np.array([ (4.083, 5.700, 2.856), (0.568, 0.095, 4.217), (0.470, 4.774, 3.551), (4.181, 1.022, 3.522), (5.572, 5.587, 1.892), (-0.920, 0.209, 5.181), (3.663, 3.255, 2.585), (0.988, 2.541, 4.488), (3.834, 4.011, 0.979), (0.816, 1.785, 6.094), (2.223, 1.314, 1.108), (2.428, 4.481, 5.965), (1.177, 0.092, 0.406), (3.474, 5.703, 6.667), (4.911, 5.036, 2.573), (-0.260, 0.759, 4.500), (4.358, 3.787, 1.918), (0.293, 2.009, 5.155), (0.205, 1.729, 1.101), (4.446, 4.067, 5.972), (1.285, 0.947, 0.957), (3.366, 4.848, 6.116), (0.485, 2.901, 1.709), (4.165, 2.895, 5.364), (4.066, 1.426, 0.670), (0.585, 4.369, 6.403)]) * ang, np.array([ (5.008, 0.018, -0.070), (1.630, 6.759, 0.064), (-1.987, -0.981, 7.079)]) * ang, list('HHHHHHHHHHHHHHCCCCCCNNOOOO'), [0.703, 0.703, 0.726, 0.726, 0.731, 0.731, 0.727, 0.727, 0.754, 0.754, 0.750, 0.750, 0.755, 0.755, 0.809, 0.809, 0.827, 0.827, 0.834, 0.834, 0.840, 0.840, 0.886, 0.886, 0.892, 0.892]) # fmt: on RANK = None def parse(output): blocks = [ [l.split() for l in block.strip().split('\n')] for block in output.split('--------------')[1:-1] ] n_atoms = int(blocks[0][0][-1]) version_pymbd = blocks[0][1][-1] version_libmbd = blocks[0][2][-1] block_size, grid = None, None block = iter(blocks[1]) for words in block: if words[0] == 'id': break elif words[0] == 'BLACS': if words[1] == 'block': block_size = int(words[-1]) else: grid = [int(words[-3]), int(words[-1])] timing = [ { 'id': int(words[0]), 'level': int(words[1]), 'label': ' '.join(words[2:-2]), 'count': int(words[-2]), 'time': float(words[-1]), } for words in block ] energy = float(blocks[2][0][-1]) return { 'version_pymbd': version_pymbd, 'version_libmbd': version_libmbd, 'n_atoms': n_atoms, 'timing': timing, 'energy': energy, 'block_size': block_size, 'grid': grid, } def make_supercell(coords, lattice, species, vol_ratios, sc): sc = np.array(sc) n_uc = np.product(sc) c = np.stack( np.meshgrid(range(sc[0]), range(sc[1]), range(sc[2])), axis=-1 ).reshape(-1, 3) coords = ((c @ lattice)[:, None, :] + coords).reshape(-1, 3) lattice = lattice * sc[:, None] species = n_uc * species vol_ratios = n_uc * vol_ratios return coords, lattice, species, vol_ratios def _print(*args): if not RANK: print(*args) def run(supercell, k_grid, finite, force, method, early_return, repeat): if with_mpi: from mpi4py import MPI global RANK RANK = MPI.COMM_WORLD.Get_rank() _print('--------------') coords, lattice, species, vol_ratios = make_supercell(*unit_cell, supercell) _print('number of atoms:', len(coords)) _print('pyMBD version:', '.'.join(map(str, _version))) _print('libMBD version:', '{}.{}.{}-{}'.format(*LIBMBD_VERSION)) _print('--------------') if early_return: return geom = MBDGeom(coords) if finite else MBDGeom(coords, lattice, k_grid) if method == 'mbd@rsscs': func = geom.mbd_energy_species elif method == 'mbd': func = partial(geom.mbd_energy_species, variant='plain') elif method == 'ts': func = geom.ts_energy_species with geom: for _ in range(repeat): res = func(species, vol_ratios, 0.83, force=force) geom.print_timing() if force: ene, grad, *_ = res else: ene = res ene = ene / len(coords) _print('--------------') _print('energy:', ene) if force: _print('grad[0]:', grad[0]) _print('--------------') def main(args): parser = ArgumentParser() parser.add_argument( '--parse', action='store_true', help='parse stdin and output JSON', ) parser.add_argument( '--supercell', nargs=3, type=int, default=[1, 1, 1], metavar='N', help='supercell definition', ) parser.add_argument( '--k-grid', nargs=3, type=int, default=[1, 1, 1], metavar='N', help='k-grid definition', ) parser.add_argument( '--finite', action='store_true', help='run a finite system', ) parser.add_argument( '--no-force', action='store_false', dest='force', help='switch off calculation of gradients', ) parser.add_argument( '--method', default='mbd@rsscs', choices=['mbd@rsscs', 'mbd', 'ts'], help='method to run', ) parser.add_argument( '--early-return', action='store_true', help='return before doing any work', ) parser.add_argument( '--repeat', type=int, default=1, help='run benchmark repeatedly', ) args = vars(parser.parse_args(args)) if args.pop('parse', False): from pprint import pprint pprint(parse(sys.stdin.read())) else: run(**args) if __name__ == '__main__': main(sys.argv[1:]) libmbd-libmbd-88d61bc/src/pymbd/fortran.py000066400000000000000000000351611452573331700205620ustar00rootroot00000000000000# This Source Code Form is subject to the terms of the Mozilla Public # License, v. 2.0. If a copy of the MPL was not distributed with this # file, You can obtain one at http://mozilla.org/MPL/2.0/. from __future__ import division, print_function import re from functools import wraps import numpy as np from .__init__ import __version__ as PYMBD_VERSION from .pymbd import _array, from_volumes try: from ._libmbd import ffi as _ffi, lib as _lib except ImportError: raise Exception('pyMBD C extension unimportable, cannot use Fortran') from None __all__ = ['MBDGeom', 'with_mpi', 'with_scalapack'] with_mpi = _lib.cmbd_with_mpi """Whether libMBD was compiled with MPI""" with_scalapack = _lib.cmbd_with_scalapack """Whether libMBD was compiled with Scalapack""" LIBMBD_VERSION = ( _lib.cmbd_version_major, _lib.cmbd_version_minor, _lib.cmbd_version_patch, _ffi.string(_lib.cmbd_version_suffix).strip().decode(), ) # do not test versions when running autodoc if PYMBD_VERSION and isinstance(LIBMBD_VERSION[0], int): assert PYMBD_VERSION[0] == LIBMBD_VERSION[0] if PYMBD_VERSION[0] == 0: assert PYMBD_VERSION[1] == LIBMBD_VERSION[1] else: assert PYMBD_VERSION[1] <= LIBMBD_VERSION[1] if len(PYMBD_VERSION) == 4: git_commit = re.split('[+-]', PYMBD_VERSION[3])[1] assert LIBMBD_VERSION[3].endswith(git_commit) class MBDFortranError(Exception): def __init__(self, code, origin, msg): super(MBDFortranError, self).__init__(msg) self.code = code self.origin = origin def _auto_context(method): @wraps(method) def wrapper(self, *args, **kwargs): if self._geom_f: return method(self, *args, **kwargs) with self: return method(self, *args, **kwargs) return wrapper class MBDGeom(object): """Represents an initialized libMBD `geom_t <../type/geom_t.html>`_ object. :param array-like coords: (a.u.) atomic coordinates as rows :param array-like lattice: (a.u.) lattice vectors as rows :param array-like k_grid: number of :math:`k`-points per reciprocal lattice vector :param array-like custom_k_pts: (a.u.) custom :math:`k`-points as rows :param int n_freq: number of quadrature points for frequency integration :param bool do_rpa: whether to calculate MBD energy via frequency integration :param bool get_spectrum: whether to return eigenvalues and eigenvectors :param bool get_rpa_orders: whether to return RPA order decomposition :param bool rpa_rescale_eigs: whether to rescale RPA eigenvalues """ def __init__( self, coords, lattice=None, k_grid=None, custom_k_pts=None, n_freq=None, do_rpa=False, get_spectrum=False, get_rpa_orders=False, rpa_rescale_eigs=False, max_atoms_per_block=None, ewald_cutoff_scaling=(1.0, 1.0), ): self._geom_f = None self._coords, self._lattice = map(_array, (coords, lattice)) self._k_grid = _array(k_grid, dtype='i4') self._custom_k_pts = _array(custom_k_pts) self._n_freq = n_freq self._do_rpa = do_rpa self._get_spectrum = get_spectrum self._get_rpa_orders = get_rpa_orders self._rpa_rescale_eigs = rpa_rescale_eigs self._max_atoms_per_block = max_atoms_per_block self._ewald_cutoff_scaling = ewald_cutoff_scaling def __len__(self): return len(self._coords) def __enter__(self): self._geom_f = _lib.cmbd_init_geom( len(self), _cast('double*', self._coords), _cast('double*', self._lattice), _cast('int*', self._k_grid), len(self._custom_k_pts) if self._custom_k_pts is not None else 0, _cast('double*', self._custom_k_pts), self._n_freq or 0, self._do_rpa, self._get_spectrum, self._get_rpa_orders, self._rpa_rescale_eigs, self._max_atoms_per_block or 0, self._ewald_cutoff_scaling, ) return self def __exit__(self, exc_type, exc_value, traceback): _lib.cmbd_destroy_geom(self._geom_f) self._geom_f = None def _check_exc(self): code = _array(0, dtype=int) origin = _ffi.new('char[50]') msg = _ffi.new('char[150]') _lib.cmbd_get_exception(self._geom_f, _cast('int*', code), origin, msg) if code != 0: raise MBDFortranError( int(code), _ffi.string(origin).decode(), _ffi.string(msg).decode() ) @property def coords(self): """(a.u.) Atom coordinates in rows.""" return self._coords.copy() @coords.setter def coords(self, coords): _lib.cmbd_update_coords(self._geom_f, _cast('double*', _array(coords))) @property def lattice(self): """(a.u.) Lattice vectors in rows.""" return self._lattice.copy() @lattice.setter def lattice(self, lattice): _lib.cmbd_update_lattice(self._geom_f, _cast('double*', _array(lattice))) def has_lattice(self): """Whether structure is a crystal.""" return self._lattice is not None def print_timing(self): """Print timing from libMBD.""" _lib.cmbd_print_timing(self._geom_f) @_auto_context def ts_energy(self, alpha_0, C6, R_vdw, sR, d=20.0, damping='fermi', force=False): """Calculate a TS energy. :param array-like alpha_0: (a.u.) atomic polarizabilities :param array-like C6: (a.u.) atomic :math:`C_6` coefficients :param array-like R_vdw: (a.u.) atomic vdW radii :param float sR: TS damping parameter :math:`s_R` :param float d: TS damping parameter :math:`d` :param damping str: type of damping :param force bool: if True, calculate energy gradients """ alpha_0, C6, R_vdw = map(_array, (alpha_0, C6, R_vdw)) n_atoms = len(self) damping_f = _lib.cmbd_init_damping( len(self), damping.encode(), _cast('double*', R_vdw), _ffi.NULL, sR, d ) res_f = _lib.cmbd_ts_energy( self._geom_f, _cast('double*', alpha_0), _cast('double*', C6), damping_f, force, ) _lib.cmbd_destroy_damping(damping_f) self._check_exc() ene = np.empty(1) # for some reason np.array(0) doesn't work gradients, lattice_gradients = 2 * [None] if force: gradients = np.zeros((n_atoms, 3)) if self.has_lattice(): lattice_gradients = np.zeros((3, 3)) results = (ene, gradients, lattice_gradients, *(7 * [None])) _lib.cmbd_get_results(res_f, *(_cast('double*', x) for x in results)) _lib.cmbd_destroy_result(res_f) ene = ene.item() if force: ene = (ene, gradients) if self.has_lattice(): ene += (lattice_gradients,) return ene @_auto_context def mbd_energy( # noqa: C901 self, alpha_0, C6, R_vdw=None, beta=0.0, a=6.0, sigma=None, damping='fermi,dip', variant='rsscs', force=False, intermediates=False, ): r"""Calculate an MBD energy. :param array-like alpha_0: (a.u.) atomic polarizabilities :param array-like C6: (a.u.) atomic :math:`C_6` coefficients :param array-like R_vdw: (a.u.) atomic vdW radii :param array-like sigma: (a.u.) oscillator widths :param float beta: MBD damping parameter :math:`\beta` :param float a: MBD damping parameter :math:`a` :param damping str: type of damping :param variant str: one of 'plain', 'scs', 'rsscs' :param force bool: if True, calculate energy gradients """ alpha_0, C6, R_vdw, sigma = map(_array, (alpha_0, C6, R_vdw, sigma)) n_atoms = len(self) damping_f = _lib.cmbd_init_damping( n_atoms, damping.encode(), _cast('double*', R_vdw), _cast('double*', sigma), beta, a, ) args = ( self._geom_f, _cast('double*', alpha_0), _cast('double*', C6), damping_f, force, ) if variant == 'plain': res_f = _lib.cmbd_mbd_energy(*args) else: args = args[:1] + (variant.encode(),) + args[1:] res_f = _lib.cmbd_mbd_scs_energy(*args) _lib.cmbd_destroy_damping(damping_f) self._check_exc() ene = np.empty(1) # for some reason np.array(0) doesn't work gradients, lattice_gradients = 2 * [None] alpha_0_scs, C6_scs = 2 * [None] eigs, modes, rpa_orders, eigs_k, modes_k = 5 * [None] if force: gradients = np.zeros((n_atoms, 3)) if self.has_lattice(): lattice_gradients = np.zeros((3, 3)) if intermediates: alpha_0_scs, C6_scs = np.zeros(n_atoms), np.zeros(n_atoms) if self._get_spectrum: if self.has_lattice(): n_kpts = ( len(self._custom_k_pts) if self._custom_k_pts is not None else self._k_grid.prod() ) eigs_k = np.zeros((3 * n_atoms, n_kpts), order='F') modes_k = np.zeros( (3 * n_atoms, 3 * n_atoms, n_kpts), dtype=complex, order='F' ) else: eigs = np.zeros(3 * n_atoms) modes = np.zeros((3 * n_atoms, 3 * n_atoms), order='F') elif self._get_rpa_orders: rpa_orders = np.zeros(10) results = ( ene, gradients, lattice_gradients, eigs, modes, rpa_orders, eigs_k, modes_k, alpha_0_scs, C6_scs, ) _lib.cmbd_get_results(res_f, *(_cast('double*', x) for x in results)) _lib.cmbd_destroy_result(res_f) ene = ene.item() if self.has_lattice(): eigs, modes = eigs_k, modes_k if self._get_spectrum: ene = ene, eigs, modes elif self._get_rpa_orders: ene = ene, rpa_orders if force or intermediates: ene = (ene,) if force: ene += (gradients,) if self.has_lattice(): ene += (lattice_gradients,) if intermediates: ene += (alpha_0_scs, C6_scs) return ene @_auto_context def dipole_matrix( self, damping, beta=0.0, k_point=None, R_vdw=None, sigma=None, a=6.0 ): # noqa: D102 R_vdw, sigma, k_point = map(_array, (R_vdw, sigma, k_point)) n_atoms = len(self) damping_f = _lib.cmbd_init_damping( n_atoms, damping.encode(), _cast('double*', R_vdw), _cast('double*', sigma), beta, a, ) dipmat = np.empty( (3 * n_atoms, 3 * n_atoms), dtype=float if k_point is None else complex ) _lib.cmbd_dipole_matrix( self._geom_f, damping_f, _cast('double*', k_point), _cast('double*', dipmat) ) _lib.cmbd_destroy_damping(damping_f) self._check_exc() return dipmat def mbd_energy_species(self, species, volume_ratios, beta, **kwargs): r"""Calculate an MBD energy from atom types and Hirshfed-volume ratios. :param array-like species: atom types (elements) :param array-like volume_ratios: ratios of Hirshfeld volumes in molecule and vacuum :param float beta: MBD damping parameter :math:`\beta` :param kwargs: see :meth:`mbd_energy` """ alpha_0, C6, R_vdw = from_volumes(species, volume_ratios) return self.mbd_energy(alpha_0, C6, R_vdw, beta, **kwargs) def ts_energy_species(self, species, volume_ratios, beta, **kwargs): """Calculate a TS energy from atom types and Hirshfed-volume ratios. :param array-like species: atom types (elements) :param array-like volume_ratios: ratios of Hirshfeld volumes in molecule and vacuum :param float sR: TS damping parameter :math:`s_R` :param kwargs: see :meth:`ts_energy` """ alpha_0, C6, R_vdw = from_volumes(species, volume_ratios) return self.ts_energy(alpha_0, C6, R_vdw, beta, **kwargs) @_auto_context def dipole_energy(self, a0, w, w_t, version, r_vdw, beta, a, C): # noqa: D102 n_atoms = len(self) res = _lib.cmbd_dipole_energy( self._geom_f, n_atoms, _cast('double*', a0), _cast('double*', w), _cast('double*', w_t), version.encode(), _cast('double*', r_vdw), beta, a, _cast('double*', C), ) self._check_exc() return res @_auto_context def coulomb_energy(self, q, m, w_t, version, r_vdw, beta, a, C): # noqa: D102 n_atoms = len(self) res = _lib.cmbd_coulomb_energy( self._geom_f, n_atoms, _cast('double*', q), _cast('double*', m), _cast('double*', w_t), version.encode(), _cast('double*', r_vdw), beta, a, _cast('double*', C), ) self._check_exc() return res @_auto_context def nonint_density(self, pts, q, m, w): # noqa: D102 n_pts = len(pts) n_atoms = len(self) rho = np.empty(n_pts) _lib.cmbd_nonint_density( self._geom_f, n_atoms, n_pts, _cast('double*', pts), _cast('double*', q), _cast('double*', m), _cast('double*', w), _cast('double*', rho), ) self._check_exc() return rho @_auto_context def int_density(self, pts, q, m, w_t, modes): # noqa: D102 n_pts = len(pts) n_atoms = len(self) rho = np.empty(n_pts) _lib.cmbd_int_density( self._geom_f, n_atoms, n_pts, _cast('double*', pts), _cast('double*', q), _cast('double*', m), _cast('double*', w_t), _cast('double*', modes), _cast('double*', rho), ) self._check_exc() return rho def _ndarray(ptr, shape=None, dtype='float'): buffer_size = (np.prod(shape) if shape else 1) * np.dtype(dtype).itemsize return np.ndarray(buffer=_ffi.buffer(ptr, buffer_size), shape=shape, dtype=dtype) def _cast(ctype, array): return _ffi.NULL if array is None else _ffi.cast(ctype, array.ctypes.data) libmbd-libmbd-88d61bc/src/pymbd/pymbd.py000066400000000000000000000260621452573331700202220ustar00rootroot00000000000000# This Source Code Form is subject to the terms of the Mozilla Public # License, v. 2.0. If a copy of the MPL was not distributed with this # file, You can obtain one at http://mozilla.org/MPL/2.0/. from __future__ import division, print_function import csv import sys from itertools import product import numpy as np from numpy.polynomial.legendre import leggauss from pkg_resources import resource_string from scipy.special import erf, erfc __all__ = ['mbd_energy', 'mbd_energy_species', 'screening', 'ang'] ang = 1 / 0.529177249 """(a.u.) angstrom""" def screening(coords, alpha_0, C6, R_vdw, beta, lattice=None, nfreq=15): r"""Screen atomic polarizabilities. :param array-like coords: (a.u.) atom coordinates in rows :param array-like alpha_0: (a.u.) atomic polarizabilities :param array-like C6: (a.u.) atomic :math:`C_6` coefficients :param array-like R_vdw: (a.u.) atomic vdW radii :param float beta: MBD damping parameter :math:`\beta` :param array-like lattice: (a.u.) lattice vectors in rows :param int nfreq: number of grid points for frequency quadrature Returns static polarizabilities, :math:`C_6` coefficients, and :math:`R_\mathrm{vdw}` coefficients (a.u.). """ freq, freq_w = freq_grid(nfreq) omega = 4 / 3 * C6 / alpha_0**2 alpha_dyn = [alpha_0 / (1 + (u / omega) ** 2) for u in freq] alpha_dyn_rsscs = [] for a in alpha_dyn: sigma = (np.sqrt(2 / np.pi) * a / 3) ** (1 / 3) dipmat = dipole_matrix( coords, 'fermi,dip,gg', sigma=sigma, R_vdw=R_vdw, beta=beta, lattice=lattice ) a_nlc = np.linalg.inv(np.diag(np.repeat(1 / a, 3)) + dipmat) a_contr = sum(np.sum(a_nlc[i::3, i::3], 1) for i in range(3)) / 3 alpha_dyn_rsscs.append(a_contr) alpha_dyn_rsscs = np.stack(alpha_dyn_rsscs) C6_rsscs = 3 / np.pi * np.sum(freq_w[:, None] * alpha_dyn_rsscs**2, 0) R_vdw_rsscs = R_vdw * (alpha_dyn_rsscs[0, :] / alpha_0) ** (1 / 3) return alpha_dyn_rsscs[0], C6_rsscs, R_vdw_rsscs def mbd_energy(coords, alpha_0, C6, R_vdw, beta, lattice=None, k_grid=None, nfreq=15): r"""Calculate an MBD energy. :param array-like coords: (a.u.) atom coordinates in rows :param array-like alpha_0: (a.u.) atomic polarizabilities :param array-like C6: (a.u.) atomic :math:`C_6` coefficients :param array-like R_vdw: (a.u.) atomic vdW radii :param float beta: MBD damping parameter :math:`\beta` :param array-like lattice: (a.u.) lattice vectors in rows :param array-like k_grid: number of :math:`k`-points along reciprocal axes :param int nfreq: number of grid points for frequency quadrature """ coords, alpha_0, C6, R_vdw, lattice = map( _array, (coords, alpha_0, C6, R_vdw, lattice) ) alpha_0_rsscs, C6_rsscs, R_vdw_rsscs = screening( coords, alpha_0, C6, R_vdw, beta, lattice=lattice, nfreq=15 ) omega_rsscs = 4 / 3 * C6_rsscs / alpha_0_rsscs**2 pre = np.repeat(omega_rsscs * np.sqrt(alpha_0_rsscs), 3) if lattice is None: k_points = [None] else: assert k_grid is not None k_points = get_kpts(lattice, k_grid) ene = 0.0 for k_point in k_points: eigs = np.linalg.eigvalsh( np.diag(np.repeat(omega_rsscs**2, 3)) + np.outer(pre, pre) * dipole_matrix( coords, 'fermi,dip', R_vdw=R_vdw_rsscs, beta=beta, lattice=lattice, k_point=k_point, ) ) ene += np.sum(np.sqrt(eigs)) / 2 ene = ene / len(k_points) - 3 * np.sum(omega_rsscs) / 2 return ene def mbd_energy_species(coords, species, volume_ratios, beta, **kwargs): r"""Calculate an MBD energy from atom types and Hirshfed-volume ratios. :param array-like coords: (a.u.) atom coordinates in rows :param array-like species: atom types (elements) :param array-like volume_ratios: ratios of Hirshfeld volumes in molecule and vacuum :param float beta: MBD damping parameter :math:`\beta` :param kwargs: see :func:`mbd_energy` """ alpha_0, C6, R_vdw = from_volumes(species, volume_ratios) return mbd_energy(coords, alpha_0, C6, R_vdw, beta, **kwargs) def dipole_matrix( coords, damping, beta=0.0, lattice=None, k_point=None, R_vdw=None, sigma=None, a=6.0 ): if lattice is not None: volume = max(np.abs(np.product(np.linalg.eigvals(lattice))), 0.2) ewald_alpha = 2.5 / volume ** (1 / 3) real_space_cutoff = 6 / ewald_alpha range_cell = supercell_circum(lattice, real_space_cutoff) else: range_cell = (0, 0, 0) do_ewald = lattice is not None and damping in {'fermi,dip'} n = len(coords) dtype = float if k_point is None else complex dipmat = np.zeros((n, n, 3, 3), dtype=dtype) if R_vdw is not None: S_vdw = beta * (R_vdw[:, None] + R_vdw[None, :]) if sigma is not None: sigma_ij = np.sqrt(sigma[:, None] ** 2 + sigma[None, :] ** 2) for idx_cell in product(*(range(-i, i + 1) for i in range_cell)): R_cell = lattice.T.dot(idx_cell) if lattice is not None else np.zeros(3) Rs = coords[:, None, :] - coords[None, :, :] + R_cell dists = np.sqrt(np.sum(Rs**2, -1)) if damping == 'fermi,dip': T = damping_fermi(dists, S_vdw, a)[:, :, None, None] * T_bare(Rs) elif damping == 'fermi,dip,gg': T = (1 - damping_fermi(dists, S_vdw, a)[:, :, None, None]) * T_erf_coulomb( Rs, sigma_ij ) else: raise ValueError(f'Unsupported damping: {damping}') if do_ewald: T += T_erfc(Rs, ewald_alpha) - T_bare(Rs) if k_point is not None: k_pref = np.exp(-1j * np.sum(k_point * Rs, -1)) T = k_pref[:, :, None, None] * T dipmat += T if do_ewald: dipmat += dipole_matrix_ewald(coords, lattice, ewald_alpha, k_point) n = len(coords) return np.reshape(np.transpose(dipmat, (0, 2, 1, 3)), (3 * n, 3 * n)) def dipole_matrix_ewald(coords, lattice, alpha, k_point=None): Rs = coords[:, None, :] - coords[None, :, :] rlattice = 2 * np.pi * np.linalg.inv(lattice.T) volume = abs(np.product(np.linalg.eigvals(lattice))) rec_space_cutoff = 10 * alpha range_G_vector = supercell_circum(rlattice, rec_space_cutoff) dtype = float if k_point is None else complex dipmat = np.zeros((len(Rs), len(Rs), 3, 3), dtype=dtype) fourier_factor = ( (lambda x: np.cos(x)) if k_point is None else (lambda x: np.exp(1j * x)) ) for idx_gvec in product(*(range(-i, i + 1) for i in range_G_vector)): if idx_gvec == (0, 0, 0): continue gvec = rlattice.T.dot(idx_gvec) k_total = k_point + gvec if k_point is not None else gvec k_sq = sum(k_total**2) if np.sqrt(k_sq) > rec_space_cutoff: continue k_prefactor = ( 4 * np.pi / volume * np.exp(-k_sq / (4 * alpha**2)) / k_sq * np.outer(k_total, k_total) ) dipmat += k_prefactor * fourier_factor(np.sum(gvec * Rs, -1))[:, :, None, None] dipmat += -np.eye(len(Rs))[:, :, None, None] * np.diag( np.repeat(4 * alpha**3 / (3 * np.sqrt(np.pi)), 3) ) k_sq = np.sum(k_point**2) if k_point is not None else 0 if np.sqrt(k_sq) > 1e-15: dipmat += ( 4 * np.pi / volume * np.exp(-k_sq / (4 * alpha**2)) / k_sq * np.outer(k_point, k_point) ) else: dipmat += np.diag(np.repeat(4 * np.pi / (3 * volume), 3)) return dipmat def supercell_circum(latt, radius): rlatt = 2 * np.pi * np.linalg.inv(latt.T) layer_sep = np.sum(latt * rlatt / np.sqrt(np.sum(rlatt**2, 1))[None, :], 0) return np.ceil(radius / layer_sep + 0.5).astype(int) def damping_fermi(R, S_vdw, d): return 1 / (1 + np.exp(-d * (R / S_vdw - 1))) def T_bare(R): R_2 = np.sum(R**2, -1) R_5 = np.where(R_2 > 0, np.sqrt(R_2) ** 5, np.inf) return ( -3 * R[:, :, :, None] * R[:, :, None, :] + R_2[:, :, None, None] * np.eye(3)[None, None, :, :] ) / R_5[:, :, None, None] def T_erf_coulomb(R, sigma): bare = T_bare(R) R_1 = np.sqrt(np.sum(R**2, -1)) R_5 = np.where(R_1 > 0, R_1**5, np.inf) RR_R5 = R[:, :, :, None] * R[:, :, None, :] / R_5[:, :, None, None] zeta = R_1 / sigma theta = 2 * zeta / np.sqrt(np.pi) * np.exp(-(zeta**2)) erf_theta = erf(zeta) - theta return ( erf_theta[:, :, None, None] * bare + (2 * (zeta**2) * theta)[:, :, None, None] * RR_R5 ) def T_erfc(R, a): R_2 = np.sum(R**2, -1) R_1 = np.sqrt(R_2) R_3 = np.where(R_1 > 0, R_1**3, np.inf) R_5 = np.where(R_1 > 0, R_1**5, np.inf) B = ( erfc(a * R_1) + (2 * a * R_1 / np.sqrt(np.pi)) * np.exp(-((a * R_1) ** 2)) ) / R_3 C = ( 3 * erfc(a * R_1) + (2 * a * R_1 / np.sqrt(np.pi)) * (3 + 2 * (a * R_1) ** 2) * np.exp(-((a * R_1) ** 2)) ) / R_5 return -C[:, :, None, None] * R[:, :, :, None] * R[:, :, None, :] + B[ :, :, None, None ] * np.eye(3) def from_volumes(species, volumes, kind='TS'): if kind == 'TS': alpha_0, C6, R_vdw = ( np.array([vdw_params[sp][param] for sp in species]) for param in 'alpha_0(TS) C6(TS) R_vdw(TS)'.split() ) elif kind == 'BG': alpha_0, C6, R_vdw = ( np.array([vdw_params[sp][param] for sp in species]) for param in 'alpha_0(BG) C6(BG) R_vdw(TS)'.split() ) elif kind == 'TSsurf': alpha_0, C6, R_vdw = ( np.array( [ vdw_params[sp][param] or vdw_params[sp][param.replace('TSsurf', 'TS')] for sp in species ] ) for param in 'alpha_0(TSsurf) C6(TSsurf) R_vdw(TSsurf)'.split() ) else: raise ValueError(f'Unkonwn vdW parameter kind: {kind}') volumes = np.array(volumes) alpha_0 *= volumes C6 *= volumes**2 R_vdw *= volumes ** (1 / 3) return alpha_0, C6, R_vdw def get_kpts(lattice, k_grid, shift=0.5): k_grid, lattice = map(np.array, (k_grid, lattice)) k_idxs = (np.array(list(product(*map(range, k_grid)))) + shift) / k_grid k_idxs = np.where(k_idxs > 0.5, k_idxs - 1, k_idxs) rlattice = 2 * np.pi * np.linalg.inv(lattice.T) k_points = k_idxs.dot(rlattice) return k_points def freq_grid(n, L=0.6): x, w = leggauss(n) w = 2 * L / (1 - x) ** 2 * w x = L * (1 + x) / (1 - x) return np.hstack(([0], x[::-1])), np.hstack(([0], w[::-1])) def _array(obj, *args, **kwargs): if obj is not None: kwargs.setdefault('dtype', float) return np.array(obj, *args, **kwargs) def _get_vdw_params(): csv_lines = resource_string(__name__, 'vdw-params.csv').split(b'\n') if sys.version_info[0] > 2: csv_lines = [l.decode() for l in csv_lines] reader = csv.DictReader(csv_lines, quoting=csv.QUOTE_NONNUMERIC) vdw_params = {row.pop('symbol'): row for row in reader} return vdw_params vdw_params = _get_vdw_params() libmbd-libmbd-88d61bc/src/pymbd/tensorflow.py000066400000000000000000000114151452573331700213050ustar00rootroot00000000000000# This Source Code Form is subject to the terms of the Mozilla Public # License, v. 2.0. If a copy of the MPL was not distributed with this # file, You can obtain one at http://mozilla.org/MPL/2.0/. from __future__ import division, print_function from math import pi import numpy as np import tensorflow as tf from .pymbd import freq_grid __all__ = () pi = tf.constant(pi, tf.float64) ang = 1 / 0.529177249 class MBDEvaluator(object): def __init__(self, gradients=False, **kwargs): self._inputs = coords, alpha_0, C6, R_vdw, beta = [ tf.placeholder(tf.float64, shape=shape, name=name) for shape, name in [ ((None, 3), 'coords'), ((None,), 'alpha_0'), ((None,), 'C6'), ((None,), 'R_vdw'), ((), 'beta'), ] ] self._output = mbd_energy(*self._inputs, **kwargs) if gradients: self._init_gradients() else: self._gradients = None def _init_gradients(self): self._gradients = tf.gradients(self._output, [self._inputs[0]])[0] def __call__(self, coords, alpha_0, C6, R_vdw, beta=0.83, gradients=None): inputs = dict(zip(self._inputs, [coords, alpha_0, C6, R_vdw, beta])) outputs = self._output if gradients or gradients is None and self._gradients is not None: if self._gradients is None: self._init_gradients() outputs = outputs, self._gradients return tf.get_default_session().run(outputs, inputs) def mbd_energy(coords, alpha_0, C6, R_vdw, beta, nfreq=15): freq, freq_w = freq_grid(nfreq) omega = 4 / 3 * C6 / alpha_0**2 alpha_dyn = [alpha_0 / (1 + (u / omega) ** 2) for u in freq] alpha_dyn_rsscs = [] for a in alpha_dyn: sigma = (tf.sqrt(2 / pi) * a / 3) ** (1 / 3) dipmat = dipole_matrix( coords, 'fermi,dip,gg', sigma=sigma, R_vdw=R_vdw, beta=beta ) a_nlc = tf.linalg.inv(tf.diag(_repeat(1 / a, 3)) + dipmat) a_contr = sum(tf.reduce_sum(a_nlc[i::3, i::3], 1) for i in range(3)) / 3 alpha_dyn_rsscs.append(a_contr) alpha_dyn_rsscs = tf.stack(alpha_dyn_rsscs) C6_rsscs = 3 / pi * tf.reduce_sum(freq_w[:, None] * alpha_dyn_rsscs**2, 0) R_vdw_rsscs = R_vdw * (alpha_dyn_rsscs[0, :] / alpha_0) ** (1 / 3) omega_rsscs = 4 / 3 * C6_rsscs / alpha_dyn_rsscs[0, :] ** 2 dipmat = dipole_matrix(coords, 'fermi,dip', R_vdw=R_vdw_rsscs, beta=beta) pre = _repeat(omega_rsscs * tf.sqrt(alpha_dyn_rsscs[0, :]), 3) eigs = tf.linalg.eigvalsh( tf.diag(_repeat(omega_rsscs**2, 3)) + pre[:, None] * pre[None, :] * dipmat ) ene = tf.reduce_sum(tf.sqrt(eigs)) / 2 - 3 * tf.reduce_sum(omega_rsscs) / 2 return ene def dipole_matrix(coords, damping, beta=0.0, R_vdw=None, sigma=None, a=6.0): Rs = coords[:, None, :] - coords[None, :, :] if R_vdw is not None: S_vdw = beta * (R_vdw[:, None] + R_vdw[None, :]) # 1e10 rather than inf is necessary to avoid nan gradients dists = tf.sqrt(_set_diag(tf.reduce_sum(Rs**2, -1), 1e10)) if sigma is not None: sigmaij = tf.sqrt(sigma[:, None] ** 2 + sigma[None, :] ** 2) if damping == 'fermi,dip': dipmat = damping_fermi(dists, S_vdw, a)[:, :, None, None] * T_bare(Rs) elif damping == 'fermi,dip,gg': dipmat = (1 - damping_fermi(dists, S_vdw, a)[:, :, None, None]) * T_erf_coulomb( Rs, sigmaij ) else: raise ValueError(f'Unsupported damping: {damping}') n_atoms = tf.shape(coords)[0] return tf.reshape(tf.transpose(dipmat, (0, 2, 1, 3)), (3 * n_atoms, 3 * n_atoms)) def damping_fermi(R, S_vdw, d): return 1 / (1 + tf.exp(-d * (R / S_vdw - 1))) def T_bare(R): R_2 = tf.reduce_sum(R**2, -1) # 1e10 rather than inf is necessary to avoid nan gradients R_5 = tf.sqrt(_set_diag(R_2, 1e10)) ** 5 return ( -3 * R[:, :, :, None] * R[:, :, None, :] + R_2[:, :, None, None] * np.eye(3)[None, None, :, :] ) / R_5[:, :, None, None] def T_erf_coulomb(R, sigma): bare = T_bare(R) # 1e-10 rather than 0 is necessary to avoid nan gradients from sqrt(0) R_1 = tf.sqrt(_set_diag(tf.reduce_sum(R**2, -1), 1e-10)) # 1e10 rather than inf is necessary to avoid nan gradients R_5 = _set_diag(R_1**5, 1e10) RR_R5 = R[:, :, :, None] * R[:, :, None, :] / R_5[:, :, None, None] zeta = R_1 / sigma theta = 2 * zeta / tf.sqrt(pi) * tf.exp(-(zeta**2)) erf_theta = tf.erf(zeta) - theta return ( erf_theta[:, :, None, None] * bare + (2 * (zeta**2) * theta)[:, :, None, None] * RR_R5 ) def _set_diag(A, val): return tf.matrix_set_diag(A, tf.fill(tf.shape(A)[0:1], tf.cast(val, tf.float64))) def _repeat(a, n): return tf.reshape(tf.tile(a[:, None], (1, n)), (-1,)) libmbd-libmbd-88d61bc/src/pymbd/utils.py000066400000000000000000000033721452573331700202460ustar00rootroot00000000000000# This Source Code Form is subject to the terms of the Mozilla Public # License, v. 2.0. If a copy of the MPL was not distributed with this # file, You can obtain one at http://mozilla.org/MPL/2.0/. from __future__ import division, print_function import numpy as np __all__ = () def numerical_gradients(geom, func, *args, delta=1e-3, **kwargs): steps, diff = finite_diff_gen(kwargs.pop('npts', 5)) coords_0 = geom.coords gradients = np.zeros(coords_0.shape) for i_atom in range(coords_0.shape[0]): for i_xyz in range(3): ene = {} for step in steps: coords = coords_0.copy() coords[i_atom, i_xyz] += step * delta geom.coords = coords ene[step] = getattr(geom, func)(*args, **kwargs) gradients[i_atom, i_xyz] = diff(ene, delta) return gradients def numerical_latt_gradients(geom, func, *args, **kwargs): delta = kwargs.pop('delta', 1e-3) steps, diff = finite_diff_gen(kwargs.pop('npts', 5)) lattice_0 = geom.lattice gradients = np.zeros((3, 3)) for i_vec in range(3): for i_xyz in range(3): ene = {} for step in steps: lattice = lattice_0.copy() lattice[i_vec, i_xyz] += step * delta geom.lattice = lattice ene[step] = getattr(geom, func)(*args, **kwargs) gradients[i_vec, i_xyz] = diff(ene, delta) return gradients def _diff3(x, delta): return (-1.0 / 2 * x[-1] + 1.0 / 2 * x[1]) / delta def _diff5(x, delta): return ( 1.0 / 12 * x[-2] - 2.0 / 3 * x[-1] + 2.0 / 3 * x[1] - 1.0 / 12 * x[2] ) / delta def finite_diff_gen(npts): return {3: ([-1, 1], _diff3), 5: ([-2, -1, 1, 2], _diff5)}[npts] libmbd-libmbd-88d61bc/src/pymbd/vdw-params.csv000066400000000000000000000430241452573331700213300ustar00rootroot00000000000000"symbol","N","Z","alpha_0(BG)","alpha_0(TS)","C6(BG)","C6(TS)","R_vdw(TS)","alpha_0(TSsurf)","C6(TSsurf)","R_vdw(TSsurf)" "H",1,1,4.499159818,4.5,6.51,6.5,3.1,,, "He",2,2,1.37993307,1.38,1.47,1.46,2.65,,, "Li",3,3,164.1439712,164.2,1408,1387,4.16,,, "Be",4,4,37.70852738,38,214,214,4.17,,, "B",5,5,20.50267245,21,99.2,99.5,3.89,,, "C",6,6,11.69938074,12,47.9,46.6,3.59,,, "N",7,7,7.250524608,7.4,25.7,24.2,3.34,,, "O",8,8,5.200326538,5.4,16.7,15.6,3.19,,, "F",9,9,3.599962152,3.8,10.2,9.52,3.04,,, "Ne",10,10,2.670134809,2.67,6.91,6.38,2.91,,, "Na",11,11,163.0799998,162.7,1566,1556,3.73,,, "Mg",12,12,71.43368109,71,629,627,4.27,,, "Al",13,13,57.4926251,60,520,528,4.33,,, "Si",14,14,37.01100017,37,308,305,4.2,,, "P",15,15,24.79491273,25,187,185,4.01,,, "S",16,16,19.4960936,19.6,140,134,3.86,,, "Cl",17,17,14.69834031,15,97.1,94.6,3.71,,, "Ar",18,18,11.09879641,11.1,67.4,64.3,3.55,,, "K",19,19,290.2526211,292.9,3914,3897,3.71,,, "Ca",20,20,159.5002782,160,2232,2221,4.65,,, "Sc",21,21,122.9784535,120,1570,1383,4.59,,, "Ti",22,22,101.9788541,98,1203,1044,4.51,,, "V",23,23,87.31457082,84,955,832,4.44,,, "Cr",24,24,78.44649963,78,709,602,3.99,,, "Mn",25,25,66.82774146,63,635,552,3.97,,, "Fe",26,26,60.41581308,56,548,482,4.23,,, "Co",27,27,53.87415085,50,461,408,4.18,,, "Ni",28,28,48.40652007,48,393,373,3.82,10.22,59.2,2.28 "Cu",29,29,41.67940517,42,264,253,3.76,10.88,58.9,2.4 "Zn",30,30,38.41133802,40,276,284,4.02,13.77,46,2.82 "Ga",31,31,52.08089707,60,456,498,4.19,,, "Ge",32,32,40.19767312,41,365,354,4.2,,, "As",33,33,29.59404038,29,260,246,4.11,,, "Se",34,34,26.19618104,25,233,210,4.04,,, "Br",35,35,21.60106584,20,187,162,3.93,,, "Kr",36,36,16.7989966,16.8,136,129.6,3.82,,, "Rb",37,37,317.4857877,319.2,4660,4691,3.72,,, "Sr",38,38,198.0042878,199,3230,3170,4.54,,, "Y",39,39,162.9383628,126.737,2599,1968.58,4.8151,,, "Zr",40,40,112.0178139,119.97,1362,1677.91,4.53,,, "Nb",41,41,97.928823,101.603,1144,1263.61,4.2365,,, "Mo",42,42,87.10249487,88.4225785,1025,1028.73,4.099,,, "Tc",43,43,79.63861636,80.083,939,1390.87,4.076,,, "Ru",44,44,72.25208659,65.895,809,609.754,3.9953,,, "Rh",45,45,66.41596018,56.1,708,469,3.95,,, "Pd",46,46,61.68403238,23.68,628,157.5,3.66,13.9,102,3.06 "Ag",47,47,46.19229333,50.6,341,339,3.82,15.36,122,2.57 "Cd",48,48,46.71360184,39.7,405,452,3.99,,, "In",49,49,62.10788008,70.22,643,707.046,4.23198,,, "Sn",50,50,60.01786626,55.95,715,587.417,4.303,,, "Sb",51,51,43.99780575,43.67197,504,459.322,4.276,,, "Te",52,52,39.99474791,37.65,471,396,4.22,,, "I",53,53,33.60483879,35,389,385,4.17,,, "Xe",54,54,27.20458594,27.3,302,285.9,4.08,,, "Cs",55,55,396.4571942,427.12,6657,6582.08,3.78,,, "Ba",56,56,278.2640843,275,5543,5727,4.77,,, "La",57,57,213.7804816,213.7,3729,3884.5,3.14,,, "Ce",58,58,204.7268724,204.7,3480,3708.33,3.26,,, "Pr",59,59,215.8958619,215.8,3760,3911.84,3.28,,, "Nd",60,60,208.5599042,208.4,3561,3908.75,3.3,,, "Pm",61,61,200.0841878,200.2,3338,3847.68,3.27,,, "Sm",62,62,192.1202919,192.1,3134,3708.69,3.32,,, "Eu",63,63,184.3285631,184.2,2938,3511.71,3.4,,, "Gd",64,64,158.3310057,158.3,2336,2781.53,3.62,,, "Tb",65,65,169.6318399,169.5,2587,3124.41,3.42,,, "Dy",66,66,162.7849843,164.64,2429,2984.29,3.26,,, "Ho",67,67,156.3457996,156.3,2283,2839.95,3.24,,, "Er",68,68,150.2764821,150.2,2148,2724.12,3.3,,, "Tm",69,69,144.3274459,144.3,2019,2576.78,3.26,,, "Yb",70,70,138.950199,138.9,1905,2387.53,3.22,,, "Lu",71,71,137.1348638,137.2,2022,2371.8,3.2,,, "Hf",72,72,83.74205207,99.52,1036,1274.8,4.21,,, "Ta",73,73,73.85518664,82.53,887,1019.92,4.15,,, "W",74,74,65.8469926,71.041,757,847.93,4.08,,, "Re",75,75,60.24080474,63.04,663,710.2,4.02,,, "Os",76,76,55.27611138,55.055,584,596.67,3.84,,, "Ir",77,77,51.3298598,42.51,522,359.1,4,,, "Pt",78,78,48.03425579,39.68,470,347.1,3.92,14.45,120.5,2.8 "Au",79,79,45.36805397,36.5,427,298,3.86,15.62,133.9,2.91 "Hg",80,80,33.50610759,33.9,268,392,3.98,,, "Tl",81,81,51.38892299,69.92,509,717.44,3.91,,, "Pb",82,82,47.91416332,61.8,534,697,4.31,,, "Bi",83,83,43.18768656,49.02,513,571,4.32,,, "Po",84,84,36.1057933,45.013,424,530.92,4.097,,, "At",85,85,30.41486867,38.93,351,457.53,4.07,,, "Rn",86,86,32.20383261,33.54,408,390.63,4.23,,, "Fr",87,87,,317.8,,4224.44,3.9,,, "Ra",88,88,,246.2,,4851.32,4.98,,, "Ac",89,89,,203.3,,3604.41,2.75,,, "Th",90,90,,217,,4047.54,2.85,,, "Pa",91,91,,154.4,,2367.42,2.71,,, "U",92,92,,127.8,,1877.1,3,,, "Np",93,93,,150.5,,2507.88,3.28,,, "Pu",94,94,,132.2,,2117.27,3.45,,, "Am",95,95,,131.2,,2110.98,3.51,,, "Cm",96,96,,143.6,,2403.22,3.47,,, "Bk",97,97,,125.3,,1985.82,3.56,,, "Cf",98,98,,121.5,,1891.92,3.55,,, "Es",99,99,,117.5,,1851.1,3.76,,, "Fm",100,100,,113.4,,1787.07,3.89,,, "Md",101,101,,109.4,,1701,3.93,,, "No",102,102,,105.4,,1578.18,3.78,,, "H-",2,1,7.373680343,,19,,,,, "He+",1,2,0.293937405,,0.109,,,,, "Li2+",1,3,0.056775552,,0.009,,,,, "Li+",2,3,0.193006642,,0.079,,,,, "Li-",4,3,161.4973949,,1970,,,,, "Be3+",1,4,0.014192453,,0.001,,,,, "Be2+",2,4,0.011999948,,0.001,,,,, "Be+",3,4,24.50516902,,70.3,,,,, "B3+",2,5,0.014900944,,0.002,,,,, "B2+",3,5,5.688435859,,6.89,,,,, "B+",4,5,9.669429754,,25.2,,,,, "B-",6,5,32.94459575,,232,,,,, "B2-",7,5,39.09419167,,335,,,,, "C3+",3,6,2.724674725,,2.04,,,,, "C2+",4,6,3.83951097,,5.71,,,,, "C+",5,6,5.65958813,,13.3,,,,, "C-",7,6,15.47372585,,81.7,,,,, "C2-",8,6,16.59454089,,99.4,,,,, "N3+",4,7,2.075194997,,2.07,,,,, "N2+",5,7,2.429932255,,3.37,,,,, "N+",6,7,3.679611674,,8.02,,,,, "N-",8,7,8.038142248,,33.1,,,,, "N2-",9,7,8.69356866,,40.3,,,,, "O3+",5,8,1.641345237,,1.7,,,,, "O2+",6,8,1.670113611,,2.26,,,,, "O+",7,8,2.55017906,,5.27,,,,, "O-",9,8,5.397512671,,19.1,,,,, "O2-",10,8,5.854527161,,23.1,,,,, "F3+",6,9,1.090746069,,1.09,,,,, "F2+",7,9,1.220025684,,1.66,,,,, "F+",8,9,1.779978507,,3.44,,,,, "F-",10,9,14.99716298,,73.5,,,,, "Ne3+",7,10,0.762635208,,0.769,,,,, "Ne2+",8,10,0.957907094,,1.34,,,,, "Ne+",9,10,1.442870778,,2.75,,,,, "Na3+",8,11,0.454147769,,0.427,,,,, "Na2+",9,11,0.602372154,,0.756,,,,, "Na+",10,11,0.930024701,,1.54,,,,, "Na-",12,11,196.6030834,,2900,,,,, "Mg3+",9,12,0.31933305,,0.293,,,,, "Mg2+",10,12,0.429992674,,0.504,,,,, "Mg+",11,12,35.00075273,,155,,,,, "Al3+",10,13,0.209736674,,0.176,,,,, "Al2+",11,13,10.43015723,,24.8,,,,, "Al+",12,13,19.58103334,,89.7,,,,, "Al-",14,13,109.3886595,,1555,,,,, "Al2-",15,13,137.8200082,,2443,,,,, "Si3+",11,14,5.429052612,,9.07,,,,, "Si2+",12,14,9.403660719,,29.2,,,,, "Si+",13,14,18.21186275,,94.8,,,,, "Si-",15,14,59.58015424,,698,,,,, "Si2-",16,14,63.67248441,,837,,,,, "P3+",12,15,5.490121249,,12.6,,,,, "P2+",13,15,8.963551873,,31.9,,,,, "P+",14,15,14.26400876,,74.1,,,,, "P-",16,15,33.70775557,,322,,,,, "P2-",17,15,36.66324598,,392,,,,, "S3+",13,16,5.734378849,,15.8,,,,, "S2+",14,16,8.132050649,,31.1,,,,, "S+",15,16,11.91960945,,62.2,,,,, "S-",17,16,24.12488848,,206,,,,, "S2-",18,16,26.27678476,,249,,,,, "Cl3+",14,17,4.984146343,,14.5,,,,, "Cl2+",15,17,6.681717015,,25.5,,,,, "Cl+",16,17,9.268911171,,46.1,,,,, "Cl-",18,17,30.30050308,,276,,,,, "Ar3+",15,18,4.14007494,,12.1,,,,, "Ar2+",16,18,5.269969824,,19.4,,,,, "Ar+",17,18,7.275705992,,34.2,,,,, "K3+",16,19,2.967513561,,8.03,,,,, "K2+",17,19,3.80033411,,12.8,,,,, "K+",18,19,5.049985463,,21,,,,, "K-",20,19,381.8190955,,8220,,,,, "Ca3+",17,20,2.636213791,,7.25,,,,, "Ca2+",18,20,3.050131114,,9.77,,,,, "Ca+",19,20,75.47245714,,554,,,,, "Sc3+",18,21,2.272979833,,6.19,,,,, "Sc2+",19,21,32.84875201,,165,,,,, "Sc+",20,21,59.98722107,,531,,,,, "Sc-",22,21,133.8470779,,1857,,,,, "Sc2-",23,21,134.4788926,,1943,,,,, "Ti3+",19,22,18.23735304,,69.8,,,,, "Ti2+",20,22,31.19442294,,201,,,,, "Ti+",21,22,44.64103828,,286,,,,, "Ti-",23,22,109.7037485,,1384,,,,, "Ti2-",24,22,109.5117464,,1421,,,,, "V3+",20,23,18.72497166,,93.5,,,,, "V2+",21,23,26.6552537,,161,,,,, "V+",22,23,36.52908272,,217,,,,, "V-",24,23,94.53297241,,1102,,,,, "V2-",25,23,94.10852797,,1120,,,,, "Cr3+",21,24,16.32140198,,61.8,,,,, "Cr2+",22,24,23.55422347,,110,,,,, "Cr+",23,24,38.24435346,,236,,,,, "Cr-",25,24,83.49865239,,908,,,,, "Cr2-",26,24,82.85996684,,913,,,,, "Mn3+",22,25,14.05907777,,61.6,,,,, "Mn2+",23,25,19.87121585,,105,,,,, "Mn+",24,25,25.75693526,,132,,,,, "Mn-",26,25,74.74188935,,762,,,,, "Mn2-",27,25,74.32065904,,767,,,,, "Fe3+",23,26,12.79032535,,53.8,,,,, "Fe2+",24,26,18.05874648,,91.3,,,,, "Fe+",25,26,23.16203063,,114,,,,, "Fe-",27,26,66.46111121,,640,,,,, "Fe2-",28,26,66.12291693,,644,,,,, "Co3+",24,27,11.43093686,,45.6,,,,, "Co2+",25,27,16.12490085,,77.3,,,,, "Co+",26,27,20.58334291,,95.8,,,,, "Co-",28,27,59.7536424,,545,,,,, "Co2-",29,27,59.4769471,,548,,,,, "Ni3+",25,28,10.24744445,,38.8,,,,, "Ni2+",26,28,14.40341748,,65.6,,,,, "Ni+",27,28,18.44309373,,81.5,,,,, "Ni-",29,28,54.15788589,,470,,,,, "Ni2-",30,28,53.97599802,,472,,,,, "Cu3+",26,29,7.345036482,,19.9,,,,, "Cu2+",27,29,10.57523784,,35.2,,,,, "Cu+",28,29,17.55997002,,75.9,,,,, "Cu-",30,29,49.27385073,,407,,,,, "Zn3+",27,30,7.996930347,,27,,,,, "Zn2+",28,30,11.23685047,,45.6,,,,, "Zn+",29,30,17.91856832,,91.7,,,,, "Zn-",31,30,845.4906202,,17793,,,,, "Ga3+",28,31,15.23506843,,71.8,,,,, "Ga2+",29,31,15.22732496,,71.8,,,,, "Ga+",30,31,15.21732611,,71.8,,,,, "Ga-",32,31,103.2035095,,1433,,,,, "Ga2-",33,31,134.1205443,,2358,,,,, "Ge3+",29,32,9.10902981,,33.4,,,,, "Ge2+",30,32,9.10547808,,33.4,,,,, "Ge+",31,32,18.46432458,,108,,,,, "Ge-",33,32,63.32204261,,796,,,,, "Ge2-",34,32,68.73550399,,977,,,,, "As3+",30,33,5.944150649,,17.5,,,,, "As2+",31,33,9.925434515,,43.2,,,,, "As+",32,33,16.44225988,,102,,,,, "As-",34,33,40.03861896,,443,,,,, "As2-",35,33,43.91257603,,544,,,,, "Se3+",31,34,7.11830845,,26.2,,,,, "Se2+",32,34,10.4240312,,52,,,,, "Se+",33,34,15.70270143,,104,,,,, "Se-",35,34,31.73135958,,332,,,,, "Se2-",36,34,34.72309095,,403,,,,, "Br3+",32,35,6.990433625,,28.6,,,,, "Br2+",33,35,9.617274957,,50.6,,,,, "Br+",34,35,13.6438942,,91.2,,,,, "Br-",36,35,42.81721829,,497,,,,, "Kr3+",33,36,6.155599299,,25.9,,,,, "Kr2+",34,36,8.029704922,,41.7,,,,, "Kr+",35,36,11.1474649,,71.9,,,,, "Rb3+",34,37,4.463460524,,17.3,,,,, "Rb2+",35,37,5.775201156,,27.2,,,,, "Rb+",36,37,8.320371813,,49.1,,,,, "Rb-",38,37,464.9268456,,11420,,,,, "Sr3+",35,38,4.466709804,,18.5,,,,, "Sr2+",36,38,5.519602086,,26.9,,,,, "Sr+",37,38,90.22492941,,790,,,,, "Y3+",36,39,4.561931379,,20.3,,,,, "Y2+",37,39,47.40015591,,325,,,,, "Y+",38,39,88.05804084,,1017,,,,, "Y-",40,39,174.9054993,,3078,,,,, "Y2-",41,39,181.260251,,3436,,,,, "Zr3+",37,40,27.82371007,,154,,,,, "Zr2+",38,40,48.50134887,,430,,,,, "Zr+",39,40,62.04108803,,574,,,,, "Zr-",41,40,134.491762,,2157,,,,, "Zr2-",42,40,135.799622,,2299,,,,, "Nb3+",38,41,33.38250109,,251,,,,, "Nb2+",39,41,45.05976636,,404,,,,, "Nb+",40,41,55.27018046,,512,,,,, "Nb-",42,41,113.5748657,,1684,,,,, "Nb2-",43,41,113.6965766,,1756,,,,, "Mo3+",39,42,22.84407089,,133,,,,, "Mo2+",40,42,31.4231084,,223,,,,, "Mo+",41,42,47.61467467,,424,,,,, "Mo-",43,42,100.2978521,,1385,,,,, "Mo2-",44,42,99.42215985,,1410,,,,, "Tc3+",40,43,20.98163922,,133,,,,, "Tc2+",41,43,28.20843434,,210,,,,, "Tc+",42,43,32.68246568,,246,,,,, "Tc-",44,43,90.57412078,,1169,,,,, "Tc2-",45,43,89.95400259,,1186,,,,, "Ru3+",41,44,18.82432854,,116,,,,, "Ru2+",42,44,25.32926087,,181,,,,, "Ru+",43,44,37.90143983,,327,,,,, "Ru-",45,44,82.37962156,,1007,,,,, "Ru2-",46,44,81.93187267,,1021,,,,, "Rh3+",42,45,17.04928021,,101,,,,, "Rh2+",43,45,22.96614848,,158,,,,, "Rh+",44,45,34.40152113,,284,,,,, "Rh-",46,45,75.86901635,,881,,,,, "Rh2-",47,45,75.44210021,,890,,,,, "Pd3+",43,46,15.55880538,,88.9,,,,, "Pd2+",44,46,20.94017724,,138,,,,, "Pd+",45,46,31.48754065,,248,,,,, "Pd-",47,46,70.46654795,,779,,,,, "Pd2-",48,46,70.17696246,,787,,,,, "Ag3+",44,47,9.171282038,,38.7,,,,, "Ag2+",45,47,12.63934839,,61.6,,,,, "Ag+",46,47,19.96035392,,115,,,,, "Ag-",48,47,66.00662466,,698,,,,, "Cd3+",45,48,11.28415344,,55.7,,,,, "Cd2+",46,48,15.24370967,,86.3,,,,, "Cd+",47,48,23.13382663,,155,,,,, "Cd-",49,48,862.6593606,,20233,,,,, "In3+",46,49,9.806188775,,45.3,,,,, "In2+",47,49,13.27325692,,70.1,,,,, "In+",48,49,20.24418942,,127,,,,, "In-",50,49,133.245673,,2239,,,,, "In2-",51,49,171.525913,,3601,,,,, "Sn3+",47,50,11.06733071,,54.4,,,,, "Sn2+",48,50,15.01367897,,84.2,,,,, "Sn+",49,50,29.18298579,,237,,,,, "Sn-",51,50,89.05139464,,1411,,,,, "Sn2-",52,50,95.75505931,,1702,,,,, "Sb3+",48,51,9.674316684,,44.5,,,,, "Sb2+",49,51,15.77202467,,98.8,,,,, "Sb+",50,51,25.49686716,,215,,,,, "Sb-",52,51,59.64103028,,859,,,,, "Sb2-",53,51,64.9352253,,1041,,,,, "Te3+",49,52,11.77506158,,65.2,,,,, "Te2+",50,52,17.00208822,,122,,,,, "Te+",51,52,25.09214373,,230,,,,, "Te-",53,52,49.1013704,,684,,,,, "Te2-",54,52,53.43013497,,821,,,,, "I3+",50,53,11.75361316,,71.3,,,,, "I2+",51,53,15.99022262,,121,,,,, "I+",52,53,22.10694885,,205,,,,, "I-",54,53,61.65374531,,925,,,,, "Xe3+",51,54,10.75424571,,67.6,,,,, "Xe2+",52,54,13.81046104,,104,,,,, "Xe+",53,54,18.71227599,,170,,,,, "Cs3+",52,55,7.055581513,,38.6,,,,, "Cs2+",53,55,8.982416857,,58.1,,,,, "Cs+",54,55,14.99916591,,129,,,,, "Cs-",56,55,655.9562593,,19574,,,,, "Ba3+",53,56,8.040725388,,50,,,,, "Ba2+",54,56,9.969829615,,71.8,,,,, "Ba+",55,56,121.1834824,,1296,,,,, "La3+",54,57,6.080398338,,34.7,,,,, "La2+",55,57,52.02908905,,404,,,,, "La+",56,57,94.1833322,,1177,,,,, "La-",58,57,318.608817,,6805,,,,, "La2-",59,57,316.5418129,,6767,,,,, "Ce3+",55,58,30.6660268,,197,,,,, "Ce2+",56,58,52.42968917,,513,,,,, "Ce+",57,58,89.14119254,,1081,,,,, "Ce-",59,58,308.7566781,,6460,,,,, "Ce2-",60,58,307.9215432,,6449,,,,, "Pr3+",56,59,37.16704449,,316,,,,, "Pr2+",57,59,54.95751403,,549,,,,, "Pr+",58,59,93.36415376,,1156,,,,, "Pr-",60,59,298.597153,,6128,,,,, "Pr2-",61,59,297.7235279,,6113,,,,, "Nd3+",57,60,35.63914411,,296,,,,, "Nd2+",58,60,52.68798415,,514,,,,, "Nd+",59,60,89.64488413,,1085,,,,, "Nd-",61,60,288.7583059,,5812,,,,, "Nd2-",62,60,288.4621425,,5812,,,,, "Pm3+",58,61,34.00014828,,276,,,,, "Pm2+",59,61,50.26668767,,478,,,,, "Pm+",60,61,85.66775015,,1011,,,,, "Pm-",62,61,279.9914763,,5534,,,,, "Pm2-",63,61,279.6286319,,5531,,,,, "Sm3+",59,62,32.37339509,,255,,,,, "Sm2+",60,62,47.93913319,,444,,,,, "Sm+",61,62,81.78124348,,941,,,,, "Sm-",63,62,271.6778923,,5276,,,,, "Sm2-",64,62,271.2742066,,5270,,,,, "Eu3+",60,63,30.844904,,237,,,,, "Eu2+",61,63,45.70351626,,412,,,,, "Eu+",62,63,78.0884199,,876,,,,, "Eu-",64,63,263.7773424,,5035,,,,, "Eu2-",65,63,263.918988,,5044,,,,, "Gd3+",61,64,26.50681964,,188,,,,, "Gd2+",62,64,39.27421302,,328,,,,, "Gd+",63,64,67.21104193,,698,,,,, "Gd-",65,64,255.5006142,,4793,,,,, "Gd2-",66,64,255.0792362,,4786,,,,, "Tb3+",62,65,28.30317933,,208,,,,, "Tb2+",63,65,41.99350488,,362,,,,, "Tb+",64,65,71.80068817,,769,,,,, "Tb-",66,65,247.6021743,,4566,,,,, "Tb2-",67,65,247.1966953,,4559,,,,, "Dy3+",63,66,27.06473846,,194,,,,, "Dy2+",64,66,40.10350538,,337,,,,, "Dy+",65,66,68.61621806,,717,,,,, "Dy-",67,66,240.0602045,,4353,,,,, "Dy2-",68,66,240.1553599,,4359,,,,, "Ho3+",64,67,25.88492406,,181,,,,, "Ho2+",65,67,38.36930298,,315,,,,, "Ho+",66,67,65.77255239,,672,,,,, "Ho-",68,67,233.339601,,4165,,,,, "Ho2-",69,67,233.4187472,,4170,,,,, "Er3+",65,68,24.76718285,,169,,,,, "Er2+",66,68,36.72215739,,294,,,,, "Er+",67,68,63.04138293,,630,,,,, "Er-",69,68,226.8966596,,3989,,,,, "Er2-",70,68,226.9706698,,3993,,,,, "Tm3+",66,69,23.70914836,,158,,,,, "Tm2+",67,69,35.17916554,,276,,,,, "Tm+",68,69,60.42412114,,590,,,,, "Tm-",70,69,221.1561765,,3833,,,,, "Yb3+",67,70,22.73280525,,148,,,,, "Yb2+",68,70,33.78154259,,259,,,,, "Yb+",69,70,58.02423831,,555,,,,, "Lu3+",68,71,29.17518173,,215,,,,, "Lu2+",69,71,43.36991638,,376,,,,, "Lu+",70,71,74.63752627,,808,,,,, "Lu-",72,71,171.1936009,,2997,,,,, "Lu2-",73,71,180.1392674,,3423,,,,, "Hf3+",69,72,21.65516428,,138,,,,, "Hf2+",70,72,32.21007574,,241,,,,, "Hf+",71,72,47.49619582,,443,,,,, "Hf-",73,72,130.605184,,2140,,,,, "Hf2-",74,72,132.9311225,,2317,,,,, "Ta3+",70,73,21.61520395,,137,,,,, "Ta2+",71,73,28.77033815,,216,,,,, "Ta+",72,73,42.03194101,,388,,,,, "Ta-",74,73,110.5829441,,1709,,,,, "Ta2-",75,73,111.1041855,,1802,,,,, "W3+",71,74,19.24590151,,121,,,,, "W2+",72,74,25.51121877,,189,,,,, "W+",73,74,37.13455217,,333,,,,, "W-",75,74,98.16720668,,1437,,,,, "W2-",76,74,97.21433253,,1470,,,,, "Re3+",72,75,17.35136626,,108,,,,, "Re2+",73,75,22.94965141,,167,,,,, "Re+",74,75,33.37322163,,290,,,,, "Re-",76,75,88.96749882,,1230,,,,, "Re2-",77,75,88.2616446,,1254,,,,, "Os3+",73,76,15.80752513,,97.3,,,,, "Os2+",74,76,20.88002354,,148,,,,, "Os+",75,76,30.4070176,,256,,,,, "Os-",77,76,81.79879506,,1083,,,,, "Os2-",78,76,81.28978161,,1103,,,,, "Ir3+",74,77,14.5094386,,87.8,,,,, "Ir2+",75,77,19.1600502,,133,,,,, "Ir+",76,77,27.90932985,,228,,,,, "Ir-",78,77,76.04866652,,965,,,,, "Ir2-",79,77,75.6407796,,982,,,,, "Pt3+",75,78,13.40330956,,79.5,,,,, "Pt2+",76,78,17.67018875,,119,,,,, "Pt+",77,78,25.81239276,,204,,,,, "Pt-",79,78,71.26933347,,868,,,,, "Pt2-",80,78,70.91342145,,881,,,,, "Au3+",76,79,12.43344255,,72.3,,,,, "Au2+",77,79,16.40086293,,108,,,,, "Au+",78,79,24.02517369,,184,,,,, "Au-",80,79,67.31574146,,788,,,,, "Hg3+",77,80,9.004657926,,45.2,,,,, "Hg2+",78,80,11.89452712,,67.3,,,,, "Hg+",79,80,17.49461789,,114,,,,, "Tl3+",78,81,8.688490795,,43.3,,,,, "Tl2+",79,81,11.49256921,,64.3,,,,, "Tl+",80,81,16.98077998,,109,,,,, "Tl-",82,81,144.6204221,,2621,,,,, "Tl2-",83,81,186.4317606,,4197,,,,, "Pb3+",79,82,9.157015943,,47.2,,,,, "Pb2+",80,82,12.13216218,,69.9,,,,, "Pb+",81,82,23.4679779,,185,,,,, "Pb-",83,82,100.7630653,,1764,,,,, "Pb2-",84,82,108.3145086,,2121,,,,, "Bi3+",80,83,9.604834653,,51,,,,, "Bi2+",81,83,15.62114777,,107,,,,, "Bi+",82,83,25.18967763,,226,,,,, "Bi-",84,83,69.6226131,,1130,,,,, "Bi2-",85,83,75.80186708,,1365,,,,, "Po3+",81,84,10.75138497,,63.9,,,,, "Po2+",82,84,15.53016047,,115,,,,, "Po+",83,84,22.85078432,,213,,,,, "Po-",85,84,58.83665769,,936,,,,, "Po2-",86,84,64.01979864,,1120,,,,, "At3+",82,85,10.79084626,,69.2,,,,, "At2+",83,85,14.66827515,,114,,,,, "At+",84,85,20.21371407,,190,,,,, "At-",86,85,54.4739698,,801,,,,, "Rn3+",83,86,12.94058497,,97.5,,,,, "Rn2+",84,86,16.60787711,,147,,,,, "Rn+",85,86,22.3881953,,236,,,,, libmbd-libmbd-88d61bc/tests/000077500000000000000000000000001452573331700157675ustar00rootroot00000000000000libmbd-libmbd-88d61bc/tests/CMakeLists.txt000066400000000000000000000027271452573331700205370ustar00rootroot00000000000000add_executable(mbd_grad_tests mbd_grad_tests.F90 mbd_grad_test_cases.F90) add_executable(mbd_api_tests mbd_api_tests.F90) foreach(TEST_APP mbd_grad_tests mbd_api_tests) target_include_directories(${TEST_APP} PRIVATE $) target_link_libraries(${TEST_APP} PRIVATE mbd) if(ENABLE_SCALAPACK_MPI) target_link_libraries(${TEST_APP} PRIVATE MPI::MPI_Fortran) set_property(TARGET ${TEST_APP} APPEND PROPERTY COMPILE_DEFINITIONS WITH_MPI WITH_SCALAPACK) endif() if(ENABLE_ELSI) set_property(TARGET ${TEST_APP} APPEND PROPERTY COMPILE_DEFINITIONS WITH_ELSI) endif() endforeach() execute_process( COMMAND ${CMAKE_CURRENT_SOURCE_DIR}/collect-mbd-tests.py WORKING_DIRECTORY ${PROJECT_SOURCE_DIR} OUTPUT_VARIABLE TESTS OUTPUT_STRIP_TRAILING_WHITESPACE ) if(ENABLE_SCALAPACK_MPI) set(MPI_NODES $ENV{MPI_NODES}) if(NOT "${MPI_NODES}") set(MPI_NODES ${MPIEXEC_MAX_NUMPROCS}) endif() set(MPIEXEC_EXTRA_FLAGS $ENV{MPIEXEC_EXTRA_FLAGS}) endif() foreach(TEST ${TESTS}) string(REPLACE "/" ";" TEST_APP_CASE ${TEST}) list(GET TEST_APP_CASE 0 TEST_APP) list(GET TEST_APP_CASE 1 TEST_CASE) add_test(NAME "${TEST_APP}/${TEST_CASE}" COMMAND ${MPIEXEC_EXECUTABLE} ${MPIEXEC_EXTRA_FLAGS} ${MPIEXEC_NUMPROC_FLAG} ${MPI_NODES} ${MPIEXEC_PREFLAGS} $ ${TEST_CASE} ${MPIEXEC_POSTFLAGS} ) endforeach() libmbd-libmbd-88d61bc/tests/collect-mbd-tests.py000077500000000000000000000006561452573331700217000ustar00rootroot00000000000000#!/usr/bin/env python3 import re tests = [] with open('tests/mbd_grad_test_cases.F90') as f: for l in f: m = re.match(r' *subroutine *test_(\w+) *\(', l) if m: tests.append(f'grad/{m.group(1)}') with open('tests/mbd_api_tests.F90') as f: for l in f: m = re.match(r' *case *\( *["\'](\w+)["\'] *\)', l) if m: tests.append(f'api/{m.group(1)}') print(';'.join(tests)) libmbd-libmbd-88d61bc/tests/conftest.py000066400000000000000000000135121452573331700201700ustar00rootroot00000000000000import numpy as np import pytest from pymbd import ang from pymbd.fortran import with_mpi, with_scalapack def pytest_collection_modifyitems(config, items): if with_scalapack: skip = pytest.mark.skip(reason="doesn't support ScaLAPACK") for item in items: if 'no_scalapack' in item.keywords: item.add_marker(skip) if with_mpi: from mpi4py import MPI if with_mpi: from functools import wraps import _pytest._io.terminalwriter rank = MPI.COMM_WORLD.Get_rank() _write_out = _pytest._io.terminalwriter.TerminalWriter.write @wraps(_write_out) def write_wrapper(*args, **kwargs): if rank == 0: _write_out(*args, **kwargs) _pytest._io.terminalwriter.TerminalWriter.write = write_wrapper # fmt: off @pytest.fixture def benzene_dimer(): return [ (np.array([ (-1.047, -1.421, 0.000), (-1.454, -0.855, 1.206), (-1.454, -0.855, -1.206), (-2.266, 0.277, 1.206), (-2.671, 0.845, 0.000), (-2.266, 0.277, -1.206), (-1.133, -1.292, -2.142), (-2.582, 0.716, -2.143), (-3.303, 1.723, 0.000), (-2.582, 0.716, 2.143), (-1.133, -1.292, 2.142), (-0.406, -2.291, 0.000)]) * ang, 6 * ['C'] + 6 * ['H'], [0.825, 0.821, 0.821, 0.815, 0.814, 0.815, 0.624, 0.611, 0.610, 0.611, 0.624, 0.643]), (np.array([ (1.047, 1.421, 0.000), (1.454, 0.855, -1.206), (1.454, 0.855, 1.206), (2.266, -0.277, -1.206), (2.671, -0.845, 0.000), (2.266, -0.277, 1.206), (0.406, 2.291, 0.000), (1.133, 1.292, 2.142), (2.582, -0.716, 2.143), (3.303, -1.723, 0.000), (2.582, -0.716, -2.143), (1.133, 1.292, -2.142)]) * ang, 6 * ['C'] + 6 * ['H'], [0.825, 0.821, 0.821, 0.815, 0.814, 0.815, 0.643, 0.624, 0.611, 0.610, 0.611, 0.624])] @pytest.fixture def ethylcarbamate(): return [ (np.array([ (4.083, 5.700, 2.856), (0.568, 0.095, 4.217), (0.470, 4.774, 3.551), (4.181, 1.022, 3.522), (5.572, 5.587, 1.892), (-0.920, 0.209, 5.181), (3.663, 3.255, 2.585), (0.988, 2.541, 4.488), (3.834, 4.011, 0.979), (0.816, 1.785, 6.094), (2.223, 1.314, 1.108), (2.428, 4.481, 5.965), (1.177, 0.092, 0.406), (3.474, 5.703, 6.667), (4.911, 5.036, 2.573), (-0.260, 0.759, 4.500), (4.358, 3.787, 1.918), (0.293, 2.009, 5.155), (0.205, 1.729, 1.101), (4.446, 4.067, 5.972), (1.285, 0.947, 0.957), (3.366, 4.848, 6.116), (0.485, 2.901, 1.709), (4.165, 2.895, 5.364), (4.066, 1.426, 0.670), (0.585, 4.369, 6.403)]) * ang, np.array([ (5.008, 0.018, -0.070), (1.630, 6.759, 0.064), (-1.987, -0.981, 7.079)]) * ang, (2, 2, 2), list('HHHHHHHHHHHHHHCCCCCCNNOOOO'), [0.703, 0.703, 0.726, 0.726, 0.731, 0.731, 0.727, 0.727, 0.754, 0.754, 0.750, 0.750, 0.755, 0.755, 0.809, 0.809, 0.827, 0.827, 0.834, 0.834, 0.840, 0.840, 0.886, 0.886, 0.892, 0.892]), (np.array([ (4.088, 5.753, 2.783), (5.625, 5.562, 1.906), (3.652, 3.273, 2.592), (3.854, 3.998, 0.981), (5.422, 4.834, 3.521), (6.213, 0.125, 0.386), (7.201, 1.360, 1.112), (4.913, 5.058, 2.573), (4.366, 3.792, 1.934), (5.167, 1.729, 1.084), (6.291, 0.963, 0.938), (4.042, 1.399, 0.752), (5.490, 2.915, 1.682)]) * ang, None, None, list('HHHHHHHCCCNOO'), [0.581, 0.607, 0.642, 0.646, 0.607, 0.596, 0.597, 0.762, 0.799, 0.845, 0.824, 0.974, 0.896]), ] @pytest.fixture def argon_crystal(): return ( np.array([(0.3, 0.1, 0.2), (4.1, -0.2, -0.1)]) * ang, np.array([(8.1, 0.1, -0.2), (0.3, 3.9, -0.1), (-0.1, 0.2, 4.2)]) * ang, (4, 4, 4), ['Ar', 'Ar'], [1.0, 1.0], ) @pytest.fixture def peptide_meoh(): return [ (np.array([ (2.137, 0.252, 0.453), (2.857, 0.879, 0.544), (2.656, -1.053, 0.687), (1.823, -1.742, 0.582), (3.422, -1.322, -0.039), (3.064, -1.154, 1.693)]) * ang, list('OHCHHH'), [0.9114, 0.5960, 0.7523, 0.5886, 0.5850, 0.5850]), (np.array([ (-0.849, -0.339, 2.491), (0.184, -0.011, 2.416), (-0.882, -1.342, 2.912), (-1.390, 0.316, 3.168), (-1.564, -0.353, 1.159), (-2.749, -0.651, 1.056), (-0.801, -0.027, 0.088), (0.161, 0.240, 0.218), (-1.385, -0.002, -1.234), (-1.891, -0.942, -1.440), (-2.119, 0.796, -1.330), (-0.594, 0.149, -1.963)]) * ang, list('CHHHCONHCHHH'), [0.7657, 0.6027, 0.6062, 0.6077, 0.8343, 0.9815, 0.8325, 0.5931, 0.7592, 0.6286, 0.6133, 0.5698]), (np.array([ (-0.849, -0.339, 2.491), (0.184, -0.011, 2.416), (-0.882, -1.342, 2.912), (-1.390, 0.316, 3.168), (-1.564, -0.353, 1.159), (-2.749, -0.651, 1.056), (-0.801, -0.027, 0.088), (0.161, 0.240, 0.218), (-1.385, -0.002, -1.234), (-1.891, -0.942, -1.440), (-2.119, 0.796, -1.330), (-0.594, 0.149, -1.963), (2.137, 0.252, 0.453), (2.857, 0.879, 0.544), (2.656, -1.053, 0.687), (1.823, -1.742, 0.582), (3.422, -1.322, -0.039), (3.064, -1.154, 1.693)]) * ang, list('CHHHCONHCHHHOHCHHH'), [0.7767, 0.6594, 0.6193, 0.6167, 0.8414, 0.9898, 0.8462, 0.7213, 0.7668, 0.6367, 0.6211, 0.5915, 0.8615, 0.5511, 0.7415, 0.6022, 0.5701, 0.5759]) ] @pytest.fixture def bulk_lithium(): return ( np.array([(0.0, 0.0, 0.0)]) * ang, np.array([ (-1.7385, 1.7385, 1.7385), (1.7385, -1.7385, 1.7385), (1.7385, 1.7385, -1.7385)]) * ang, (4, 4, 4), ['Li'], [1.0], ) libmbd-libmbd-88d61bc/tests/mbd_api_tests.F90000066400000000000000000000056741452573331700211000ustar00rootroot00000000000000! This Source Code Form is subject to the terms of the Mozilla Public ! License, v. 2.0. If a copy of the MPL was not distributed with this ! file, You can obtain one at http://mozilla.org/MPL/2.0/. program mbd_api_tests use mbd_constants use mbd, only: mbd_input_t, mbd_calc_t #ifdef WITH_MPI use mbd_mpi #endif implicit none logical :: failed character(len=50) :: test_name #ifdef WITH_MPI integer :: err call MPI_INIT(err) #endif call get_command_argument(1, test_name) failed = .false. call test(test_name) #ifdef WITH_MPI call MPI_FINALIZE(err) #endif if (failed) stop 1 contains subroutine test(test_name) character(len=*), intent(in) :: test_name type(mbd_input_t) :: inp type(mbd_calc_t) :: calc real(dp) :: energy real(dp), allocatable :: gradients(:, :) integer :: code character(200) :: origin, msg inp%atom_types = ['Ar', 'Ar'] inp%coords = reshape([0d0, 0d0, 0d0, 0d0, 0d0, 4d0 * ang], [3, 2]) inp%log_level = MBD_LOG_LVL_DEBUG inp%xc = 'pbe' select case (test_name) case ('exception') inp%xc = 'xxx' call calc%init(inp) call calc%get_exception(code, origin, msg) if (code /= MBD_EXC_DAMPING) failed = .true. case ('energy') call calc%init(inp) call calc%update_vdw_params_custom([11d0, 11d0], [63.525d0, 63.525d0], [3.55d0, 3.55d0]) call calc%evaluate_vdw_method(energy) call check(energy, -2.4329456747018696d-4, 1d-10) case ('gradients') call calc%init(inp) call calc%update_vdw_params_custom([11d0, 11d0], [63.525d0, 63.525d0], [3.55d0, 3.55d0]) call calc%evaluate_vdw_method(energy) allocate (gradients(3, 2)) call calc%get_gradients(gradients) call check(sum(abs(gradients)), 2.3279742219399908d-4, 1d-10) case ('energy_from_ratios') call calc%init(inp) call calc%update_vdw_params_from_ratios([1d0, 1d0]) call calc%evaluate_vdw_method(energy) call check(energy, -0.0002462647623815428d0, 1d-10) case ('hirshfeld_gradients') inp%calculate_vdw_params_gradients = .true. call calc%init(inp) call calc%update_vdw_params_from_ratios([1d0, 1d0]) call calc%evaluate_vdw_method(energy) allocate (gradients(2, 1)) call calc%get_vdw_params_ratios_gradients(gradients(:, 1)) call check(sum(abs(gradients)), 2.9686524938125897d-004, 1d-10) case ('ts_gradients') inp%method = 'ts' call calc%init(inp) call calc%update_vdw_params_from_ratios([1d0, 1d0]) call calc%evaluate_vdw_method(energy) allocate (gradients(3, 2)) call calc%get_gradients(gradients) call check(sum(abs(gradients)), 3.8405275467790542d-4, 1d-10) end select call calc%destroy() end subroutine subroutine check(val, ref, rel) real(dp), intent(in) :: val, ref, rel if (.not. abs((val - ref) / ref) < rel) then failed = .true. end if end subroutine end program libmbd-libmbd-88d61bc/tests/mbd_grad_test_cases.F90000066400000000000000000001770641452573331700222420ustar00rootroot00000000000000! This Source Code Form is subject to the terms of the Mozilla Public ! License, v. 2.0. If a copy of the MPL was not distributed with this ! file, You can obtain one at http://mozilla.org/MPL/2.0/. module mbd_grad_test_cases use mbd_constants use mbd_damping, only: damping_t, damping_fermi use mbd_dipole, only: dipole_matrix, T_bare, T_erf_coulomb, damping_grad, T_erfc use mbd_geom, only: geom_t use mbd_gradients, only: grad_t, grad_matrix_re_t, grad_request_t, grad_scalar_t use mbd_hamiltonian, only: get_mbd_hamiltonian_energy use mbd_methods, only: get_mbd_scs_energy use mbd_ts, only: get_ts_energy use mbd_scs, only: run_scs use mbd_utils, only: diff7, findval, tostr, result_t implicit none type(geom_t), allocatable :: geom integer :: n_failed, rank contains logical function failed(diff, thre) real(dp), intent(in) :: diff, thre failed = .not. abs(diff) < thre if (rank == 0) write (6, '(A,G10.3,A,G10.3,A)') 'diff:', diff, ', threshold:', thre, ': ' if (failed) n_failed = n_failed + 1 end function subroutine print_matrix(label, A, prec) character(len=*), intent(in) :: label real(dp), intent(in) :: A(:, :) integer, optional, intent(in) :: prec integer :: m, n, i, j, prec_ character(len=10) :: fm if (present(prec)) then prec_ = prec else prec_ = 3 end if m = size(A, 1) n = size(A, 2) write (fm, '("(g",i2,".",i1,")")') prec_ + 8, prec_ write (6, '(A,":")') label do i = 1, m do j = 1, n write (6, fm, advance="no") A(i, j) end do write (6, *) end do end subroutine subroutine test_T_bare_deriv() real(dp) :: r(3), r_diff(3), T(3, 3), diff(3, 3), T_diff_num(3, 3, -3:3), delta type(grad_matrix_re_t) :: dT integer :: a, b, c, i_step delta = 1d-2 r = [1.12d0, -2.12d0, 0.12d0] T = T_bare(r, dT, .true.) diff = 0d0 do c = 1, 3 do i_step = -3, 3 if (i_step == 0) cycle r_diff = r r_diff(c) = r_diff(c) + i_step * delta T_diff_num(:, :, i_step) = T_bare(r_diff) end do #ifndef WITHOUT_DO_CONCURRENT do concurrent(a=1:3, b=1:3) #else do a = 1, 3 do b = 1, 3 #endif T_diff_num(a, b, 0) = diff7(T_diff_num(a, b, :), delta) end do #ifdef WITHOUT_DO_CONCURRENT end do #endif diff = max(diff, abs(T_diff_num(:, :, 0) - dT%dr(:, :, c)) / T_diff_num(:, :, 0)) end do if (failed(maxval(abs(diff)), 1d-10)) then end if end subroutine subroutine test_T_GG_deriv_expl() real(dp) :: r(3), r_diff(3), T(3, 3), diff(3, 3), T_diff_num(3, 3, -3:3), delta, sigma type(grad_matrix_re_t) :: dT integer :: a, b, c, i_step delta = 1d-2 r = [1.02d0, -2.22d0, 0.15d0] sigma = 1.2d0 T = T_erf_coulomb(r, sigma, dT, grad_request_t(dcoords=.true.)) diff = 0d0 do c = 1, 3 do i_step = -3, 3 if (i_step == 0) cycle r_diff = r r_diff(c) = r_diff(c) + i_step * delta T_diff_num(:, :, i_step) = T_erf_coulomb(r_diff, sigma) end do #ifndef WITHOUT_DO_CONCURRENT do concurrent(a=1:3, b=1:3) #else do a = 1, 3 do b = 1, 3 #endif T_diff_num(a, b, 0) = diff7(T_diff_num(a, b, :), delta) end do #ifdef WITHOUT_DO_CONCURRENT end do #endif diff = max(diff, abs(T_diff_num(:, :, 0) - dT%dr(:, :, c)) / T_diff_num(:, :, 0)) end do if (failed(maxval(abs(diff)), 1d-10)) then end if end subroutine subroutine test_T_GG_deriv_impl() real(dp) :: r(3), T(3, 3), diff(3, 3), T_diff_num(3, 3, -3:3), delta, sigma, sigma_diff type(grad_matrix_re_t) :: dT integer :: a, b, i_step delta = 1d-3 r = [1.02d0, -2.22d0, 0.15d0] sigma = 1.2d0 T = T_erf_coulomb(r, sigma, dT, grad_request_t(dsigma=.true.)) do i_step = -3, 3 if (i_step == 0) cycle sigma_diff = sigma + i_step * delta T_diff_num(:, :, i_step) = T_erf_coulomb(r, sigma_diff) end do #ifndef WITHOUT_DO_CONCURRENT do concurrent(a=1:3, b=1:3) #else do a = 1, 3 do b = 1, 3 #endif T_diff_num(a, b, 0) = diff7(T_diff_num(a, b, :), delta) end do #ifdef WITHOUT_DO_CONCURRENT end do #endif diff = (T_diff_num(:, :, 0) - dT%dsigma) / T_diff_num(:, :, 0) if (failed(maxval(abs(diff)), 1d-10)) then call print_matrix('delta dTGG', diff) end if end subroutine subroutine test_T_fermi_deriv_impl() real(dp) :: r(3), T(3, 3), T0(3, 3), & diff(3, 3), T_diff_num(3, 3, -3:3), delta, rvdw, rvdw_diff, f type(grad_matrix_re_t) :: dT, dT0 type(grad_scalar_t) :: df integer :: a, b, i_step delta = 1d-3 r = [1.02d0, -2.22d0, 0.15d0] rvdw = 2.5d0 f = damping_fermi(r, rvdw, 6d0, df, grad_request_t(dr_vdw=.true.)) T0 = T_bare(r) T = damping_grad(f, df, T0, dT0, dT, grad_request_t(dr_vdw=.true.)) do i_step = -3, 3 if (i_step == 0) cycle rvdw_diff = rvdw + i_step * delta T_diff_num(:, :, i_step) = damping_fermi(r, rvdw_diff, 6d0) * T_bare(r) end do #ifndef WITHOUT_DO_CONCURRENT do concurrent(a=1:3, b=1:3) #else do a = 1, 3 do b = 1, 3 #endif T_diff_num(a, b, 0) = diff7(T_diff_num(a, b, :), delta) end do #ifdef WITHOUT_DO_CONCURRENT end do #endif diff = (T_diff_num(:, :, 0) - dT%dvdw) / T_diff_num(:, :, 0) if (failed(maxval(abs(diff)), 1d-10)) then call print_matrix('delta dTfermi', diff) end if end subroutine subroutine test_T_erfc_deriv_expl() real(dp) :: r(3), r_diff(3), T(3, 3), diff(3, 3), T_diff_num(3, 3, -3:3), delta, gamm type(grad_matrix_re_t) :: dT integer :: a, b, c, i_step delta = 1d-2 r = [1.02d0, -2.22d0, 0.15d0] gamm = 1.2d0 T = T_erfc(r, gamm, dT, grad_request_t(dcoords=.true.)) diff = 0d0 do c = 1, 3 do i_step = -3, 3 if (i_step == 0) cycle r_diff = r r_diff(c) = r_diff(c) + i_step * delta T_diff_num(:, :, i_step) = T_erfc(r_diff, gamm) end do #ifndef WITHOUT_DO_CONCURRENT do concurrent(a=1:3, b=1:3) #else do a = 1, 3 do b = 1, 3 #endif T_diff_num(a, b, 0) = diff7(T_diff_num(a, b, :), delta) end do #ifdef WITHOUT_DO_CONCURRENT end do #endif diff = max(diff, abs(T_diff_num(:, :, 0) - dT%dr(:, :, c)) / T_diff_num(:, :, 0)) end do if (failed(maxval(abs(diff)), 1d-9)) then end if end subroutine subroutine test_mbd_deriv_expl() real(dp) :: delta type(damping_t) :: damp real(dp), allocatable :: coords(:, :) real(dp), allocatable :: gradients(:, :) real(dp), allocatable :: diff(:, :) real(dp), allocatable :: alpha_0(:) real(dp), allocatable :: omega(:) type(result_t) :: res(-3:3) real(dp), allocatable :: gradients_anl(:, :) integer :: i_atom, n_atoms, i_xyz, i_step delta = 0.01d0 n_atoms = 3 allocate (coords(3, n_atoms), source=0d0) allocate (gradients(n_atoms, 3)) coords(1, 3) = 1d0 coords(2, 1) = 4d0 coords(3, 2) = 4d0 geom%coords = coords call geom%init() damp%version = 'fermi,dip' damp%r_vdw = [3.55d0, 3.5d0, 3.56d0] damp%beta = 0.83d0 alpha_0 = [11d0, 10d0, 12d0] omega = [.7d0, .65d0, .75d0] res(0) = get_mbd_hamiltonian_energy(geom, alpha_0, omega, damp, grad_request_t(dcoords=.true.)) gradients_anl = res(0)%dE%dcoords do i_atom = 1, n_atoms do i_xyz = 1, 3 do i_step = -3, 3 if (i_step == 0) cycle geom%coords = coords geom%coords(i_xyz, i_atom) = geom%coords(i_xyz, i_atom) + i_step * delta res(i_step) = get_mbd_hamiltonian_energy(geom, alpha_0, omega, damp, grad_request_t()) end do gradients(i_atom, i_xyz) = diff7(res%energy, delta) end do end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 1d-8)) then call print_matrix('delta gradients', diff) end if end subroutine subroutine test_mbd_ewald_deriv_expl() real(dp) :: delta, k_point(3) type(damping_t) :: damp real(dp), allocatable :: & coords(:, :), gradients(:, :), diff(:, :), alpha_0(:), omega(:), & gradients_anl(:, :) type(result_t) :: res(-3:3) integer :: i_atom, n_atoms, i_xyz, i_step delta = 0.01d0 n_atoms = 2 allocate (coords(3, n_atoms), source=0d0) allocate (gradients(n_atoms, 3)) coords(3, 1) = 1d0 coords(1, 2) = 1d0 coords(2, 2) = 4d0 geom%coords = coords geom%lattice = reshape([6d0, 1d0, 0d0, -1d0, 9d0, 1d0, 0d0, 1d0, 7d0], [3, 3]) k_point = [0.4d0, 0d0, 0d0] call geom%init() damp%version = 'fermi,dip' damp%r_vdw = [3.55d0, 3.5d0] damp%beta = 0.83d0 alpha_0 = [11d0, 10d0] omega = [.7d0, .65d0] res(0) = get_mbd_hamiltonian_energy(geom, alpha_0, omega, damp, & grad_request_t(dcoords=.true.), k_point) gradients_anl = res(0)%dE%dcoords do i_atom = 1, n_atoms do i_xyz = 1, 3 do i_step = -3, 3 if (i_step == 0) cycle geom%coords = coords geom%coords(i_xyz, i_atom) = geom%coords(i_xyz, i_atom) + i_step * delta res(i_step) = get_mbd_hamiltonian_energy(geom, alpha_0, omega, damp, & grad_request_t(), k_point) end do gradients(i_atom, i_xyz) = diff7(res%energy, delta) end do end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 2d-8)) then call print_matrix('delta gradients', diff) call print_matrix('anl', gradients_anl) call print_matrix('num', gradients) end if end subroutine subroutine test_mbd_ewald_deriv_impl_q() real(dp) :: delta, k_point(3), k_point_diff(3) type(damping_t) :: damp real(dp), allocatable :: & gradients(:), diff(:), alpha_0(:), omega(:), gradients_anl(:) type(result_t) :: res(-3:3) integer :: n_atoms, i_xyz, i_step delta = 0.01d0 n_atoms = 2 allocate (geom%coords(3, n_atoms), source=0d0) allocate (gradients(3)) geom%coords(3, 1) = 1d0 geom%coords(1, 2) = 1d0 geom%coords(2, 2) = 4d0 geom%lattice = reshape([6d0, 1d0, 0d0, -1d0, 9d0, 1d0, 0d0, 1d0, 7d0], [3, 3]) k_point = [0.4d0, 0d0, 0d0] call geom%init() damp%version = 'fermi,dip' damp%r_vdw = [3.55d0, 3.5d0] damp%beta = 0.83d0 alpha_0 = [11d0, 10d0] omega = [.7d0, .65d0] res(0) = get_mbd_hamiltonian_energy(geom, alpha_0, omega, damp, & grad_request_t(dq=.true.), k_point) gradients_anl = res(0)%dE%dq do i_xyz = 1, 3 do i_step = -3, 3 if (i_step == 0) cycle k_point_diff = k_point k_point_diff(i_xyz) = k_point_diff(i_xyz) + i_step * delta res(i_step) = get_mbd_hamiltonian_energy(geom, alpha_0, omega, damp, & grad_request_t(), k_point_diff) end do gradients(i_xyz) = diff7(res%energy, delta) end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 1d-6)) then print *, 'delta gradients', diff print *, 'anl', gradients_anl print *, 'num', gradients end if end subroutine subroutine test_mbd_ewald_deriv_stress() real(dp) :: delta, k_point(3) type(damping_t) :: damp real(dp), allocatable :: & lattice(:, :), gradients(:, :), diff(:, :), alpha_0(:), omega(:), & gradients_anl(:, :) type(result_t) :: res(-3:3) integer :: i_latt, n_atoms, i_xyz, i_step delta = 0.01d0 n_atoms = 2 allocate (geom%coords(3, n_atoms), source=0d0) allocate (gradients(3, 3)) geom%coords(3, 1) = 1d0 geom%coords(1, 2) = 1d0 geom%coords(2, 2) = 4d0 lattice = reshape([6d0, 1d0, 0d0, -1d0, 9d0, 1d0, 0d0, 1d0, 7d0], [3, 3]) geom%lattice = lattice k_point = [0.4d0, 0d0, 0d0] call geom%init() damp%version = 'fermi,dip' damp%r_vdw = [3.55d0, 3.5d0] damp%beta = 0.83d0 alpha_0 = [11d0, 10d0] omega = [.7d0, .65d0] res(0) = get_mbd_hamiltonian_energy(geom, alpha_0, omega, damp, & grad_request_t(dlattice=.true.), k_point) gradients_anl = res(0)%dE%dlattice do i_latt = 1, 3 do i_xyz = 1, 3 do i_step = -3, 3 if (i_step == 0) cycle geom%lattice = lattice geom%lattice(i_xyz, i_latt) = geom%lattice(i_xyz, i_latt) + i_step * delta res(i_step) = get_mbd_hamiltonian_energy(geom, alpha_0, omega, damp, & grad_request_t(), k_point) end do gradients(i_latt, i_xyz) = diff7(res%energy, delta) end do end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 1d-5)) then call print_matrix('delta gradients', diff) call print_matrix('anl', gradients_anl) call print_matrix('num', gradients) end if end subroutine subroutine test_scs_deriv_expl() real(dp) :: delta type(damping_t) :: damp real(dp), allocatable :: coords(:, :) real(dp), allocatable :: gradients(:, :, :), gradients_anl(:, :, :) real(dp), allocatable :: diff(:, :, :) real(dp), allocatable :: alpha_0(:) integer :: i_atom, n_atoms, i_xyz, i_step, j_atom, my_i_atom, my_nratoms, & my_ncatoms, my_j_atom real(dp), allocatable :: alpha_scs(:, :) type(grad_t), allocatable :: dalpha_scs(:) delta = 0.05d0 n_atoms = 3 allocate (coords(3, n_atoms), source=0d0) coords(1, 3) = 1d0 coords(2, 1) = 4d0 coords(3, 2) = 4d0 geom%coords = coords call geom%init() my_nratoms = size(geom%idx%i_atom) my_ncatoms = size(geom%idx%j_atom) allocate (gradients(my_nratoms, my_ncatoms, 3)) allocate (gradients_anl(my_nratoms, my_ncatoms, 3)) allocate (alpha_scs(n_atoms, -3:3), dalpha_scs(my_nratoms)) damp%version = 'fermi,dip,gg' damp%r_vdw = [3.55d0, 3.5d0, 3.56d0] damp%beta = 0.83d0 alpha_0 = [11d0, 10d0, 12d0] alpha_scs(:, 0) = & run_scs(geom, alpha_0, damp, dalpha_scs, grad_request_t(dcoords=.true.)) do my_i_atom = 1, my_nratoms gradients_anl(my_i_atom, :, :) = dalpha_scs(my_i_atom)%dcoords end do do j_atom = 1, n_atoms my_j_atom = findval(geom%idx%j_atom, j_atom) do i_xyz = 1, 3 do i_step = -3, 3 if (i_step == 0) cycle geom%coords = coords geom%coords(i_xyz, j_atom) = geom%coords(i_xyz, j_atom) + & i_step * delta alpha_scs(:, i_step) = & run_scs(geom, alpha_0, damp, dalpha_scs, grad_request_t()) end do if (my_j_atom > 0) then do my_i_atom = 1, my_nratoms i_atom = geom%idx%i_atom(my_i_atom) gradients(my_i_atom, my_j_atom, i_xyz) = & diff7(alpha_scs(i_atom, :), delta) end do end if end do end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 1d-5)) then call print_matrix('diff x', diff(:, :, 1)) call print_matrix('diff y', diff(:, :, 2)) call print_matrix('diff z', diff(:, :, 3)) end if end subroutine subroutine test_scs_ewald_deriv_expl() real(dp) :: delta type(damping_t) :: damp real(dp), allocatable :: coords(:, :) real(dp), allocatable :: gradients(:, :, :), gradients_anl(:, :, :) real(dp), allocatable :: diff(:, :, :) real(dp), allocatable :: alpha_0(:) integer :: i_atom, n_atoms, i_xyz, i_step, j_atom, my_i_atom, my_nratoms, & my_ncatoms, my_j_atom real(dp), allocatable :: alpha_scs(:, :) type(grad_t), allocatable :: dalpha_scs(:) delta = 0.05d0 n_atoms = 2 allocate (coords(3, n_atoms), source=0d0) coords(3, 1) = 1d0 coords(1, 2) = 1d0 coords(2, 2) = 4d0 geom%coords = coords geom%lattice = reshape([6d0, 1d0, 0d0, -1d0, 9d0, 1d0, 0d0, 1d0, 7d0], [3, 3]) call geom%init() my_nratoms = size(geom%idx%i_atom) my_ncatoms = size(geom%idx%j_atom) allocate (gradients(my_nratoms, my_ncatoms, 3)) allocate (gradients_anl(my_nratoms, my_ncatoms, 3)) allocate (alpha_scs(n_atoms, -3:3), dalpha_scs(my_nratoms)) damp%version = 'fermi,dip,gg' damp%r_vdw = [3.55d0, 3.5d0] damp%beta = 0.83d0 alpha_0 = [11d0, 10d0] alpha_scs(:, 0) = & run_scs(geom, alpha_0, damp, dalpha_scs, grad_request_t(dcoords=.true.)) do my_i_atom = 1, my_nratoms gradients_anl(my_i_atom, :, :) = dalpha_scs(my_i_atom)%dcoords end do do j_atom = 1, n_atoms my_j_atom = findval(geom%idx%j_atom, j_atom) do i_xyz = 1, 3 do i_step = -3, 3 if (i_step == 0) cycle geom%coords = coords geom%coords(i_xyz, j_atom) = geom%coords(i_xyz, j_atom) + & i_step * delta alpha_scs(:, i_step) = & run_scs(geom, alpha_0, damp, dalpha_scs, grad_request_t()) end do if (my_j_atom > 0) then do my_i_atom = 1, my_nratoms i_atom = geom%idx%i_atom(my_i_atom) gradients(my_i_atom, my_j_atom, i_xyz) = & diff7(alpha_scs(i_atom, :), delta) end do end if end do end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 1d-5)) then call print_matrix('diff x', diff(:, :, 1)) call print_matrix('diff y', diff(:, :, 2)) call print_matrix('diff z', diff(:, :, 3)) end if end subroutine subroutine test_scs_ewald_deriv_stress() real(dp) :: delta type(damping_t) :: damp real(dp), allocatable :: gradients(:, :, :), gradients_anl(:, :, :), & diff(:, :, :), alpha_0(:), lattice(:, :) integer :: i_atom, n_atoms, i_xyz, i_step, my_i_atom, my_nratoms, & my_ncatoms, i_latt real(dp), allocatable :: alpha_scs(:, :) type(grad_t), allocatable :: dalpha_scs(:) delta = 0.05d0 n_atoms = 2 allocate (geom%coords(3, n_atoms), source=0d0) geom%coords(3, 1) = 1d0 geom%coords(1, 2) = 1d0 geom%coords(2, 2) = 4d0 lattice = reshape([6d0, 1d0, 0d0, -1d0, 9d0, 1d0, 0d0, 1d0, 7d0], [3, 3]) geom%lattice = lattice call geom%init() my_nratoms = size(geom%idx%i_atom) my_ncatoms = size(geom%idx%j_atom) allocate (gradients(my_nratoms, 3, 3)) allocate (gradients_anl(my_nratoms, 3, 3)) allocate (alpha_scs(n_atoms, -3:3), dalpha_scs(my_nratoms)) damp%version = 'fermi,dip,gg' damp%r_vdw = [3.55d0, 3.5d0] damp%beta = 0.83d0 alpha_0 = [11d0, 10d0] alpha_scs(:, 0) = & run_scs(geom, alpha_0, damp, dalpha_scs, grad_request_t(dlattice=.true.)) do my_i_atom = 1, my_nratoms gradients_anl(my_i_atom, :, :) = dalpha_scs(my_i_atom)%dlattice end do do i_latt = 1, 3 do i_xyz = 1, 3 do i_step = -3, 3 if (i_step == 0) cycle geom%lattice = lattice geom%lattice(i_xyz, i_latt) = geom%lattice(i_xyz, i_latt) + i_step * delta alpha_scs(:, i_step) = & run_scs(geom, alpha_0, damp, dalpha_scs, grad_request_t()) end do do my_i_atom = 1, my_nratoms i_atom = geom%idx%i_atom(my_i_atom) gradients(my_i_atom, i_latt, i_xyz) = diff7(alpha_scs(i_atom, :), delta) end do end do end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 1d-4)) then call print_matrix('diff x', diff(:, :, 1)) call print_matrix('diff y', diff(:, :, 2)) call print_matrix('diff z', diff(:, :, 3)) end if end subroutine subroutine test_scs_deriv_impl_alpha real(dp) :: delta type(damping_t) :: damp real(dp), allocatable :: coords(:, :), gradients(:, :), & gradients_anl(:, :), diff(:, :), alpha_0(:), alpha_0_diff(:), & alpha_scs(:, :) integer :: i_atom, n_atoms, i_step, j_atom, my_i_atom, my_nratoms, & my_ncatoms, my_j_atom type(grad_t), allocatable :: dalpha_scs(:) delta = 0.1d0 n_atoms = 3 allocate (coords(3, n_atoms), source=0d0) coords(1, 3) = 1d0 coords(2, 1) = 4d0 coords(3, 2) = 4d0 geom%coords = coords call geom%init() my_nratoms = size(geom%idx%i_atom) my_ncatoms = size(geom%idx%j_atom) allocate (gradients(my_nratoms, my_ncatoms)) allocate (gradients_anl(my_nratoms, my_ncatoms)) allocate (alpha_scs(n_atoms, -3:3), dalpha_scs(my_nratoms)) damp%version = 'fermi,dip,gg' damp%r_vdw = [3.55d0, 3.5d0, 3.56d0] damp%beta = 0.83d0 alpha_0 = [11d0, 10d0, 12d0] alpha_scs(:, 0) = & run_scs(geom, alpha_0, damp, dalpha_scs, grad_request_t(dalpha=.true.)) do my_i_atom = 1, my_nratoms gradients_anl(my_i_atom, :) = dalpha_scs(my_i_atom)%dalpha end do do j_atom = 1, n_atoms my_j_atom = findval(geom%idx%j_atom, j_atom) do i_step = -3, 3 if (i_step == 0) cycle alpha_0_diff = alpha_0 alpha_0_diff(j_atom) = alpha_0_diff(j_atom) + i_step * delta alpha_scs(:, i_step) = & run_scs(geom, alpha_0_diff, damp, dalpha_scs, grad_request_t()) end do if (my_j_atom > 0) then do my_i_atom = 1, my_nratoms i_atom = geom%idx%i_atom(my_i_atom) gradients(my_i_atom, my_j_atom) = diff7(alpha_scs(i_atom, :), delta) end do end if end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 1d-6)) then call print_matrix('diff', diff) end if end subroutine subroutine test_scs_ewald_deriv_impl_alpha real(dp) :: delta type(damping_t) :: damp real(dp), allocatable :: coords(:, :), gradients(:, :), & gradients_anl(:, :), diff(:, :), alpha_0(:), alpha_0_diff(:), & alpha_scs(:, :) integer :: i_atom, n_atoms, i_step, j_atom, my_i_atom, my_nratoms, & my_ncatoms, my_j_atom type(grad_t), allocatable :: dalpha_scs(:) delta = 0.1d0 n_atoms = 2 allocate (coords(3, n_atoms), source=0d0) coords(3, 1) = 1d0 coords(1, 2) = 1d0 coords(2, 2) = 4d0 geom%coords = coords geom%lattice = reshape([6d0, 1d0, 0d0, -1d0, 9d0, 1d0, 0d0, 1d0, 7d0], [3, 3]) call geom%init() my_nratoms = size(geom%idx%i_atom) my_ncatoms = size(geom%idx%j_atom) allocate (gradients(my_nratoms, my_ncatoms)) allocate (gradients_anl(my_nratoms, my_ncatoms)) allocate (alpha_scs(n_atoms, -3:3), dalpha_scs(my_nratoms)) damp%version = 'fermi,dip,gg' damp%r_vdw = [3.55d0, 3.5d0] damp%beta = 0.83d0 alpha_0 = [11d0, 10d0] alpha_scs(:, 0) = & run_scs(geom, alpha_0, damp, dalpha_scs, grad_request_t(dalpha=.true.)) do my_i_atom = 1, my_nratoms gradients_anl(my_i_atom, :) = dalpha_scs(my_i_atom)%dalpha end do do j_atom = 1, n_atoms my_j_atom = findval(geom%idx%j_atom, j_atom) do i_step = -3, 3 if (i_step == 0) cycle alpha_0_diff = alpha_0 alpha_0_diff(j_atom) = alpha_0_diff(j_atom) + i_step * delta alpha_scs(:, i_step) = & run_scs(geom, alpha_0_diff, damp, dalpha_scs, grad_request_t()) end do if (my_j_atom > 0) then do my_i_atom = 1, my_nratoms i_atom = geom%idx%i_atom(my_i_atom) gradients(my_i_atom, my_j_atom) = diff7(alpha_scs(i_atom, :), delta) end do end if end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 1d-6)) then call print_matrix('diff', diff) end if end subroutine subroutine test_scs_deriv_impl_vdw real(dp) :: delta type(damping_t) :: damp real(dp), allocatable :: coords(:, :), gradients(:, :), & gradients_anl(:, :), diff(:, :), alpha_0(:), alpha_scs(:, :), rvdw(:) integer :: i_atom, n_atoms, i_step, j_atom, my_i_atom, my_nratoms, & my_ncatoms, my_j_atom type(grad_t), allocatable :: dalpha_scs(:) delta = 0.1d0 n_atoms = 3 allocate (coords(3, n_atoms), source=0d0) coords(1, 3) = 1d0 coords(2, 1) = 4d0 coords(3, 2) = 4d0 geom%coords = coords call geom%init() my_nratoms = size(geom%idx%i_atom) my_ncatoms = size(geom%idx%j_atom) allocate (gradients(my_nratoms, my_ncatoms)) allocate (gradients_anl(my_nratoms, my_ncatoms)) allocate (alpha_scs(n_atoms, -3:3), dalpha_scs(my_nratoms)) damp%version = 'fermi,dip,gg' rvdw = [3.55d0, 3.5d0, 3.56d0] damp%r_vdw = rvdw damp%beta = 0.83d0 alpha_0 = [11d0, 10d0, 12d0] alpha_scs(:, 0) = & run_scs(geom, alpha_0, damp, dalpha_scs, grad_request_t(dr_vdw=.true.)) do my_i_atom = 1, my_nratoms gradients_anl(my_i_atom, :) = dalpha_scs(my_i_atom)%dr_vdw end do do j_atom = 1, n_atoms my_j_atom = findval(geom%idx%j_atom, j_atom) do i_step = -3, 3 if (i_step == 0) cycle damp%r_vdw = rvdw damp%r_vdw(j_atom) = damp%r_vdw(j_atom) + i_step * delta alpha_scs(:, i_step) = & run_scs(geom, alpha_0, damp, dalpha_scs, grad_request_t()) end do if (my_j_atom > 0) then do my_i_atom = 1, my_nratoms i_atom = geom%idx%i_atom(my_i_atom) gradients(my_i_atom, my_j_atom) = diff7(alpha_scs(i_atom, :), delta) end do end if end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 1d-6)) then call print_matrix('diff', diff(:, :)) end if end subroutine subroutine test_scs_ewald_deriv_impl_vdw real(dp) :: delta type(damping_t) :: damp real(dp), allocatable :: coords(:, :), gradients(:, :), & gradients_anl(:, :), diff(:, :), alpha_0(:), alpha_scs(:, :), rvdw(:) integer :: i_atom, n_atoms, i_step, j_atom, my_i_atom, my_nratoms, & my_ncatoms, my_j_atom type(grad_t), allocatable :: dalpha_scs(:) delta = 0.1d0 n_atoms = 2 allocate (coords(3, n_atoms), source=0d0) coords(3, 1) = 1d0 coords(1, 2) = 1d0 coords(2, 2) = 4d0 geom%coords = coords geom%lattice = reshape([6d0, 1d0, 0d0, -1d0, 9d0, 1d0, 0d0, 1d0, 7d0], [3, 3]) call geom%init() my_nratoms = size(geom%idx%i_atom) my_ncatoms = size(geom%idx%j_atom) allocate (gradients(my_nratoms, my_ncatoms)) allocate (gradients_anl(my_nratoms, my_ncatoms)) allocate (alpha_scs(n_atoms, -3:3), dalpha_scs(my_nratoms)) damp%version = 'fermi,dip,gg' rvdw = [3.55d0, 3.5d0] damp%r_vdw = rvdw damp%beta = 0.83d0 alpha_0 = [11d0, 10d0] alpha_scs(:, 0) = & run_scs(geom, alpha_0, damp, dalpha_scs, grad_request_t(dr_vdw=.true.)) do my_i_atom = 1, my_nratoms gradients_anl(my_i_atom, :) = dalpha_scs(my_i_atom)%dr_vdw end do do j_atom = 1, n_atoms my_j_atom = findval(geom%idx%j_atom, j_atom) do i_step = -3, 3 if (i_step == 0) cycle damp%r_vdw = rvdw damp%r_vdw(j_atom) = damp%r_vdw(j_atom) + i_step * delta alpha_scs(:, i_step) = & run_scs(geom, alpha_0, damp, dalpha_scs, grad_request_t()) end do if (my_j_atom > 0) then do my_i_atom = 1, my_nratoms i_atom = geom%idx%i_atom(my_i_atom) gradients(my_i_atom, my_j_atom) = diff7(alpha_scs(i_atom, :), delta) end do end if end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 1d-5)) then call print_matrix('diff', diff(:, :)) end if end subroutine subroutine test_mbd_deriv_impl_alpha() real(dp) :: delta type(damping_t) :: damp real(dp), allocatable :: coords(:, :), gradients(:), & gradients_anl(:), diff(:), alpha_0(:), alpha_0_diff(:), omega(:) type(result_t) :: res(-3:3) integer :: i_atom, n_atoms, i_step delta = 0.1d0 n_atoms = 3 allocate (coords(3, n_atoms), source=0d0) allocate (gradients(n_atoms)) coords(1, 3) = 1d0 coords(2, 1) = 4d0 coords(3, 2) = 4d0 geom%coords = coords call geom%init() damp%version = 'fermi,dip' damp%r_vdw = [3.55d0, 3.5d0, 3.56d0] damp%beta = 0.83d0 alpha_0 = [11d0, 10d0, 12d0] omega = [.7d0, .65d0, .75d0] res(0) = get_mbd_hamiltonian_energy(geom, alpha_0, omega, damp, & grad_request_t(dalpha=.true.)) gradients_anl = res(0)%dE%dalpha do i_atom = 1, n_atoms do i_step = -3, 3 if (i_step == 0) cycle alpha_0_diff = alpha_0 alpha_0_diff(i_atom) = alpha_0_diff(i_atom) + i_step * delta res(i_step) = get_mbd_hamiltonian_energy(geom, alpha_0_diff, omega, damp, & grad_request_t()) end do gradients(i_atom) = diff7(res%energy, delta) end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 1d-6)) then call print_matrix('diff', reshape(diff, [n_atoms, 1])) end if end subroutine subroutine test_mbd_ewald_deriv_impl_alpha() real(dp) :: delta, k_point(3) type(damping_t) :: damp real(dp), allocatable :: coords(:, :), gradients(:), & gradients_anl(:), diff(:), alpha_0(:), alpha_0_diff(:), omega(:) type(result_t) :: res(-3:3) integer :: i_atom, n_atoms, i_step delta = 0.1d0 n_atoms = 2 allocate (coords(3, n_atoms), source=0d0) allocate (gradients(n_atoms)) coords(3, 1) = 1d0 coords(1, 2) = 1d0 coords(2, 2) = 4d0 geom%coords = coords geom%lattice = reshape([6d0, 1d0, 0d0, -1d0, 9d0, 1d0, 0d0, 1d0, 7d0], [3, 3]) k_point = [0.4d0, 0d0, 0d0] call geom%init() damp%version = 'fermi,dip' damp%r_vdw = [3.55d0, 3.5d0] damp%beta = 0.83d0 alpha_0 = [11d0, 10d0] omega = [.7d0, .65d0] res(0) = get_mbd_hamiltonian_energy(geom, alpha_0, omega, damp, & grad_request_t(dalpha=.true.), k_point) gradients_anl = res(0)%dE%dalpha do i_atom = 1, n_atoms do i_step = -3, 3 if (i_step == 0) cycle alpha_0_diff = alpha_0 alpha_0_diff(i_atom) = alpha_0_diff(i_atom) + i_step * delta res(i_step) = get_mbd_hamiltonian_energy(geom, alpha_0_diff, omega, damp, & grad_request_t(), k_point) end do gradients(i_atom) = diff7(res%energy, delta) end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 1d-6)) then call print_matrix('diff', reshape(diff, [n_atoms, 1])) call print_matrix('anl', reshape(gradients_anl, [n_atoms, 1])) call print_matrix('num', reshape(gradients, [n_atoms, 1])) end if end subroutine subroutine test_mbd_deriv_impl_omega() real(dp) :: delta type(damping_t) :: damp real(dp), allocatable :: coords(:, :), gradients(:), & gradients_anl(:), diff(:), alpha_0(:), omega_diff(:), omega(:) type(result_t) :: res(-3:3) integer :: i_atom, n_atoms, i_step delta = 0.03d0 n_atoms = 3 allocate (coords(3, n_atoms), source=0d0) allocate (gradients(n_atoms)) coords(1, 3) = 1d0 coords(2, 1) = 4d0 coords(3, 2) = 4d0 geom%coords = coords call geom%init() damp%version = 'fermi,dip' damp%r_vdw = [3.55d0, 3.5d0, 3.56d0] damp%beta = 0.83d0 alpha_0 = [11d0, 10d0, 12d0] omega = [.7d0, .65d0, .75d0] res(0) = get_mbd_hamiltonian_energy(geom, alpha_0, omega, damp, & grad_request_t(domega=.true.)) gradients_anl = res(0)%dE%domega do i_atom = 1, n_atoms do i_step = -3, 3 if (i_step == 0) cycle omega_diff = omega omega_diff(i_atom) = omega_diff(i_atom) + i_step * delta res(i_step) = get_mbd_hamiltonian_energy(geom, alpha_0, omega_diff, damp, & grad_request_t()) end do gradients(i_atom) = diff7(res%energy, delta) end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 2d-8)) then call print_matrix('delta gradients', reshape(diff, [n_atoms, 1])) end if end subroutine subroutine test_mbd_ewald_deriv_impl_omega() real(dp) :: delta, k_point(3) type(damping_t) :: damp real(dp), allocatable :: coords(:, :), gradients(:), & gradients_anl(:), diff(:), alpha_0(:), omega_diff(:), omega(:) type(result_t) :: res(-3:3) integer :: i_atom, n_atoms, i_step delta = 0.03d0 n_atoms = 2 allocate (coords(3, n_atoms), source=0d0) allocate (gradients(n_atoms)) coords(3, 1) = 1d0 coords(1, 2) = 1d0 coords(2, 2) = 4d0 geom%coords = coords geom%lattice = reshape([6d0, 1d0, 0d0, -1d0, 9d0, 1d0, 0d0, 1d0, 7d0], [3, 3]) k_point = [0.4d0, 0d0, 0d0] call geom%init() damp%version = 'fermi,dip' damp%r_vdw = [3.55d0, 3.5d0] damp%beta = 0.83d0 alpha_0 = [11d0, 10d0] omega = [.7d0, .65d0] res(0) = get_mbd_hamiltonian_energy(geom, alpha_0, omega, damp, & grad_request_t(domega=.true.), k_point) gradients_anl = res(0)%dE%domega do i_atom = 1, n_atoms do i_step = -3, 3 if (i_step == 0) cycle omega_diff = omega omega_diff(i_atom) = omega_diff(i_atom) + i_step * delta res(i_step) = get_mbd_hamiltonian_energy(geom, alpha_0, omega_diff, damp, & grad_request_t(), k_point) end do gradients(i_atom) = diff7(res%energy, delta) end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 2d-8)) then call print_matrix('delta gradients', reshape(diff, [n_atoms, 1])) end if end subroutine subroutine test_mbd_deriv_impl_vdw() real(dp) :: delta type(damping_t) :: damp real(dp), allocatable :: coords(:, :), gradients(:), & gradients_anl(:), diff(:), alpha_0(:), omega(:), r_vdw(:) type(result_t) :: res(-3:3) integer :: i_atom, n_atoms, i_step delta = 1d-3 n_atoms = 3 allocate (coords(3, n_atoms), source=0d0) allocate (gradients(n_atoms)) coords(2, 1) = 4d0 coords(3, 2) = 4d0 geom%coords = coords call geom%init() damp%version = 'fermi,dip' r_vdw = [3.55d0, 3.5d0, 3.56d0] damp%r_vdw = r_vdw damp%beta = 0.83d0 alpha_0 = [11d0, 10d0, 12d0] omega = [.7d0, .65d0, .75d0] res(0) = get_mbd_hamiltonian_energy(geom, alpha_0, omega, damp, & grad_request_t(dr_vdw=.true.)) gradients_anl = res(0)%dE%dr_vdw do i_atom = 1, n_atoms do i_step = -3, 3 if (i_step == 0) cycle damp%r_vdw = r_vdw damp%r_vdw(i_atom) = damp%r_vdw(i_atom) + i_step * delta res(i_step) = get_mbd_hamiltonian_energy(geom, alpha_0, omega, damp, & grad_request_t()) end do gradients(i_atom) = diff7(res%energy, delta) end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 1d-8)) then call print_matrix('delta gradients', reshape(diff, [n_atoms, 1])) end if end subroutine subroutine test_mbd_ewald_deriv_impl_vdw() real(dp) :: delta, k_point(3) type(damping_t) :: damp real(dp), allocatable :: coords(:, :), gradients(:), & gradients_anl(:), diff(:), alpha_0(:), omega(:), r_vdw(:) type(result_t) :: res(-3:3) integer :: i_atom, n_atoms, i_step delta = 1d-3 n_atoms = 2 allocate (coords(3, n_atoms), source=0d0) allocate (gradients(n_atoms)) coords(3, 1) = 1d0 coords(1, 2) = 1d0 coords(2, 2) = 4d0 geom%coords = coords geom%lattice = reshape([6d0, 1d0, 0d0, -1d0, 9d0, 1d0, 0d0, 1d0, 7d0], [3, 3]) k_point = [0.4d0, 0d0, 0d0] call geom%init() damp%version = 'fermi,dip' r_vdw = [3.55d0, 3.5d0] damp%r_vdw = r_vdw damp%beta = 0.83d0 alpha_0 = [11d0, 10d0] omega = [.7d0, .65d0] res(0) = get_mbd_hamiltonian_energy(geom, alpha_0, omega, damp, & grad_request_t(dr_vdw=.true.), k_point) gradients_anl = res(0)%dE%dr_vdw do i_atom = 1, n_atoms do i_step = -3, 3 if (i_step == 0) cycle damp%r_vdw = r_vdw damp%r_vdw(i_atom) = damp%r_vdw(i_atom) + i_step * delta res(i_step) = get_mbd_hamiltonian_energy(geom, alpha_0, omega, damp, & grad_request_t(), k_point) end do gradients(i_atom) = diff7(res%energy, delta) end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 1d-8)) then call print_matrix('delta gradients', reshape(diff, [n_atoms, 1])) call print_matrix('gradients anl', reshape(gradients_anl, [n_atoms, 1])) call print_matrix('gradients num', reshape(gradients, [n_atoms, 1])) end if end subroutine subroutine test_mbd_rsscs_deriv_expl() real(dp) :: delta type(damping_t) :: damp real(dp), allocatable :: coords(:, :) real(dp), allocatable :: gradients(:, :), gradients_anl(:, :) real(dp), allocatable :: diff(:, :) real(dp), allocatable :: alpha_0(:) real(dp), allocatable :: C6(:) type(result_t) :: res(-3:3) integer :: i_atom, n_atoms, i_xyz, i_step delta = 0.01d0 n_atoms = 3 allocate (coords(3, n_atoms), source=0d0) allocate (gradients(n_atoms, 3)) coords(2, 1) = 4d0 coords(3, 2) = 4d0 coords(1, 3) = 1d0 geom%coords = coords call geom%init() damp%r_vdw = [3.55d0, 3.5d0, 3.56d0] damp%beta = 0.83d0 alpha_0 = [11d0, 10d0, 12d0] C6 = [65d0, 60d0, 70d0] res(0) = get_mbd_scs_energy(geom, 'rsscs', alpha_0, C6, damp, & grad_request_t(dcoords=.true.)) gradients_anl = res(0)%dE%dcoords do i_atom = 1, n_atoms do i_xyz = 1, 3 do i_step = -3, 3 if (i_step == 0) cycle geom%coords = coords geom%coords(i_xyz, i_atom) = geom%coords(i_xyz, i_atom) + & i_step * delta res(i_step) = get_mbd_scs_energy(geom, 'rsscs', alpha_0, C6, damp, & grad_request_t()) end do gradients(i_atom, i_xyz) = diff7(res%energy, delta) end do end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 1d-8)) then call print_matrix('delta gradients', diff) end if end subroutine subroutine test_mbd_rsscs_ewald_deriv_expl() real(dp) :: delta type(damping_t) :: damp real(dp), allocatable :: coords(:, :) real(dp), allocatable :: gradients(:, :), gradients_anl(:, :) real(dp), allocatable :: diff(:, :) real(dp), allocatable :: alpha_0(:) real(dp), allocatable :: C6(:) type(result_t) :: res(-3:3) integer :: i_atom, n_atoms, i_xyz, i_step delta = 0.01d0 n_atoms = 2 allocate (coords(3, n_atoms), source=0d0) allocate (gradients(n_atoms, 3)) coords(3, 1) = 1d0 coords(1, 2) = 1d0 coords(2, 2) = 4d0 geom%coords = coords geom%lattice = reshape([6d0, 1d0, 0d0, -1d0, 9d0, 1d0, 0d0, 1d0, 7d0], [3, 3]) geom%k_grid = [2, 2, 2] call geom%init() damp%version = 'fermi,dip' damp%r_vdw = [3.55d0, 3.5d0] damp%beta = 0.83d0 alpha_0 = [11d0, 10d0] C6 = [65d0, 60d0] res(0) = get_mbd_scs_energy(geom, 'rsscs', alpha_0, C6, damp, & grad_request_t(dcoords=.true.)) gradients_anl = res(0)%dE%dcoords do i_atom = 1, n_atoms do i_xyz = 1, 3 do i_step = -3, 3 if (i_step == 0) cycle geom%coords = coords geom%coords(i_xyz, i_atom) = geom%coords(i_xyz, i_atom) + & i_step * delta res(i_step) = get_mbd_scs_energy(geom, 'rsscs', alpha_0, C6, damp, & grad_request_t()) end do gradients(i_atom, i_xyz) = diff7(res%energy, delta) end do end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 1d-8)) then call print_matrix('delta gradients', diff) end if end subroutine subroutine test_mbd_rsscs_ewald_deriv_stress() real(dp) :: delta type(damping_t) :: damp real(dp), allocatable :: gradients(:, :), gradients_anl(:, :), & diff(:, :), alpha_0(:), C6(:), lattice(:, :) type(result_t) :: res(-3:3) integer :: n_atoms, i_xyz, i_step, i_latt delta = 0.01d0 n_atoms = 2 allocate (geom%coords(3, n_atoms), source=0d0) allocate (gradients(3, 3)) geom%coords(3, 1) = 1d0 geom%coords(1, 2) = 1d0 geom%coords(2, 2) = 4d0 lattice = reshape([6d0, 1d0, 0d0, -1d0, 9d0, 1d0, 0d0, 1d0, 7d0], [3, 3]) geom%lattice = lattice geom%k_grid = [2, 2, 2] call geom%init() damp%version = 'fermi,dip' damp%r_vdw = [3.55d0, 3.5d0] damp%beta = 0.83d0 alpha_0 = [11d0, 10d0] C6 = [65d0, 60d0] res(0) = get_mbd_scs_energy(geom, 'rsscs', alpha_0, C6, damp, & grad_request_t(dlattice=.true.)) gradients_anl = res(0)%dE%dlattice do i_latt = 1, 3 do i_xyz = 1, 3 do i_step = -3, 3 if (i_step == 0) cycle geom%lattice = lattice geom%lattice(i_xyz, i_latt) = geom%lattice(i_xyz, i_latt) + i_step * delta res(i_step) = get_mbd_scs_energy(geom, 'rsscs', alpha_0, C6, damp, & grad_request_t()) end do gradients(i_latt, i_xyz) = diff7(res%energy, delta) end do end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 3d-6)) then call print_matrix('delta gradients', diff) call print_matrix('gradients anl', gradients_anl) call print_matrix('gradients num', gradients) end if end subroutine subroutine test_mbd_rsscs_deriv_impl_alpha() real(dp) :: delta type(damping_t) :: damp real(dp), allocatable :: coords(:, :), gradients(:), & gradients_anl(:), diff(:), alpha_0(:), alpha_0_diff(:), C6(:) type(result_t) :: res(-3:3) integer :: i_atom, n_atoms, i_step delta = 3d-2 n_atoms = 3 allocate (coords(3, n_atoms), source=0d0) allocate (gradients(n_atoms)) coords(1, 3) = 1d0 coords(2, 1) = 4d0 coords(3, 2) = 4d0 geom%coords = coords call geom%init() damp%version = 'fermi,dip' damp%r_vdw = [3.55d0, 3.5d0, 3.56d0] damp%beta = 0.83d0 alpha_0 = [11d0, 10d0, 12d0] C6 = [65d0, 60d0, 70d0] res(0) = get_mbd_scs_energy(geom, 'rsscs', alpha_0, C6, damp, & grad_request_t(dalpha=.true.)) gradients_anl = res(0)%dE%dalpha do i_atom = 1, n_atoms do i_step = -3, 3 if (i_step == 0) cycle alpha_0_diff = alpha_0 alpha_0_diff(i_atom) = alpha_0_diff(i_atom) + i_step * delta res(i_step) = get_mbd_scs_energy(geom, 'rsscs', alpha_0_diff, C6, damp, & grad_request_t()) end do gradients(i_atom) = diff7(res%energy, delta) end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 1d-7)) then call print_matrix('delta gradients', reshape(diff, [n_atoms, 1])) end if end subroutine subroutine test_mbd_rsscs_deriv_impl_C6() real(dp) :: delta type(damping_t) :: damp real(dp), allocatable :: coords(:, :), gradients(:), & gradients_anl(:), diff(:), alpha_0(:), C6_diff(:), C6(:) type(result_t) :: res(-3:3) integer :: i_atom, n_atoms, i_step delta = 0.01d0 n_atoms = 3 allocate (coords(3, n_atoms), source=0d0) allocate (gradients(n_atoms)) coords(1, 3) = 1d0 coords(2, 1) = 4d0 coords(3, 2) = 4d0 geom%coords = coords call geom%init() damp%version = 'fermi,dip' damp%r_vdw = [3.55d0, 3.5d0, 3.56d0] damp%beta = 0.83d0 alpha_0 = [11d0, 10d0, 12d0] C6 = [65d0, 60d0, 70d0] res(0) = get_mbd_scs_energy(geom, 'rsscs', alpha_0, C6, damp, & grad_request_t(dC6=.true.)) gradients_anl = res(0)%dE%dC6 do i_atom = 1, n_atoms do i_step = -3, 3 if (i_step == 0) cycle C6_diff = C6 C6_diff(i_atom) = C6_diff(i_atom) + i_step * delta res(i_step) = get_mbd_scs_energy(geom, 'rsscs', alpha_0, C6_diff, damp, & grad_request_t()) end do gradients(i_atom) = diff7(res%energy, delta) end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 5d-8)) then call print_matrix('delta gradients', reshape(diff, [n_atoms, 1])) end if end subroutine subroutine test_mbd_rsscs_deriv_impl_vdw() real(dp) :: delta type(damping_t) :: damp real(dp), allocatable :: coords(:, :), gradients(:), & gradients_anl(:), diff(:), alpha_0(:), C6(:), r_vdw(:) type(result_t) :: res(-3:3) integer :: i_atom, n_atoms, i_step delta = 1d-2 n_atoms = 3 allocate (coords(3, n_atoms), source=0d0) allocate (gradients(n_atoms)) coords(2, 1) = 4d0 coords(3, 2) = 4d0 geom%coords = coords call geom%init() damp%version = 'fermi,dip' r_vdw = [3.55d0, 3.5d0, 3.56d0] damp%r_vdw = r_vdw damp%beta = 0.83d0 alpha_0 = [11d0, 10d0, 12d0] C6 = [65d0, 60d0, 70d0] res(0) = get_mbd_scs_energy(geom, 'rsscs', alpha_0, C6, damp, & grad_request_t(dr_vdw=.true.)) gradients_anl = res(0)%dE%dr_vdw do i_atom = 1, n_atoms do i_step = -3, 3 if (i_step == 0) cycle damp%r_vdw = r_vdw damp%r_vdw(i_atom) = damp%r_vdw(i_atom) + i_step * delta res(i_step) = get_mbd_scs_energy(geom, 'rsscs', alpha_0, C6, damp, & grad_request_t()) end do gradients(i_atom) = diff7(res%energy, delta) end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 1d-8)) then call print_matrix('delta gradients', reshape(diff, [n_atoms, 1])) end if end subroutine subroutine test_mbd_rsscs_ewald_deriv_impl_alpha() real(dp) :: delta type(damping_t) :: damp real(dp), allocatable :: coords(:, :), gradients(:), & gradients_anl(:), diff(:), alpha_0(:), alpha_0_diff(:), C6(:) type(result_t) :: res(-3:3) integer :: i_atom, n_atoms, i_step delta = 3d-2 n_atoms = 2 allocate (coords(3, n_atoms), source=0d0) allocate (gradients(n_atoms)) coords(3, 1) = 1d0 coords(1, 2) = 1d0 coords(2, 2) = 4d0 geom%coords = coords geom%lattice = reshape([6d0, 1d0, 0d0, -1d0, 9d0, 1d0, 0d0, 1d0, 7d0], [3, 3]) geom%k_grid = [2, 2, 2] call geom%init() damp%version = 'fermi,dip' damp%r_vdw = [3.55d0, 3.5d0] damp%beta = 0.83d0 alpha_0 = [11d0, 10d0] C6 = [65d0, 60d0] res(0) = get_mbd_scs_energy(geom, 'rsscs', alpha_0, C6, damp, & grad_request_t(dalpha=.true.)) gradients_anl = res(0)%dE%dalpha do i_atom = 1, n_atoms do i_step = -3, 3 if (i_step == 0) cycle alpha_0_diff = alpha_0 alpha_0_diff(i_atom) = alpha_0_diff(i_atom) + i_step * delta res(i_step) = get_mbd_scs_energy(geom, 'rsscs', alpha_0_diff, C6, damp, & grad_request_t()) end do gradients(i_atom) = diff7(res%energy, delta) end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 1d-7)) then call print_matrix('delta gradients', reshape(diff, [n_atoms, 1])) end if end subroutine subroutine test_mbd_rsscs_ewald_deriv_impl_C6() real(dp) :: delta type(damping_t) :: damp real(dp), allocatable :: coords(:, :), gradients(:), & gradients_anl(:), diff(:), alpha_0(:), C6_diff(:), C6(:) type(result_t) :: res(-3:3) integer :: i_atom, n_atoms, i_step delta = 0.01d0 n_atoms = 2 allocate (coords(3, n_atoms), source=0d0) allocate (gradients(n_atoms)) coords(3, 1) = 1d0 coords(1, 2) = 1d0 coords(2, 2) = 4d0 geom%coords = coords geom%lattice = reshape([6d0, 1d0, 0d0, -1d0, 9d0, 1d0, 0d0, 1d0, 7d0], [3, 3]) geom%k_grid = [2, 2, 2] call geom%init() damp%version = 'fermi,dip' damp%r_vdw = [3.55d0, 3.5d0] damp%beta = 0.83d0 alpha_0 = [11d0, 10d0] C6 = [65d0, 60d0] res(0) = get_mbd_scs_energy(geom, 'rsscs', alpha_0, C6, damp, & grad_request_t(dC6=.true.)) gradients_anl = res(0)%dE%dC6 do i_atom = 1, n_atoms do i_step = -3, 3 if (i_step == 0) cycle C6_diff = C6 C6_diff(i_atom) = C6_diff(i_atom) + i_step * delta res(i_step) = get_mbd_scs_energy(geom, 'rsscs', alpha_0, C6_diff, damp, & grad_request_t()) end do gradients(i_atom) = diff7(res%energy, delta) end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 5d-8)) then call print_matrix('delta gradients', reshape(diff, [n_atoms, 1])) end if end subroutine subroutine test_mbd_rsscs_ewald_deriv_impl_vdw() real(dp) :: delta type(damping_t) :: damp real(dp), allocatable :: coords(:, :), gradients(:), & gradients_anl(:), diff(:), alpha_0(:), C6(:), r_vdw(:) type(result_t) :: res(-3:3) integer :: i_atom, n_atoms, i_step delta = 1d-2 n_atoms = 2 allocate (coords(3, n_atoms), source=0d0) allocate (gradients(n_atoms)) coords(3, 1) = 1d0 coords(1, 2) = 1d0 coords(2, 2) = 4d0 geom%coords = coords geom%lattice = reshape([6d0, 1d0, 0d0, -1d0, 9d0, 1d0, 0d0, 1d0, 7d0], [3, 3]) geom%k_grid = [2, 2, 2] call geom%init() damp%version = 'fermi,dip' r_vdw = [3.55d0, 3.5d0] damp%r_vdw = r_vdw damp%beta = 0.83d0 alpha_0 = [11d0, 10d0] C6 = [65d0, 60d0] res(0) = get_mbd_scs_energy(geom, 'rsscs', alpha_0, C6, damp, & grad_request_t(dr_vdw=.true.)) gradients_anl = res(0)%dE%dr_vdw do i_atom = 1, n_atoms do i_step = -3, 3 if (i_step == 0) cycle damp%r_vdw = r_vdw damp%r_vdw(i_atom) = damp%r_vdw(i_atom) + i_step * delta res(i_step) = get_mbd_scs_energy(geom, 'rsscs', alpha_0, C6, damp, & grad_request_t()) end do gradients(i_atom) = diff7(res%energy, delta) end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 1d-8)) then call print_matrix('delta gradients', reshape(diff, [n_atoms, 1])) end if end subroutine subroutine test_ts_deriv_expl() real(dp) :: delta type(damping_t) :: damp real(dp), allocatable :: coords(:, :) real(dp), allocatable :: gradients(:, :), gradients_anl(:, :) real(dp), allocatable :: diff(:, :) real(dp), allocatable :: alpha_0(:) real(dp), allocatable :: C6(:) type(result_t) :: res(-3:3) integer :: i_atom, n_atoms, i_xyz, i_step delta = 0.01d0 n_atoms = 3 allocate (coords(3, n_atoms), source=0d0) allocate (gradients(n_atoms, 3)) coords(2, 1) = 4d0 coords(3, 2) = 4d0 coords(1, 3) = 1d0 geom%coords = coords call geom%init() damp%version = 'fermi' damp%r_vdw = [3.55d0, 3.5d0, 3.56d0] damp%ts_sr = 0.94d0 alpha_0 = [11d0, 10d0, 12d0] C6 = [65d0, 60d0, 70d0] res(0) = get_ts_energy(geom, alpha_0, C6, damp, grad_request_t(dcoords=.true.)) gradients_anl = res(0)%dE%dcoords do i_atom = 1, n_atoms do i_xyz = 1, 3 do i_step = -3, 3 if (i_step == 0) cycle geom%coords = coords geom%coords(i_xyz, i_atom) = geom%coords(i_xyz, i_atom) + & i_step * delta res(i_step) = get_ts_energy(geom, alpha_0, C6, damp, grad_request_t()) end do gradients(i_atom, i_xyz) = diff7(res%energy, delta) end do end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 1d-8)) then call print_matrix('gradients', gradients) call print_matrix('gradients_anl', gradients_anl) call print_matrix('delta gradients', diff) end if end subroutine subroutine test_ts_ewald_deriv_expl() real(dp) :: delta type(damping_t) :: damp real(dp), allocatable :: coords(:, :) real(dp), allocatable :: gradients(:, :), gradients_anl(:, :) real(dp), allocatable :: diff(:, :) real(dp), allocatable :: alpha_0(:) real(dp), allocatable :: C6(:) type(result_t) :: res(-3:3) integer :: i_atom, n_atoms, i_xyz, i_step delta = 0.01d0 n_atoms = 2 allocate (coords(3, n_atoms), source=0d0) allocate (gradients(n_atoms, 3)) coords(3, 1) = 1d0 coords(1, 2) = 1d0 coords(2, 2) = 4d0 geom%coords = coords geom%lattice = reshape([6d0, 1d0, 0d0, -1d0, 9d0, 1d0, 0d0, 1d0, 7d0], [3, 3]) geom%k_grid = [2, 2, 2] call geom%init() damp%version = 'fermi' damp%r_vdw = [3.55d0, 3.5d0] damp%ts_sr = 0.94d0 alpha_0 = [11d0, 10d0] C6 = [65d0, 60d0] res(0) = get_ts_energy(geom, alpha_0, C6, damp, grad_request_t(dcoords=.true.)) gradients_anl = res(0)%dE%dcoords do i_atom = 1, n_atoms do i_xyz = 1, 3 do i_step = -3, 3 if (i_step == 0) cycle geom%coords = coords geom%coords(i_xyz, i_atom) = geom%coords(i_xyz, i_atom) + & i_step * delta res(i_step) = get_ts_energy(geom, alpha_0, C6, damp, grad_request_t()) end do gradients(i_atom, i_xyz) = diff7(res%energy, delta) end do end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 1d-8)) then call print_matrix('delta gradients', diff) end if end subroutine subroutine test_ts_ewald_deriv_stress() real(dp) :: delta type(damping_t) :: damp real(dp), allocatable :: gradients(:, :), gradients_anl(:, :), & diff(:, :), alpha_0(:), C6(:), lattice(:, :) type(result_t) :: res(-3:3) integer :: n_atoms, i_xyz, i_step, i_latt delta = 0.01d0 n_atoms = 2 allocate (geom%coords(3, n_atoms), source=0d0) allocate (gradients(3, 3)) geom%coords(3, 1) = 1d0 geom%coords(1, 2) = 1d0 geom%coords(2, 2) = 4d0 lattice = reshape([6d0, 1d0, 0d0, -1d0, 9d0, 1d0, 0d0, 1d0, 7d0], [3, 3]) geom%lattice = lattice geom%k_grid = [2, 2, 2] call geom%init() damp%version = 'fermi' damp%r_vdw = [3.55d0, 3.5d0] damp%ts_sr = 0.94d0 alpha_0 = [11d0, 10d0] C6 = [65d0, 60d0] res(0) = get_ts_energy(geom, alpha_0, C6, damp, grad_request_t(dlattice=.true.)) gradients_anl = res(0)%dE%dlattice do i_latt = 1, 3 do i_xyz = 1, 3 do i_step = -3, 3 if (i_step == 0) cycle geom%lattice = lattice geom%lattice(i_xyz, i_latt) = geom%lattice(i_xyz, i_latt) + i_step * delta res(i_step) = get_ts_energy(geom, alpha_0, C6, damp, grad_request_t()) end do gradients(i_latt, i_xyz) = diff7(res%energy, delta) end do end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 3d-6)) then call print_matrix('delta gradients', diff) call print_matrix('gradients anl', gradients_anl) call print_matrix('gradients num', gradients) end if end subroutine subroutine test_ts_deriv_impl_alpha() real(dp) :: delta type(damping_t) :: damp real(dp), allocatable :: coords(:, :), gradients(:), & gradients_anl(:), diff(:), alpha_0(:), alpha_0_diff(:), C6(:) type(result_t) :: res(-3:3) integer :: i_atom, n_atoms, i_step delta = 3d-2 n_atoms = 3 allocate (coords(3, n_atoms), source=0d0) allocate (gradients(n_atoms)) coords(1, 3) = 1d0 coords(2, 1) = 4d0 coords(3, 2) = 4d0 geom%coords = coords call geom%init() damp%version = 'fermi' damp%r_vdw = [3.55d0, 3.5d0, 3.56d0] damp%ts_sr = 0.94d0 alpha_0 = [11d0, 10d0, 12d0] C6 = [65d0, 60d0, 70d0] res(0) = get_ts_energy(geom, alpha_0, C6, damp, grad_request_t(dalpha=.true.)) gradients_anl = res(0)%dE%dalpha do i_atom = 1, n_atoms do i_step = -3, 3 if (i_step == 0) cycle alpha_0_diff = alpha_0 alpha_0_diff(i_atom) = alpha_0_diff(i_atom) + i_step * delta res(i_step) = get_ts_energy(geom, alpha_0_diff, C6, damp, grad_request_t()) end do gradients(i_atom) = diff7(res%energy, delta) end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 1d-7)) then call print_matrix('delta gradients', reshape(diff, [n_atoms, 1])) end if end subroutine subroutine test_ts_deriv_impl_C6() real(dp) :: delta type(damping_t) :: damp real(dp), allocatable :: coords(:, :), gradients(:), & gradients_anl(:), diff(:), alpha_0(:), C6_diff(:), C6(:) type(result_t) :: res(-3:3) integer :: i_atom, n_atoms, i_step delta = 0.01d0 n_atoms = 3 allocate (coords(3, n_atoms), source=0d0) allocate (gradients(n_atoms)) coords(1, 3) = 1d0 coords(2, 1) = 4d0 coords(3, 2) = 4d0 geom%coords = coords call geom%init() damp%version = 'fermi' damp%r_vdw = [3.55d0, 3.5d0, 3.56d0] damp%ts_sr = 0.94d0 alpha_0 = [11d0, 10d0, 12d0] C6 = [65d0, 60d0, 70d0] res(0) = get_ts_energy(geom, alpha_0, C6, damp, grad_request_t(dC6=.true.)) gradients_anl = res(0)%dE%dC6 do i_atom = 1, n_atoms do i_step = -3, 3 if (i_step == 0) cycle C6_diff = C6 C6_diff(i_atom) = C6_diff(i_atom) + i_step * delta res(i_step) = get_ts_energy(geom, alpha_0, C6_diff, damp, grad_request_t()) end do gradients(i_atom) = diff7(res%energy, delta) end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 5d-8)) then call print_matrix('delta gradients', reshape(diff, [n_atoms, 1])) end if end subroutine subroutine test_ts_deriv_impl_vdw() real(dp) :: delta type(damping_t) :: damp real(dp), allocatable :: coords(:, :), gradients(:), & gradients_anl(:), diff(:), alpha_0(:), C6(:), r_vdw(:) type(result_t) :: res(-3:3) integer :: i_atom, n_atoms, i_step delta = 1d-2 n_atoms = 3 allocate (coords(3, n_atoms), source=0d0) allocate (gradients(n_atoms)) coords(2, 1) = 4d0 coords(3, 2) = 4d0 geom%coords = coords call geom%init() damp%version = 'fermi' r_vdw = [3.55d0, 3.5d0, 3.56d0] damp%r_vdw = r_vdw damp%ts_sr = 0.94d0 alpha_0 = [11d0, 10d0, 12d0] C6 = [65d0, 60d0, 70d0] res(0) = get_ts_energy(geom, alpha_0, C6, damp, grad_request_t(dr_vdw=.true.)) gradients_anl = res(0)%dE%dr_vdw do i_atom = 1, n_atoms do i_step = -3, 3 if (i_step == 0) cycle damp%r_vdw = r_vdw damp%r_vdw(i_atom) = damp%r_vdw(i_atom) + i_step * delta res(i_step) = get_ts_energy(geom, alpha_0, C6, damp, grad_request_t()) end do gradients(i_atom) = diff7(res%energy, delta) end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 1d-8)) then call print_matrix('delta gradients', reshape(diff, [n_atoms, 1])) end if end subroutine subroutine test_ts_ewald_deriv_impl_alpha() real(dp) :: delta type(damping_t) :: damp real(dp), allocatable :: coords(:, :), gradients(:), & gradients_anl(:), diff(:), alpha_0(:), alpha_0_diff(:), C6(:) type(result_t) :: res(-3:3) integer :: i_atom, n_atoms, i_step delta = 3d-2 n_atoms = 2 allocate (coords(3, n_atoms), source=0d0) allocate (gradients(n_atoms)) coords(3, 1) = 1d0 coords(1, 2) = 1d0 coords(2, 2) = 4d0 geom%coords = coords geom%lattice = reshape([6d0, 1d0, 0d0, -1d0, 9d0, 1d0, 0d0, 1d0, 7d0], [3, 3]) geom%k_grid = [2, 2, 2] call geom%init() damp%version = 'fermi' damp%r_vdw = [3.55d0, 3.5d0] damp%ts_sr = 0.94d0 alpha_0 = [11d0, 10d0] C6 = [65d0, 60d0] res(0) = get_ts_energy(geom, alpha_0, C6, damp, grad_request_t(dalpha=.true.)) gradients_anl = res(0)%dE%dalpha do i_atom = 1, n_atoms do i_step = -3, 3 if (i_step == 0) cycle alpha_0_diff = alpha_0 alpha_0_diff(i_atom) = alpha_0_diff(i_atom) + i_step * delta res(i_step) = get_ts_energy(geom, alpha_0_diff, C6, damp, grad_request_t()) end do gradients(i_atom) = diff7(res%energy, delta) end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 1d-7)) then call print_matrix('delta gradients', reshape(diff, [n_atoms, 1])) end if end subroutine subroutine test_ts_ewald_deriv_impl_C6() real(dp) :: delta type(damping_t) :: damp real(dp), allocatable :: coords(:, :), gradients(:), & gradients_anl(:), diff(:), alpha_0(:), C6_diff(:), C6(:) type(result_t) :: res(-3:3) integer :: i_atom, n_atoms, i_step delta = 0.01d0 n_atoms = 2 allocate (coords(3, n_atoms), source=0d0) allocate (gradients(n_atoms)) coords(3, 1) = 1d0 coords(1, 2) = 1d0 coords(2, 2) = 4d0 geom%coords = coords geom%lattice = reshape([6d0, 1d0, 0d0, -1d0, 9d0, 1d0, 0d0, 1d0, 7d0], [3, 3]) geom%k_grid = [2, 2, 2] call geom%init() damp%version = 'fermi' damp%r_vdw = [3.55d0, 3.5d0] damp%ts_sr = 0.94d0 alpha_0 = [11d0, 10d0] C6 = [65d0, 60d0] res(0) = get_ts_energy(geom, alpha_0, C6, damp, grad_request_t(dC6=.true.)) gradients_anl = res(0)%dE%dC6 do i_atom = 1, n_atoms do i_step = -3, 3 if (i_step == 0) cycle C6_diff = C6 C6_diff(i_atom) = C6_diff(i_atom) + i_step * delta res(i_step) = get_ts_energy(geom, alpha_0, C6_diff, damp, grad_request_t()) end do gradients(i_atom) = diff7(res%energy, delta) end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 5d-8)) then call print_matrix('delta gradients', reshape(diff, [n_atoms, 1])) end if end subroutine subroutine test_ts_ewald_deriv_impl_vdw() real(dp) :: delta type(damping_t) :: damp real(dp), allocatable :: coords(:, :), gradients(:), & gradients_anl(:), diff(:), alpha_0(:), C6(:), r_vdw(:) type(result_t) :: res(-3:3) integer :: i_atom, n_atoms, i_step delta = 1d-2 n_atoms = 2 allocate (coords(3, n_atoms), source=0d0) allocate (gradients(n_atoms)) coords(3, 1) = 1d0 coords(1, 2) = 1d0 coords(2, 2) = 4d0 geom%coords = coords geom%lattice = reshape([6d0, 1d0, 0d0, -1d0, 9d0, 1d0, 0d0, 1d0, 7d0], [3, 3]) geom%k_grid = [2, 2, 2] call geom%init() damp%version = 'fermi' r_vdw = [3.55d0, 3.5d0] damp%r_vdw = r_vdw damp%ts_sr = 0.94d0 alpha_0 = [11d0, 10d0] C6 = [65d0, 60d0] res(0) = get_ts_energy(geom, alpha_0, C6, damp, grad_request_t(dr_vdw=.true.)) gradients_anl = res(0)%dE%dr_vdw do i_atom = 1, n_atoms do i_step = -3, 3 if (i_step == 0) cycle damp%r_vdw = r_vdw damp%r_vdw(i_atom) = damp%r_vdw(i_atom) + i_step * delta res(i_step) = get_ts_energy(geom, alpha_0, C6, damp, grad_request_t()) end do gradients(i_atom) = diff7(res%energy, delta) end do call geom%destroy() diff = (gradients - gradients_anl) / gradients_anl if (failed(maxval(abs(diff)), 1d-8)) then call print_matrix('delta gradients', reshape(diff, [n_atoms, 1])) end if end subroutine end module libmbd-libmbd-88d61bc/tests/mbd_grad_tests.F90000066400000000000000000000073101452573331700212310ustar00rootroot00000000000000! This Source Code Form is subject to the terms of the Mozilla Public ! License, v. 2.0. If a copy of the MPL was not distributed with this ! file, You can obtain one at http://mozilla.org/MPL/2.0/. program mbd_grad_tests use mbd_constants use mbd_geom, only: geom_t use mbd_grad_test_cases #ifdef WITH_MPI use mbd_mpi #endif implicit none character(len=50) :: test_name #ifdef WITH_MPI integer :: err call MPI_INIT(err) call MPI_COMM_RANK(MPI_COMM_WORLD, rank, err) #else rank = 0 #endif call get_command_argument(1, test_name) n_failed = 0 call exec_test(test_name) #ifdef WITH_MPI call MPI_FINALIZE(err) #endif if (n_failed /= 0) stop 1 contains subroutine exec_test(test_name) character(len=*), intent(in) :: test_name allocate (geom) geom%log%level = MBD_LOG_LVL_INFO geom%parallel_mode = 'atoms' select case (test_name) case ('T_bare_deriv'); call test_T_bare_deriv() case ('T_GG_deriv_expl'); call test_T_GG_deriv_expl() case ('T_GG_deriv_impl'); call test_T_GG_deriv_impl() case ('T_erfc_deriv_expl'); call test_T_erfc_deriv_expl() case ('T_fermi_deriv_impl'); call test_T_fermi_deriv_impl() case ('mbd_deriv_expl'); call test_mbd_deriv_expl() case ('mbd_ewald_deriv_expl'); call test_mbd_ewald_deriv_expl() case ('mbd_ewald_deriv_stress'); call test_mbd_ewald_deriv_stress() case ('scs_deriv_expl'); call test_scs_deriv_expl() case ('scs_ewald_deriv_expl'); call test_scs_ewald_deriv_expl() case ('scs_ewald_deriv_stress'); call test_scs_ewald_deriv_stress() case ('scs_deriv_impl_alpha'); call test_scs_deriv_impl_alpha() case ('scs_ewald_deriv_impl_alpha'); call test_scs_ewald_deriv_impl_alpha() case ('scs_deriv_impl_vdw'); call test_scs_deriv_impl_vdw() case ('scs_ewald_deriv_impl_vdw'); call test_scs_ewald_deriv_impl_vdw() case ('mbd_deriv_impl_alpha'); call test_mbd_deriv_impl_alpha() case ('mbd_ewald_deriv_impl_alpha'); call test_mbd_ewald_deriv_impl_alpha() case ('mbd_deriv_impl_omega'); call test_mbd_deriv_impl_omega() case ('mbd_ewald_deriv_impl_omega'); call test_mbd_ewald_deriv_impl_omega() case ('mbd_deriv_impl_vdw'); call test_mbd_deriv_impl_vdw() case ('mbd_ewald_deriv_impl_vdw'); call test_mbd_ewald_deriv_impl_vdw() case ('mbd_ewald_deriv_impl_q'); call test_mbd_ewald_deriv_impl_q() case ('mbd_rsscs_deriv_expl'); call test_mbd_rsscs_deriv_expl() case ('mbd_rsscs_ewald_deriv_expl'); call test_mbd_rsscs_ewald_deriv_expl() case ('mbd_rsscs_ewald_deriv_stress'); call test_mbd_rsscs_ewald_deriv_stress() case ('mbd_rsscs_deriv_impl_alpha'); call test_mbd_rsscs_deriv_impl_alpha() case ('mbd_rsscs_deriv_impl_C6'); call test_mbd_rsscs_deriv_impl_C6() case ('mbd_rsscs_deriv_impl_vdw'); call test_mbd_rsscs_deriv_impl_vdw() case ('mbd_rsscs_ewald_deriv_impl_alpha'); call test_mbd_rsscs_ewald_deriv_impl_alpha() case ('mbd_rsscs_ewald_deriv_impl_C6'); call test_mbd_rsscs_ewald_deriv_impl_C6() case ('mbd_rsscs_ewald_deriv_impl_vdw'); call test_mbd_rsscs_ewald_deriv_impl_vdw() case ('ts_deriv_expl'); call test_ts_deriv_expl() case ('ts_ewald_deriv_expl'); call test_ts_ewald_deriv_expl() case ('ts_ewald_deriv_stress'); call test_ts_ewald_deriv_stress() case ('ts_deriv_impl_alpha'); call test_ts_deriv_impl_alpha() case ('ts_deriv_impl_C6'); call test_ts_deriv_impl_C6() case ('ts_deriv_impl_vdw'); call test_ts_deriv_impl_vdw() case ('ts_ewald_deriv_impl_alpha'); call test_ts_ewald_deriv_impl_alpha() case ('ts_ewald_deriv_impl_C6'); call test_ts_ewald_deriv_impl_C6() case ('ts_ewald_deriv_impl_vdw'); call test_ts_ewald_deriv_impl_vdw() end select if (geom%exc%code /= 0) print *, 'Exception!' deallocate (geom) end subroutine end program libmbd-libmbd-88d61bc/tests/test_benchmark.py000066400000000000000000000011751452573331700213360ustar00rootroot00000000000000# This Source Code Form is subject to the terms of the Mozilla Public # License, v. 2.0. If a copy of the MPL was not distributed with this # file, You can obtain one at http://mozilla.org/MPL/2.0/. import subprocess import sys import pytest from pymbd.benchmark import parse @pytest.mark.parametrize( 'args', [[], ['--finite'], ['--method=ts']], ids=lambda x: ' '.join(x) ) @pytest.mark.no_scalapack def test_benchmark(args): stdout = subprocess.run( [sys.executable, '-u', '-m', 'pymbd.benchmark', *args], check=True, stdout=subprocess.PIPE, ).stdout.decode() assert parse(stdout)['energy'] libmbd-libmbd-88d61bc/tests/test_fortran.py000066400000000000000000000222521452573331700210560ustar00rootroot00000000000000import numpy as np import pytest from pytest import approx from pymbd import ang, from_volumes from pymbd.fortran import MBDFortranError, MBDGeom from pymbd.utils import numerical_gradients, numerical_latt_gradients def test_argon_dimer_plain(): ene = MBDGeom([(0, 0, 0), (0, 0, 4 * ang)]).mbd_energy( [11, 11], [63.525, 63.525], [3.55, 3.55], 0.83, variant='plain' ) assert ene == approx(-0.00024329110270970844, rel=1e-10) @pytest.mark.no_scalapack def test_argon_dimer_dipole_matrix(): dip = MBDGeom([(0, 0, 0), (0, 0, 4 * ang)]).dipole_matrix('bare') assert (dip != 0).sum() == 6 def test_argon_dimer_rsscs(): ene = MBDGeom([(0, 0, 0), (0, 0, 4 * ang)]).mbd_energy_species( ['Ar', 'Ar'], [1, 1], 0.83 ) assert ene == approx(-0.0002462647623815428, rel=1e-10) def test_argon_dimer_rsscs_rpa(): geom = MBDGeom([(0, 0, 0), (0, 0, 4 * ang)], do_rpa=True, get_rpa_orders=True) ene, orders = geom.mbd_energy_species(['Ar', 'Ar'], [1, 1], 0.83) assert ene == approx(-0.0002462647623815428, rel=1e-10) assert orders[1] == approx(-0.0002461558113413099, rel=1e-10) assert orders[2] == approx(0) assert orders[3] == approx(-1.0885208380438466e-07, rel=1e-10) def test_argon_dimer_ts(): ene = MBDGeom([(0, 0, 0), (0, 0, 4 * ang)]).ts_energy( [11, 11], [63.525, 63.525], [3.55, 3.55], 0.94 ) assert ene == approx(-0.000318123017869182, rel=1e-10) def test_benzene_dimer(benzene_dimer): mon1, mon2 = benzene_dimer dim = (np.vstack((mon1[0], mon2[0])), mon1[1] + mon2[1], mon1[2] + mon2[2]) enes = [ MBDGeom(coords).mbd_energy_species(species, vol_ratios, 0.83) for coords, species, vol_ratios in (mon1, mon2, dim) ] ene_int = enes[2] - enes[1] - enes[0] assert ene_int == approx(-0.006312323931302544, rel=1e-10) def test_benzene_gradients(benzene_dimer): coords, species, vol_ratios = benzene_dimer[0] ene, gradients = MBDGeom(coords).mbd_energy_species( species, vol_ratios, 0.83, force=True ) with MBDGeom(coords) as geom: num_gradients = numerical_gradients( geom, 'mbd_energy_species', species, vol_ratios, 0.83 ) for i in range(len(coords)): assert gradients[i] == approx(num_gradients[i], rel=1e-10, abs=1e-10) @pytest.mark.no_scalapack def test_benzene_dimer_python(benzene_dimer): mon1, mon2 = benzene_dimer dim = (np.vstack((mon1[0], mon2[0])), mon1[1] + mon2[1], mon1[2] + mon2[2]) enes = [ MBDGeom(coords).mbd_energy_species(species, vol_ratios, 0.83) for coords, species, vol_ratios in (mon1, mon2, dim) ] ene_int = enes[2] - enes[1] - enes[0] assert ene_int == approx(-0.006312323931302544, rel=1e-10) def test_benzene_gradients_plain(benzene_dimer): coords, species, vol_ratios = benzene_dimer[0] ene, gradients = MBDGeom(coords).mbd_energy_species( species, vol_ratios, 0.83, variant='plain', force=True ) with MBDGeom(coords) as geom: num_gradients = numerical_gradients( geom, 'mbd_energy_species', species, vol_ratios, 0.83, variant='plain' ) for i in range(len(coords)): assert gradients[i] == approx(num_gradients[i], rel=1e-10, abs=1e-10) def test_benzene_dimer_scs(benzene_dimer): mon1, mon2 = benzene_dimer dim = (np.vstack((mon1[0], mon2[0])), mon1[1] + mon2[1], mon1[2] + mon2[2]) enes = [ MBDGeom(coords).mbd_energy_species( species, vol_ratios, 1, a=2.56, variant='scs' ) for coords, species, vol_ratios in (mon1, mon2, dim) ] ene_int = enes[2] - enes[1] - enes[0] assert ene_int == approx(-0.007462380657774048, rel=1e-10) def test_benzene_dimer_ts(benzene_dimer): mon1, mon2 = benzene_dimer dim = (np.vstack((mon1[0], mon2[0])), mon1[1] + mon2[1], mon1[2] + mon2[2]) enes = [ MBDGeom(coords).ts_energy_species(species, vol_ratios, 0.94) for coords, species, vol_ratios in (mon1, mon2, dim) ] ene_int = enes[2] - enes[1] - enes[0] assert ene_int == approx(-0.008490052683234028, rel=1e-10) def test_benzene(benzene_dimer): coords, species, vol_ratios = benzene_dimer[0] alpha_0, C6, R_vdw = from_volumes(species, vol_ratios) ene = MBDGeom(coords).mbd_energy(alpha_0, C6, R_vdw, 0.83, variant='plain') assert ene == approx(-0.007002398506090302, rel=1e-10) def test_benzene_rpa(benzene_dimer): coords, species, vol_ratios = benzene_dimer[0] alpha_0, C6, R_vdw = from_volumes(species, vol_ratios) ene = MBDGeom(coords, do_rpa=True).mbd_energy( alpha_0, C6, R_vdw, 0.83, variant='plain' ) assert ene == approx(-0.007002398506090302, rel=1e-9) def test_benzene_rpa_scaled(benzene_dimer): coords, species, vol_ratios = benzene_dimer[0] alpha_0, C6, R_vdw = from_volumes(species, vol_ratios) ene = MBDGeom(coords, do_rpa=True, rpa_rescale_eigs=True).mbd_energy( alpha_0, C6, R_vdw, 0.83, variant='plain' ) assert ene != approx(-0.007002398506090302, rel=1e-9) assert ene == approx(-0.007002398506090302, rel=1e-7) def test_ethylcarbamate(ethylcarbamate): enes = [ MBDGeom(coords, lattice, k_grid).mbd_energy_species(species, vol_ratios, 0.83) for coords, lattice, k_grid, species, vol_ratios in ethylcarbamate ] ene_int = enes[0] - 2 * enes[1] assert ene_int == approx(-0.037040868610822564, rel=1e-10) def test_argon_crystal(argon_crystal): coords, lattice, k_grid, species, vol_ratios = argon_crystal ene = MBDGeom(coords, lattice, k_grid).mbd_energy_species(species, vol_ratios, 0.83) assert ene == approx(-0.0021037562496878173, rel=1e-10) def test_argon_crystal_rpa(argon_crystal): coords, lattice, k_grid, species, vol_ratios = argon_crystal ene = MBDGeom(coords, lattice, k_grid, do_rpa=True).mbd_energy_species( species, vol_ratios, 0.83, variant='plain' ) assert ene == approx(-0.0021036969146744147, rel=1e-10) @pytest.mark.no_scalapack def test_argon_crystal_modes(argon_crystal): coords, lattice, k_grid, species, vol_ratios = argon_crystal geom = MBDGeom( coords, lattice, custom_k_pts=[(0, 0, 0), (0.1, 0, 0)], get_spectrum=True ) _, eigs, C = geom.mbd_energy_species(species, vol_ratios, 0.83) assert abs(C[:, :, 0].imag).sum() == approx(0) assert abs(C[:, :, 1].imag).sum() != approx(0) def test_argon_crystal_gradients(argon_crystal): coords, lattice, k_grid, species, vol_ratios = argon_crystal ene, gradients, latt_gradients = MBDGeom( coords, lattice, k_grid ).mbd_energy_species(species, vol_ratios, 0.83, force=True) with MBDGeom(coords, lattice, k_grid) as geom: num_gradients = numerical_gradients( geom, 'mbd_energy_species', species, vol_ratios, 0.83 ) for i in range(len(coords)): assert gradients[i] == approx(num_gradients[i], rel=1e-10, abs=1e-10) with MBDGeom(coords, lattice, k_grid) as geom: num_latt_gradients = numerical_latt_gradients( geom, 'mbd_energy_species', species, vol_ratios, 0.83 ) for i in range(3): assert latt_gradients[i] == approx(num_latt_gradients[i], rel=1e-10, abs=1e-10) def test_lithium(bulk_lithium): coords, lattice, k_grid, species, vol_ratios = bulk_lithium with pytest.raises(MBDFortranError): MBDGeom(coords, lattice, k_grid).mbd_energy_species(species, vol_ratios, 0.83) def test_ethylcarbamate_scs(ethylcarbamate): enes = [ MBDGeom(coords, lattice, k_grid).mbd_energy_species( species, vol_ratios, 1, a=2.56, variant='scs' ) for coords, lattice, k_grid, species, vol_ratios in ethylcarbamate ] ene_int = enes[0] - 2 * enes[1] assert ene_int == approx(-0.03633331132194684, rel=1e-10) def test_ethylcarbamate_ts(ethylcarbamate): enes = [ MBDGeom(coords, lattice).ts_energy_species(species, vol_ratios, 0.83) for coords, lattice, _, species, vol_ratios in ethylcarbamate ] ene_int = enes[0] - 2 * enes[1] assert ene_int == approx(-0.05218213230219945, rel=1e-10) @pytest.mark.no_scalapack def test_mbd_coulomb(peptide_meoh): a = 14.4 beta = 2.0 enes = [] for coords, species, vol_ratios in peptide_meoh: geom = MBDGeom(coords, get_spectrum=True) _, eigs, C = geom.mbd_energy_species(species, vol_ratios, beta=0.83) omega_t = np.sqrt(eigs) alpha_0, C6, R_vdw = from_volumes(species, vol_ratios) omega = 4 * C6 / (3 * alpha_0**2) charges = np.ones_like(alpha_0) masses = 1 / (alpha_0 * omega**2) ecoul = geom.coulomb_energy( charges, masses, omega_t, 'fermi', R_vdw, beta, a, C ) edip = geom.dipole_energy( alpha_0, omega, omega_t, 'fermi,dip', R_vdw, beta, a, C ) C = np.identity(len(omega_t)) omega_non = np.repeat(omega, 3) ecoul_non = geom.coulomb_energy( charges, masses, omega_non, 'fermi', R_vdw, beta, a, C ) edip_non = geom.dipole_energy( alpha_0, omega, omega_t, 'fermi,dip', R_vdw, beta, a, C ) enes.append(ecoul - edip - (ecoul_non - edip_non)) ene_int = enes[2] - enes[0] - enes[1] assert ene_int == approx(0.0002460638172163822 / 627.503, rel=1e-10) libmbd-libmbd-88d61bc/tests/test_main.py000066400000000000000000000002211452573331700203170ustar00rootroot00000000000000from pytest import approx def test_main(): from pymbd.__main__ import ene, ene_expected assert ene == approx(ene_expected, rel=1e-10) libmbd-libmbd-88d61bc/tests/test_python.py000066400000000000000000000007101452573331700207170ustar00rootroot00000000000000import pytest from pytest import approx from pymbd import mbd_energy_species @pytest.mark.no_scalapack def test_ethylcarbamate(ethylcarbamate): enes = [ mbd_energy_species( coords, species, vol_ratios, 0.83, lattice=lattice, k_grid=k_grid ) for coords, lattice, k_grid, species, vol_ratios in ethylcarbamate ] ene_int = enes[0] - 2 * enes[1] assert ene_int == approx(-0.037040868610822564, rel=1e-10)