From d71d4d2254dca3213a42b64395a9e5842e73315c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Tue, 24 Nov 2020 12:20:10 +0100 Subject: [PATCH 01/17] Add source of slateratom, sktwocnt and sktools This contains the source of the extbasis SVN-branch converted to a CMake build system for slateratom and sktwocnt and commit id 8deb11148409 of the devel branch of sktools. --- .gitignore | 8 + AUTHORS.rst | 14 + CMakeLists.txt | 59 ++ CONTRIBUTING.rst | 81 ++ COPYING | 674 +++++++++++++ COPYING.LESSER | 165 ++++ README.rst | 71 +- common/lib/CMakeLists.txt | 21 + common/lib/accuracy.f90 | 13 + common/lib/constants.f90 | 11 + common/lib/fifo.f90 | 8 + common/lib/fifo_real1.f90 | 264 ++++++ common/lib/fifo_real2.f90 | 271 ++++++ common/lib/fifobase.f90 | 332 +++++++ common/lib/taggedout.f90 | 548 +++++++++++ doc/devel/code_structure.txt | 52 + doc/devel/general_notes.txt | 66 ++ doc/input.txt | 73 ++ examples/mio/skdef.hsd | 456 +++++++++ sktools/CMakeLists.txt | 7 + sktools/MANIFEST.in | 0 sktools/bin/collectspinw | 57 ++ sktools/bin/collectwavecoeffs | 71 ++ sktools/bin/skdiff | 79 ++ sktools/bin/skgen | 275 ++++++ sktools/bin/skmanip | 113 +++ sktools/setup.py | 31 + sktools/src/sktools/__init__.py | 1 + sktools/src/sktools/calculators/__init__.py | 29 + sktools/src/sktools/calculators/gridatom.py | 1 + sktools/src/sktools/calculators/sktwocnt.py | 272 ++++++ sktools/src/sktools/calculators/slateratom.py | 418 ++++++++ sktools/src/sktools/common.py | 468 +++++++++ sktools/src/sktools/compressions.py | 180 ++++ sktools/src/sktools/hsd/__init__.py | 64 ++ sktools/src/sktools/hsd/converter.py | 123 +++ sktools/src/sktools/hsd/formatter.py | 204 ++++ sktools/src/sktools/hsd/parser.py | 428 +++++++++ sktools/src/sktools/hsd/query.py | 590 ++++++++++++ sktools/src/sktools/hsd/test.hsd | 36 + sktools/src/sktools/hsd/tree.py | 105 ++ sktools/src/sktools/hsd/treebuilder.py | 342 +++++++ sktools/src/sktools/oldskfile.py | 380 ++++++++ sktools/src/sktools/radial_grid.py | 53 ++ sktools/src/sktools/skdef.py | 525 ++++++++++ sktools/src/sktools/skgen/__init__.py | 5 + sktools/src/sktools/skgen/atom.py | 416 ++++++++ sktools/src/sktools/skgen/common.py | 163 ++++ sktools/src/sktools/skgen/compression.py | 290 ++++++ sktools/src/sktools/skgen/path.py | 152 +++ sktools/src/sktools/skgen/sktable.py | 210 ++++ sktools/src/sktools/skgen/twocnt.py | 348 +++++++ sktools/src/sktools/taggedfile.py | 119 +++ sktools/src/sktools/twocenter_grids.py | 46 + sktwocnt/CMakeLists.txt | 2 + sktwocnt/lib/CMakeLists.txt | 26 + sktwocnt/lib/bisection.f90 | 114 +++ sktwocnt/lib/coordtrans.f90 | 209 ++++ sktwocnt/lib/dftbxc.f90 | 350 +++++++ sktwocnt/lib/gridgenerator.f90 | 122 +++ sktwocnt/lib/gridorbital.f90 | 231 +++++ sktwocnt/lib/interpolation.f90 | 152 +++ sktwocnt/lib/partition.f90 | 79 ++ sktwocnt/lib/quadrature.f90 | 110 +++ sktwocnt/lib/sphericalharmonics.f90 | 218 +++++ sktwocnt/lib/twocnt.f90 | 368 +++++++ sktwocnt/prog/CMakeLists.txt | 11 + sktwocnt/prog/cmdargs.f90 | 32 + sktwocnt/prog/input.f90 | 255 +++++ sktwocnt/prog/main.f90 | 21 + sktwocnt/prog/output.f90 | 48 + slateratom/CMakeLists.txt | 2 + slateratom/lib/CMakeLists.txt | 33 + slateratom/lib/broyden.f90 | 479 ++++++++++ slateratom/lib/core_overlap.f90 | 393 ++++++++ slateratom/lib/coulomb_hfex.f90 | 309 ++++++ slateratom/lib/coulomb_potential.f90 | 113 +++ slateratom/lib/density.f90 | 702 ++++++++++++++ slateratom/lib/densitymatrix.f90 | 42 + slateratom/lib/dft.f90 | 889 +++++++++++++++++ slateratom/lib/diagonalizations.f90 | 894 ++++++++++++++++++ slateratom/lib/globals.f90 | 124 +++ .../lib/grid_differentiation_sign_1.txt | 40 + .../lib/grid_differentiation_sign_2.txt | 40 + slateratom/lib/hamiltonian.f90 | 269 ++++++ slateratom/lib/input.f90 | 287 ++++++ slateratom/lib/integration.f90 | 247 +++++ slateratom/lib/numerical_differentiation.f90 | 162 ++++ slateratom/lib/output.f90 | 559 +++++++++++ slateratom/lib/total_energy.f90 | 240 +++++ slateratom/lib/utilities.f90 | 155 +++ slateratom/lib/zora_routines.f90 | 337 +++++++ slateratom/prog/CMakeLists.txt | 9 + slateratom/prog/cmdargs.f90 | 32 + slateratom/prog/main.f90 | 213 +++++ utils/export/skprogs-activate.sh.in | 11 + utils/export/skprogs-config.cmake.in | 10 + 97 files changed, 18726 insertions(+), 1 deletion(-) create mode 100644 .gitignore create mode 100644 AUTHORS.rst create mode 100644 CMakeLists.txt create mode 100644 CONTRIBUTING.rst create mode 100644 COPYING create mode 100644 COPYING.LESSER create mode 100644 common/lib/CMakeLists.txt create mode 100644 common/lib/accuracy.f90 create mode 100644 common/lib/constants.f90 create mode 100644 common/lib/fifo.f90 create mode 100644 common/lib/fifo_real1.f90 create mode 100644 common/lib/fifo_real2.f90 create mode 100644 common/lib/fifobase.f90 create mode 100644 common/lib/taggedout.f90 create mode 100644 doc/devel/code_structure.txt create mode 100644 doc/devel/general_notes.txt create mode 100644 doc/input.txt create mode 100644 examples/mio/skdef.hsd create mode 100644 sktools/CMakeLists.txt create mode 100644 sktools/MANIFEST.in create mode 100755 sktools/bin/collectspinw create mode 100755 sktools/bin/collectwavecoeffs create mode 100755 sktools/bin/skdiff create mode 100755 sktools/bin/skgen create mode 100755 sktools/bin/skmanip create mode 100644 sktools/setup.py create mode 100644 sktools/src/sktools/__init__.py create mode 100644 sktools/src/sktools/calculators/__init__.py create mode 100644 sktools/src/sktools/calculators/gridatom.py create mode 100644 sktools/src/sktools/calculators/sktwocnt.py create mode 100644 sktools/src/sktools/calculators/slateratom.py create mode 100644 sktools/src/sktools/common.py create mode 100644 sktools/src/sktools/compressions.py create mode 100644 sktools/src/sktools/hsd/__init__.py create mode 100644 sktools/src/sktools/hsd/converter.py create mode 100644 sktools/src/sktools/hsd/formatter.py create mode 100644 sktools/src/sktools/hsd/parser.py create mode 100644 sktools/src/sktools/hsd/query.py create mode 100644 sktools/src/sktools/hsd/test.hsd create mode 100644 sktools/src/sktools/hsd/tree.py create mode 100644 sktools/src/sktools/hsd/treebuilder.py create mode 100644 sktools/src/sktools/oldskfile.py create mode 100644 sktools/src/sktools/radial_grid.py create mode 100644 sktools/src/sktools/skdef.py create mode 100644 sktools/src/sktools/skgen/__init__.py create mode 100644 sktools/src/sktools/skgen/atom.py create mode 100644 sktools/src/sktools/skgen/common.py create mode 100644 sktools/src/sktools/skgen/compression.py create mode 100644 sktools/src/sktools/skgen/path.py create mode 100644 sktools/src/sktools/skgen/sktable.py create mode 100644 sktools/src/sktools/skgen/twocnt.py create mode 100644 sktools/src/sktools/taggedfile.py create mode 100644 sktools/src/sktools/twocenter_grids.py create mode 100644 sktwocnt/CMakeLists.txt create mode 100644 sktwocnt/lib/CMakeLists.txt create mode 100644 sktwocnt/lib/bisection.f90 create mode 100644 sktwocnt/lib/coordtrans.f90 create mode 100644 sktwocnt/lib/dftbxc.f90 create mode 100644 sktwocnt/lib/gridgenerator.f90 create mode 100644 sktwocnt/lib/gridorbital.f90 create mode 100644 sktwocnt/lib/interpolation.f90 create mode 100644 sktwocnt/lib/partition.f90 create mode 100644 sktwocnt/lib/quadrature.f90 create mode 100644 sktwocnt/lib/sphericalharmonics.f90 create mode 100644 sktwocnt/lib/twocnt.f90 create mode 100644 sktwocnt/prog/CMakeLists.txt create mode 100644 sktwocnt/prog/cmdargs.f90 create mode 100644 sktwocnt/prog/input.f90 create mode 100644 sktwocnt/prog/main.f90 create mode 100644 sktwocnt/prog/output.f90 create mode 100644 slateratom/CMakeLists.txt create mode 100644 slateratom/lib/CMakeLists.txt create mode 100644 slateratom/lib/broyden.f90 create mode 100644 slateratom/lib/core_overlap.f90 create mode 100644 slateratom/lib/coulomb_hfex.f90 create mode 100644 slateratom/lib/coulomb_potential.f90 create mode 100644 slateratom/lib/density.f90 create mode 100644 slateratom/lib/densitymatrix.f90 create mode 100644 slateratom/lib/dft.f90 create mode 100644 slateratom/lib/diagonalizations.f90 create mode 100644 slateratom/lib/globals.f90 create mode 100644 slateratom/lib/grid_differentiation_sign_1.txt create mode 100644 slateratom/lib/grid_differentiation_sign_2.txt create mode 100644 slateratom/lib/hamiltonian.f90 create mode 100644 slateratom/lib/input.f90 create mode 100644 slateratom/lib/integration.f90 create mode 100644 slateratom/lib/numerical_differentiation.f90 create mode 100644 slateratom/lib/output.f90 create mode 100644 slateratom/lib/total_energy.f90 create mode 100644 slateratom/lib/utilities.f90 create mode 100644 slateratom/lib/zora_routines.f90 create mode 100644 slateratom/prog/CMakeLists.txt create mode 100644 slateratom/prog/cmdargs.f90 create mode 100644 slateratom/prog/main.f90 create mode 100644 utils/export/skprogs-activate.sh.in create mode 100644 utils/export/skprogs-config.cmake.in diff --git a/.gitignore b/.gitignore new file mode 100644 index 00000000..193c11bf --- /dev/null +++ b/.gitignore @@ -0,0 +1,8 @@ +*~ +*.o +*.mod +*.a +*.pyc +__pycache__ +sktools/build + diff --git a/AUTHORS.rst b/AUTHORS.rst new file mode 100644 index 00000000..163d6315 --- /dev/null +++ b/AUTHORS.rst @@ -0,0 +1,14 @@ +******* +Authors +******* + +The following people (in alphabetic order by their family names) have +contributed to this package : + +* Bálint Aradi (University of Bremen) + +* Ben Hourahine (University of Strathclyde, UK) + +* Christof Köhler (University of Bremen) + +* Thomas Niehaus (University of Lyon, France) diff --git a/CMakeLists.txt b/CMakeLists.txt new file mode 100644 index 00000000..4f089310 --- /dev/null +++ b/CMakeLists.txt @@ -0,0 +1,59 @@ +cmake_minimum_required(VERSION 3.16) + +project(SkProgs VERSION 0.1 LANGUAGES Fortran) + +include(GNUInstallDirs) + +set(default_build_type "RelWithDebInfo") +if(NOT CMAKE_BUILD_TYPE AND NOT CMAKE_CONFIGURATION_TYPES) + message(STATUS "Build type: ${default_build_type} (default single-config)") + set(CMAKE_BUILD_TYPE "${default_build_type}" CACHE STRING "Build type" FORCE) + set_property(CACHE CMAKE_BUILD_TYPE PROPERTY STRINGS "Debug" "Release" "RelWithDebInfo") +elseif(CMAKE_BUILD_TYPE AND NOT CMAKE_CONFIGURATION_TYPES) + message(STATUS + "Build type: ${CMAKE_BUILD_TYPE} (manually selected single-config)") +else() + message(STATUS "Build type: Multi-Config (build type selected at the build step)") +endif() + + +#################### External dependencies #################### + +find_package(Libxc QUIET) +if (NOT Libxc_FOUND) + message(STATUS "Libxc: No CMake export file found, trying to find with pkg-config") + find_package(PkgConfig QUIET) + pkg_check_modules(pc_libxc REQUIRED libxc) + pkg_check_modules(pc_libxcf90 REQUIRED libxcf90) + add_library(Libxc::xc INTERFACE IMPORTED) + target_link_libraries(Libxc::xc INTERFACE ${pc_libxc_LINK_LIBRARIES}) + target_include_directories(Libxc::xc INTERFACE ${pc_libxc_INCLUDE_DIRS}) + add_library(Libxc::xcf90 INTERFACE IMPORTED) + target_link_libraries(Libxc::xcf90 INTERFACE ${pc_libxcf90_LINK_LIBRARIES}) + target_include_directories(Libxc::xc INTERFACE ${pc_libxcf90_INCLUDE_DIRS}) +elseif(NOT TARGET Libxc::xcf90) + message(FATAL_ERROR "Libxc CMake export file found, but target Libxc::xcf90 is missing " + "(maybe Libxc was built without the -DENABLE_FORTRAN=True switch?") +endif() + +find_package(Python3 COMPONENTS Interpreter REQUIRED) +set(PYTHON_INTERPRETER "${Python3_EXECUTABLE}") +set(PYTHON_VERSION_MAJOR_MINOR "${Python3_VERSION_MAJOR}.${Python3_VERSION_MINOR}") +#################### Add source components #################### + +add_subdirectory(common/lib) +add_subdirectory(slateratom) +add_subdirectory(sktwocnt) +add_subdirectory(sktools) + +#################### Extra install #################### + +configure_file( + ${CMAKE_CURRENT_SOURCE_DIR}/utils/export/skprogs-activate.sh.in + ${CMAKE_CURRENT_BINARY_DIR}/skprogs-activate.sh + @ONLY) + +install( + PROGRAMS "${CMAKE_CURRENT_BINARY_DIR}/skprogs-activate.sh" + DESTINATION "${CMAKE_INSTALL_BINDIR}/") + diff --git a/CONTRIBUTING.rst b/CONTRIBUTING.rst new file mode 100644 index 00000000..93f75b4e --- /dev/null +++ b/CONTRIBUTING.rst @@ -0,0 +1,81 @@ +**************************** +Contributing code to SkProgs +**************************** + +SkProgs is an open source project, and everyone is welcome to contribute +improvements and extensions, provided they are willing to provide their changes +under the same license as SkProgs itself. + + +How to contribute +================= + +The preferred method is to fork the project on `github +`_), make your changes and then create a +pull request. Your changes should be based on the default branch. Before you +start, please familiarise yourself with our developers guide +``_ to understand our git +workflow and style conventions. + + +Attribution +=========== + +Every contributor is welcome to be listed in the `AUTHORS.rst` file. List +yourself by including a change to `AUTHORS.rst` in your pull +request. Contributors should be ordered alphabetically by their family name. + + +Developer certificate of origin +=============================== + +When you contribute to the project, your contribution must align with the +`Developer Certificate of Origin +`_:: + + Developer Certificate of Origin + Version 1.1 + + Copyright (C) 2004, 2006 The Linux Foundation and its contributors. + 1 Letterman Drive + Suite D4700 + San Francisco, CA, 94129 + + Everyone is permitted to copy and distribute verbatim copies of this + license document, but changing it is not allowed. + + + Developer's Certificate of Origin 1.1 + + By making a contribution to this project, I certify that: + + (a) The contribution was created in whole or in part by me and I + have the right to submit it under the open source license + indicated in the file; or + + (b) The contribution is based upon previous work that, to the best + of my knowledge, is covered under an appropriate open source + license and I have the right under that license to submit that + work with modifications, whether created in whole or in part + by me, under the same open source license (unless I am + permitted to submit under a different license), as indicated + in the file; or + + (c) The contribution was provided directly to me by some other + person who certified (a), (b) or (c) and I have not modified + it. + + (d) I understand and agree that this project and the contribution + are public and that a record of the contribution (including all + personal information I submit with it, including my sign-off) is + maintained indefinitely and may be redistributed consistent with + this project or the open source license(s) involved. + + +By issuing a pull request or contributing code in any other ways to the project, +you explicitly declare that your contribution is in accordance with the +Developer's Certificate of Origin as described above. + +Please, also make sure, that all of your git commits contain your real name and +email address; pseudonyms and anonymous contributions unfortunately can not be +accepted. diff --git a/COPYING b/COPYING new file mode 100644 index 00000000..94a9ed02 --- /dev/null +++ b/COPYING @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/COPYING.LESSER b/COPYING.LESSER new file mode 100644 index 00000000..65c5ca88 --- /dev/null +++ b/COPYING.LESSER @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. diff --git a/README.rst b/README.rst index 0a4dd70f..826fda22 100644 --- a/README.rst +++ b/README.rst @@ -1 +1,70 @@ -Package containing tools for creating DFTB parameterizations +******* +SkProgs +******* + +Package containing a few programs enabling to generate Slater-Koster files for +the DFTB-method. + +**NOTE**: This packages comes with minimal documentation and with a currently +rather fragile user interface. It is considered to be neither stable nor +robust. Make sure, you check results as careful as possible. Use at your own +risk! + + +Installing +========== + +Prerequisites +------------- + +* Fortran 2003 compiler + +* CMake (>= 3.16) + +* Python3 + +* LibXC library with f90 interface (tested with version 4.3.4, version 5.x does + not work due to inteface changes in LibXC) + + +Building the code +----------------- + +Follow the usual CMake build workflow: + +* Configure the project, specify your compiler (e.g. ``gfortran``), the install + location (e.g. ``$HOME/opt/skprogs``) and the build directory + (e.g. ``_build``):: + + FC=gfortran cmake -DCMAKE_INSTALL_PREFIX=$HOME/opt/skprogs -B _build . + + If libXC is installed in a non-standard location, you may need to specify + either the ``CMAKE_PREFIX_PATH`` environment variable (if libXC was built with + CMake) or the ``PKG_CONFIG_PATH`` environment variable (if libXC was built + with autotools) in order to guide the library search:: + + CMAKE_PREFIX_PATH=YOUR_LIBXC_INSTALL_FOLDER FC=gfortan cmake [...] + + PKG_CONFIG_PATH=FOLDER_WITH_LIBXC_PC_FILES FC=gfortran cmake [...] + + +* If the configuration was successful, buid the code :: + + cmake --build _build -- -j + + +* If the build was successful, install the code :: + + cmake --install _build + + +License +======= + +SkProgs is released under the GNU Lesser General Public License. + +You can redistribute it and/or modify it under the terms of the GNU Lesser +General Public License as published by the Free Software Foundation, either +version 3 of the License, or (at your option) any later version. See the files +`COPYING `_ and `COPYING.LESSER `_ for the detailed +licensing conditions. diff --git a/common/lib/CMakeLists.txt b/common/lib/CMakeLists.txt new file mode 100644 index 00000000..c6a15afc --- /dev/null +++ b/common/lib/CMakeLists.txt @@ -0,0 +1,21 @@ +set(sources-f90 + accuracy.f90 + constants.f90 + fifo.f90 + fifo_real1.f90 + fifo_real2.f90 + fifobase.f90 + taggedout.f90) + +add_library(skprogs-common ${sources-f90}) + +set(moddir ${CMAKE_CURRENT_BINARY_DIR}/modfiles) +set_target_properties(skprogs-common PROPERTIES Fortran_MODULE_DIRECTORY ${moddir}) +target_include_directories(skprogs-common PUBLIC + $ + $) + +if(BUILD_SHARED_LIBS) + install(TARGETS skprogs-common EXPORT skprogs-targets DESTINATION ${CMAKE_INSTALL_LIBDIR}) +endif() +#install(DIRECTORY ${moddir}/ DESTINATION ${CMAKE_INSTALL_MODULEDIR}) diff --git a/common/lib/accuracy.f90 b/common/lib/accuracy.f90 new file mode 100644 index 00000000..5e2aa0b3 --- /dev/null +++ b/common/lib/accuracy.f90 @@ -0,0 +1,13 @@ +!> Some global accuracy settings. +module accuracy + implicit none + public + + integer, parameter :: dp = 8 + integer, parameter :: cp = dp !* precision of the complex data type + integer, parameter :: sc = 10 !* length of a short string + integer, parameter :: mc = 50 !* length of a medium length string + integer, parameter :: lc = 200 !* length of a long string + +end module accuracy + diff --git a/common/lib/constants.f90 b/common/lib/constants.f90 new file mode 100644 index 00000000..03f27ec9 --- /dev/null +++ b/common/lib/constants.f90 @@ -0,0 +1,11 @@ +module constants + use accuracy + implicit none + + real(dp), parameter :: pi = 3.14159265358979323846_dp + real(dp), parameter :: r_Bohr = 0.529177249_dp !< Bohr radius (Å) + real(dp), parameter :: Bohr__AA = r_Bohr !< Bohr->Angstrom + real(dp), parameter :: AA__Bohr = 1.0_dp / Bohr__AA !< Angstrom->Bohr + real(dp), parameter :: Hartree = 27.2113845_dp !< H -> eV (CODATA) + real(dp), parameter :: sol = 137.0359997_dp !< Speed of Light a.u. +end module constants diff --git a/common/lib/fifo.f90 b/common/lib/fifo.f90 new file mode 100644 index 00000000..f9eb9976 --- /dev/null +++ b/common/lib/fifo.f90 @@ -0,0 +1,8 @@ +!> Provides all implemented fifos. +module fifo_module + use fifo_real1_module + use fifo_real2_module + implicit none + +end module fifo_module + diff --git a/common/lib/fifo_real1.f90 b/common/lib/fifo_real1.f90 new file mode 100644 index 00000000..c5bbb5c9 --- /dev/null +++ b/common/lib/fifo_real1.f90 @@ -0,0 +1,264 @@ +!> Implements fifo for rank 1 real (double precision) arrays. +module fifo_real1_module + use fifobase_module + implicit none + private + + public :: fifo_real1, size + + integer, parameter :: dp = kind(1.0d0) + + !> Extended data type. + type :: mydata + real(dp), allocatable :: data(:) + end type mydata + + !> Extendid fifo. + type, extends(fifobase) :: fifo_real1 + contains + procedure :: push => fifo_real1_push + procedure :: pop => fifo_real1_pop + procedure :: get => fifo_real1_get + procedure :: push_alloc => fifo_real1_push_alloc + procedure :: pop_alloc => fifo_real1_pop_alloc + procedure :: popall => fifo_real1_popall + procedure :: popall_concat => fifo_real1_popall_concat + ! Workaround: should be private, but NAG fails to override private routines. + procedure :: datatofile => fifo_real1_datatofile + procedure :: datafromfile => fifo_real1_datafromfile + end type fifo_real1 + + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!! FIFO_REAL1 Routines +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Makes a copy of item and stores it in the collection. + !! \param self Instance. + !! \param item Item to store. + subroutine fifo_real1_push(self, item) + class(fifo_real1), intent(inout) :: self + real(dp), intent(in) :: item(:) + + class(*), pointer :: wrapper + + allocate(mydata :: wrapper) + select type(wrapper) + type is (mydata) + wrapper%data = item ! Automatic allocation + end select + call self%pushptr(wrapper) + + end subroutine fifo_real1_push + + + !> Retrieves the next item (fifo) and removes it from the collection. + !! \param self Instance. + !! \param item Item storing the result. + subroutine fifo_real1_pop(self, item) + class(fifo_real1), intent(inout) :: self + real(dp), intent(out) :: item(:) + + class(*), pointer :: wrapper + + call self%popptr(wrapper) + select type (wrapper) + type is (mydata) + item(:) = wrapper%data + end select + deallocate(wrapper) + + end subroutine fifo_real1_pop + + + !> Retrieves the next item without removing it from the collection. + !! + !! \details At first call the first element of the fifo is retrieved. At + !! subsequent calls the elements are returned following the fifo principle. If + !! the last element in the fifo had been returned, the first will be returned + !! again. + !! + !! \param self Instance. + !! \param item Item storing the result. + subroutine fifo_real1_get(self, item) + class(fifo_real1), intent(inout) :: self + real(dp), intent(out) :: item(:) + + class(*), pointer :: wrapper + + call self%getptr(wrapper) + select type (wrapper) + type is (mydata) + item(:) = wrapper%data + end select + + end subroutine fifo_real1_get + + + !> Moves an allocatable item into the collection. + !! + !! \details Similar to push but for allocatable elements. The allocation + !! status of the item is moved to the collection, so that the original item is + !! automatically deallocated. No temporary copy of the item is created. + !! + !! \param self Instance. + !! \param item Item to store. Deallocated on return. + subroutine fifo_real1_push_alloc(self, item) + class(fifo_real1), intent(inout) :: self + real(dp), allocatable, intent(inout) :: item(:) + + class(*), pointer :: wrapper + + allocate(mydata :: wrapper) + select type (wrapper) + type is (mydata) + call move_alloc(item, wrapper%data) + end select + call self%pushptr(wrapper) + + end subroutine fifo_real1_push_alloc + + + !> Retrieves the next item (fifo) and removes it from the collection. + !! + !! \details Similar to pop but for allocatable elements. The allocation status + !! is moved from the collection to the item, so that the item will be + !! automatically allocated. No temporary copy of the item is created. + !! + !! \param self Instance. + !! \param item Item storing the result. + subroutine fifo_real1_pop_alloc(self, item) + class(fifo_real1), intent(inout) :: self + real(dp), allocatable, intent(out) :: item(:) + + class(*), pointer :: wrapper + + call self%popptr(wrapper) + select type (wrapper) + type is (mydata) + call move_alloc(wrapper%data, item) + end select + deallocate(wrapper) + + end subroutine fifo_real1_pop_alloc + + + !> Retrieves all items from the collection as an allocatable array and deletes + !! them. + !! + !! \details The routine allocates an array with the given shape and an + !! additional dimension with the size of the collectoin. + !! + !! \param self Instance. + !! \param itemshape Shape of the items in the collection. + !! \param items Array containing the items. + !! + !! \warning It is the responsibility of the caller to invoke this method + !! only on collections containing elements with the same shape. No checking + !! of shape conformance is done. + subroutine fifo_real1_popall(self, items) + class(fifo_real1), intent(inout) :: self + real(dp), allocatable, intent(out) :: items(:,:) + + class(*), pointer :: wrapper + integer :: itemshape(1) + integer :: ii + + call self%getptr(wrapper) + select type (wrapper) + type is (mydata) + itemshape(:) = shape(wrapper%data) + end select + allocate(items(itemshape(1), size(self))) + do ii = 1, size(self) + call self%pop(items(:,ii)) + end do + + end subroutine fifo_real1_popall + + + !> Retrieves all items from the collection as an allocatable array by + !! concatenating them and deletes them. + !! + !! \details The routine allocates an array with the given shape times + !! the size of the collection. + !! + !! \param self Instance. + !! \param items Array containing the items. + subroutine fifo_real1_popall_concat(self, items) + class(fifo_real1), intent(inout) :: self + real(dp), allocatable, intent(out) :: items(:) + + integer :: ii, ind, total, nn + class(*), pointer :: wrapper + + total = 0 + do ii = 1, size(self) + call self%getptr(wrapper) + select type (wrapper) + type is (mydata) + total = total + size(wrapper%data) + end select + end do + allocate(items(total)) + ind = 1 + do ii = 1, size(self) + call self%popptr(wrapper) + select type (wrapper) + type is (mydata) + nn = size(wrapper%data) + items(ind:ind+nn-1) = wrapper%data(:) + ind = ind + nn + end select + deallocate(wrapper) + end do + + end subroutine fifo_real1_popall_concat + + + !> Overrides the datatofile method of the base class. + !! \param self Instance. + !! \param fileid Id of the file in which data should be written. + !! \param filepos Position in the file, to which data should be written. + !! \param data Data node to save to file. + subroutine fifo_real1_datatofile(self, fileid, filepos, data) + class(fifo_real1), intent(inout) :: self + integer, intent(in) :: fileid, filepos + class(*), pointer, intent(inout) :: data + + select type (data) + type is (mydata) + write(fileid, pos=filepos) shape(data%data) + write(fileid) data%data + end select + deallocate(data) + + end subroutine fifo_real1_datatofile + + + !> Overides the datafromfile method of the base class. + !! \param self Instance. + !! \param fileid Id of the file from which data should be read. + !! \param filepos Position in the file, from which data should be read. + !! \param data Data node to create from file. + subroutine fifo_real1_datafromfile(self, fileid, filepos, data) + class(fifo_real1), intent(inout) :: self + integer, intent(in) :: fileid, filepos + class(*), pointer, intent(out) :: data + + integer :: itemshape(1) + + allocate(mydata :: data) + select type (data) + type is (mydata) + read(fileid, pos=filepos) itemshape + allocate(data%data(itemshape(1))) + read(fileid) data%data + end select + + end subroutine fifo_real1_datafromfile + + +end module fifo_real1_module diff --git a/common/lib/fifo_real2.f90 b/common/lib/fifo_real2.f90 new file mode 100644 index 00000000..56bdd825 --- /dev/null +++ b/common/lib/fifo_real2.f90 @@ -0,0 +1,271 @@ +!> Implements fifo for rank 2 real (double precision) arrays. +module fifo_real2_module + use fifobase_module + implicit none + private + + public :: fifo_real2, size + + integer, parameter :: dp = kind(1.0d0) + + !> Extended data type. + type :: mydata + real(dp), allocatable :: data(:,:) + end type mydata + + !> Extendid fifo. + type, extends(fifobase) :: fifo_real2 + contains + procedure :: push => fifo_real2_push + procedure :: pop => fifo_real2_pop + procedure :: get => fifo_real2_get + procedure :: push_alloc => fifo_real2_push_alloc + procedure :: pop_alloc => fifo_real2_pop_alloc + procedure :: popall => fifo_real2_popall + procedure :: popall_concat => fifo_real2_popall_concat + ! Workaround: should be private, but NAG fails to override private routines. + procedure :: datatofile => fifo_real2_datatofile + procedure :: datafromfile => fifo_real2_datafromfile + end type fifo_real2 + + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!! FIFO_REAL2 Routines +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Makes a copy of item and stores it in the collection. + !! \param self Instance. + !! \param item Item to store. + subroutine fifo_real2_push(self, item) + class(fifo_real2), intent(inout) :: self + real(dp), intent(in) :: item(:,:) + + class(*), pointer :: wrapper + + allocate(mydata :: wrapper) + select type(wrapper) + type is (mydata) + wrapper%data = item ! Automatic allocation + end select + call self%pushptr(wrapper) + + end subroutine fifo_real2_push + + + !> Retrieves the next item (fifo) and removes it from the collection. + !! \param self Instance. + !! \param item Item storing the result. + subroutine fifo_real2_pop(self, item) + class(fifo_real2), intent(inout) :: self + real(dp), intent(out) :: item(:,:) + + class(*), pointer :: wrapper + + call self%popptr(wrapper) + select type (wrapper) + type is (mydata) + item(:,:) = wrapper%data + end select + deallocate(wrapper) + + end subroutine fifo_real2_pop + + + !> Retrieves the next item without removing it from the collection. + !! + !! \details At first call the first element of the fifo is retrieved. At + !! subsequent calls the elements are returned following the fifo principle. If + !! the last element in the fifo had been returned, the first will be returned + !! again. + !! + !! \param self Instance. + !! \param item Item storing the result. + subroutine fifo_real2_get(self, item) + class(fifo_real2), intent(inout) :: self + real(dp), intent(out) :: item(:,:) + + class(*), pointer :: wrapper + + call self%getptr(wrapper) + select type (wrapper) + type is (mydata) + item(:,:) = wrapper%data + end select + + end subroutine fifo_real2_get + + + !> Moves an allocatable item into the collection. + !! + !! \details Similar to push but for allocatable elements. The allocation + !! status of the item is moved to the collection, so that the original item is + !! automatically deallocated. No temporary copy of the item is created. + !! + !! \param self Instance. + !! \param item Item to store. Deallocated on return. + subroutine fifo_real2_push_alloc(self, item) + class(fifo_real2), intent(inout) :: self + real(dp), allocatable, intent(inout) :: item(:,:) + + class(*), pointer :: wrapper + + allocate(mydata :: wrapper) + select type (wrapper) + type is (mydata) + call move_alloc(item, wrapper%data) + end select + call self%pushptr(wrapper) + + end subroutine fifo_real2_push_alloc + + + !> Retrieves the next item (fifo) and removes it from the collection. + !! + !! \details Similar to pop but for allocatable elements. The allocation status + !! is moved from the collection to the item, so that the item will be + !! automatically allocated. No temporary copy of the item is created. + !! + !! \param self Instance. + !! \param item Item storing the result. + subroutine fifo_real2_pop_alloc(self, item) + class(fifo_real2), intent(inout) :: self + real(dp), allocatable, intent(out) :: item(:,:) + + class(*), pointer :: wrapper + + call self%popptr(wrapper) + select type (wrapper) + type is (mydata) + call move_alloc(wrapper%data, item) + end select + deallocate(wrapper) + + end subroutine fifo_real2_pop_alloc + + + !> Retrieves all items from the collection as an array and deletes them. + !! + !! \details The array must have one more dimensions as the items in the + !! collection. The last dimension will be allocated to the size of the + !! collection. + !! + !! \param self Instance. + !! \param items Array containing the items. + !! + !! \warning It is the responsibility of the caller to invoke this method + !! only on collections containing elements with the same shape. No checking + !! of shape conformance is done. + subroutine fifo_real2_popall(self, items) + class(fifo_real2), intent(inout) :: self + real(dp), allocatable, intent(out) :: items(:,:,:) + + class(*), pointer :: wrapper + integer :: itemshape(2) + integer :: ii + + call self%getptr(wrapper) + select type (wrapper) + type is (mydata) + itemshape = shape(wrapper%data) + end select + allocate(items(itemshape(1), itemshape(2), size(self))) + do ii = 1, size(self) + call self%pop(items(:,:,ii)) + end do + + end subroutine fifo_real2_popall + + + !> Retrieves all items from the collection as an allocatable array by + !! concatenating them and deletes them. + !! + !! \details The routine allocates an array with the given shape times + !! the size of the collection. + !! + !! \param self Instance. + !! \param items Array containing the items. + !! + !! \warning It is the responsibility of the caller to invoke this method + !! only on collections containing elements with the same shape apart of their + !! last dimension. No checking of shape conformance is done. + subroutine fifo_real2_popall_concat(self, items) + class(fifo_real2), intent(inout) :: self + real(dp), allocatable, intent(out) :: items(:,:) + + class(*), pointer :: wrapper + integer :: itemshape(2) + integer :: ii, ind, total, nn + + total = 0 + do ii = 1, size(self) + call self%getptr(wrapper) + select type (wrapper) + type is (mydata) + total = total + size(wrapper%data, dim=2) + if (ii == 1) then + itemshape(:) = shape(wrapper%data) + end if + end select + end do + allocate(items(itemshape(1), total)) + ind = 1 + do ii = 1, size(self) + call self%popptr(wrapper) + select type (wrapper) + type is (mydata) + nn = size(wrapper%data, dim=2) + items(:,ind:ind+nn-1) = wrapper%data + ind = ind + nn + end select + deallocate(wrapper) + end do + + end subroutine fifo_real2_popall_concat + + + !> Overides the datatofile method of the base class. + !! \param self Instance. + !! \param fileid Id of the file in which data should be written. + !! \param filepos Position in the file, to which data should be written. + !! \param data Data node to save to file. + subroutine fifo_real2_datatofile(self, fileid, filepos, data) + class(fifo_real2), intent(inout) :: self + integer, intent(in) :: fileid, filepos + class(*), pointer, intent(inout) :: data + + select type (data) + type is (mydata) + write(fileid, pos=filepos) shape(data%data) + write(fileid) data%data + end select + deallocate(data) + + end subroutine fifo_real2_datatofile + + + !> Overides the datafromfile method of the base class. + !! \param self Instance. + !! \param fileid Id of the file from which data should be read. + !! \param filepos Position in the file, from which data should be read. + !! \param data Data node to create from file. + subroutine fifo_real2_datafromfile(self, fileid, filepos, data) + class(fifo_real2), intent(inout) :: self + integer, intent(in) :: fileid, filepos + class(*), pointer, intent(out) :: data + + integer :: itemshape(2) + + allocate(mydata :: data) + select type (data) + type is (mydata) + read(fileid, pos=filepos) itemshape + allocate(data%data(itemshape(1), itemshape(2))) + read(fileid) data%data + end select + + end subroutine fifo_real2_datafromfile + + +end module fifo_real2_module diff --git a/common/lib/fifobase.f90 b/common/lib/fifobase.f90 new file mode 100644 index 00000000..4d588ba8 --- /dev/null +++ b/common/lib/fifobase.f90 @@ -0,0 +1,332 @@ +!> Contains the base fifo class. +module fifobase_module + implicit none + private + + public :: fifobase, size + + + !> Returns the size of the collection. + interface size + module procedure fifo_size + end interface size + + !> Base fifo implementation managing pointers. + type :: fifobase + private + integer :: nitem = 0 + integer :: inmemory = 0 + integer :: memorylimit = -1 + class(fifonode), pointer :: head => null() + class(fifonode), pointer :: tail => null() + class(fifonode), pointer :: current => null() + class(fifonode), pointer :: previous => null() + integer :: fileid + character(:), allocatable :: filename + contains + procedure :: initswap => fifo_initswap + procedure :: pushptr => fifo_pushptr + procedure :: popptr => fifo_popptr + procedure :: getptr => fifo_getptr + procedure :: getsize => fifo_size + procedure :: reset => fifo_reset + final :: fifo_destruct + procedure, private :: writenodedata => fifo_writenodedata + procedure, private :: readnodedata => fifo_readnodedata + procedure, private :: freeresources => fifo_freeresources + ! Workaround: should be private, but NAG fails to override private routines. + procedure :: datafromfile => fifo_datafromfile + procedure :: datatofile => fifo_datatofile + end type fifobase + + !> Represents one node in the fifo. + type fifonode + class(*), pointer :: data => null() + class(fifonode), pointer :: next => null() + integer :: filepos = -1 + end type fifonode + + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!! FIFO Routines +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the number of items in the collection. + !! \param obj Collection instance. + !! \return Number of items. + pure function fifo_size(obj) result(res) + class(fifobase), intent(in) :: obj + integer :: res + + res = obj%nitem + + end function fifo_size + + + !> Initializes a swap for the collection. + !! + !! \details If swap is initialized for the collection, all entries above + !! a given number are written to a file, instead of keeping them in memory. + !! When the entries are read from the collection, a read buffer must be + !! allocated, so the total number of elements kept in the memory will be + !! increased by one. + !! + !! \param memorylimit Maximal number of entries to keep in memory (-1: all + !! or 0: none or any positive number). + !! \param filename Name of the swap file. + !! \param fileid File id to use for handling the swap file. + subroutine fifo_initswap(self, memorylimit, filename, fileid) + class(fifobase), intent(inout) :: self + integer, intent(in) :: memorylimit + character(*), intent(in) :: filename + integer, intent(in) :: fileid + + if (self%memorylimit /= -1) then + stop "FIFO swap can be initialized only once" + end if + self%memorylimit = memorylimit + self%filename = filename + self%fileid = fileid + + end subroutine fifo_initswap + + + !> Pushes a pointer to the collection. + !! \param self Instance. + !! \param data Pointer to the data object. + subroutine fifo_pushptr(self, data) + class(fifobase), intent(inout) :: self + class(*), pointer, intent(in) :: data + + class(fifonode), pointer :: node + + allocate(node) + node%data => data + if (.not. associated(self%head)) then + self%head => node + self%current => node + else + self%tail%next => node + end if + self%tail => node + self%nitem = self%nitem + 1 + self%inmemory = self%inmemory + 1 + if (self%memorylimit /= -1 .and. self%inmemory > self%memorylimit) then + call self%writenodedata(node) + end if + + end subroutine fifo_pushptr + + + !> Pops a pointer from the collection. + !! \param self Instance. + !! \param data Pointer to the data object on return. + subroutine fifo_popptr(self, data) + class(fifobase), intent(inout) :: self + class(*), pointer, intent(out) :: data + + class(fifonode), pointer :: node + + if (.not. associated(self%head)) then + data => null() + return + end if + + node => self%head + self%head => node%next + if (associated(node, self%current)) then + self%current => node%next + end if + if (associated(node, self%previous)) then + nullify(self%previous) + end if + if (.not. associated(node%data)) then + call self%readnodedata(node) + end if + data => node%data + deallocate(node) + self%nitem = self%nitem - 1 + self%inmemory = self%inmemory - 1 + + end subroutine fifo_popptr + + + !> Gets a copy of a pointer from the collection. + !! \param self Instance. + !! \param data Pointer to the data object on return. + subroutine fifo_getptr(self, data) + class(fifobase), intent(inout) :: self + class(*), pointer, intent(out) :: data + + if (.not. associated(self%current)) then + data => null() + return + end if + + ! If previous get read something from file, clear the buffer. + if (associated(self%previous)) then + if (self%previous%filepos /= -1 .and. associated(self%previous%data)) then + deallocate(self%previous%data) + self%inmemory = self%inmemory - 1 + end if + end if + + if (.not. associated(self%current%data)) then + call self%readnodedata(self%current) + end if + data => self%current%data + + self%previous => self%current + if (associated(self%current%next)) then + self%current => self%current%next + else + self%current => self%head + end if + + end subroutine fifo_getptr + + + !> Restets the collection to it initial (empty) state. + !! \param self Instance. + subroutine fifo_reset(self) + class(fifobase), intent(inout) :: self + + call self%freeresources() + self%nitem = 0 + self%inmemory = 0 + self%memorylimit = -1 + nullify(self%head, self%tail, self%current, self%previous) + + end subroutine fifo_reset + + + !> Destructor for the class. + !! \param self Instance. + subroutine fifo_destruct(self) + type(fifobase), intent(inout) :: self + + call self%freeresources() + + end subroutine fifo_destruct + + + !> Destroys the nodes in the collections and closes open files. + !! \param self Instance variable. + subroutine fifo_freeresources(self) + class(fifobase), intent(inout) :: self + + class(fifonode), pointer :: node + logical :: opened + + node => self%head + do while (associated(node)) + deallocate(node%data) + self%head => node%next + deallocate(node) + node => self%head + end do + + if (self%memorylimit /= -1) then + inquire(self%fileid, opened=opened) + if (opened) then + close(self%fileid, status="delete") + end if + end if + + end subroutine fifo_freeresources + + + !> Writes the data of a node to the disc and deallocates the data object. + !! \param self Instance. + !! \param node Node with the data that should be stored in a file. + !! \note This routine invokes the data types write method instead of + !! writing the data directly. + subroutine fifo_writenodedata(self, node) + class(fifobase), intent(inout) :: self + class(fifonode), pointer, intent(inout) :: node + + character(10) :: action + + inquire(self%fileid, action=action) + if (action == "UNDEFINED") then + ! No saved entries, create new swap file + open(self%fileid, file=self%filename, access="stream", status="replace",& + & action="write", form="unformatted", position="rewind") + elseif (action == "READ") then + ! Last commmand was pop/get, close file and and reopen in append mode. + close(self%fileid) + open(self%fileid, file=self%filename, access="stream", status="old",& + & action="write", form="unformatted", position="append") + end if + + inquire(self%fileid, pos=node%filepos) + call self%datatofile(self%fileid, node%filepos, node%data) + self%inmemory = self%inmemory - 1 + + end subroutine fifo_writenodedata + + + !> Reads the data of a node from file and allocates the data object. + !! \param self Instance. + !! \param node Node with the data that should be read from a file. + !! \note This routine invokes the data types read method instead of + !! reading the data directly. + subroutine fifo_readnodedata(self, node) + class(fifobase), intent(inout) :: self + class(fifonode), pointer, intent(inout) :: node + + character(10) :: action + + inquire(self%fileid, action=action) + if (action == "WRITE") then + close(self%fileid) + open(self%fileid, file=self%filename, access="stream", status="old",& + & action="read", form="unformatted") + end if + + call self%datafromfile(self%fileid, node%filepos, node%data) + self%inmemory = self%inmemory + 1 + + end subroutine fifo_readnodedata + + + !> Writes the content of a data node to a file. + !! + !! \details Extensions of the data object should rewrite it according to + !! the data they contain. + !! + !! \param self Instance. + !! \param data Pointer to a data node, will be deallocated at exit. + !! \param fileid File in which the data should be written. + !! \param filepos Position in the file, where the data must be written. + subroutine fifo_datatofile(self, fileid, filepos, data) + class(fifobase), intent(inout) :: self + integer, intent(in) :: fileid, filepos + class(*), intent(inout), pointer :: data + + stop "Collection does not support swapping to file." + + end subroutine fifo_datatofile + + + !> Reads the content of a data node from a file. + !! + !! \details Extensions of the data object should rewrite it according to + !! the data they contain. + !! + !! \param self Instance. + !! \param fileid File from which the data should be read. + !! \param filepos Position in the file, where the data should be read from. + subroutine fifo_datafromfile(self, fileid, filepos, data) + class(fifobase), intent(inout) :: self + integer, intent(in) :: fileid, filepos + class(*), intent(out), pointer :: data + + stop "Collection does not support swapping to file." + + end subroutine fifo_datafromfile + + +end module fifobase_module diff --git a/common/lib/taggedout.f90 b/common/lib/taggedout.f90 new file mode 100644 index 00000000..d7e478b5 --- /dev/null +++ b/common/lib/taggedout.f90 @@ -0,0 +1,548 @@ +!> Contains routines to write out various data structures in a comprehensive +!! tagged format. +module taggedout + use accuracy, only : dp + implicit none + private + + public :: taggedwriter, init, writetag, taglen + + integer, parameter :: taglen = 40 + integer, parameter :: formlen = 20 + + type :: taggedwriter + character(formlen) :: form_real + character(formlen) :: form_cmplx + character(formlen) :: form_int + character(formlen) :: form_logical + end type taggedwriter + + interface init + module procedure taggedwriter_init + end interface + + !> Writes objects in a standardized tagged form to a given file. + interface writetag + module procedure taggedwriter_real0 + module procedure taggedwriter_real1 + module procedure taggedwriter_real2 + module procedure taggedwriter_real3 + module procedure taggedwriter_real4 + module procedure taggedwriter_cplx0 + module procedure taggedwriter_cplx1 + module procedure taggedwriter_cplx2 + module procedure taggedwriter_cplx3 + module procedure taggedwriter_cplx4 + module procedure taggedwriter_int0 + module procedure taggedwriter_int1 + module procedure taggedwriter_int2 + module procedure taggedwriter_int3 + module procedure taggedwriter_int4 + module procedure taggedwriter_logical0 + module procedure taggedwriter_logical1 + module procedure taggedwriter_logical2 + module procedure taggedwriter_logical3 + module procedure taggedwriter_logical4 + end interface + + +contains + + !> Initializes the tagged writer. + subroutine taggedwriter_init(self) + type(taggedwriter), intent(out) :: self + + integer :: ndec, nexp, nchar, nfield + + !! "-3.1234567E-123 ": nDec = 7, nexp = 3, nchar = 16 + nexp = ceiling(log(maxexponent(1.0_dp)/log(10.0))/log(10.0)) + ndec = precision(1.0_dp) + nchar = ndec + nexp + 6 + nfield = 80 / nchar + if (nfield == 0) then + nfield = 1 + end if + +99000 format('(', I2.2, 'ES', I2.2, '.', I2.2, 'E', I3.3, ')') + write(self%form_real, 99000) nfield, nchar, ndec, nexp + +99010 format('(', I2.2, '(2ES', I2.2, '.', I2.2, 'E', I3.3, '))') + write(self%form_cmplx, 99010) nfield/2, nchar, ndec, nexp + + !! "-12345 " + nchar = digits(1) + 2 + nfield = 80 / nchar + if (nfield == 0) then + nfield = 1 + end if + +99020 format('(', I2.2, 'I', I2.2, ')') + write (self%form_int, 99020) nfield, nchar + +99030 format('(40L2)') + write(self%form_logical, 99030) + + end subroutine taggedwriter_init + + + + subroutine taggedwriter_real0(self, file, tag, val, optform) + type(taggedwriter), intent(in) :: self + integer, intent(in) :: file + character(*), intent(in) :: tag + real(dp), intent(in) :: val + character(formlen), optional, intent(in) :: optform + + character(formlen) :: form + + if (present(optform)) then + form = optform + else + form = self%form_real + end if + +99040 format('@', A, ':real:0:') + write(file, 99040) trim(tag) + write(file, form) val + + end subroutine taggedwriter_real0 + + + + subroutine taggedwriter_real1(self, file, tag, val, optform) + type(taggedwriter), intent(in) :: self + integer, intent(in) :: file + character(len=*), intent(in) :: tag + real(dp), intent(in) :: val(:) + character(formlen), optional, intent(in) :: optform + + character(formlen) :: form + + if (present(optform)) then + form = optform + else + form = self%form_real + end if + +99050 format('@', A, ':real:1:', I0) + write(file, 99050) trim(tag), shape(val) + write(file, form) val + + end subroutine taggedwriter_real1 + + + + subroutine taggedwriter_real2(self, file, tag, val, optform) + type(taggedwriter), intent(in) :: self + integer, intent(in) :: file + character(*), intent(in) :: tag + real(dp), intent(in) :: val(:,:) + character(formlen), optional, intent(in) :: optform + + character(formlen) :: form + + if (present(optform)) then + form = optform + else + form = self%form_real + end if + +99060 format('@', A, ':real:2:', I0, ',', I0) + write(file, 99060) trim(tag), shape(val) + write(file, form) val + + end subroutine taggedwriter_real2 + + + + subroutine taggedwriter_real3(self, file, tag, val, optform) + type(taggedwriter), intent(in) :: self + integer, intent(in) :: file + character(*), intent(in) :: tag + real(dp), intent(in) :: val(:,:,:) + character(formlen), optional, intent(in) :: optform + + character(formlen) :: form + + if (present(optform)) then + form = optform + else + form = self%form_real + end if + +99070 format('@', A, ':real:3:', I0, ',', I0, ',', I0) + write(file, 99070) trim(tag), shape(val) + write(file, form) val + + end subroutine taggedwriter_real3 + + + + subroutine taggedwriter_real4(self, file, tag, val, optform) + type(taggedwriter), intent(in) :: self + integer, intent(in) :: file + character(*), intent(in) :: tag + real(dp), intent(in) :: val(:,:,:,:) + character(formlen), optional, intent(in) :: optform + + character(formlen) :: form + + if (present(optform)) then + form = optform + else + form = self%form_real + end if + +99080 format('@', A, ':real:4:', I0, ',', I0, ',', I0, ',', I0) + write(file, 99080) trim(tag), shape(val) + write(file, form) val + + end subroutine taggedwriter_real4 + + + + subroutine taggedwriter_cplx0(self, file, tag, val, optform) + type(taggedwriter), intent(in) :: self + integer, intent(in) :: file + character(*), intent(in) :: tag + complex(dp), intent(in) :: val + character(formlen), optional, intent(in) :: optform + + character(formlen) :: form + + if (present(optform)) then + form = optform + else + form = self%form_cmplx + end if + +99090 format('@', A, ':complex:0:') + write(file, 99090) trim(tag) + write(file, form) val + + end subroutine taggedwriter_cplx0 + + + + subroutine taggedwriter_cplx1(self, file, tag, val, optform) + type(taggedwriter), intent(in) :: self + integer, intent(in) :: file + character(*), intent(in) :: tag + complex(dp), intent(in) :: val(:) + character(formlen), optional, intent(in) :: optform + + character(formlen) :: form + + if (present(optform)) then + form = optform + else + form = self%form_cmplx + end if + +99100 format('@', A, ':complex:1:', I0) + write(file, 99100) trim(tag), shape(val) + write(file, form) val + + end subroutine taggedwriter_cplx1 + + + + subroutine taggedwriter_cplx2(self, file, tag, val, optform) + type(taggedwriter), intent(in) :: self + integer, intent(in) :: file + character(*), intent(in) :: tag + complex(dp), intent(in) :: val(:,:) + character(formlen), optional, intent(in) :: optform + + character(formlen) :: form + + if (present(optform)) then + form = optform + else + form = self%form_cmplx + end if + +99110 format('@', A, ':complex:2:', I0, ',', I0) + write(file, 99110) trim(tag), shape(val) + write(file, form) val + + end subroutine taggedwriter_cplx2 + + + + subroutine taggedwriter_cplx3(self, file, tag, val, optform) + type(taggedwriter), intent(in) :: self + integer, intent(in) :: file + character(*), intent(in) :: tag + complex(dp), intent(in) :: val(:,:,:) + character(formlen), optional, intent(in) :: optform + + character(formlen) :: form + + if (present(optform)) then + form = optform + else + form = self%form_cmplx + end if + +99120 format('@', A, ':complex:3:', I0, ',', I0, ',', I0) + write(file, 99120) trim(tag), shape(val) + write(file, form) val + + end subroutine taggedwriter_cplx3 + + + + subroutine taggedwriter_cplx4(self, file, tag, val, optform) + type(taggedwriter), intent(in) :: self + integer, intent(in) :: file + character(*), intent(in) :: tag + complex(dp), intent(in) :: val(:,:,:,:) + character(formlen), optional, intent(in) :: optform + + character(formlen) :: form + + if (present(optform)) then + form = optform + else + form = self%form_cmplx + end if + +99130 format('@', A, ':complex:4:', I0, ',', I0, ',', I0, ',', I0) + write(file, 99130) trim(tag), shape(val) + write(file, form) val + + end subroutine taggedwriter_cplx4 + + + + subroutine taggedwriter_int0(self, file, tag, val, optform) + type(taggedwriter), intent(in) :: self + integer, intent(in) :: file + character(*), intent(in) :: tag + integer, intent(in) :: val + character(formlen), optional, intent(in) :: optform + + character(formlen) :: form + + if (present(optform)) then + form = optform + else + form = self%form_int + end if + +99140 format('@', A, ':integer:0:') + write(file, 99140) trim(tag) + write(file, form) val + + end subroutine taggedwriter_int0 + + + + subroutine taggedwriter_int1(self, file, tag, val, optform) + type(taggedwriter), intent(in) :: self + integer, intent(in) :: file + character(*), intent(in) :: tag + integer, intent(in) :: val(:) + character(formlen), optional, intent(in) :: optform + + character(formlen) :: form + + if (present(optform)) then + form = optform + else + form = self%form_int + end if + +99150 format('@', A, ':integer:1:', I0) + write(file, 99150) trim(tag), shape(val) + write(file, form) val + + end subroutine taggedwriter_int1 + + + + subroutine taggedwriter_int2(self, file, tag, val, optform) + type(taggedwriter), intent(in) :: self + integer, intent(in) :: file + character(*), intent(in) :: tag + integer, intent(in) :: val(:,:) + character(formlen), optional, intent(in) :: optform + + character(formlen) :: form + + if (present(optform)) then + form = optform + else + form = self%form_int + end if + +99160 format('@', A, ':integer:2:', I0, ',', I0) + write(file, 99160) trim(tag), shape(val) + write(file, form) val + + end subroutine taggedwriter_int2 + + + + subroutine taggedwriter_int3(self, file, tag, val, optform) + type(taggedwriter), intent(in) :: self + integer, intent(in) :: file + character(*), intent(in) :: tag + integer, intent(in) :: val(:,:,:) + character(formlen), optional, intent(in) :: optform + + character(formlen) :: form + + if (present(optform)) then + form = optform + else + form = self%form_int + end if + +99170 format('@', A, ':integer:3:', I0, ',', I0, ',', I0) + write(file, 99170) trim(tag), shape(val) + write(file, form) val + + end subroutine taggedwriter_int3 + + + + subroutine taggedwriter_int4(self, file, tag, val, optform) + type(taggedwriter), intent(in) :: self + integer, intent(in) :: file + character(*), intent(in) :: tag + integer, intent(in) :: val(:,:,:,:) + character(formlen), optional, intent(in) :: optform + + character(formlen) :: form + + if (present(optform)) then + form = optform + else + form = self%form_int + end if + +99180 format('@', A, ':integer:4:', I0, ',', I0, ',', I0, ',', I0) + write(file, 99180) trim(tag), shape(val) + write(file, form) val + + end subroutine taggedwriter_int4 + + + + subroutine taggedwriter_logical0(self, file, tag, val, optform) + type(taggedwriter), intent(in) :: self + integer, intent(in) :: file + character(*), intent(in) :: tag + logical, intent(in) :: val + character(formlen), optional, intent(in) :: optform + + character(formlen) :: form + + if (present(optform)) then + form = optform + else + form = self%form_logical + end if + +99190 format('@', A, ':logical:0:') + write(file, 99190) trim(tag) + write(file, form) val + + end subroutine taggedwriter_logical0 + + + + subroutine taggedwriter_logical1(self, file, tag, val, optform) + type(taggedwriter), intent(in) :: self + integer, intent(in) :: file + character(*), intent(in) :: tag + logical, intent(in) :: val(:) + character(formlen), optional, intent(in) :: optform + + character(formlen) :: form + + if (present(optform)) then + form = optform + else + form = self%form_logical + end if + +99200 format('@', A, ':logical:1:', I0) + write(file, 99200) trim(tag), shape(val) + write(file, form) val + + end subroutine taggedwriter_logical1 + + + + subroutine taggedwriter_logical2(self, file, tag, val, optform) + type(taggedwriter), intent(in) :: self + integer, intent(in) :: file + character(*), intent(in) :: tag + logical, intent(in) :: val(:,:) + character(formlen), optional, intent(in) :: optform + + character(formlen) :: form + + if (present(optform)) then + form = optform + else + form = self%form_logical + end if + +99210 format('@', A, ':logical:2:', I0, ',', I0) + write(file, 99210) trim(tag), shape(val) + write(file, form) val + + end subroutine taggedwriter_logical2 + + + + subroutine taggedwriter_logical3(self, file, tag, val, optform) + type(taggedwriter), intent(in) :: self + integer, intent(in) :: file + character(*), intent(in) :: tag + logical, intent(in) :: val(:,:,:) + character(formlen), optional, intent(in) :: optform + + character(formlen) :: form + + if (present(optform)) then + form = optform + else + form = self%form_logical + end if + +99220 format('@', A, ':logical:3:', I0, ',', I0, ',', I0) + write(file, 99220) trim(tag), shape(val) + write(file, form) val + + end subroutine taggedwriter_logical3 + + + + subroutine taggedwriter_logical4(self, file, tag, val, optform) + type(taggedwriter), intent(in) :: self + integer, intent(in) :: file + character(*), intent(in) :: tag + logical, intent(in) :: val(:,:,:,:) + character(formlen), optional, intent(in) :: optform + + character(formlen) :: form + + if (present(optform)) then + form = optform + else + form = self%form_logical + end if + +99230 format('@', A, ':logical:4:', I0, ',', I0, ',', I0, ',', I0) + write(file, 99230) trim(tag), shape(val) + write(file, form) val + + end subroutine taggedwriter_logical4 + + +end module taggedout diff --git a/doc/devel/code_structure.txt b/doc/devel/code_structure.txt new file mode 100644 index 00000000..e65dea68 --- /dev/null +++ b/doc/devel/code_structure.txt @@ -0,0 +1,52 @@ +OVERVIEW +-------- + +main.f90: main program + +globals.f90: Variables of the main program, except the mixer all + other subroutines/functions use intent(in)/intent(out) to protect + these variables, so in some sence this is not global + The variables are also allocated here. + IMPORTANT: This also gives a short comment what the variable is ! + +broyden.f90: Broyden mixer, this is the old DFTB stuff with little + cleanup + +constants.f90: some constants + +core_overlap.f90: routines to calculate the core hamiltonian + (one-electron) and overlap matrix elements (supervectors) + +coulomb_hfex.f90: Coulomb and HF exchange supermatrices + +coulomb_potential.f90: Coulomb potential (for ZORA and output) from + analytical expressions. + +density.f90: routines for electron density, wavefunctions, primitives + +densitymatrix.f90: get density matrix + +dft.f90: DFT functionals and various helper routines (density on grid ...) + +diagonalizations.f90: this is EWEVGE with a wrapper + +hamiltonian.f90: routines to build the hamiltonian from its parts + +input.f90: input routines + +integration.f90: Becke mesh definitions and helper routines + +numerical_differentiation.f90: numerical differentiation with 6-points + needed for naive ZORA implementation, e.g. dV/dr with V the potential + +output.f90: output routines + +precision.f90: DFTB precision routine + +total_energy.f90: routines to calculate total energy + +utilities.f90: misc stuff (factorial etc.) + +zora_routines.f90: ZORA routines, contains even the routines for the + naive implementation, see NAIVE_ZORA for their use + diff --git a/doc/devel/general_notes.txt b/doc/devel/general_notes.txt new file mode 100644 index 00000000..05db4166 --- /dev/null +++ b/doc/devel/general_notes.txt @@ -0,0 +1,66 @@ +The Hartree-Fock core of the code is a near one-to-one implementation of +the Roothaan formulas, see especially rmp_32_186_1960.pdf in the +references directory (Here, only the special case of 1S atoms is +implemented). + +Due to this, the matrix elements of the Coulomb potential are calculated +directly without recourse to the potential, except in the +case of a ZORA calculation. For a ZORA calculation the Coulomb +matrixelements are also calculated directly, but to obtain the ZORA +kinetic energy operator the Coulomb potential is calcuated explicitely +using analytical formulas for the spherical symmetric case. + +For the exchange-correlation matrix elements and energies a radial +integration mesh as described by Becke is used. The density and its +derivatives are calculated from analytical expressions for every +mesh-point in every iteration. The number of radial points is adjusted +depending on the nuclear charge, e.g. +if (nuc>10) num_mesh_points=750 +if (nuc>18) num_mesh_points=1000 +if (nuc>36) num_mesh_points=1250 +if (nuc>54) num_mesh_points=1500 + +The accuracy of the integration grid (1500 points is crazy!) is tested at +the start of the calculation by comparing the overlap of the normalized +primitive Slater functions to one. + +Additionally, at the beginning of every calculation the eigenvalues of +the overlap matrix are calculated. If the eigenavlues are smaller than +1e-10 linear dependency of the basis set is assumed and the calculation +is stopped. One may try to converge a calculation with such a linear +dependent basis set, but usually variational collaps occurs during SCF. +The new code is not quite as stable as twocnt with respect to this it +seems. + +The Perdew-Wang LDA (PW-LDA), Perdew-Burke-Ernzerhof (PBE) GGA and the +X-Alpha functional are available. The LDA/GGA routines are basically the +reference implementations available on the net with some Voodoo to get +the prefactors (4*pi) right, based on Uwe Gerstmanns implementation in +the Desclaux code. The X-Alpha routine uses a value of 0.7 for +alpha with a known issue: Although I am confident I got the prefactor +right I cannot reproduce literature results. Not sure why. + +For the ZORA stuff see vlenthe.pdf in references. Here, I basically use +the implementation for ADF Band (Chapter 6.2) which explicitely assumes a +sphericallysymmetric potential with one more step (which has to be +checked): Impementing 6.13-6.15 directly leads to an matrix element +containg the second derivative of the basis function. IMHO one can +integrate this again by parts as in usual kinetic energy expressions and +get rid of the second derivative. The routines for both cases are still +available in the ZORA module and an old version using the second +derivative has also been checked in (watch out for slightly different +input !, directory NAIVE_ZORA). + +Please note: Due to the point nucleus used here, the logarithmic +derivative at r=0 is divergent, e.g. cusp values should be infinity and +our basis sets are no longer good there ! With a finite nucleus the +expansion of the wavefunction at r=0 would be of Gaussian and not of +Slater type and one could not do the second integration by parts for +ZORA as currently implemented. + +The confining potential matrix elements are also evaluated analytically. +The confinig potential does not enter in the ZORA kinetic energy +operator, since the kinetic energy would then vanish for r->infty which is +clearly wrong. Having the confining potential only in the SCF potential but +not in the ZORA kinetic energy seems to work reasonanbly judging from the +expectation values. diff --git a/doc/input.txt b/doc/input.txt new file mode 100644 index 00000000..5cce911c --- /dev/null +++ b/doc/input.txt @@ -0,0 +1,73 @@ +DOCUMENTATION FOR INPUT FILE +---------------------------- +See also the example inputs in the testing directory ! + +Line 1: + nuc_charge max_ang max_scf ZORA + integer :: nuc_charge, nuclear charge of the nucleus + integer :: max_ang, maximum angular momentum of atom, max_ang < 5 + integer :: max_scf, maximum number of SCF iterations + logical :: ZORA, switch on (scaled) ZORA for DFT only + +Line 2: + xc_functional + integer :: xc_functional, 0=HF, 1=X-Alpha, 2=PW-LDA, 3=PBE + + NOTE: HF only correct for 1S states, X-Aalpha is untested alpha=0.7 + +Line 3: + r_0 power + real(dp) :: r_0, compression radius in Bohr radii + integer :: power, power of confining potential + + NOTE: This are in fact max_l+1 lines, one for each angular momentum + SPECIAL VALUE: power=0 switches confinement off ! + +Line 4: + num_occ + integer :: num_occ, number of occupied shells + + NOTE: This are in fact max_l+1 lines, one for each angular momentum + +Line 5: + num_exp num_poly + integer :: num_exp, number of exponents + integer :: number of polynomial coefficients + + NOTE: This are in fact max_l+1 lines, one for each angular momentum + WARNING: To get the twocnt input you have to add 1 to num_poly, e.g. if + the twocnt input is 5 2 you have to use 5 3 here ! + +Line 6: + gen_alpha + logical :: gen_alpha, generate num_exp exponents automatically if + .true. according to usual DFTB convention + +Line 7: + if gen_alpha then + alpha_min alpha_max + real(dp) :: alpha_min, smallest exponent in generated set + real(dp) :: alpha_max, largest exponent in generated set + else + read in one exponent after another for each angular momentum + end if + + NOTE: This are at least max_l+1 lines, one for each angular momentum + +Line 8: + print_eigen + logical :: print_eigen, print egenvectors and moments if true + +Line 9: + broyden factor + logical :: broyden, if true use Broyden mixer, simple mix else + real(dp) :: factor, mixing factor for simple mix and first Broyden + step + +Line 10: + occ_up occ_down + real(dp) :: occ_up, number of electrons with up spin + real(dp) :: occ_down, number of electrons with down spin + + NOTE: These are (max_l+1)*num_occ(l) lines, for each angular momentum + num_occ lines are expected. diff --git a/examples/mio/skdef.hsd b/examples/mio/skdef.hsd new file mode 100644 index 00000000..2a9e2e5f --- /dev/null +++ b/examples/mio/skdef.hsd @@ -0,0 +1,456 @@ +# Data for auorg +SkdefVersion = 1 + +Globals { + XCFunctional = pbe + Superposition = density +} + + +AtomParameters { + + $OCCUPATIONS_Ne { + 1S = 1.0 1.0 + 2S = 1.0 1.0 + 2P = 3.0 3.0 + } + + $OCCUPATIONS_Ar { + $OCCUPATIONS_Ne + 3S = 1.0 1.0 + 3P = 3.0 3.0 + } + + $OCCUPATIONS_Kr { + $OCCUPATIONS_Ar + 3D = 5.0 5.0 + 4S = 1.0 1.0 + 4P = 3.0 3.0 + } + + $OCCUPATIONS_Xe { + $OCCUPATIONS_Kr + 4D = 5.0 5.0 + 5S = 1.0 1.0 + 5P = 3.0 3.0 + } + + $OCCUPATIONS_Hg { + $OCCUPATIONS_Xe + 4F = 7.0 7.0 + 5D = 5.0 5.0 + 6S = 1.0 1.0 + } + + $OCCUPATIONS_Rn { + $OCCUPATIONS_Hg + 6P = 3.0 3.0 + } + + H { + AtomConfig { + AtomicNumber = 1 + Mass = 1.008 + Occupations { + 1S = 1.0 0.0 + } + ValenceShells = 1s + Relativistics = None + } + DftbAtom { + ShellResolved = No + DensityCompression = PowerCompression { Power = 2; Radius = 2.5 } + WaveCompressions = SingleAtomCompressions { + S = PowerCompression { Power = 2; Radius = 3.0 } + } + } + } + + C { + AtomConfig { + AtomicNumber = 6 + Mass = 12.01 + Occupations { + 1S = 1.0 1.0 + 2S = 1.0 1.0 + 2P = 2.0 0.0 + } + ValenceShells = 2s 2p + Relativistics = None + } + DftbAtom { + ShellResolved = No + DensityCompression = PowerCompression { Power = 2; Radius = 7.0 } + WaveCompressions = SingleAtomCompressions { + S = PowerCompression { Power = 2; Radius = 2.7 } + P = PowerCompression { Power = 2; Radius = 2.7 } + } + } + } + + N { + AtomConfig { + AtomicNumber = 7 + Mass = 14.007 + Occupations { + 1S = 1.0 1.0 + 2S = 1.0 1.0 + 2P = 2.0 1.0 + } + ValenceShells = 2s 2p + Relativistics = None + } + DftbAtom { + ShellResolved = No + DensityCompression = PowerCompression{ Power = 2; Radius = 11.0 } + WaveCompressions = SingleAtomCompressions { + S = PowerCompression { Power = 2; Radius = 2.2 } + P = PowerCompression { Power = 2; Radius = 2.2 } + } + CustomizedOnsites { + 2s = -0.64 + } + } + } + + O { + AtomConfig { + AtomicNumber = 8 + Mass = 16.01 + Occupations { + 1S = 1.0 1.0 + 2S = 1.0 1.0 + 2P = 2.0 2.0 + } + ValenceShells = 2s 2p + Relativistics = None + } + DftbAtom { + ShellResolved = No + DensityCompression = PowerCompression{ Power = 2; Radius = 9.0 } + WaveCompressions = SingleAtomCompressions { + S = PowerCompression { Power = 2; Radius = 2.3 } + P = PowerCompression { Power = 2; Radius = 2.3 } + } + } + } + + S { + AtomConfig { + AtomicNumber = 16 + Mass = 32.065 + Occupations { + $OCCUPATIONS_Ne + 3S = 1.0 1.0 + 3P = 2.0 2.0 + 3D = 0.0 0.0 + } + ValenceShells = 3s 3p 3d + Relativistics = None + } + DftbAtom { + ShellResolved = No + DensityCompression = PowerCompression{ Power = 2; Radius = 9.0 } + WaveCompressions = SingleAtomCompressions { + S = PowerCompression { Power = 2; Radius = 3.8 } + P = PowerCompression { Power = 2; Radius = 3.8 } + D = PowerCompression { Power = 2; Radius = 4.4 } + } + } + } + + P { + AtomConfig { + AtomicNumber = 15 + Mass = 32.065 + Occupations { + $OCCUPATIONS_Ne + 3S = 1.0 1.0 + 3P = 2.0 1.0 + 3D = 0.0 0.0 + } + ValenceShells = 3s 3p 3d + Relativistics = None + } + DftbAtom { + ShellResolved = No + DensityCompression = PowerCompression{ Power = 2; Radius = 9.0 } + WaveCompressions = SingleAtomCompressions { + S = PowerCompression { Power = 2; Radius = 3.8 } + P = PowerCompression { Power = 2; Radius = 3.8 } + D = PowerCompression { Power = 2; Radius = 4.4 } + } + CustomizedOnsites { + 3D = 0.520437 + } + } + } + + Ti { + AtomConfig { + AtomicNumber = 22 + Mass = 47.867 + Occupations { + 1S = 1.0 1.0 + 2S = 1.0 1.0 + 3S = 1.0 1.0 + 4S = 1.0 1.0 + 2P = 3.0 3.0 + 3P = 3.0 3.0 + 4P = 0.0 0.0 + 3D = 1.0 1.0 + } + ValenceShells = 4s 4p 3d + Relativistics = None + } + DftbAtom { + ShellResolved = No + DensityCompression = PowerCompression{ Power = 2; Radius = 14.0 } + WaveCompressions = SingleAtomCompressions { + S = PowerCompression { Power = 2; Radius = 4.3 } + P = PowerCompression { Power = 2; Radius = 4.3 } + D = PowerCompression { Power = 2; Radius = 4.3 } + } + CustomizedHubbards { + 3D = 0.20006 + 4S = 0.20006 + 4P = 0.20006 + } + } + } + + + Au { + AtomConfig { + AtomicNumber = 79 + Mass = 196.967 + Occupations { + $OCCUPATIONS_Xe + 6S = 1.0 0.0 + 5D = 5.0 5.0 + 4F = 7.0 7.0 + } + ValenceShells = 6s 6p 5d + Relativistics = Zora + } + DftbAtom { + ShellResolved = Yes + DensityCompression = PowerCompression{ Power = 2; Radius = 9.41 } + WaveCompressions = SingleAtomCompressions { + S = PowerCompression { Power = 2; Radius = 6.50 } + P = PowerCompression { Power = 2; Radius = 4.51 } + D = PowerCompression { Power = 2; Radius = 6.50 } + F = PowerCompression { Power = 2; Radius = 6.50 } + } + } + } +} + + +OnecenterParameters { + + $StandardDeltaFilling { + DeltaFilling = 0.01 + } + + H { + $StandardDeltaFilling + Calculator = SlaterAtom { + Exponents { + S = 0.50 1.0 2.0 + } + MaxPowers { + S = 3 + } + } + } + + C { + $StandardDeltaFilling + Calculator = SlaterAtom { + Exponents { + S = 0.5 1.14 2.62 6.0 + P = 0.5 1.14 2.62 6.0 + } + MaxPowers { + S = 3 + P = 3 + } + } + } + + N { + $StandardDeltaFilling + Calculator = SlaterAtom { + Exponents { + S = 0.5 1.2 2.9 7.0 + P = 0.5 1.2 2.9 7.0 + } + MaxPowers { + S = 3 + P = 3 + } + } + } + + O { + $StandardDeltaFilling + Calculator = SlaterAtom { + Exponents { + S = 0.5 1.26 3.17 8.0 + P = 0.5 1.26 3.17 8.0 + } + MaxPowers { + S = 3 + P = 3 + } + } + } + + S { + $StandardDeltaFilling + Calculator = SlaterAtom { + Exponents { + S = 0.5 1.19 2.83 6.73 16.0 + P = 0.5 1.19 2.83 6.73 16.0 + D = 0.5 1.19 2.83 6.73 16.0 + } + MaxPowers { + S = 3 + P = 3 + D = 3 + } + } + } + + P { + $StandardDeltaFilling + Calculator = SlaterAtom { + Exponents { + S = 0.5 1.19 2.83 6.73 15.0 + P = 0.5 1.19 2.83 6.73 15.0 + D = 0.5 1.19 2.83 6.73 15.0 + } + MaxPowers { + S = 3 + P = 3 + D = 3 + } + } + } + + Ti { + $StandardDeltaFilling + Calculator = SlaterAtom { + Exponents { + S = 0.01 0.0685 0.4690 3.2120 22.0 + P = 0.01 0.0685 0.4690 3.2120 22.0 + D = 0.01 0.0685 0.4690 3.2120 22.0 + } + MaxPowers { + S = 5 + P = 5 + D = 5 + } + } + } + + Au { + $StandardDeltaFilling + Calculator = SlaterAtom { + Exponents { + S = 1.00 2.98 8.89 26.5 79.0 235.5 + P = 1.00 2.98 8.89 26.5 79.0 235.5 + D = 1.00 2.98 8.89 26.5 79.0 235.5 + F = 1.00 2.98 8.89 26.5 79.0 235.5 + } + MaxPowers { + S = 4 + P = 4 + D = 4 + F = 4 + } + } + } +} + + +TwoCenterParameters { + + $EqGrid = EquidistantGrid { + GridStart = 0.4 + GridSeparation = 0.02 + Tolerance = 5e-5 + MaxDistance = 40.0 + } + + $EqGridShort = EquidistantGrid { + GridStart = 0.4 + GridSeparation = 0.02 + Tolerance = 5e-5 + MaxDistance = 0.5 + } + + # Various specific cutoffs to match SK-file cutoffs in mio-1-1 + $EqGridCutoff10 = EquidistantGrid { + GridStart = 0.4 + GridSeparation = 0.02 + Tolerance = 5e-5 + MaxDistance = -10.001 + } + + $EqGridCutoff12 = EquidistantGrid { + GridStart = 0.4 + GridSeparation = 0.02 + Tolerance = 5e-5 + MaxDistance = -12.39 + } + + $SkTwocnt_300_150 = Sktwocnt { + IntegrationPoints = 300 150 + } + + $SkTwocnt_400_200 = Sktwocnt { + IntegrationPoints = 400 200 + } + + H-H { Grid = $EqGridCutoff10; Calculator = $SkTwocnt_300_150 } + H-C { Grid = $EqGridCutoff10; Calculator = $SkTwocnt_300_150 } + H-N { Grid = $EqGridCutoff10; Calculator = $SkTwocnt_300_150 } + H-O { Grid = $EqGridCutoff10; Calculator = $SkTwocnt_300_150 } + H-S { Grid = $EqGridCutoff10; Calculator = $SkTwocnt_300_150 } + H-P { Grid = $EqGridCutoff10; Calculator = $SkTwocnt_300_150 } + H-Ti { Grid = $EqGrid; Calculator = $SkTwocnt_400_200 } + H-Au { Grid = $EqGrid; Calculator = $SkTwocnt_400_200 } + C-C { Grid = $EqGridCutoff10; Calculator = $SkTwocnt_300_150 } + C-N { Grid = $EqGridCutoff10; Calculator = $SkTwocnt_300_150 } + C-O { Grid = $EqGridCutoff10; Calculator = $SkTwocnt_300_150 } + C-S { Grid = $EqGridCutoff10; Calculator = $SkTwocnt_300_150 } + C-P { Grid = $EqGridCutoff10; Calculator = $SkTwocnt_300_150 } + C-Ti { Grid = $EqGrid; Calculator = $SkTwocnt_400_200 } + C-Au { Grid = $EqGrid; Calculator = $SkTwocnt_400_200 } + N-N { Grid = $EqGridCutoff10; Calculator = $SkTwocnt_300_150 } + N-O { Grid = $EqGridCutoff10; Calculator = $SkTwocnt_300_150 } + N-S { Grid = $EqGridCutoff10; Calculator = $SkTwocnt_300_150 } + N-P { Grid = $EqGridCutoff10; Calculator = $SkTwocnt_300_150 } + N-Ti { Grid = $EqGrid; Calculator = $SkTwocnt_400_200 } + N-Au { Grid = $EqGrid; Calculator = $SkTwocnt_400_200 } + O-O { Grid = $EqGridCutoff10; Calculator = $SkTwocnt_300_150 } + O-S { Grid = $EqGridCutoff10; Calculator = $SkTwocnt_300_150 } + O-P { Grid = $EqGridCutoff10; Calculator = $SkTwocnt_300_150 } + O-Ti { Grid = $EqGrid; Calculator = $SkTwocnt_400_200 } + O-Au { Grid = $EqGrid; Calculator = $SkTwocnt_400_200 } + S-S { Grid = $EqGridCutoff10; Calculator = $SkTwocnt_300_150 } + S-P { Grid = $EqGridCutoff10; Calculator = $SkTwocnt_300_150 } + S-Ti { Grid = $EqGrid; Calculator = $SkTwocnt_400_200 } + S-Au { Grid = $EqGrid; Calculator = $SkTwocnt_400_200 } + P-P { Grid = $EqGridCutoff10; Calculator = $SkTwocnt_300_150 } + P-Ti { Grid = $EqGrid; Calculator = $SkTwocnt_400_200 } + P-Au { Grid = $EqGrid; Calculator = $SkTwocnt_400_200 } + Ti-Ti { Grid = $EqGridCutoff12; Calculator = $SkTwocnt_400_200 } + Ti-Au { Grid = $EqGrid; Calculator = $SkTwocnt_400_200 } + Au-Au { Grid = $EqGrid; Calculator = $SkTwocnt_400_200 } +} + + +# skgen -o slateratom -t sktwocnt sktable H,O H,O | tee output diff --git a/sktools/CMakeLists.txt b/sktools/CMakeLists.txt new file mode 100644 index 00000000..a63ab63e --- /dev/null +++ b/sktools/CMakeLists.txt @@ -0,0 +1,7 @@ +set(cmake-command " + execute_process( + COMMAND ${PYTHON_INTERPRETER} setup.py install --prefix=$ENV{DESTDIR}/${CMAKE_INSTALL_PREFIX} + WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}) +") + +install(CODE "${cmake-command}") diff --git a/sktools/MANIFEST.in b/sktools/MANIFEST.in new file mode 100644 index 00000000..e69de29b diff --git a/sktools/bin/collectspinw b/sktools/bin/collectspinw new file mode 100755 index 00000000..29602e45 --- /dev/null +++ b/sktools/bin/collectspinw @@ -0,0 +1,57 @@ +#!/usr/bin/env python3 +import argparse +from sktools.skdef import Skdef +import sktools.skgen as skgen +import sktools.common as sc + +HELP_TXT = """Collects spin coupling constants by iterating over the +elements defined in skdef.hsd. If the atomic calculation has been done already, +it will be reused, otherwised it is done on the fly. +""" + +SCRIPTNAME = sc.get_script_name() +SPINW_FILE_NAME = "spinw.txt" + + +def main(): + args = parseargs() + logger = sc.get_script_logger(args.loglevel, SCRIPTNAME) + logger.info("Collecting spinw constants") + skdef = Skdef.fromfile("skdef.hsd") + searchdirs = [ args.builddir, ] + elems = skdef.atomparameters.keys() + fp = open(SPINW_FILE_NAME, "w") + for elem in elems: + calculator = skgen.run_atom( + skdef, elem, args.builddir, searchdirs, args.onecnt_binary) + fp.write(sc.capitalize_elem_name(elem) + ":\n") + results = calculator.get_result() + spinw = results.get_spinws() + ndim = spinw.shape[0] + formstr = "{:13.5f}" * ndim + "\n" + for line in spinw: + fp.write(formstr.format(*line)) + fp.write("\n") + fp.close() + logger.info("File '{}' written.".format(SPINW_FILE_NAME)) + + +def parseargs(): + parser = argparse.ArgumentParser(description=HELP_TXT) + parser.add_argument( + "-b", "--build-dir", default="_build", dest="builddir", + help="build directory (default: _build)") + parser.add_argument( + "-o", "--onecenter-binary", dest="onecnt_binary", default=None, + help="binary to use for the one-center calculations (default: depends " + "on the calculator specified in the input)") + parser.add_argument( + "-l", "--log-level", dest="loglevel", default="info", + choices=[ "debug", "info", "warning", "error" ], + help="Logging level (default: info)") + return parser.parse_args() + + + +if __name__ == "__main__": + main() diff --git a/sktools/bin/collectwavecoeffs b/sktools/bin/collectwavecoeffs new file mode 100755 index 00000000..0d4857fb --- /dev/null +++ b/sktools/bin/collectwavecoeffs @@ -0,0 +1,71 @@ +#!/usr/bin/env python3 +import sys +import os.path +from sktools.common import * +from sktools.taggedfile import TaggedFile +from sktools.skdef import SKDefs +from sktools.oldskfile import OldSKFile +import argparse + +helptxt = """Collects coefficient information for waveplot. It +iterates over the elements defined in skdefs.py and collects the wave +function coefficients and other information necessary for +waveplot. The homonuclear SK-files for those elements must have been +created already. If it is missing, the given element will be ignored. +""" + + +def writecoeffs(fp, elem, atomconfig, homoskname, wavecompdir): + homosk = OldSKFile.fromfile(homoskname) + cutoff = homosk.nr * homosk.dr / 2.0 + fp.write("{} {{\n".format(elem)) + fp.write(" AtomicNumber = {:d}\n".format(atomconfig.znuc)) + for nn, ll in atomconfig.valenceorbs: + coeffsname = "coeffs_{:02d}{:1s}.tag".format(nn, ANGMOM_NAMES[ll]) + coeffs = TaggedFile.fromfile(os.path.join(wavecompdir, coeffsname), + transpose=True) + fp.write(" Orbital {\n") + fp.write(" AngularMomentum = {:d}\n".format(ll)) + fp.write(" Occupation = {:.1f}\n".format(coeffs["occupation"])) + fp.write(" Cutoff = {:5.2f}\n".format(cutoff)) + fp.write(" Exponents {\n") + writefloats(fp, coeffs["exponents"], indent=6, numperline=3, + formstr="{:21.12E}") + fp.write(" }\n") + fp.write(" Coefficients {\n") + writefloats(fp, coeffs["coefficients"], indent=3, numperline=3, + formstr="{:21.12E}") + fp.write(" }\n") + fp.write(" }\n") + fp.write("}\n") + + +def parseargs(): + parser = argparse.ArgumentParser(description=helptxt) + return parser.parse_args() + + +def main(): + args = parseargs() + skdefs = SKDefs.fromfile("skdefs.py") + atomconfigs = skdefs.atomconfigs + elems = atomconfigs.keys() + fp = open("wfc.hsd", "w") + indent = " " * 2 + for elem in elems: + homoskname = "{}-{}.skf".format(elem, elem) + wavecompdir = os.path.join(elem, "wavecomp") + filespresent = (os.path.exists(homoskname) + and os.path.exists(wavecompdir)) + if not filespresent: + print("*** Skipping: ", elem) + continue + + print("*** Processing: ", elem) + atomconfig = atomconfigs[elem] + writecoeffs(fp, elem, atomconfig, homoskname, wavecompdir) + fp.close() + + +if __name__ == "__main__": + main() diff --git a/sktools/bin/skdiff b/sktools/bin/skdiff new file mode 100755 index 00000000..3caad992 --- /dev/null +++ b/sktools/bin/skdiff @@ -0,0 +1,79 @@ +#!/usr/bin/env python3 +import argparse +import numpy as np +from sktools import PACKAGE_VERSION +from sktools.oldskfile import OldSKFile + +helptxt = """Reads two sk files and compares the numerical values stored in them.""" + +def parseargs(): + """Parse the program arguments. + """ + parser = argparse.ArgumentParser(description=helptxt) + parser.add_argument("--version", action="version", + version="sktools {}".format(PACKAGE_VERSION)) + parser.add_argument("skfile", nargs=2, help="SK files to compare") + parser.add_argument( + "-a", "--atomic", dest="homo", action="store_true", default=False, + help="Compare atomic values as stored in homonuclear sk-files") + parser.add_argument( + "-s", "--skip", dest="nskip", type=int, default=0, + help="Skip a given number of lines") + return parser.parse_args() + + +def compare_atomic_data(sk1, sk2): + """Compares the atomic data stored in two homonuclear SK-file. + """ + onsite_diffs = abs(sk1.onsites - sk2.onsites) + maxpos = np.argmax(onsite_diffs) + print("Onsite: {:12.3e} {:5d}".format(onsite_diffs[maxpos], maxpos)) + hubbu_diffs = abs(sk1.hubbardus - sk2.hubbardus) + maxpos = np.argmax(hubbu_diffs) + print("Hubbards: {:12.3e} {:5d}".format(hubbu_diffs[maxpos], maxpos)) + print("Hubbard (s): {:12.3e}".format(hubbu_diffs[-1])) + occ_diffs = abs(sk1.occupations - sk2.occupations) + maxpos = np.argmax(occ_diffs) + print("Occupations: {:12.3e} {:5d}".format(occ_diffs[maxpos], maxpos)) + + +def compare_integral_tables(sk1, sk2, nstart): + """Compares integral tables in two sk-files + """ + if abs(sk1.dr - sk2.dr) > 1e-8: + print("Incompatible grid separation ({:.3f} vs {:.3f}).") + return + nr = min(sk1.nr, sk2.nr) + if nstart > nr: + print("Tables too short.") + return + hamdiff = abs(abs(sk1.hamiltonian[nstart:nr,:]) + - abs(sk2.hamiltonian[nstart:nr,:])) + maxpos = np.argmax(hamdiff) + maxinds = np.unravel_index(maxpos, hamdiff.shape) + print("Hamiltonian: {:12.3e} ({:4d},{:3d})".format( + hamdiff[maxinds], maxinds[0] + nstart, maxinds[1])) + overdiff = abs(abs(sk1.overlap[nstart:nr,:]) + - abs(sk2.overlap[nstart:nr,:])) + maxpos = np.argmax(overdiff) + maxinds = np.unravel_index(maxpos, overdiff.shape) + print("Overlap: {:12.3e} ({:4d},{:3d})".format( + overdiff[maxinds], maxinds[0] + nstart + 1, maxinds[1] + 1)) + + +def main(): + args = parseargs() + sk1 = OldSKFile.fromfile(args.skfile[0], args.homo) + sk2 = OldSKFile.fromfile(args.skfile[1], args.homo) + if args.homo: + print("*** Atomic data:""") + compare_atomic_data(sk1, sk2) + print() + + print("*** Integral tables:") + compare_integral_tables(sk1, sk2, args.nskip) + + + +if __name__ == "__main__": + main() diff --git a/sktools/bin/skgen b/sktools/bin/skgen new file mode 100755 index 00000000..0ff73fb8 --- /dev/null +++ b/sktools/bin/skgen @@ -0,0 +1,275 @@ +#!/usr/bin/env python3 +import sys +if sys.hexversion < 0x03020000: + sys.exit("Program only works with Python 3.2 or greater") +import argparse +import numpy as np +if np.__version__.startswith("1.6."): + sys.exit("Program only works with Numpy 1.7.x or greater") +from sktools import PACKAGE_VERSION +import sktools.common as sc +from sktools.skdef import Skdef +import sktools.skgen as skgen + +SCRIPTNAME = sc.get_script_name() + +# Global script logger, will be overriden by the setup_logger() method in +# the respective subcommands depending on the command line loglevel options +logger = None + + +def main(): + parser, subparsers = get_parser_and_subparser_container() + setup_parser_main(parser) + onecnt_common = get_onecnt_common_parser() + setup_parser_atom(subparsers, onecnt_common, run_atom) + setup_parser_denscomp(subparsers, onecnt_common, run_denscomp) + setup_parser_wavecomp(subparsers, onecnt_common, run_wavecomp) + twocnt_common = get_twocnt_common_parser() + setup_parser_twocnt(subparsers, twocnt_common, run_twocnt) + setup_parser_sktable(subparsers, twocnt_common, run_sktable) + parse_command_line_and_run_subcommand(parser) + + +def run_atom(args): + setup_logger(args.loglevel) + logger.info("Subcommand atom started") + elements = convert_argument_to_elements(args.element) + skdefs = merge_skdefs(args.configfiles) + searchdirs = [ args.builddir, ] + args.includedirs + resultdirs = [] + for elem in elements: + calculator = skgen.run_atom( + skdefs, elem, args.builddir, searchdirs, args.onecnt_binary, + args.eigenonly, args.eigenspinonly) + resultdirs.append(calculator.get_result_directory()) + logger.info("Subcommand atom finished") + logger.info("Atom results in {}".format(" ".join(resultdirs))) + + +def run_denscomp(args): + setup_logger(args.loglevel) + logger.info("Subcommand denscomp started") + elements = convert_argument_to_elements(args.element) + skdefs = merge_skdefs(args.configfiles) + searchdirs = [ args.builddir, ] + args.includedirs + resultdirs = [] + for elem in elements: + calculator = skgen.run_denscomp( + skdefs, elem, args.builddir, searchdirs, args.onecnt_binary) + resultdirs.append(calculator.get_result_directory()) + logger.info("Subcommand densecomp finished") + logger.info("Denscomp results in {}".format(" ".join(resultdirs))) + + +def run_wavecomp(args): + setup_logger(args.loglevel) + logger.info("Subcommand wavecomp started") + elements = convert_argument_to_elements(args.element) + skdefs = merge_skdefs(args.configfiles) + searchdirs = [ args.builddir, ] + args.includedirs + resultdirs = [] + for elem in elements: + calculator = skgen.run_wavecomp( + skdefs, elem, args.builddir, searchdirs, args.onecnt_binary) + dirnames = " ".join(calculator.get_result_directories()) + resultdirs.append(dirnames) + logger.info("Subcommand wavecomp finished") + logger.info("Wavecomp results in {}".format(" ".join(resultdirs))) + + +def run_twocnt(args): + setup_logger(args.loglevel) + logger.info("Subcommand twocnt started") + skdefs = merge_skdefs(args.configfiles) + builddir = args.builddir + searchdirs = [ builddir, ] + args.includedirs + resultdirs = [] + element_pairs = convert_arguments_to_element_pairs(args.element1, + args.element2) + for elem1, elem2 in element_pairs: + calculator = skgen.run_twocnt( + skdefs, elem1, elem2, builddir, searchdirs, args.onecnt_binary, + args.twocnt_binary) + resultdirs.append(calculator.get_result_directory()) + logger.info("Subcommand twocnt finished") + logger.info("Twocnt results in {}".format(" ".join(resultdirs))) + + +def run_sktable(args): + setup_logger(args.loglevel) + logger.info("Subcommand sktable started") + skdefs = merge_skdefs(args.configfiles) + builddir = args.builddir + searchdirs = [ builddir, ] + args.includedirs + workdir = args.outdir + add_dummy_rep = args.dummyrep + skfiles_written = [] + element_pairs = convert_arguments_to_element_pairs(args.element1, + args.element2) + for elem1, elem2 in element_pairs: + skfiles_written += skgen.run_sktable( + skdefs, elem1, elem2, builddir, searchdirs, args.onecnt_binary, + args.twocnt_binary, workdir, add_dummy_rep) + logger.info("Directory with assembled SK-file(s): {}".format(workdir)) + logger.info("SK-file(s) written: {}".format(" ".join(skfiles_written))) + + +def get_parser_and_subparser_container(): + parser = argparse.ArgumentParser( + description="General tool for generating Slater-Koster tables.") + subparsers = parser.add_subparsers(title="available subcommands", + help="") + return parser, subparsers + + +def get_onecnt_common_parser(): + """Common settings for all one-center calculations.""" + onecnt_common = argparse.ArgumentParser(add_help=False) + onecnt_common.add_argument( + "element", help="element to process: either one element (e.g. N) or a " + "comma separated list of element names *without* spaces in between " + "(e.g. N,C,H)") + return onecnt_common + + +def get_twocnt_common_parser(): + twocnt_common = argparse.ArgumentParser(add_help=False) + twocnt_common.add_argument( + "element1", help="first element of the element pair to process: " + "either one element (e.g. N) or a comma separated list of element " + "names *without* spaces in between (e.g. N,C,H)") + twocnt_common.add_argument( + "element2", help="second element of the element pair to process: " + "either one element (e.g. N) or a comma separated list of element " + "names *without* spaces in between (e.g. N,C,H)") + return twocnt_common + + +def setup_parser_main(parser): + parser.add_argument("--version", action="version", + version="sktools {}".format(PACKAGE_VERSION)) + parser.add_argument( + "-I", "--include-dir", action="append", default=[], + dest="includedirs", + help="directory to include in the search for calculation " + "(default: build directory only)") + parser.add_argument( + "-c", "--config-file", action="append", dest="configfiles", + default=[ "skdef.hsd", ], + help="config file(s) to be parsed (default: ./skdef.hsd)" + ) + parser.add_argument( + "-b", "--build-dir", default="_build", dest="builddir", + help="build directory (default: _build)") + parser.add_argument( + "-o", "--onecenter-binary", dest="onecnt_binary", default=None, + help="binary to use for the one-center calculations (default: depends " + "on the calculator specified in the input)") + parser.add_argument( + "-t", "--twocenter-binary", dest="twocnt_binary", default=None, + help="binary to use for the two-center calculationrs (default: depends " + "on the calculator speciefied in the input)") + parser.add_argument( + "-l", "--log-level", dest="loglevel", default="info", + choices=[ "debug", "info", "warning", "error" ], + help="Logging level (default: info)") + + +def setup_parser_atom(subparsers, onecnt_common, target_function): + parser_atom = subparsers.add_parser( + "atom", parents=[onecnt_common], + help="calculates the free atom to get eigenlevels, hubbard values, spin" + " couplings, etc.") + parser_atom.add_argument( + "-e", "--eigenlevels-only", dest="eigenonly", action="store_true", + default=False, help="calculates only eigenlevels of the spin " + "unpolarized atom but no derivatives.") + parser_atom.add_argument( + "-s", "--spin-polarized", dest="eigenspinonly", action="store_true", + default=False, help="calculates only the eigenlevels of the spin " + "polarized atom but no derivatives") + parser_atom.set_defaults(func=target_function) + + +def setup_parser_denscomp(subparsers, onecnt_common, target_function): + parser_denscomp = subparsers.add_parser( + "denscomp", parents=[ onecnt_common ], + help="calculates density compression") + parser_denscomp.set_defaults(func=target_function) + + +def setup_parser_wavecomp(subparsers, onecnt_common, target_function): + parser_wavecomp = subparsers.add_parser( + "wavecomp", parents=[ onecnt_common ], + help="calculates wave function compression") + parser_wavecomp.set_defaults(func=target_function) + + +def setup_parser_twocnt(subparsers, twocnt_common, target_function): + parser_twocnt = subparsers.add_parser( + "twocnt", parents=[ twocnt_common ], + help="calculates two center integrals") + parser_twocnt.set_defaults(func=target_function) + + +def setup_parser_sktable(subparsers, twocnt_common, target_function): + parser_sktable = subparsers.add_parser( + "sktable", parents=[ twocnt_common ], + help="creates an sktable for a given element pair") + parser_sktable.add_argument( + "-d", "--dummy-repulsive", action="store_true", dest="dummyrep", + default=False, help="add dummy repulsive spline to the sk tables") + parser_sktable.add_argument( + "-o", "--output-dir", dest="outdir", default=".", + help="directory where the skfiles should be written to (default: .)") + parser_sktable.set_defaults(func=target_function) + + +def parse_command_line_and_run_subcommand(parser): + args = parser.parse_args() + args.func(args) + + +def setup_logger(loglevel): + global logger + logger = sc.get_script_logger(loglevel, SCRIPTNAME) + + +def merge_skdefs(filenames): + """Returns a merged skdefs object using all specified skdef files.""" + + skdef = Skdef.fromfile(filenames[0]) + for filename in filenames[1:]: + skdef2 = Skdef.fromfile(filename) + skdef.update(skdef2) + return skdef + + +def convert_argument_to_elements(argument): + return argument.split(",") + + +def convert_arguments_to_element_pairs(argument1, argument2): + elements1 = convert_argument_to_elements(argument1) + elements2 = convert_argument_to_elements(argument2) + processed = set() + element_pairs = [] + for elem1 in elements1: + elem1low = elem1.lower() + for elem2 in elements2: + elem2low = elem2.lower() + already_processed = ((elem1low, elem2low) in processed + or (elem2low, elem1low) in processed) + if not already_processed: + element_pairs.append(( elem1, elem2 )) + processed.add(( elem1low, elem2low )) + return element_pairs + + + +if __name__ == "__main__": + try: + main() + except sc.SkgenException as ex: + sc.fatalerror(str(ex)) diff --git a/sktools/bin/skmanip b/sktools/bin/skmanip new file mode 100755 index 00000000..e5aa3af7 --- /dev/null +++ b/sktools/bin/skmanip @@ -0,0 +1,113 @@ +#!/usr/bin/env python3 +import sys +import argparse +import re +import xml.etree.ElementTree as etree +from sktools import PACKAGE_VERSION +import sktools.common as sc +from sktools.oldskfile import OldSKFile + +SCRIPTNAME = sc.get_script_name() + + +FNAME_PATTERN = re.compile("(?P\w+)-(?P\w+)\.skf") + + +def main(): + parser, subparsers = get_parser_and_subparser_container() + setup_parser_main(parser) + common = get_common_parser() + setup_parser_getdoc(subparsers, common, run_getdoc) + setup_parser_setdoc(subparsers, common, run_setdoc) + parse_command_line_and_run_subcommand(parser) + + +def run_getdoc(args): + skfile = args.skfile + if args.sktype == "auto": + homo = is_homo_file(skfile) + else: + homo = (args.sktype == "homo") + sk = OldSKFile.fromfile(skfile, homo) + doc = sk.documentation + fobj = sys.stdout if args.file == "-" else args.file + fp, tobeclosed = sc.openfile(fobj, "w") + fp.write(etree.tostring(doc, encoding="UTF-8").decode("UTF-8")) + if tobeclosed: + fp.close() + +def run_setdoc(args): + skfile = args.skfile + if args.sktype == "auto": + homo = is_homo_file(skfile) + else: + homo = (args.sktype == "homo") + sk = OldSKFile.fromfile(skfile, homo) + fobj = sys.stdin if args.file == "-" else args.file + fp, tobeclosed = sc.openfile(fobj, "r") + xml = fp.read() + if tobeclosed: + fp.close() + doc = etree.fromstring(xml) + sk.documentation = doc + sk.tofile(skfile) + + +def is_homo_file(filename): + match = FNAME_PATTERN.match(filename) + if match: + homo = (match.group("elem1") == match.group("elem2")) + else: + homo = False + return homo + + +def get_parser_and_subparser_container(): + parser = argparse.ArgumentParser( + description="General tool for manipulating SK-tables.") + subparsers = parser.add_subparsers(title="available subcommands", + help="") + return parser, subparsers + + +def get_common_parser(): + """Common settings for all one-center calculations.""" + common = argparse.ArgumentParser(add_help=False) + common.add_argument("skfile", help="skfile to process.") + common.add_argument( + "-t", "--type", dest="sktype", choices=[ "homo", "hetero", "auto" ], + default="auto", help="Type of skfile (default: auto)") + common.add_argument( + "-f", "--file", default="-", + help="Reads/writes from/into file instead using stdin/stderr") + return common + + +def setup_parser_main(parser): + parser.add_argument("--version", action="version", + version="skmanip {}".format(PACKAGE_VERSION)) + + +def setup_parser_getdoc(subparsers, common, target_function): + parser = subparsers.add_parser("get_documentation", parents=[ common ], + help="Extracts the documentation into a file") + parser.set_defaults(func=target_function) + + +def setup_parser_setdoc(subparsers, common, target_function): + parser = subparsers.add_parser("set_documentation", parents=[ common ], + help="Replaces the documentation in an SK-file") + parser.set_defaults(func=target_function) + + +def parse_command_line_and_run_subcommand(parser): + args = parser.parse_args() + args.func(args) + + +if __name__ == "__main__": + try: + sc.check_version() + main() + except sc.SkgenException as ex: + sc.fatalerror(str(ex)) \ No newline at end of file diff --git a/sktools/setup.py b/sktools/setup.py new file mode 100644 index 00000000..b0c36428 --- /dev/null +++ b/sktools/setup.py @@ -0,0 +1,31 @@ +#!/usr/bin/env python3 +from distutils.core import setup + +setup( + name="sktools", + version='20.2', + description="Tools to create SK-parameters", + author="DFTB+ developers", + url="http://www.dftbplus.org", + platforms="platform independent", + package_dir={"": "src"}, + packages=["sktools", "sktools.hsd", "sktools.calculators", "sktools.skgen"], + scripts=[ + "bin/skgen", + ], + classifiers=[ + "Programming Language :: Python", + "Environment :: Console", + "Intended Audience :: Science/Research", + "License :: OSI Approved :: BSD License", + "Operating System :: OS Independent", + "Topic :: Scientific/Engineering", + ], + long_description=""" +Processing and converting data related to the DFTB+ package +----------------------------------------------------------- +A few scripts which should make the life of DFTB+ users easier, by providing +functions to process and convert various DFTB+ data formats. +""", + requires=[ "numpy" ] +) diff --git a/sktools/src/sktools/__init__.py b/sktools/src/sktools/__init__.py new file mode 100644 index 00000000..05aefabd --- /dev/null +++ b/sktools/src/sktools/__init__.py @@ -0,0 +1 @@ +PACKAGE_VERSION = "0.4" diff --git a/sktools/src/sktools/calculators/__init__.py b/sktools/src/sktools/calculators/__init__.py new file mode 100644 index 00000000..3fa5e475 --- /dev/null +++ b/sktools/src/sktools/calculators/__init__.py @@ -0,0 +1,29 @@ +from .slateratom import SlaterAtom, SlaterAtomSettings +from .sktwocnt import Sktwocnt, SktwocntSettings + +__all__ = [ "ONECENTER_CALCULATORS", "ONECENTER_CALCULATOR_SETTINGS", + "TWOCENTER_CALCULATORS", "TWOCENTER_CALCULATOR_SETTINGS" ] + + +class RegisteredCalculator: + + def __init__(self, settings, calculator): + self.settings = settings + self.calculator = calculator + + +ONECENTER_CALCULATOR_SETTINGS = { + "slateratom": SlaterAtomSettings +} + +ONECENTER_CALCULATORS = { + RegisteredCalculator(SlaterAtomSettings, SlaterAtom) +} + +TWOCENTER_CALCULATOR_SETTINGS = { + "sktwocnt": SktwocntSettings +} + +TWOCENTER_CALCULATORS = { + RegisteredCalculator(SktwocntSettings, Sktwocnt) +} \ No newline at end of file diff --git a/sktools/src/sktools/calculators/gridatom.py b/sktools/src/sktools/calculators/gridatom.py new file mode 100644 index 00000000..20b10c9c --- /dev/null +++ b/sktools/src/sktools/calculators/gridatom.py @@ -0,0 +1 @@ +__author__ = 'aradi' diff --git a/sktools/src/sktools/calculators/sktwocnt.py b/sktools/src/sktools/calculators/sktwocnt.py new file mode 100644 index 00000000..8945e5b5 --- /dev/null +++ b/sktools/src/sktools/calculators/sktwocnt.py @@ -0,0 +1,272 @@ +import os +import shelve +import subprocess as subproc +import numpy as np +import sktools.hsd as hsd +import sktools.hsd.converter as conv +import sktools.common as sc +from sktools import twocenter_grids +from sktools import radial_grid + + +AVAILABLE_FUNCTIONALS = [ sc.XC_FUNCTIONAL_LDA, sc.XC_FUNCTIONAL_PBE ] +INPUT_FILE = "sktwocnt.in" +STDOUT_FILE = "output" +BASISFUNCTION_FILE = "basisfuncs.dbm" +DEFAULT_BINARY = "sktwocnt" + + +class SktwocntSettings(sc.ClassDict): + """Specific settings for sktwocnt program. + + Attributes + ---------- + integrationpoints : int, int + Two integers representing the nr. of points for radial and angular + integration. + """ + + def __init__(self, integrationpoints): + super().__init__() + self.integrationpoints = integrationpoints + + @classmethod + def fromhsd(cls, node, query): + """Generate the object from HSD tree""" + integrationpoints, child = query.getvalue( + node, "integrationpoints", conv.int1, returnchild=True) + if len(integrationpoints) != 2: + raise hsd.HSDInvalidTagValueException( + "Two integration point parameters must be specified", child) + return cls(integrationpoints) + + def __eq__(self, other): + if not isinstance(other, SktwocntSettings): + return False + if self.integrationpoints != other.integrationpoints: + return False + return True + + +class Sktwocnt: + + def __init__(self, workdir): + self._workdir = workdir + + def set_input(self, settings, superpos, functional, grid, atom1data, + atom2data=None): + myinput = SktwocntInput(settings, superpos, functional, grid, atom1data, + atom2data) + myinput.write(self._workdir) + + def run(self, binary=DEFAULT_BINARY): + runner = SktwocntCalculation(binary, self._workdir) + runner.run() + + def get_result(self): + result = SktwocntResult(self._workdir) + return result + + +class SktwocntInput: + + _INTERACTION_FROM_NTYPES = { + 1: "homo", + 2: "hetero", + } + + _DENSITY_SUPERPOS_FROM_FUNCTIONAL = { + sc.XC_FUNCTIONAL_LDA: "density_lda", + sc.XC_FUNCTIONAL_PBE: "density_pbe", + } + + _POTENTIAL_SUPERPOS = "potential" + + def __init__(self, settings, superpos, functional, grid, atom1data, + atom2data=None): + self._settings = settings + self._atom1data = atom1data + self._hetero = atom2data is not None + if self._hetero: + self._atom2data = atom2data + else: + self._atom2data = self._atom1data + self._check_superposition(superpos) + self._densitysuperpos = (superpos == sc.SUPERPOSITION_DENSITY) + self._check_functional(functional) + self._functional = functional + self._check_grid(grid) + self._grid = grid + + @staticmethod + def _check_superposition(superpos): + if superpos not in [ sc.SUPERPOSITION_POTENTIAL, + sc.SUPERPOSITION_DENSITY ]: + msg = "Sktwocnt: Invalid superposition type" + sc.SkgenException(msg) + + @staticmethod + def _check_functional(functional): + if functional not in AVAILABLE_FUNCTIONALS: + raise sc.SkgenException("Invalid functional type") + + @staticmethod + def _check_grid(grid): + if not isinstance(grid, twocenter_grids.EquidistantGrid): + msg = "Sktwocnt only can hande equidistant grids" + raise sc.SkgenException(msg) + + def write(self, workdir): + atomfiles1 = self._store_atomdata(workdir, self._atom1data, 1) + if self._hetero: + atomfiles2 = self._store_atomdata(workdir, self._atom2data, 2) + else: + atomfiles2 = None + self._store_twocnt_input(workdir, atomfiles1, atomfiles2) + self._store_basisfunctions(workdir) + + def _store_atomdata(self, workdir, atomdata, iatom): + atomfiles = sc.ClassDict() + atomfiles.wavefuncs = self._store_wavefuncs(workdir, atomdata.wavefuncs, + iatom) + atomfiles.potential = self._store_potentials(workdir, + atomdata.potentials, iatom) + atomfiles.density = self._store_density(workdir, atomdata.density, + iatom) + return atomfiles + + @staticmethod + def _store_wavefuncs(workdir, wavefuncs, iatom): + wavefuncfiles = [] + for nn, ll, wfc012 in wavefuncs: + fname = "wave{:d}_{:d}{:s}.dat".format(iatom, nn, + sc.ANGMOM_TO_SHELL[ll]) + wfc012.tofile(os.path.join(workdir, fname)) + wavefuncfiles.append(( nn, ll, fname )) + return wavefuncfiles + + @staticmethod + def _store_potentials(workdir, potentials, iatom): + fname = "potentials{:d}.dat".format(iatom) + # Vxc up and down should be equivalent, twocnt reads only one. + newdata = potentials.data.take(( radial_grid.VNUC, radial_grid.VHARTREE, radial_grid.VXCUP ), + axis=1) + newgriddata = radial_grid.GridData(potentials.grid, newdata) + newgriddata.tofile(os.path.join(workdir, fname)) + return fname + + @staticmethod + def _store_density(workdir, density, iatom): + fname = "density{:d}.dat".format(iatom) + density.tofile(os.path.join(workdir, fname)) + return fname + + def _store_basisfunctions(self, workdir): + config = shelve.open( + os.path.join(workdir, BASISFUNCTION_FILE), "n") + config["basis1"] = [ (nn, ll) for nn, ll, wfc012 + in self._atom1data.wavefuncs ] + config["basis2"] = [ (nn, ll) for nn, ll, wfc012 + in self._atom2data.wavefuncs ] + config.close() + + def _store_twocnt_input(self, workdir, atomfiles1, atomfiles2=None): + fp = open(os.path.join(workdir, INPUT_FILE), "w") + self._write_twocnt_header(fp) + self._write_twocnt_gridinfo(fp) + self._write_twocnt_integration_parameters(fp) + self._write_twocnt_atom_block(fp, atomfiles1) + if self._hetero: + self._write_twocnt_atom_block(fp, atomfiles2) + fp.close() + + def _write_twocnt_header(self, fp): + if self._densitysuperpos: + superposname = \ + self._DENSITY_SUPERPOS_FROM_FUNCTIONAL[self._functional] + else: + superposname = self._POTENTIAL_SUPERPOS + fp.write("{} {}\n".format("hetero" if self._hetero else "homo", + superposname)) + + def _write_twocnt_gridinfo(self, fp): + fp.write("{:f} {:f} {:e} {:f}\n".format( + self._grid.gridstart, self._grid.gridseparation, + self._grid.tolerance, self._grid.maxdistance)) + + def _write_twocnt_integration_parameters(self, fp): + fp.write("{:d} {:d}\n".format(*self._settings.integrationpoints)) + + def _write_twocnt_atom_block(self, fp, atomfiles): + fp.write("{:d}\n".format(len(atomfiles.wavefuncs))) + for nn, ll, wavefuncfile in atomfiles.wavefuncs: + fp.write("'{}' {:d}\n".format(wavefuncfile, ll)) + fp.write("'{}'\n".format(atomfiles.potential)) + if self._densitysuperpos: + fp.write("'{}'\n".format(atomfiles.density)) + else: + fp.write("'{}'\n".format("nostart")) + + + +class SktwocntCalculation: + + def __init__(self, binary, workdir): + self._binary = binary + self._workdir = workdir + + def run(self): + fpin = open(os.path.join(self._workdir, INPUT_FILE), "r") + fpout = open(os.path.join(self._workdir, STDOUT_FILE), "w") + proc = subproc.Popen([ self._binary ], cwd=self._workdir, + stdin=fpin, stdout=fpout, stderr=subproc.STDOUT) + proc.wait() + fpin.close() + fpout.close() + + + +class SktwocntResult: + + def __init__(self, workdir): + basis1, basis2 = self._read_basis(workdir) + self._integmap = self._create_integral_mapping(basis1, basis2) + ninteg = len(self._integmap) + self._skham = self._read_sktable( + os.path.join(workdir, "at1-at2.ham.dat"), ninteg) + self._skover = self._read_sktable( + os.path.join(workdir, "at1-at2.over.dat"), ninteg) + + @staticmethod + def _read_basis(workdir): + config = shelve.open(os.path.join(workdir, BASISFUNCTION_FILE), "r") + basis1 = list(config["basis1"]) + basis2 = list(config["basis2"]) + config.close() + return basis1, basis2 + + @staticmethod + def _create_integral_mapping(basis1, basis2): + ninteg = 0 + integmap = {} + for n1, l1 in basis1: + for n2, l2 in basis2: + for mm in range(min(l1, l2) + 1): + ninteg += 1 + integmap[(n1, l1, n2, l2, mm)] = ninteg + return integmap + + @staticmethod + def _read_sktable(fname, ninteg): + fp = open(fname, "r") + nline = int(fp.readline()) + # noinspection PyNoneFunctionAssignment,PyTypeChecker + tmp = np.fromfile(fp, dtype=float, count=ninteg * nline, sep=" ") + tmp.shape = ( nline, ninteg ) + return tmp + + def get_hamiltonian(self): + return self._skham + + def get_overlap(self): + return self._skover diff --git a/sktools/src/sktools/calculators/slateratom.py b/sktools/src/sktools/calculators/slateratom.py new file mode 100644 index 00000000..1f044d47 --- /dev/null +++ b/sktools/src/sktools/calculators/slateratom.py @@ -0,0 +1,418 @@ +import os +import subprocess as subproc +import numpy as np +import sktools.hsd.converter as conv +import sktools.common as sc +from sktools.taggedfile import TaggedFile +import sktools.compressions +import sktools.radial_grid as oc + + +AVAILABLE_FUNCTIONALS = [ sc.XC_FUNCTIONAL_LDA, sc.XC_FUNCTIONAL_PBE ] +INPUT_FILE = "slateratom.in" +STDOUT_FILE = "output" +DEFAULT_BINARY = "slateratom" + + +def register_onecenter_calculator(): + """Returns data for calculator registration""" + calc = sc.ClassDict() + calc.settings = SlaterAtomSettings + calc.calculator = SlaterAtom + return calc + + +def register_hsd_settings(): + return SlaterAtomSettings + + +class SlaterAtomSettings(sc.ClassDict): + """Specific settings for slateratom program. + + Attributes + ---------- + exponents : list + [ exp_s, exp_p, ... ] list, where each exp_* is a list of the exponents + for the given angular momentum. + maxpowers : list + Maximal power for every angular momentum. + """ + + def __init__(self, exponents, maxpowers): + super().__init__() + self.exponents = exponents + self.maxpowers = maxpowers + + @classmethod + def fromhsd(cls, root, query): + node = query.getchild(root, "exponents") + exponents = sc.get_shellvalues_list(node, query, conv.float1) + node = query.getchild(root, "maxpowers") + maxpowers = sc.get_shellvalues_list(node, query, conv.int0) + return cls(exponents, maxpowers) + + def __eq__(self, other): + if not isinstance(other, SlaterAtomSettings): + return False + if len(self.exponents) != len(other.exponents): + return False + if len(self.maxpowers) != len(other.maxpowers): + return False + for ll in range(len(self.exponents)): + if self.maxpowers[ll] != other.maxpowers[ll]: + return False + myexps = self.exponents[ll] + otherexps = other.exponents[ll] + if len(myexps) != len(otherexps): + return False + for ii in range(len(myexps)): + if abs(myexps[ii] - otherexps[ii]) > sc.INPUT_FLOAT_TOLERANCE: + return False + return True + + +class SlaterAtom: + + def __init__(self, workdir): + self._workdir = workdir + + def set_input(self, settings, atomconfig, functional, compression): + myinput = SlateratomInput(settings, atomconfig, functional, compression) + myinput.write(self._workdir) + + def run(self, binary=DEFAULT_BINARY): + runner = SlateratomCalculation(binary, self._workdir) + runner.run() + + def get_result(self): + return SlateratomResult(self._workdir) + + +class SlateratomInput: + """Represents the input of the slateratom program. + + Parameters + ---------- + atomconfig : AtomConfig + Configuration of the atom to be calculated. + functional : str + DFT functional type ('lda' or 'pbe') + compressions : list + List of PowerCompression objects. Either empty (no compression applied) + or has a compression object for every angular momentum of the atom. + settings : SlaterAtom + Further detailed settings of the program. + """ + + _XCFUNCTIONALS = { sc.XC_FUNCTIONAL_LDA: 2, sc.XC_FUNCTIONAL_PBE: 3 } + + _LOGICALSTRS = { True: ".true.", False: ".false." } + + _COMMENT = "#" + + + def __init__(self, settings, atomconfig, functional, compressions): + self._settings = settings + self._atomconfig = atomconfig + znuc = self._atomconfig.atomicnumber + if abs(znuc - int(znuc)) > 1e-12: + msg = "Slateratom: Only integer atomic numbers are allowed" + raise sc.SkgenException(msg) + if len(settings.exponents) != atomconfig.maxang + 1: + msg = "Slateratom: Missing STO exponents for some shells" + raise sc.SkgenException(msg) + if len(settings.maxpowers) != atomconfig.maxang + 1: + msg = "Slateratom: Missing STO max. powers for some shells" + raise sc.SkgenException(msg) + myxcfuncs = sc.XC_FUNCTIONAL_LDA, sc.XC_FUNCTIONAL_PBE + if functional not in myxcfuncs: + msg = "Invalid xc-functional type for slateratom" + raise sc.SkgenException(msg) + self._functional = self._XCFUNCTIONALS[functional] + + if compressions is None: + compressions = [] + for comp in compressions: + if not isinstance(comp, sktools.compressions.PowerCompression): + msg = "Invalid compressiont type {} for slateratom".format( + comp.__class__.__name__) + raise sc.SkgenException(msg) + if abs(comp.power - float(int(comp.power))) > 1e-8: + msg = "Slateratom only supports integer compression exponents" + raise sc.SkgenException(msg) + maxang = atomconfig.maxang + ncompr = len(compressions) + if ncompr and ncompr != maxang + 1: + msg = "Invalid number of compressions" \ + "(expected {:d}, got {:d})".format(maxang + 1, ncompr) + raise sc.SkgenException(msg) + self._compressions = compressions + myrelativistics = sc.RELATIVISTICS_NONE, sc.RELATIVISTICS_ZORA + if atomconfig.relativistics not in myrelativistics: + raise sc.SkgenException("Invalid relativistics type for slateratom") + self._relativistic = atomconfig.relativistics == sc.RELATIVISTICS_ZORA + + + def write(self, workdir): + """Writes a valid input for the program. + + Parameters + ---------- + workdir : str + Existing working directory where the input should be written to. + """ + maxang = self._atomconfig.maxang + out = [ + "{:d} {:d} {:d} {:s} \t{:s} znuc maxang nscc relativistic".format( + int(self._atomconfig.atomicnumber), maxang, 120, + self._LOGICALSTRS[self._relativistic], self._COMMENT), + + "{:d}\t{:s} functional: 0=HF, 1=X-Alpha, 2=PW-LDA, 3=PBE ".format( + self._functional, self._COMMENT) + ] + + # Compressions + if not len(self._compressions): + out += [ "{:g} {:d} \t{:s} Compr. radius and power ({:s})".format( + 1e30, 0, self._COMMENT, sc.ANGMOM_TO_SHELL[ll]) + for ll in range(maxang + 1) ] + else: + out += [ "{:g} {:d} \t{:s} Compr. radius and power ({:s})".format( + compr.radius, int(compr.power), self._COMMENT, + sc.ANGMOM_TO_SHELL[ll]) + for ll, compr in enumerate(self._compressions) ] + + out += [ "{:d} \t{:s} nr. of occupied shells ({:s})".format( + len(occ), self._COMMENT, sc.ANGMOM_TO_SHELL[ll]) + for ll, occ in enumerate(self._atomconfig.occupations) ] + + # STO powers and exponents + exponents = self._settings.exponents + maxpowers = self._settings.maxpowers + out += [ "{:d} {:d} \t{:s} nr. of exponents, max. power ({:s})".format( + len(exponents[ll]), maxpowers[ll], self._COMMENT, + sc.ANGMOM_TO_SHELL[ll]) + for ll in range(maxang + 1) ] + out.append("{:s} \t{:s} automatic exponent generation".format( + self._LOGICALSTRS[False], self._COMMENT)) + for ll, skexp_ang in enumerate(exponents): + for ii, skexp in enumerate(skexp_ang): + out.append("{:10f} \t{:s} exponent {:d} ({:s})".format( + skexp, self._COMMENT, ii + 1, sc.ANGMOM_TO_SHELL[ll])) + + out.append("{:s} \t{:s} write eigenvectors".format( + self._LOGICALSTRS[False], self._COMMENT)) + out.append("{} {:g} \t{:s} broyden mixer, mixing factor".format( + self._LOGICALSTRS[True], 0.1, self._COMMENT)) + + # Occupations + for ll, occperl in enumerate(self._atomconfig.occupations): + for ii, occ in enumerate(occperl): + nn = ii + 1 + ll # principal quantum number + out.append("{:g} {:g} \t{:s} occupations ({:d}{:s})".format( + occ[0], occ[1], self._COMMENT, nn, sc.ANGMOM_TO_SHELL[ll])) + + # Valence shell range + valenceqns = [[ sc.MAX_PRINCIPAL_QN, 0 ], ] * (maxang + 1) + for nn, ll in self._atomconfig.valenceshells: + valenceqns[ll][0] = min(valenceqns[ll][0], nn) + valenceqns[ll][1] = max(valenceqns[ll][1], nn) + for ll, vqns in enumerate(valenceqns): + out.append("{:d} {:d} \t{:s} valence shells from to ({:s})".format( + vqns[0], vqns[1], self._COMMENT, sc.ANGMOM_TO_SHELL[ll])) + + fp = open(os.path.join(workdir, INPUT_FILE), "w") + fp.write("\n".join(out)) + fp.close() + + +class SlateratomCalculation: + """Represents a program run. + + Parameters + ---------- + binary : str + Binary to use. + workdir : str + Working directory with valid input in it. + """ + + def __init__(self, binary, workdir): + self._binary = binary + self._workdir = workdir + + def run(self): + """Run the code.""" + fpin = open(os.path.join(self._workdir, INPUT_FILE), "r") + fpout = open(os.path.join(self._workdir, STDOUT_FILE), "w") + proc = subproc.Popen([ self._binary ], cwd=self._workdir, + stdin=fpin, stdout=fpout, stderr=subproc.STDOUT) + proc.wait() + fpin.close() + fpout.close() + + +class SlateratomResult: + """Represents the output of a run. + + Parameters + ---------- + workdir : str + Working directory with the output of a run. + """ + + def __init__(self, workdir): + self._workdir = workdir + fp = open(os.path.join(self._workdir, "energies.tag"), "r") + self._energiestag = TaggedFile.fromfile(fp, transpose=True) + fp.close() + + def get_homo_or_lowest_nl(self, ss): + """Returns homo. If spin channel has no electrons, lowest level. + """ + tagname = "eigenlevels_dn" if ss else "eigenlevels_up" + energies = self._energiestag[tagname] + tagname = "occupations_dn" if ss else "occupations_up" + occupations = self._energiestag[tagname].flat + sorted_energy_inds = np.argsort(energies.flat) + if np.all(occupations < 1e-8): + # No electrons (e.g. spin down in H) -> lowest level as homo + homo = sorted_energy_inds[0] + else: + for homo in sorted_energy_inds[::-1]: + if occupations[homo] >= 1e-8: + break + else: + raise sc.SkgenException("Homo not found!") + homo_ll = homo // energies.shape[1] + mm = homo % energies.shape[1] + homo_nn = mm + homo_ll + 1 + return homo_nn, homo_ll + + def get_eigenvalue(self, ss, nn, ll): + """Returns an eigenvalue. + + Parameters + ---------- + ss : int + Spin channel (0, 1, ...). + nn : int + Principal quantum number (1, 2, ...). + ll : int + Angular momentum (0, 1, ...). + + Returns + ------- + eigenvalue : float + Required eigenvalue. + """ + if ss: + tagname = "eigenlevels_dn" + else: + tagname = "eigenlevels_up" + return self._energiestag[tagname][ll, nn - ll - 1] + + def get_occupation(self, ss, nn, ll): + """Returns an occupation. + + Parameters + ---------- + ss : int + Spin channel (0, 1, ...). + nn : int + Principal quantum number (1, 2, ...). + ll : int + Angular momentum (0, 1, ...). + + Returns + ------- + occupation : float + Required occupation number. + """ + if ss: + tagname = "occupations_dn" + else: + tagname = "occupations_up" + return self._energiestag[tagname][ll, nn - ll - 1] + + def get_energy(self): + """Returns the total energy. + + Returns + ------- + energy: float + Required total energy. + """ + return self._energiestag["total_energy"] + + def get_potentials(self): + """Returns various potential components of the atom + + Returns + ------- + potentials : GridData + Grid data with following potentials: + nuclear, coulomb, xc-spinup, xc-spindown. + """ + fp = open(os.path.join(self._workdir, "pot.dat"), "r") + fp.readline() + fp.readline() + ngrid = int(fp.readline()) + # noinspection PyNoneFunctionAssignment,PyTypeChecker + pots = np.fromfile(fp, dtype=float, count=ngrid * 6, sep=" ") + fp.close() + pots.shape = (ngrid, 6) + grid = oc.RadialGrid(pots[:, 0], pots[:, 1]) + potentials = pots[:,2:6] + return oc.GridData(grid, potentials) + + def get_density012(self): + """Returns the radial density and its first and second derivatives. + + Returns + ------- + density : GridData + Grid data with the density and its first and second derivatives. + """ + fp = open(os.path.join(self._workdir, "dens.dat"), "r") + fp.readline() + fp.readline() + fp.readline() + fp.readline() + fp.readline() + ngrid = int(fp.readline()) + # noinspection PyNoneFunctionAssignment,PyTypeChecker + dens = np.fromfile(fp, dtype=float, count=ngrid * 7, sep=" ") + fp.close() + dens.shape = (ngrid, 7) + grid = oc.RadialGrid(dens[:,0], dens[:,1]) + density = dens[:,2:5] + return oc.GridData(grid, density) + + def get_wavefunction012(self, ss, nn, ll): + """Returns radial wave function and its first and second derivatives. + + Returns + ------- + density : GridData + Grid data with the wavefunction and its first and second derivatives. + """ + if ss == 0: + formstr = "wave_{:02d}{:s}_up.dat" + else: + formstr = "wave_{:02d}{:s}_dn.dat" + wavefile = formstr.format(nn, sc.ANGMOM_TO_SHELL[ll]) + wavefile = os.path.join(self._workdir, wavefile) + if not os.path.exists(wavefile): + raise sc.SkgenException("Missing wave function file " + wavefile) + fp = open(wavefile, "r") + fp.readline() + fp.readline() + ngrid = int(fp.readline()) + fp.readline() + # noinspection PyNoneFunctionAssignment,PyTypeChecker + wavefunc = np.fromfile(fp, dtype=float, count=5 * ngrid, sep=" ") + wavefunc.shape = (ngrid, 5) + grid = oc.RadialGrid(wavefunc[:, 0], wavefunc[:, 1]) + wfcs = wavefunc[:,2:5] + return oc.GridData(grid, wfcs) diff --git a/sktools/src/sktools/common.py b/sktools/src/sktools/common.py new file mode 100644 index 00000000..a9d6ac57 --- /dev/null +++ b/sktools/src/sktools/common.py @@ -0,0 +1,468 @@ +import sys +import re +import os.path +import shelve +import dbm +import tempfile +import shutil +import logging + +import sktools.hsd as hsd +import sktools.hsd.converter as conv + + +logger = logging.getLogger("common") + + +# Maximal angular momentum +MAX_ANGMOM = 4 + +# Translate between angular momentum and shell name +ANGMOM_TO_SHELL = [ "s", "p", "d", "f", "g" ] + +# Translate between shell name and angular momentum +SHELL_TO_ANGMOM = { "s": 0, "p": 1, "d": 2, "f": 3, "g": 4 } + +# Name of the spin channels +SPIN_NAMES = [ "u", "d" ] + +# Max. principal quantum number +MAX_PRINCIPAL_QN = 7 + +RELATIVISTICS_NONE = 0 +RELATIVISTICS_ZORA = 1 +RELATIVISTICS_TYPES = { "none": RELATIVISTICS_NONE, + "zora": RELATIVISTICS_ZORA } + +XC_FUNCTIONAL_LDA = 0 +XC_FUNCTIONAL_PBE = 1 +XC_FUNCTIONAL_TYPES = { "lda": XC_FUNCTIONAL_LDA, + "pbe": XC_FUNCTIONAL_PBE } + +SUPERPOSITION_POTENTIAL = 0 +SUPERPOSITION_DENSITY = 1 +SUPERPOSITION_TYPES = { "potential": SUPERPOSITION_POTENTIAL, + "density": SUPERPOSITION_DENSITY } + +WAVEFUNC_FILE_NAME_FORMAT = "wave_{:02d}{:s}.dat" +POTENTIAL_FILE_NAME = "pot.dat" +DENSITY_FILE_NAME = "dens.dat" + + +# Tolerance for float numbers in user input +INPUT_FLOAT_TOLERANCE = 1E-8 + + +class SkgenException(Exception): + pass + + +def openfile(fobj, mode): + """Opens a file.""" + isfname = isinstance(fobj, str) + if isfname: + fp = open(fobj, mode) + else: + fp = fobj + return fp, isfname + + +def writefloats(fp, nums, indent=0, indentstr=None, numperline=4, + formstr="{:23.15E}"): + if indentstr is None: + indentstr = " " * indent + lineform = indentstr + formstr * numperline + "\n" + nums1d = nums.flat + nnumber = len(nums1d) + nline = nnumber // numperline + for ii in range(nline): + fp.write(lineform.format( + *nums1d[ii * numperline:(ii + 1) * numperline])) + res = nnumber % numperline + if res: + lineform = indentstr + formstr * res + "\n" + fp.write(lineform.format(*nums1d[nnumber - res:nnumber])) + + +# Fortran float pattern with possibility for reccurance +PAT_FORTRAN_FLOAT = re.compile( + r"^(?:(?P[0-9]+)\*)?(?P[+-]?\d*\.?\d*(?:[eE][+-]?\d+)?)$") +PAT_FORTRAN_SEPARATOR = re.compile(r"[,]?\s+") + +def split_fortran_fields(txt, maxsplit=0): + """"Splits a line containing Fortran (numeric) fields.""" + return [ field + for field in PAT_FORTRAN_SEPARATOR.split(txt, maxsplit=maxsplit) + if len(field) > 1 ] + +def convert_fortran_floats(txt): + """Converts floats in fortran notation to intrinsic floats""" + result = [] + words = split_fortran_fields(txt) + for word in words: + match = PAT_FORTRAN_FLOAT.match(word) + if not match: + result.append(None) + continue + occ = match.group("occurance") + if occ is not None: + occ = int(occ) + else: + occ = 1 + val = float(match.group("value")) + result += [ val, ] * occ + return result + + +# Shell name pattern +PAT_SHELLNAME = re.compile(r"^(?P[0-9])(?P[spdfg])$") + + +def shell_name_to_ind(txt): + """Converts a named shell (e.g. '1s') into (n, l) tuple (e.g. (1, 0)). + + Parameters + ---------- + txt : str + Text to parse. + + Returns + ------- + n : int + Principal quantum number + l : int + Angular momentum + + Raises + ------ + ValueError + If conversion was not successfull. + """ + match = PAT_SHELLNAME.match(txt) + if not match: + raise ValueError("Invalid shell name '{}'".format(txt)) + return int(match.group("n")), SHELL_TO_ANGMOM[match.group("shell")] + + +def shell_ind_to_name(nn, ll): + return "{:d}{}".format(nn, ANGMOM_TO_SHELL[ll]) + + +class FileFromStringOrHandler: + + def __init__(self, fname_or_handler, mode): + if isinstance(fname_or_handler, str): + self._fp = open(fname_or_handler, mode) + self._tobeclosed = True + else: + self._fp = fname_or_handler + self._tobeclosed = False + + def __enter__(self): + return self + + def __exit__(self, exc_type, exc_val, exc_tb): + if self._tobeclosed: + self._fp.close() + + def write(self, *args, **kwargs): + return self._fp.write(*args, **kwargs) + + def writelines(self, *args, **kwargs): + return self._fp.writelines(*args, **kwargs) + + def read(self, *args, **kwargs): + return self._fp.read(*args, **kwargs) + + def readline(self, *args, **kwargs): + return self._fp.readline(*args, **kwargs) + + def readlines(self, *args, **kwargs): + return self._fp.readlines(*args, **kwargs) + + + +class ClassDict: + """Dictionary like object accessible in class notation. + """ + + def __init__(self, initdata=None): + self._dict = {} + if initdata is not None: + self._dict.update(initdata) + + def __setattr__(self, key, value): + if key.startswith("_"): + super().__setattr__(key, value) + else: + self[key] = value + + def __getattr__(self, item): + if item.startswith("_"): + return super().__getattribute__(item) + else: + return self[item] + + def __contains__(self, item): + return item in self._dict + + def __setitem__(self, key, value): + self._dict[key] = value + + def __getitem__(self, item): + try: + return self._dict[item] + except KeyError: + pass + msg = "{} instance has no key/attribute '{}'".format( + self.__class__.__name__, item) + raise KeyError(msg) + + def __iter__(self): + return iter(self._dict) + + def __len__(self): + return len(self._dict) + + def __eq__(self, other): + if isinstance(other, ClassDict): + return self._dict == other._dict + else: + return self._dict == other + + def update(self, other): + self._dict.update(other._dict) + + def get(self, key, default=None): + return self._dict.get(key, default) + + def keys(self): + return self._dict.keys() + + + +def fatalerror(msg, errorcode=-1): + """Issue error message and exit.""" + logger.critical(msg) + sys.exit(errorcode) + + +def getshellvalues(node, query): + """Returns dictionary with the values assigned to individual shells.""" + values = {} + for child in node: + try: + shell = shell_name_to_ind(child.tag) + except ValueError: + raise hsd.HSDInvalidTagException( + msg="Invalid shell name '{}'".format(child.tag), node=child) + value = query.getvalue(child, ".", conv.float0) + values[shell] = value + return values + + +def get_shellvalues_list(node, query, converter): + values = [] + for ll, shellname in enumerate(ANGMOM_TO_SHELL): + shellnode = query.findchild(node, shellname, optional=True) + if shellnode is None: + break + value = query.getvalue(shellnode, ".", converter) + values.append(value) + return values + + +def hsd_node_factory(classtype, classes, node, query): + """Creates an object depending on the node and a class dictionary. + + Parameters + ---------- + classtype : str + Textual name of the class to create for error messages + (e.g. 'twocenter calculator') + classes : dict + Contains classes (not instances!) with their corresponding hsd-name. + Each must have a `fromhsd(node, query)` class method. + node : Element + HSD representation of the node. + query : query object + Query object to use. + + Returns + ------- + node : Element or None + Returns the element created using the hsd input in the node or None + if the node passed was None. + """ + if node is None: + return None + myclass = classes.get(node.tag) + if myclass is None: + raise hsd.HSDInvalidTagException("Unknown {} '{}'".format(classtype, + node.tag)) + return myclass.fromhsd(node, query) + + +def store_as_shelf(fname, shelfdict=None, **kwargs): + """Stores the given keyword arguments in a shelf. + + Parameters + ---------- + fname : str + Name of the file which will contain the shelf content. + shelfdict : dict, optional + Dictionary with values to be stored in the shelf file. + **kwargs : arbitrary, optional + Keyword value pairs to be stored in the shelf file. + """ + db = shelve.open(fname, "n") + if shelfdict is not None: + for key, value in shelfdict.items(): + db[key] = value + for key in kwargs: + db[key] = kwargs[key] + db.close() + + +def retrive_from_shelf(fname): + db = shelve.open(fname, "r") + resdict = dict(db) + db.close() + return resdict + + +def create_unique_workdir(workroot, subdirprefix): + workdir = tempfile.mkdtemp(prefix=subdirprefix, dir=workroot) + logger.debug("Created working directory %s", workdir) + return workdir + + +def create_workdir(workdir, reuse_existing=False): + """Creates a working directory. + + Parameters + ---------- + workdir : str + Working directory to create. If directory already exists, it will + be deleted, unless reuse_existing is set to True. + resuse_existing : bool, optional + Reuse if working directory already exists. + """ + if os.path.exists(workdir): + if reuse_existing: + return + logger.debug("Removing existing working directory %s", workdir) + shutil.rmtree(workdir) + os.makedirs(workdir) + logger.debug("Created working directory %s", workdir) + + +def find_dir_with_matching_shelf(search_dirs, shelf_file, **kwargs): + """Returns the directory containing a shelve with given content. + + Paramters + --------- + search_dirs : directories to scan + Directories to scan. + shelf_file : str + Name of the file containing the shelve. + **kwargs : arbitrary + Name and content of the items the shelve should contain. + + Returns + ------- + directory : str + The directory, where a shelve file containing at least the given + content exist. If no such directory was found, None is returned. + """ + for directory in search_dirs: + if is_shelf_file_matching(os.path.join(directory, shelf_file), kwargs): + return directory + return None + + +def is_shelf_file_matching(shelf_file, mydict): + try: + db = shelve.open(shelf_file, "r") + except dbm.error: + return False + match = True + for key in mydict: + match = key in db and db[key] == mydict[key] + if not match: + return False + return True + + +def get_dirs_with_matching_shelf(search_dirs, shelf_file, **kwargs): + matching_dirs = [] + for directory in search_dirs: + shelf_path = os.path.join(directory, shelf_file) + if is_shelf_file_matching(shelf_path, kwargs): + matching_dirs.append(directory) + return matching_dirs + + +def shelf_exists(shelf_name): + try: + db = shelve.open(shelf_name, "r") + except dbm.error: + result = False + else: + db.close() + result = True + return result + + +def capitalize_elem_name(elem): + return elem[0].upper() + elem[1:].lower() + + +class ScriptLogFormatter(logging.Formatter): + + log_formats = { + logging.CRITICAL: "!!! [{logrecord.name}] {logrecord.message}", + logging.ERROR: "!!! [{logrecord.name}] {logrecord.message}", + logging.WARNING: "! [{logrecord.name}] {logrecord.message}", + logging.INFO: "[{logrecord.name}] {logrecord.message}", + logging.DEBUG: "[{logrecord.name}] {logrecord.message}" + } + default_log_format = "{logrecord.levelno}: {logrecord.message}" + + def __init__(self): + super().__init__("{message}", style="{") + + def format(self, logrecord): + # Make sure, message attribute of logrecord is generated + super().format(logrecord) + formatstr = self.log_formats.get(logrecord.levelno, + self.default_log_format) + result = formatstr.format(logrecord=logrecord) + return result + + +def log_path(path): + cwd = os.path.curdir + pathname_abs = os.path.abspath(path) + pathname_rel = os.path.relpath(path, cwd) + if len(pathname_abs) < len(pathname_rel): + pathname = pathname_abs + else: + pathname = pathname_rel + return "(" + pathname + ")" + + + +def get_script_logger(loglevel, scriptname): + loghandler = logging.StreamHandler() + myformatter = ScriptLogFormatter() + loghandler.setFormatter(myformatter) + logging.root.addHandler(loghandler) + numeric_level = getattr(logging, loglevel.upper(), None) + logging.root.setLevel(numeric_level) + logger = logging.getLogger(scriptname) + return logger + + +def get_script_name(): + return os.path.basename(sys.argv[0]) diff --git a/sktools/src/sktools/compressions.py b/sktools/src/sktools/compressions.py new file mode 100644 index 00000000..20f16bc5 --- /dev/null +++ b/sktools/src/sktools/compressions.py @@ -0,0 +1,180 @@ +"""Contains various compression types.""" +import sktools.hsd as hsd +import sktools.hsd.converter as conv +import sktools.common as sc + + +####################################################################### +# Compressions +####################################################################### + + +class PowerCompression(sc.ClassDict): + """Compression by a power function (r/r0)^n. + + Attributes + ---------- + power : float + Power of the compression function (n). + radius : float + Radius of the compression (r0) + """ + + @classmethod + def fromhsd(cls, root, query): + """Creates instance from a HSD-node and with given query object.""" + + power, child = query.getvalue(root, "power", conv.float0, + returnchild=True) + if power <= 0.0: + raise hsd.HSDInvalidTagValueException( + msg="Invalid compression power {:f}".format(power), node=child) + radius, child = query.getvalue(root, "radius", conv.float0, + returnchild=True) + if radius <= 0.0: + raise hsd.HSDInvalidTagValueException( + msg="Invalid compression radius {:f}".format(radius), + node=child) + + myself = cls() + myself.power = power + myself.radius = radius + return myself + + + def tohsd(self, root, query, parentname=None): + if parentname is None: + mynode = root + else: + mynode = query.setchild(root, "PowerCompression") + query.setchildvalue(mynode, "power", conv.float0, self.power) + query.setchildvalue(mynode, "radius", conv.float0, self.radius) + + + def __eq__(self, other): + power_ok = abs(self.power - other.power) < 1e-8 + radius_ok = abs(self.radius - other.radius) < 1e-8 + return power_ok and radius_ok + + +# Registered compressions with corresponing hsd name as key +COMPRESSIONS = { + "powercompression": PowerCompression, +} + + +####################################################################### +# Compression containers +####################################################################### + + +class SingleAtomCompressions(sc.ClassDict): + """Compression container for cases where all compressed wavefunctions are + determined from one single atomic calculation. + + Attributes + ---------- + 0,1,2.. : compression object + Compression type for the given object. + """ + + def getatomcompressions(self, atomconfig): + """Returns compressions for one or more atomic calculations. + + Parameters + ---------- + atomconfig : AtomConfig + Configuration of the atom, for which the compression container + had been specified. + + Returns + ------- + atomcompressions : list + List of ( compressions, valenceshells ) tuples. Compressions + is a list of compression objects with one compression for every + angular momentum of the atom, representing a complete compression + for an atomic calculation. Valencshells is a list of (nn, ll) + tuples containing principal quantum number and angular momentum of + the valenceshells, for which the wave function should be taken + from that compressed calculation. + """ + compressions = [] + for ll in range(atomconfig.maxang + 1): + if ll not in self: + msg = "Missing wave compression for shell {:s}".format( + sc.ANGMOM_TO_SHELL[ll]) + raise sc.SkgenException(msg) + compressions.append(self[ll]) + atomcompressions = [ ( compressions, atomconfig.valenceshells )] + return atomcompressions + + + @classmethod + def fromhsd(cls, root, query): + myself = cls() + for ll, shellname in enumerate(sc.ANGMOM_TO_SHELL): + child = query.findchild(root, shellname, optional=True) + if child is None: + break + compr = sc.hsd_node_factory( + "wavefunction compression", COMPRESSIONS, + query.getvaluenode(child, "."), query) + myself[ll] = compr + return myself + + +class MultipleAtomCompressions(sc.ClassDict): + + def getatomcompressions(self, atomconfig): + """Returns compressions for one or more atomic calculations. + + Parameters + ---------- + atomconfig : AtomConfig + Configuration of the atom, for which the compression container + had been specified. + + Returns + ------- + atomcompressions : list + List of ( compressions, valenceshells ) tuples. Compressions + is a list of compression objects with one compression for every + angular momentum of the atom, representing a complete compression + for an atomic calculation. Valencshells is a list of (nn, ll) + tuples containing principal quantum number and angular momentum of + the valenceshells, for which the wave function should be taken + from that compressed calculation. + """ + atomcompressions = [] + for nn, ll in atomconfig.valenceshells: + if (nn, ll) not in self: + msg = "Missing compression for shell {:d}{:s}".format( + nn, sc.ANGMOM_TO_SHELL[ll]) + raise sc.SkgenException(msg) + comprs = [ self[(nn, ll)], ] * (atomconfig.maxang + 1) + atomcompressions.append(( comprs, [ (nn, ll), ])) + return atomcompressions + + + + @classmethod + def fromhsd(cls, root, query): + myself = cls() + for shellnode in root: + try: + nn, ll = sc.shell_name_to_ind(shellnode.tag) + except ValueError: + raise hsd.HSDInvalidTagException( + "Invalid shell name '{}'".format(shellnode.tag), shellnode) + wavecompr = sc.hsd_node_factory( + "wavefunction compression", COMPRESSIONS, + query.getvaluenode(shellnode, "."), query) + myself[(nn, ll)] = wavecompr + return myself + + +# Registered compression containers with corresponing hsd name as key +COMPRESSION_CONTAINERS = { + "singleatomcompressions": SingleAtomCompressions, + "multipleatomcompressions": MultipleAtomCompressions, +} diff --git a/sktools/src/sktools/hsd/__init__.py b/sktools/src/sktools/hsd/__init__.py new file mode 100644 index 00000000..b8e805db --- /dev/null +++ b/sktools/src/sktools/hsd/__init__.py @@ -0,0 +1,64 @@ +"""Implements various functionalities for creating and querying the +HSD (Human readable Structured Data) format. +""" + + +class HSDException(Exception): + """Base class for exceptions in the HSD package.""" + pass + + +class HSDQueryError(HSDException): + """Base class for errors detected by the HSDQuery object. + + + Attributes: + filename: Name of the file where error occured (or empty string). + line: Line where the error occurred (or -1). + tag: Name of the tag with the error (or empty string). + """ + + def __init__(self, msg="", node=None): + """Initializes the exception. + + Args: + msg: Error message + node: HSD element where error occured (optional). + """ + super().__init__(msg) + if node is not None: + self.tag = node.gethsd(HSDATTR_TAG, node.tag) + self.file = node.gethsd(HSDATTR_FILE, -1) + self.line = node.gethsd(HSDATTR_LINE, None) + else: + self.tag = "" + self.file = -1 + self.line = None + + +class HSDMissingTagException(HSDQueryError): pass +class HSDInvalidTagException(HSDQueryError): pass +class HSDInvalidTagValueException(HSDQueryError): pass +class HSDMissingAttributeException(HSDQueryError): pass +class HSDInvalidAttributeException(HSDQueryError): pass +class HSDInvalidAttributeValueException(HSDQueryError): pass + + +class HSDParserError(HSDException): + """Base class for parser related errors.""" + pass + + +def unquote(txt): + """Giving string without quotes if enclosed in those.""" + if len(txt) >= 2 and (txt[0] in "\"'") and txt[-1] == txt[0]: + return txt[1:-1] + else: + return txt + + +HSDATTR_PROC = "processed" +HSDATTR_EQUAL = "equal" +HSDATTR_FILE = "file" +HSDATTR_LINE = "line" +HSDATTR_TAG = "tag" \ No newline at end of file diff --git a/sktools/src/sktools/hsd/converter.py b/sktools/src/sktools/hsd/converter.py new file mode 100644 index 00000000..87f643c1 --- /dev/null +++ b/sktools/src/sktools/hsd/converter.py @@ -0,0 +1,123 @@ +"""Contains various converters for the query module. +""" + + +class _HSDConvInt0: + + @staticmethod + def fromhsd(txt): + return int(txt) + + @staticmethod + def tohsd(value): + return str(value) + +#: Converts an +int0 = _HSDConvInt0 + + +class _HSDConvFloat0: + formstr = "{:.12E}" + + @staticmethod + def fromhsd(txt): + return float(txt) + + @staticmethod + def tohsd(value): + return _HSDConvFloat0.formstr.format(value) + +float0 = _HSDConvFloat0 + + +class _HSDConvInt1: + @staticmethod + def fromhsd(txt): + words = txt.split() + return [ _HSDConvInt0.fromhsd(word) for word in words ] + + @staticmethod + def tohsd(values): + return " ".join([ _HSDConvInt0.tohsd(val) for val in values ]) + +int1 = _HSDConvInt1 + + +class _HSDConvFloat1: + + @staticmethod + def fromhsd(txt): + words = txt.split() + return [ _HSDConvFloat0.fromhsd(word) for word in words ] + + @staticmethod + def tohsd(values): + return " ".join([ _HSDConvFloat0.tohsd(val) for val in values ]) + +float1 = _HSDConvFloat1 + + +class _HSDConvStr0: + + @staticmethod + def fromhsd(txt): + return txt + + @staticmethod + def tohsd(value): + return value + +str0 = _HSDConvStr0 + + +class _HSDConvStr1: + + @staticmethod + def fromhsd(txt): + return txt.split() + + @staticmethod + def tohsd(values): + return " ".join(values) + +str1 = _HSDConvStr1 + + +class _HSDConvBool0: + truewords = frozenset(("true", "yes", "on")) + falsewords = frozenset(("false", "no", "off")) + default_true = "Yes" + default_false = "No" + + @staticmethod + def fromhsd(txt): + lowtxt = txt.lower() + if lowtxt in _HSDConvBool0.truewords: + return True + elif lowtxt in _HSDConvBool0.falsewords: + return False + else: + raise ValueError("Unknown boolean value '{}'".format(txt)) + + @staticmethod + def tohsd(value): + if value: + return _HSDConvBool0.default_true + else: + return _HSDConvBool0.default_false + +bool0 = _HSDConvBool0 + + +class _HSDConvBool1: + + @staticmethod + def fromhsd(txt): + words = txt.split() + return [ _HSDConvBool0.fromhsd(word) for word in words ] + + @staticmethod + def tohsd(values): + return " ".join([ _HSDConvBool0.tohsd(value) for value in values ]) + +bool1 = _HSDConvBool1 diff --git a/sktools/src/sktools/hsd/formatter.py b/sktools/src/sktools/hsd/formatter.py new file mode 100644 index 00000000..67537d8a --- /dev/null +++ b/sktools/src/sktools/hsd/formatter.py @@ -0,0 +1,204 @@ +"""Formatting utilities for HSD content. +""" +import sys +import sktools.hsd as hsd + +__all__ = [ "HSDFormatter", "HSDStreamFormatter" ] + + +class HSDFormatter: + """Event controlled formatter producing HSD output.""" + + def __init__(self, indentstring=" ", closecomments=False, defattrib=None): + """Initializes HSDFormatter instance. + + Args: + indentstring: String used for indenting (default: " "). + closecomments: Whether comments after tag closing should indicate + which tag was closed (default: False). + defattrib: When specified, attribute with that name is handled as + default. When it is the only attribute, the name is not printed + just the value. (default: None) + + Note: + Per default, formatter writes to stdout. You can override this + by calling its set_output() method. + """ + self.output = sys.stdout + self._closecomments = closecomments + self._indent = indentstring + self._defattrib = defattrib + self._firsttag = True + self._curindent = "" + self._indentlist = [] + self._equalsigns = [ False, ] + self._last2 = self._last = 0 + + + def set_output(self, output): + """Sets the output for the formatter. + + Args: + output: Open file or file object, to write the formatted output in. + """ + self.output = output + + + def start_tag(self, tagname, options, hsdoptions): + """Starts an HSD tag. + + Args: + tagname: Name of the tag to be started. + options: Dictionary of the tag options. + """ + tagname = hsdoptions.get(hsd.HSDATTR_TAG, tagname) + equalsign = hsdoptions.get(hsd.HSDATTR_EQUAL, False) # opens with '='? + if options: + if (self._defattrib and len(options) == 1 + and self._defattrib in options): + optstr = " [" + options[self._defattrib] + "]" + else: + optlist = [ key + "=" + value + for key, value in options.items() ] + optstr = " [" + ",".join(optlist) + "]" + else: + optstr = "" + if self._firsttag: + indent = self._curindent + self._firsttag = False + else: + indent = "" if self._equalsigns[-1] else "\n" + self._curindent + trailing = " = " if equalsign else " {" + self.output.write(indent + tagname + optstr + trailing) + self._equalsigns.append(equalsign) + self._increaseindentation() + self._last2, self._last = self._last, 1 + + + def close_tag(self, tagname): + """Closes an HSD tag. + + Args: + tagname: Name of the tag to be closed. + """ + self._decreaseindentation() + if not self._equalsigns[-1]: + if self._last == 1: + self.output.write("}") + else: + self.output.write("\n" + self._curindent + "}") + if self._closecomments: + self.output.write(" # " + tagname) + elif self._closecomments and self._last == 2 and self._last2 != 1: + self.output.write(", " + tagname) + del self._equalsigns[-1] + self._last2, self._last = self._last, 2 + + def text(self, text): + """Adds text between tag opening and closing. + + Args: + text: Text to be added. + """ + if self._last == 1 and not self._equalsigns[-1]: + self.output.write("\n") + self.output.write(text) + self._last2, self._last = self._last, 3 + + def _increaseindentation(self): + """Increases indentation level and adjusts indentation string.""" + self._indentlist.append(self._curindent) + if not self._equalsigns[-1]: + self._curindent += self._indent + + def _decreaseindentation(self): + """Decreases indentation level and adjusts indentation string.""" + self._curindent = self._indentlist.pop() + + +class HSDStreamFormatter: + """Reads a HSD feed and writes it on the fly formatted into a stream.""" + + def __init__(self, parser, formatter): + """Intializes HSDFeedPrinter instance. + + Args: + parser: Event controled parser to be used. + formatter: Formatter to be used. + """ + self._parser = parser + self._formatter = formatter + self._parser.start_handler = self._formatter.start_tag + self._parser.close_handler = self._formatter.close_tag + self._parser.text_handler = self._formatter.text + + def feed(self, fileobj): + """Feeds the printer with content. + + The contant in fileobj is passed to the parser, and output is generated + depending on the events. + + Args: + fileobj: File with HSD-content. + """ + self._parser.feed(fileobj) + + +if __name__ == "__main__": + import io + from sktools.hsd.parser import HSDParser + + fp = io.StringIO(""" +Geometry = GenFormat { +2 S +Ga As +1 1 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 +2 2 0.13567730000E+01 0.13567730000E+01 0.13567730000E+01 +0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 +0.27135460000E+01 0.27135460000E+01 0.00000000000E+00 +0.00000000000E+00 0.27135460000E+01 0.27135460000E+01 +0.27135460000E+01 0.00000000000E+00 0.27135460000E+01 +} + +Hamiltonian = DFTB { + SCC [unit=None,dim=0] = Yes + SCCTolerance [toosmall=sure] = 1.0E-007 + MaxSCCIterations = 1000 + Mixer = Broyden { + MixingParameter = 0.200000000000000 + CachedIterations = -1 + } + MaxAngularMomentum { + Ga = "d" + As = "p" + } + Filling = Fermi { + Temperature = 1.0E-006 + IndependentKFilling = No + } + SlaterKosterFiles { + Ga-Ga = "./Ga-Ga.skf" + Ga-As = "./Ga-As.skf" + As-Ga = "./As-Ga.skf" + As-As = "./As-As.skf" + } + KPointsAndWeights { +0.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 1.00000000000000 + } + Charge = 0.000000000000000E+000 + ReadInitialCharges = No + DampXH = No + EwaldParameter = 0.000000000000000E+000 + Eigensolver = DivideAndConquer {} + ThirdOrder = No +} + +Options { + RandomSeed = 0 + WriteHS = No + ShowFoldedCoords = No +} +""") + streamformatter = HSDStreamFormatter(HSDParser(), + HSDFormatter(closecomments=True)) + streamformatter.feed(fp) diff --git a/sktools/src/sktools/hsd/parser.py b/sktools/src/sktools/hsd/parser.py new file mode 100644 index 00000000..66dcb5f0 --- /dev/null +++ b/sktools/src/sktools/hsd/parser.py @@ -0,0 +1,428 @@ +from collections import OrderedDict +import sktools.hsd as hsd + + +__all__ = [ "HSDParser", + "SYNTAX_ERROR", "UNCLOSED_TAG_ERROR", "QUOTATION_ERROR", + "BRACKET_ERROR" ] + +SYNTAX_ERROR = 1 +UNCLOSED_TAG_ERROR = 2 +UNCLOSED_OPTION_ERROR = 3 +UNCLOSED_QUOTATION_ERROR = 4 +ORPHAN_TEXT_ERROR = 5 + +GENERAL_SPECIALS = "{}[]<=\"'#;" +OPTION_SPECIALS = ",]=\"'#{};" + + + +class HSDParser: + """Event based parser for the HSD format. + + The methods `start_handler()`, `close_handler()`, `text_handler()` + and `error_handler()` should be overridden by the actual application. + """ + + def __init__(self, defattrib="default"): + """Initializes the parser. + + Args: + defattrib: Name of the default attribute (default: 'default') + """ + self._fname = "" # Name of file being processed + self._defattrib = defattrib.lower() # def. attribute name + self._checkstr = GENERAL_SPECIALS # special characters to look for + self._oldcheckstr = "" # buffer fo checkstr + self._currenttags = [] # info about opened tags + self._buffer = [] # buffering plain text between lines + self._options = OrderedDict() # options for current tag + self._hsdoptions = OrderedDict() # hsd-options for current tag + self._key = "" # current option name + self._currline = 0 # nr. of current line in file + self._flag_equalsign = False # last tag was opened with equal sign + self._flag_option = False # parser inside option specification + self._flag_quote = False # parser inside quotation + self._flag_haschild = False + self._oldbefore = "" + + + def feed(self, fileobj): + """Feeds the parser with data. + + Args: + fileobj: File like object or name of a file containing the data. + """ + isfilename = isinstance(fileobj, str) + if isfilename: + fp = open(fileobj, "r") + self._fname = fileobj + else: + fp = fileobj + for line in fp.readlines(): + self._parse(line) + self._currline += 1 + if isfilename: + fp.close() + + # Check for errors + if self._currenttags: + line0 = self._currenttags[-1][1] + else: + line0 = 0 + if self._flag_quote: + self._error(UNCLOSED_QUOTATION_ERROR, (line0, self._currline)) + elif self._flag_option: + self._error(UNCLOSED_OPTION_ERROR, (line0, self._currline)) + elif self._currenttags: + self._error(UNCLOSED_TAG_ERROR, (line0, line0)) + elif ("".join(self._buffer)).strip(): + self._error(ORPHAN_TEXT_ERROR, (line0, self._currline)) + + + def start_handler(self, tagname, options, hsdoptions): + """Handler which is called when a tag is opened. + + It should be overriden in the application to handle the event in a + customized way. + + Args: + tagname: Name of the tag which had been opened. + options: Dictionary of the options (attributes) of the tag. + hsdoptions: Dictionary of the options created during the processing + in the hsd-parser. + """ + pass + + + def close_handler(self, tagname): + """Handler which is called when a tag is closed. + + It should be overriden in the application to handle the event in a + customized way. + + Args: + tagname: Name of the tag which had been closed. + """ + pass + + + def text_handler(self, text): + """Handler which is called with the text found inside a tag. + + It should be overriden in the application to handle the event in a + customized way. + + Args: + text: Text in the current tag. + """ + pass + + + def error_handler(self, error_code, file, lines): + """Handler which is called if an error was detected during parsing. + + The default implementation throws a HSDException or a descendant of it. + + Args: + error_code: Code for signalizing the type of the error. + file: Current file name (empty string if not known). + lines: Lines between the error occurred. + """ + error_msg = ( + "Parsing error ({}) between lines {} - {} in file '{}'.".format( + error_code, lines[0] + 1, lines[1] + 1, file)) + raise hsd.HSDParserError(error_msg) + + + def interrupt_handler_hsd(self, command): + """Handles hsd type interrupt. + + The base class implements following handling: Command is interpreted as + a file name (quotes eventually removed). A parser is opened with the + same handlers as the current one, and the given file is feeded in it. + + Args: + command: Unstripped string as specified in the HSD input after + the interrupt sign. + """ + fname = hsd.unquote(command.strip()) + parser = HSDParser(defattrib=self._defattrib) + parser.start_handler = self.start_handler + parser.close_handler = self.close_handler + parser.text_handler = self.text_handler + parser.feed(fname) + + + def interrupt_handler_txt(self, command): + """Handles text type interrupt. + + The base class implements following handling: Command is interpreted as + a file name (quotes eventually removed). The file is opened and its + content is read (without parsing) and added as text. + + Args: + command: Unstripped string as specified in the HSD input after + the interrupt sign. + + Returns: + Unparsed text to be added to the HSD input. + """ + fname = hsd.unquote(command.strip()) + fp = open(fname, "r") + txt = fp.read() + fp.close() + return txt + + + def _parse(self, line): + """Parses a given line.""" + + while True: + sign, before, after = _splitbycharset(line, self._checkstr) + + # End of line + if not sign: + if self._flag_quote: + self._buffer.append(before) + elif self._flag_equalsign: + self._text("".join(self._buffer) + before.strip()) + self._closetag() + self._flag_equalsign = False + elif not self._flag_option: + self._buffer.append(before) + elif before.strip(): + self._error(SYNTAX_ERROR, (self._currline, self._currline)) + break + + # Special character is escaped + elif before.endswith("\\") and not before.endswith("\\\\"): + self._buffer.append(before + sign) + + # Equal sign outside option specification + elif sign == "=" and not self._flag_option: + # Ignore if followed by "{" (DFTB+ compatibility) + if after.lstrip().startswith("{"): + self._oldbefore = before + else: + self._flag_haschild = True + self._hsdoptions[hsd.HSDATTR_EQUAL] = True + self._starttag(before, False) + self._flag_equalsign = True + + # Equal sign inside option specification + elif sign == "=": + self._key = before.strip() + self._buffer = [] + + # Opening tag by curly brace + elif sign == "{" and not self._flag_option: + self._flag_haschild = True + self._starttag(before, self._flag_equalsign) + self._buffer = [] + self._flag_equalsign = False + + # Closing tag by curly brace + elif sign == "}" and not self._flag_option: + self._text("".join(self._buffer) + before) + self._buffer = [] + # If 'test { a = 12 }' occurs, curly brace closes two tags + if self._flag_equalsign: + self._flag_equalsign = False + self._closetag() + self._closetag() + + # Closing tag by semicolon + elif sign == ";" and self._flag_equalsign and not self._flag_option: + self._flag_equalsign = False + self._text(before) + self._closetag() + + # Comment line + elif sign == "#": + self._buffer.append(before) + after = "" + + # Opening option specification + elif sign == "[" and not self._flag_option: + if "".join(self._buffer).strip(): + self._error(SYNTAX_ERROR, (self._currline, self._currline)) + self._oldbefore = before + self._buffer = [] + self._flag_option = True + self._key = "" + self._currenttags.append(("[", self._currline, None)) + self._checkstr = OPTION_SPECIALS + + # Closing option specification + elif sign == "]" and self._flag_option: + value = "".join(self._buffer) + before + key = self._key.lower() if self._key else self._defattrib + self._options[key] = value.strip() + self._flag_option = False + self._buffer = [] + self._currenttags.pop() + self._checkstr = GENERAL_SPECIALS + + # Quoting strings + elif sign == "'" or sign == '"': + if self._flag_quote: + self._checkstr = self._oldcheckstr + self._flag_quote = False + self._buffer.append(before + sign) + self._currenttags.pop() + else: + self._oldcheckstr = self._checkstr + self._checkstr = sign + self._flag_quote = True + self._buffer.append(sign) + self._currenttags.append(('"', self._currline, None)) + + # Closing attribute specification + elif sign == "," and self._flag_option: + value = "".join(self._buffer) + before + key = self._key.lower() if self._key else self._defattrib + self._options[key] = value.strip() + + # Interrupt + elif (sign == "<" and not self._flag_option + and not self._flag_equalsign): + txtint = after.startswith("<<") + hsdint = after.startswith(" 1: + self._error(SYNTAX_ERROR, (self._currline, self._currline)) + self._hsdoptions[hsd.HSDATTR_LINE] = self._currline + self._hsdoptions[hsd.HSDATTR_TAG] = tagname_stripped + tagname_stripped = tagname_stripped.lower() + self.start_handler(tagname_stripped, self._options, self._hsdoptions) + self._currenttags.append( + ( tagname_stripped, self._currline, closeprev, self._flag_haschild)) + self._buffer = [] + self._oldbefore = "" + self._flag_haschild = False + self._options = OrderedDict() + self._hsdoptions = OrderedDict() + + + def _closetag(self): + if not self._currenttags: + self._error(SYNTAX_ERROR, (0, self._currline)) + self._buffer = [] + tag, line, closeprev, self._flag_haschild = self._currenttags.pop() + self.close_handler(tag) + if closeprev: + self._closetag() + + def _error(self, code, lines): + self.error_handler(code, self._fname, lines) + + + +def _splitbycharset(txt, charset): + """Splits a string at the first occurrence of a character in a set. + + Args: + txt: Text to split. + chars: Chars to look for. + + Returns: + Tuple (char, before, after). Char is the character which had been found + (or empty string if nothing was found). Before is the substring before + the splitting character (or the entire string). After is the substring + after the splitting character (or empty string). + """ + for firstpos, char in enumerate(txt): + if char in charset: + break + else: + return '', txt, '' + return txt[firstpos], txt[:firstpos], txt[firstpos + 1:] + + + +def _test_module(): + from io import StringIO + from sktools.hsd.formatter import HSDStreamFormatter, HSDFormatter + formatter = HSDFormatter(closecomments=True) + parser = HSDParser(defattrib="unit") + streamformatter = HSDStreamFormatter(parser, formatter) + stream = StringIO("""Geometry = GenFormat { +2 S + Ga As +1 1 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 +2 2 0.13567730000E+01 0.13567730000E+01 0.13567730000E+01 +0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 +0.27135460000E+01 0.27135460000E+01 0.00000000000E+00 +0.00000000000E+00 0.27135460000E+01 0.27135460000E+01 +0.27135460000E+01 0.00000000000E+00 0.27135460000E+01 +} +Test[unit=1, + dim=3]{} +Hamiltonian = DFTB { + SCC = Yes + SCCTolerance = 1.0E-007 + MaxSCCIterations = 1000 + $MyVariable = 12 + Mixer = Broyden {} + MaxAngularMomentum = { + Ga = "d" + As = "p" + } + Filling = Fermi { + Temperature [Kelvin] = 1.0E-006 + } + SlaterKosterFiles [format=old] { + Ga-Ga = "./Ga-Ga.skf" + Ga-As = "./Ga-As.skf" + As-Ga = "./As-Ga.skf" + As-As = "./As-As.skf" + } + KPointsAndWeights { + 0.0 0.0 0.0 1.0 + } +} +Options { + AtomResolvedEnergies = No + RestartFrequency = 20 + RandomSeed = 0 + WriteHS = No +} +""") + streamformatter.feed(stream) + + +if __name__ == "__main__": + _test_module() diff --git a/sktools/src/sktools/hsd/query.py b/sktools/src/sktools/hsd/query.py new file mode 100644 index 00000000..b40e8518 --- /dev/null +++ b/sktools/src/sktools/hsd/query.py @@ -0,0 +1,590 @@ +"""Contains the object needed to query a HSD-tree in a customized way. +""" + +import sktools.hsd as hsd +from sktools.hsd.tree import Element + +__all__ = ["HSDQueryError", "HSDMissingTagException", "HSDInvalidTagException", + "HSDInvalidTagValueException", "HSDMissingAttributeException", + "HSDInvalidAttributeException", "HSDInvalidAttributeValueException", + "HSDQuery"] + + +class HSDQuery: + """Class providing methods for querying a HSD-tree. + + Parameters + ---------- + checkuniqueness : bool, optional + Whether all query methods except `findchildren()` should check + for the uniqueness of the child found. + markprocessed : bool, optional + Whether the nodes which have been queried should be marked as + processed. + """ + + def __init__(self, checkuniqueness=False, markprocessed=False): + self.chkunique = checkuniqueness + self.mark = markprocessed + + + def findchild(self, node, name, optional=False): + """Finds a child of a node with a given name. + + Parameters + ---------- + node : Element + Parent node. + name : string + Name of the child to look for. + optional : bool, optional + Whether the child is optional only. + + Returns + ------- + child : Element or None + A hsd node if child has been found or None. + + Raises + ------- + HSDMissingTagException + If child was not found and the optional flag was False. + HSDInvalidTagException + Iff there are duplicates of the child and the query object was + initialized with `check_uniqueness=True`. + """ + if self.chkunique: + children = node.findall("./" + name) + if len(children) > 1: + raise hsd.HSDInvalidTagException( + node=children[1], + msg="Double occurance of unique tag '{}'.".format(name)) + child = children[0] if children else None + else: + child = node.find("./" + name) + if child is None and not optional: + raise hsd.HSDMissingTagException( + msg="Required tag '{}' not found.".format(name), node=node) + self.markprocessed(child) + return child + + + def findchildren(self, node, name, optional=False): + """Finds children of a node with given name. + + Parameters + ---------- + node : Element + Parent node. + name : string + Name of the children to look for. + optional : bool, optional + Whether the presence of at least one child is optional. + + Returns + ------- + childlist : list + List of child nodes or empty list. + + Raises + ------ + HSDMissingTagException + if no children were not found and the optional flag was False. + """ + children = node.findall("./" + name) + if not children and not optional: + raise hsd.HSDMissingTagException( + node=node, + msg="No occurrence of required tag '{}' found.".format( + name)) + self.markprocessed(*children) + return children + + + def getchild(self, node, name, optional=False, defattribs=None): + """Returns child with a given name. + + Parameters + ---------- + node : Element + Parent node. + name : string + Name of the child to look for. + optional : bool, optional + If set to `True`, an empty child node will be createad if a child + with the given name does not exist. + defattribs: dict, optional + Default attribute dictionary for the child if it is created. + Only makes sense if keyword argument `optional` was set to `True`. + + Returns + ------- + child : Element + The child with the given name. Either from the original HSD-tree + or the one, which had been created. In latter case, the appropriate + child is inserted into the tree. + + Raises + ------ + HSDMissingTagException + if the child was not found and keyword argument `optional` + was not set to `True`. + """ + child = self.findchild(node, name, optional) + # findchild only returns if child has been found or optional is True. + if child is None: + child = self.setchild(node, name, defattribs) + return child + + + def getvalue(self, node, name, converter=None, defvalue=None, + attribs=None, defattribs=None, hsdblock=False, + returnchild=False): + """Returns the converted value of the data stored in a child with a + given name. + + Parameters + ---------- + node : Element + Parent node. + name : string + Name of the child to look for. + converter : converter object + Object with methods fromhsd() and tohsd() which can + convert between the hsd element and the desired type. See + converters in hsd.converter for examples. + defvalue : arbitrary, optional + Default value used if child has not been found. It will be + converted to text by the tohsd() method of the converter. + attribs : frozen set + Set of attributes the node is allowed to have. + defattribs: dict, optional + Default attribute dictionary used if child has not been found. + hsdblock : bool, optional + Whether the given value should be added in hsd block notation + (enclosed in curly braces) instead of an assignment. + returnchild : bool, optional + Whether not only the value but also the child node should be + returned. + + Returns + ------- + value : arbitrary + The converted value of the child node's text or the default value + if the child had not been found. In latter case, an appropriate + node with the appropriate text representation of the default + value is inserted into the tree. + child : Element, optional + Child node. Only returned, if `returnchild=True` was set. + + Raises + ------ + HSDMissingTagException + If child was not found and no default value had been specified. + HSDInvalidTagValueException + If conversion from tag values was unsuccessful. + HSDInvalidAttributeException + If node posses an attribute which is not allowed. + + Notes + ----- + This method may store a reference to the converter object. + Make sure you pass something which does not change afterwards. + """ + optional = defvalue is not None + child = self.findchild(node, name, optional) + if child is not None: + if len(child): + raise hsd.HSDInvalidTagException("Unexpected children") + self._checkattribs(child, attribs) + if converter: + try: + value = converter.fromhsd(child.text) + except ValueError as ex: + raise hsd.HSDInvalidTagValueException( + msg="Conversion error: " + str(ex), node=child) + else: + value = child.text + return (value, child) if returnchild else value + else: + child = self.setvalue(node, name, converter, defvalue, defattribs, + hsdblock) + return (defvalue, child) if returnchild else defvalue + + + def getvaluenode(self, node, name, defvalue=None, defvaluename=None, + defattribs=None, hsdblock=False, allowtextvalue=False, + returnchild=False): + """Returns the value node stored in a child with a given + name. The child should contain either no nodes at all or only this one. + + Parameters + ---------- + node : Element + Parent node. + name : string + Name of the child to look for. + defvalue : Element, optional + If child is not found, it will be created and contain the specified + node as subnode. + defvaluename : string, optional + If child is not found, it will be created and contain a subnode + with the given name. If name is "", the child node will not + contain a subnode. It is ignored, if defvalue had been specified. + defattribs : dict, optional + Default attribute dictionary used if child has not been found. + hsdblock : bool, optional + Whether the given value should be added in hsd block notation + (enclosed in curly braces) instead of an assignment. + allowtextvalue : bool, optional + If set to yes, the child (if it exists) is allowed to have + no subnode, but a text value instead. In that case the text + value will be deleted and converted into an empty node. + returnchild : bool, optional + + Returns + ------- + node : Element or None + The child node's first child or a node with the specified default + name if child had not been found. In latter case, an + appropriate child node with this as subnode is inserted into the + tree. + child : Element, optional + The child not itself. Only returned if `returnchild=Yes` was set. + + Raises + ------ + HSDMissingTagException + If child was not found and no default value had been specified. + HSDInvalidTagException + If child has more than one child. + + Notes + ----- + This routine should be used, if the child is not a leaf but + contains a further child. + """ + optional = defvalue is not None or defvaluename is not None + child = self.findchild(node, name, optional) + if child is not None: + if len(child) > 1: + raise hsd.HSDInvalidTagException( + "Tag '{}' is not allowed to have" + " more than one child".format(child.tag), node=child) + self.markprocessed(child) + if len(child): + self.markprocessed(child[0]) + return (child[0], child) if returnchild else child[0] + elif allowtextvalue and child.text: + valuenode = Element(child.text) + child.text = "" + child.append(valuenode) + self.markprocessed(valuenode) + return (valuenode, child) if returnchild else valuenode + else: + return (None, child) if returnchild else None + else: + if defvalue is None: + defvalue = Element(defvaluename) + child, valuenode = self.setvaluenode(node, name, defvalue, + defattribs, hsdblock) + return (valuenode, child) if returnchild else valuenode + + + def setchild(self, node, name, attribs=None): + """Creates an empty child with given name and attributes. + + Parameters + ---------- + node : Element + Parent node + name : str + Name of the child to create. + attribs : dict + Dictionary of attributes for the child. + + Returns + ------- + child : Element + Node which had been created and added to the tree. + """ + child = Element(name, attribs or {}) + self.markprocessed(child) + node.append(child) + return child + + + def setvalue(self, node, name, converter, value, attribs=None, + hsdblock=False): + """Creates a child with the given value. + + Parameters + ---------- + node : Element + Parent node. + name : str + Name of the child node to create. + converter : converter object + Object with methods fromhsd() and tohsd() which can + convert between the hsd element and the desired type. See + converters in hsd.converter for examples. + value : arbitrary + Value which should be converted to text by the converter. + attribs : dict + Dictionary with attributes for the child. + hsdblock : bool, optional + Whether the given value should be added in hsd block notation + (enclosed in curly braces) instead of an assignment. + + Returns + ------- + child : Element + The child node which had been created and added. + """ + + child = Element(name, attribs or {}) + if converter: + child.text = converter.tohsd(value) + else: + child.text = value + self.markprocessed(child) + if not hsdblock: + child.sethsd(hsd.HSDATTR_EQUAL, True) + node.append(child) + return child + + + def setvaluenode(self, node, name, value=None, attribs=None, + hsdblock=False): + """Creates a child with a node with a given name as only child. + + Parameters + ---------- + node : Element + Parent node. + name : str + Name of the child to create. + value : str, optional + Name of the node to create as child of the child node. If not + specified, no subchild node is created. + attribs : dict, optional + Attributes of the child created. + hsdblock : bool, optional + Whether the given value should be added in hsd block notation + (enclosed in curly braces) instead of an assignment. + """ + child = Element(name, attribs or {}) + self.markprocessed(child) + if value is not None: + valuenode = Element(value) + self.markprocessed(valuenode) + child.append(valuenode) + else: + valuenode = None + if not hsdblock: + child.sethsd(hsd.HSDATTR_EQUAL, True) + node.append(child) + return child, valuenode + + + + + + def markprocessed(self, *nodes): + """Marks nodes as having been processed, if the query object had been + initialized with the appropriate option. + + Parameters + ---------- + *nodes : list + List of nodes to mark as processed. + """ + if self.mark: + for node in nodes: + if node is not None: + node.sethsd(hsd.HSDATTR_PROC, True) + + + def findunprocessednodes(self, node, allnodes=False): + """Returns list of all nodes which had been not marked as processed. + + Parameters + ---------- + node : Element + Parent node. + allnodes : bool, optional + By default, only highest unprocessed nodes are returned, but + not their children (which should be also unprocessed then). Setting + `allnodes` to True, retuns all nodes. + + Returns + ------- + nodelist : list of Elements + List of all nodes, which have not been queried by a HSDQuery + instance. + """ + unprocessed = [] + for child in node: + if child.gethsd(hsd.HSDATTR_PROC, None) is None: + unprocessed.append(child) + if not allnodes: + continue + unprocessed += self.findunprocessednodes(child, allnodes) + return unprocessed + + + @staticmethod + def _checkattribs(node, attribs): + """Checks whether the node has only the allowed attributes + + Parameters + ---------- + node : Element + Node to investigate. + attribs : frozen set + Set of allowed attributes + + Raises + ------ + HSDInvalidAttributeException + If an invalid attribute is found. + """ + nodekeys = frozenset(node.keys()) + if not nodekeys: + return + if not attribs: + raise hsd.HSDInvalidAttributeException( + node=node, msg="No attributes allowed.") + if not attribs >= nodekeys: + tmp = "', '".join(list(nodekeys - attribs)) + raise hsd.HSDInvalidAttributeException( + node=node, + msg="Tag '{}' contains invalid attribute(s) '{}'.".format( + node.tag, tmp)) + + +def _test_module(): + """Testing module capabilities.""" + from io import StringIO + from sktools.hsd.treebuilder import HSDTreeBuilder + from sktools.hsd.parser import HSDParser + from sktools.hsd.tree import HSDTree + import sktools.hsd.converter as conv + + unit_attr = "unit" + unit_only = frozenset([unit_attr]) + parser = HSDParser(defattrib=unit_attr) + builder = HSDTreeBuilder(parser=parser) + + # Defining force type (scalar, list) + force_units = {"ev/aa": 0.0194469050555} + + # Trivial unit conversion routine. + def multiply_unit(child, value, unitattr, units): + unit = child.get(unitattr) + convfact = units.get(unit.lower(), None) + if convfact is None: + hsd.HSDInvalidAttributeValueException( + node=child, msg="Invalid unit '{}'".format(unit)) + return value * convfact + + stream = StringIO(""" +# Various driver possibilities +# # No driver specification +#Driver {} # Use the default driver (whatever it is) +#Driver = None {} # Use the driver None {} +#Driver = None +Driver = ConjugateGradient { + MaxForceComponent [eV/AA] = 1e-2 +} + +Hamiltonian = DFTB { + # SCC = True + # SCCTolerance = 1e-4 + # MaxSCCIterations = 100 + MaxAngularMomentum { + O = "p" + H = "s" + } + Mixer = Broyden + #Mixer = Broyden { + # MixingParameter = 0.3 + #} + #ReadInitialCharges = No + KPointsAndWeights { + 0.0 0.0 0.0 0.25 + 0.25 0.25 0.25 0.75 + } +} + +Options { + WriteAutotestTag = Yes + UnknownOption = No +} + +#ParserOptions { +# ParserVersion = 4 +#} +""") + root = builder.build(stream) + qy = HSDQuery(markprocessed=True) + # A complex case: If driver was not specified, it defaults to None {} + # If it was specified but nothing was assinged to it (no child) + # it defaults to ConjugateGradient {}. + dtype, driver = qy.getvaluenode(root, "Driver", "None", + allowtextvalue=True, returnchild=True) + # Since the in the previous getvaluenode() call a default had been specified + # dtype can only be None, if "Driver" was in the input, but had no + # child (e.g. 'Driver {}' or 'Driver = ;'). In this case we set + # it to ConjugateGradient + if dtype is None: + dtype = qy.getchild(driver, "ConjugateGradient", optional=True) + if dtype.tag == "None": + pass + elif dtype.tag == "ConjugateGradient": + forcetol, child = qy.getvalue( + dtype, "MaxForceComponent", conv.float0, 1e-4, returnchild=True, + attribs=unit_only) + multiply_unit(child, forcetol, unit_attr, force_units) + elif dtype.tag == "SteepestDescent": + forcetol, child = qy.getvalue( + dtype, "MaxForceComponent", conv.float0, 1e-4, returnchild=True, + attribs=unit_only) + multiply_unit(child, forcetol, unit_attr, force_units) + stepsize = qy.getvalue(dtype, "StepSize", conv.float0, 40.0) + pass + else: + raise hsd.HSDInvalidTagException( + node=dtype, msg="Unknown driver type '{}'".format(dtype.tag)) + + ham = qy.getchild(root, "Hamiltonian") + dftb = qy.getchild(ham, "DFTB") + scc = qy.getvalue(dftb, "SCC", conv.bool0, True) + scctol = qy.getvalue(dftb, "SCCTolerance", conv.float0, 1e-4) + scciter = qy.getvalue(dftb, "MaxSCCIterations", conv.int0, 100) + mangmom = qy.getchild(dftb, "MaxAngularMomentum") + maxangs = [qy.getvalue(mangmom, species, conv.str0) + for species in ["O", "H"]] + mixer = qy.getvaluenode(dftb, "Mixer", "Broyden", allowtextvalue=True) + if mixer.tag == "Broyden": + mixparam = qy.getvalue(mixer, "MixingParameter", conv.float0, 0.2) + else: + raise hsd.HSDInvalidTagException(node=mixer, + msg="Unknown mixer type '{}'.".format( + mixer.tag)) + readcharges = qy.getvalue(dftb, "ReadInitalCharges", conv.bool0, False) + kpoints = qy.getvalue(dftb, "KPointsAndWeights", conv.float1) + if len(kpoints) % 4: + raise hsd.HSDInvalidTagValueException(node=kpoints, + msg="Incorrect number of floats") + options = qy.getchild(root, "Options", optional=True) + autotest = qy.getvalue(options, "WriteAutotestTag", conv.bool0, False) + parseroptions = qy.getchild(root, "ParserOptions", optional=True) + parserversion = qy.getvalue(parseroptions, "ParserVersion", conv.int0, 4) + tree = HSDTree(root) + tree.writehsd() + print("\nUnprocessed: ", qy.findunprocessednodes(root)) + + +if __name__ == "__main__": + _test_module() diff --git a/sktools/src/sktools/hsd/test.hsd b/sktools/src/sktools/hsd/test.hsd new file mode 100644 index 00000000..33bb7e55 --- /dev/null +++ b/sktools/src/sktools/hsd/test.hsd @@ -0,0 +1,36 @@ +Geometry = GenFormat { +<<< "test.txt" +} + +< 1: + raise hsd.HSDException("Unclosed variable defintion") + builder = self._builders[0] + elem = builder.close() + return elem + + + @property + def path(self): + """List of elements representing the path to the current element.""" + path = [] + for builder in self._builders: + path += builder.path + return path + + + def _is_variable(self, name): + """Checks whether given name is a variable.""" + return name.startswith(self.VARIABLE_NAME_PREFIX) + + + def _lookup_variable(self, varname): + """Looks up a variable in the currently opened scopes. + + Args: + varname: Name of the variable. + + Returns: + Variable element or None, if not found. + """ + variable = None + path_expression = "./" + varname + for ind in range(len(self._scopes) - 1, -1, -1): + scope = self._scopes[ind] + variable = scope.find(path_expression) + if variable is not None: + break + return variable + + + def _convert_variable_to_tag_name(self, varname): + """Converts a variable to a valid XML-tag""" + tagname = self.VARDEF_TAG_PREFIX + varname[1:].lower() + return tagname + + + +class HSDTreeBuilder: + """Builds HSD-tree by connecting parser with builder.""" + + def __init__(self, parser=None, builder=None): + """Initializes a HSDTreeBuilder instance. + + Args: + parser: Event-driven HSD-parser (default: HSDParser) + builder: Event-driven tree builder (default: TreeBuilder) + """ + if parser: + self.parser = parser + else: + self.parser = hsdparser.HSDParser() + if builder: + self.builder = builder + else: + self.builder = TreeBuilder() + self.parser.start_handler = self.builder.start + self.parser.close_handler = self.builder.end + self.parser.text_handler = self.builder.data + + + def build(self, fileobj): + """Builds a HSD-tree from a file-like object. + + Args: + fileobj: File like object containing an HSD in text form. + + Returns: + HSD-tree + """ + self.parser.feed(fileobj) + return self.builder.close() + + + +if __name__ == "__main__": + from io import StringIO + import sys + stream = StringIO("""Geometry = GenFormat { +2 S +Ga As +1 1 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 +2 2 0.13567730000E+01 0.13567730000E+01 0.13567730000E+01 +0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 +0.27135460000E+01 0.27135460000E+01 0.00000000000E+00 +0.00000000000E+00 0.27135460000E+01 0.27135460000E+01 +0.27135460000E+01 0.00000000000E+00 0.27135460000E+01 +} +Test[unit=1, + dim=3]{} + +$SlakoDef { + SlaterKosterFiles [format=old] { + $SpecValue = "As-As.skf" + Ga-Ga = "./Ga-Ga.skf" + Ga-As = "./Ga-As.skf" + As-Ga = "./As-Ga.skf" + As-As = $SpecValue + } +} + +Hamiltonian = DFTB { + $MyTemp = 1000 + $Filling = Fermi { + Temperature [Kelvin] = $mytemp + } + + SCC = Yes + SCCTolerance = 1.0E-007 + MaxSCCIterations = 1000 + Mixer = Broyden {} + MaxAngularMomentum { + Ga = "d" + As = "p" + } + Filling = $Filling + $SlakoDef + KPointsAndWeights { + 0.0 0.0 0.0 1.0 + } +} + +Options { + AtomResolvedEnergies = No + RestartFrequency = 20 + RandomSeed = 0 + WriteHS = No +}""") + mybuilder = HSDTreeBuilder(parser=hsd.parser.HSDParser(), + builder=VariableTreeBuilder()) + hsdnodes = mybuilder.build(stream) + tree = hsdtree.HSDTree(hsdnodes) + tree.write(sys.stdout, encoding="unicode") + tree.writehsd(sys.stdout) diff --git a/sktools/src/sktools/oldskfile.py b/sktools/src/sktools/oldskfile.py new file mode 100644 index 00000000..ac6e101f --- /dev/null +++ b/sktools/src/sktools/oldskfile.py @@ -0,0 +1,380 @@ +"""Contains the representation of the old SK-file.""" + +import os.path + +import numpy as np + +from . import common as sc +import sktools.twocenter_grids + + + +# Dummy null spline +NULL_SPLINE = """ +Spline +12 0.0553585 +112.9353346817185 2.801373701455403 -0.1119994835253462 +0.035 0.0375 0.204206 -35.71077211012958 2016.504000000031 24177.93762071238 +0.0375 0.04 0.12791 -25.17491577974109 2197.838532155373 -120889.6881035729 +0.04 0.0425 0.07682029999999999 -16.45240477090621 1291.165871378576 -57585.58520643491 +0.0425 0.045 0.0428593 -11.07630513663398 859.2739823303137 16659.22892930921 +0.045 0.04533 0.0207993 -6.467574682557872 984.2181993001326 -2167173.572075024 +0.04533 0.045334 0.0186943 -6.526006277016704 -1161.283637054166 353213222.4907721 +0.045334 0.046259 0.0186682 -6.518342311433599 3077.275032831984 -1324559.571220061 +0.046259 0.047184 0.0142234 -4.225362350069925 -598.3777773036936 561811.1110751317 +0.047184 0.0493131 0.0102476 -3.890262342340788 960.6480559297889 -100763.5210502349 +0.0493131 0.0503195 0.00534702 -1.169934109375229 317.0412179256228 -143026.9144497911 +0.0503195 0.0513259 0.00434492 -0.9663840979460291 -114.7856421811885 10348.58893883691 +0.0513259 0.0553585 0.00326664 -1.165980214261954 -83.5411824570522 -5782.515169399558 27636944.82683195 -3877959552.095367 + +This SPLINE is just a DUMMY-SPLINE!!!!!!!!!!!!!!! +""" + +FLOAT_FORMSTR = " {:20.12E}" + + +class OldSKFile: + + def __init__(self, extended, dr, hamiltonian, overlap, onsites=None, + spinpolerror=None, hubbardus=None, occupations=None, mass=None, + splinerep=None, polyrep=None): + self.extended = extended + self.dr = dr + self.nr = hamiltonian.shape[0] + self.hamiltonian = hamiltonian + self.overlap = overlap + self.homo = onsites is not None + self.onsites = onsites + self.spinpolerror = spinpolerror + self.hubbardus = hubbardus + self.occupations = occupations + self.mass = mass + self.splinerep = splinerep + self.polyrep = polyrep + + + @classmethod + def fromfile(cls, fname, homo): + fp = open(fname, "r") + line = fp.readline() + extended = line.startswith("@") + nshell = 4 if extended else 3 + ninteg = 20 if extended else 10 + if extended: + line = fp.readline() + words = sc.split_fortran_fields(line) + dr = float(words[0]) + nr = int(words[1]) + if homo: + values = sc.convert_fortran_floats(fp.readline()) + onsites = np.array(values[0:nshell], dtype=float) + spinpolerror = float(values[nshell]) + hubbardus = np.array(values[nshell+1:2*nshell+1], dtype=float) + occupations = np.array(values[2*nshell+1:3*nshell+1], dtype=float) + else: + onsites = spinpolerror = hubbardus = occupations = None + values = sc.convert_fortran_floats(fp.readline()) + if homo: + mass = values[0] + else: + mass = None + polyrep = np.array(values[1:10], dtype=float) + hamiltonian = np.zeros(( nr, ninteg ), dtype=float) + overlap = np.zeros(( nr, ninteg ), dtype=float) + for iline in range(nr - 1): + values = sc.convert_fortran_floats(fp.readline()) + hamiltonian[iline,0:ninteg] = values[0:ninteg] + overlap[iline,0:ninteg] = values[ninteg:2*ninteg] + # Currently, everything after SK table is treated as spline repulsive + splinerep = fp.read() + fp.close() + return cls(extended, dr, hamiltonian, overlap, onsites, spinpolerror, + hubbardus, occupations, mass, splinerep, polyrep) + + + def tofile(self, fname): + fp = open(fname, "w") + if self.extended: + fp.write("@ Data set with f-electrons, for DFTB+ only\n") + fp.write("{:f} {:d}\n".format(self.dr, self.nr)) + nshell = 4 if self.extended else 3 + ninteg = 20 if self.extended else 10 + shellfloats = FLOAT_FORMSTR * nshell + if self.homo: + fp.write(shellfloats.format(*self.onsites)) + fp.write(FLOAT_FORMSTR.format(self.spinpolerror)) + fp.write(shellfloats.format(*self.hubbardus)) + fp.write(shellfloats.format(*self.occupations)) + fp.write("\n") + if self.homo: + fp.write(FLOAT_FORMSTR.format(self.mass)) + else: + fp.write(FLOAT_FORMSTR.format(0.0)) + if self.polyrep is not None: + polyfloats = FLOAT_FORMSTR * 9 + fp.write(polyfloats.format(self.polyrep)) + else: + fp.write(" 0.0" * 9) + fp.write(" 0.0" * 10 + "\n") + integralfloats = FLOAT_FORMSTR * ninteg + for ir in range(self.nr): + fp.write(integralfloats.format(*self.hamiltonian[ir,:])) + fp.write(integralfloats.format(*self.overlap[ir,:])) + fp.write("\n") + if self.splinerep: + fp.write("\n") + fp.write(self.splinerep) + fp.write("\n") + fp.close() + + + +class OldSKFileSet: + + def __init__(self, grid, hamiltonian, overlap, basis1, basis2=None, + onsites=None, spinpolerror=None, hubbardus=None, + occupations=None, mass=None, dummy_repulsive=False): + + self._dr, self._nr0 = self._get_grid_parameters(grid) + self._dummy_repulsive = dummy_repulsive + self._hamiltonian = hamiltonian + self._overlap = overlap + self._basis1 = basis1 + self._homo = basis2 is None + + if self._homo: + self._basis2 = self._basis1 + self._onsites = self._get_basis_indexed_dict(basis1, onsites) + self._hubbardus = self._get_basis_indexed_dict(basis1, hubbardus) + self._occupations = self._get_basis_indexed_dict(basis1, + occupations) + self._spinpolerror = spinpolerror + self._mass = mass + else: + self._basis2 = basis2 + + self._SK_for_shell1, self._shells_in_SK1 = self._split_basis(basis1) + if not self._homo: + self._SK_for_shell2, self._shells_in_SK2 = self._split_basis(basis2) + else: + self._SK_for_shell2 = self._SK_for_shell1 + self._shells_in_SK2 = self._shells_in_SK1 + self._integmap = self.get_integralmap(self._basis1, self._basis2) + + + def tofile(self, workdir, elem1name, elem2name): + skfiles = self._get_skfiles() + skfilenames = self._write_skfiles(workdir, elem1name, elem2name, + skfiles) + return skfilenames + + + def _get_skfiles(self): + """Returns array of old SK file object pairs (A, B) representing the + interaction between two atoms. + """ + nsk1, nsk2 = len(self._shells_in_SK1), len(self._shells_in_SK2) + # Loop over the number of SK-files necessary to represent element + skfiles = [] + for isk1 in range(nsk1): + skfiles1 = [] + for isk2 in range(nsk2): + homoskfile = self._homo and isk1 == isk2 + skfile1 = self._get_skfile(isk1, isk2, homoskfile=homoskfile, + reverse=False) + if homoskfile: + skfile2 = None + else: + skfile2 = self._get_skfile(isk1, isk2, homoskfile=False, + reverse=True) + skfiles1.append(( skfile1, skfile2 )) + skfiles.append(skfiles1) + return skfiles + + + def _get_skfile(self, isk1, isk2, homoskfile, reverse): + shells1 = self._shells_in_SK1[isk1] + shells2 = self._shells_in_SK2[isk2] + maxang1 = self._get_highest_angmom(shells1) + maxang2 = self._get_highest_angmom(shells2) + extended = (maxang1 == 3 or maxang2 == 3) + maxang = 3 if extended else 2 + if extended: + skintegmap = self._get_oldsk_integralmap(3) + ninteg = 20 + else: + skintegmap = self._get_oldsk_integralmap(2) + ninteg = 10 + oldsk_ham = self._map_to_oldsk_integral_table( + self._hamiltonian, shells1, shells2, skintegmap, ninteg, reverse) + oldsk_over = self._map_to_oldsk_integral_table( + self._overlap, shells1, shells2, skintegmap, ninteg, reverse) + padding = np.zeros(( self._nr0 - 1, ninteg ), dtype=float) + oldsk_ham = np.vstack(( padding, oldsk_ham )) + oldsk_over = np.vstack(( padding, oldsk_over )) + if self._dummy_repulsive: + repulsive = NULL_SPLINE + else: + repulsive = None + if homoskfile: + onsites = self._map_to_oldsk_shell_values(self._onsites, shells1, + maxang) + hubbus = self._map_to_oldsk_shell_values(self._hubbardus, shells1, + maxang) + occupations = self._map_to_oldsk_shell_values(self._occupations, + shells1, maxang) + skfile = OldSKFile( + extended, self._dr, oldsk_ham, oldsk_over, onsites=onsites, + spinpolerror=self._spinpolerror, hubbardus=hubbus, + occupations=occupations, mass=self._mass, splinerep=repulsive) + else: + skfile = OldSKFile(extended, self._dr, oldsk_ham, oldsk_over, + splinerep=repulsive) + return skfile + + + @staticmethod + def _write_skfiles(workdir, elem1, elem2, skfiles): + elem1_capital = sc.capitalize_elem_name(elem1) + elem2_capital = sc.capitalize_elem_name(elem2) + form_elem1 = "{elem:s}:{ind:d}" if len(skfiles) > 1 else "{elem:s}" + form_elem2 = "{elem:s}:{ind:d}" if len(skfiles[0]) > 1 else "{elem:s}" + skfilenames = [] + for isk1, skfiles1 in enumerate(skfiles): + elem1name = form_elem1.format(elem=elem1_capital, ind=isk1+1) + for isk2, skfile12 in enumerate(skfiles1): + elem2name = form_elem2.format(elem=elem2_capital, ind=isk2+1) + skfile_ab, skfile_ba = skfile12 + fname = "{}-{}.skf".format(elem1name, elem2name) + skfilenames.append(fname) + skfile_ab.tofile(os.path.join(workdir, fname)) + if skfile_ba is not None: + fname = "{}-{}.skf".format(elem2name, elem1name) + skfilenames.append(fname) + skfile_ba.tofile(os.path.join(workdir, fname)) + return skfilenames + + + @staticmethod + def get_integralmap(basis1, basis2): + """Gives column index for integral .""" + integmap = {} + ind = 0 + for n1, l1 in basis1: + for n2, l2 in basis2: + for mm in range(min(l1, l2) + 1): + integmap[n1, l1, n2, l2, mm] = ind + ind += 1 + return integmap + + + @staticmethod + def _get_oldsk_integralmap(lmax): + skintegmap = {} + ind = 0 + for l1 in range(lmax, -1, -1): + for l2 in range(lmax, l1 - 1, -1): + for mm in range(min(l1, l2) + 1): + skintegmap[l1, l2, mm] = ind + ind += 1 + return skintegmap + + + @staticmethod + def _get_highest_angmom(shells): + maxang = 0 + for nn, ll in shells: + maxang = max(maxang, ll) + return maxang + + + def _map_to_oldsk_integral_table(self, mytable, shells1, shells2, + skintegmap, ninteg, reverse): + oldsk_table = np.zeros(( mytable.shape[0], ninteg )) + for n1, l1 in shells1: + for n2, l2 in shells2: + for mm in range(min(l1, l2) + 1): + if reverse: + ioldsk = skintegmap.get(( l2, l1, mm ), None) + prefac = float(1 - 2 * ((l1 + l2) % 2)) + else: + ioldsk = skintegmap.get(( l1, l2, mm), None) + prefac = 1.0 + if ioldsk is not None: + imy = self._integmap[n1, l1, n2, l2, mm] + oldsk_table[:,ioldsk] = prefac * mytable[:,imy] + return oldsk_table + + @staticmethod + def _map_to_oldsk_shell_values(myvalues, shells, maxang): + oldsk_values = np.zeros(maxang + 1, dtype=float) + for nn, ll in shells: + oldsk_values[maxang - ll] = myvalues[nn, ll] + return oldsk_values + + + @staticmethod + def _split_basis(basis): + # Max angular momentum + lmax = 0 + for nn, ll in basis: + lmax = max(lmax, ll) + + # separete valence shells by angular momentum + basis_per_l = [ None, ] * (lmax + 1) + for nn, ll in basis: + if basis_per_l[ll] is None: + basis_per_l[ll] = [ nn, ] + else: + basis_per_l[ll].append(nn) + + # How many sk table compatible atoms can represent a given basis + nskatom = 0 + for lbasis in basis_per_l: + if lbasis is not None: + # noinspection PyTypeChecker + nskatom = max(nskatom, len(lbasis)) + + lastshells = [ None, ] * (lmax + 1) + # Gives the atom number for given shell (nn, ll) + iskatom_shell = {} + # Gives the shells of a given iskatom ii. + shells_iskatom = [] + for iskatom in range(nskatom): + shells = [] + hasshell = False + for ll in range(lmax, -1, -1): + lbasis = basis_per_l[ll] + # noinspection PyTypeChecker + if len(lbasis): + nn = lbasis.pop(0) + lastshells[ll] = nn + iskatom_shell[nn, ll] = iskatom + hasshell = True + elif hasshell: + nn = lastshells[ll] + else: + continue + shells.insert(0, ( nn, ll )) + shells_iskatom.append(shells) + + return iskatom_shell, shells_iskatom + + + @staticmethod + def _get_grid_parameters(grid): + if not isinstance(grid, sktools.twocenter_grids.EquidistantGrid): + raise sc.SkgenException( + "Can not handle grid type " + grid.__class__.__name__) + dr = grid.gridseparation + nr0 = int(np.rint(grid.gridstart / grid.gridseparation)) + if np.abs(nr0 * dr - grid.gridstart) > 1e-12: + msg = "Start distance incommensurable with grid separation" + raise sc.SkgenException(msg) + return dr, nr0 + + + @staticmethod + def _get_basis_indexed_dict(basis, values): + mydict = { shell: value for shell, value in zip(basis, values) } + return mydict \ No newline at end of file diff --git a/sktools/src/sktools/radial_grid.py b/sktools/src/sktools/radial_grid.py new file mode 100644 index 00000000..e4bc173c --- /dev/null +++ b/sktools/src/sktools/radial_grid.py @@ -0,0 +1,53 @@ +import numpy as np +import sktools.common as sc + + +class RadialGrid: + + FLOAT_TOLERANCE = 1e-8 + + def __init__(self, rr, weights): + if len(rr) != len(weights): + raise ValueError("Length of radial grid and weights not compatible") + self.nr = len(rr) + self.rr = rr + self.weights = weights + + def __eq__(self, other): + if self.nr != other.nr: + return False + if np.max(np.abs(self.rr - other.rr)) > self.FLOAT_TOLERANCE: + return False + if np.max(np.abs(self.weights - other.weights)) > self.FLOAT_TOLERANCE: + return False + return True + + def dot(self, f1, f2): + return np.sum(self.rr * self.rr * self.weights * f1 * f2) + + +class GridData: + + FLOAT_FORMAT = "{:21.12E}" + + def __init__(self, grid, data): + if grid.nr != len(data): + raise ValueError("Incompatible grids") + self.grid = grid + self.data = np.reshape(data, (grid.nr, -1)) + + + def tofile(self, fobj): + with sc.FileFromStringOrHandler(fobj, "w") as fp: + fp.write("{:d}\n".format(self.grid.nr)) + ndata = len(self.data[0]) + formstr = self.FLOAT_FORMAT * (ndata + 2) + "\n" + for ii in range(self.grid.nr): + fp.write(formstr.format(self.grid.rr[ii], self.grid.weights[ii], + *self.data[ii])) + + +VNUC = 0 +VHARTREE = 1 +VXCUP = 2 +VXCDOWN = 3 \ No newline at end of file diff --git a/sktools/src/sktools/skdef.py b/sktools/src/sktools/skdef.py new file mode 100644 index 00000000..971ca490 --- /dev/null +++ b/sktools/src/sktools/skdef.py @@ -0,0 +1,525 @@ +"""Parser for the skdefs.hsd file""" + +import re +import copy +import numpy as np +import sktools.hsd as hsd +import sktools.hsd.converter as conv +from sktools.hsd.treebuilder import HSDTreeBuilder, VariableTreeBuilder +from sktools.hsd.query import HSDQuery +from sktools.hsd.parser import HSDParser +from . import common as sc +from . import compressions +from . import twocenter_grids +from . import calculators + + +CURRENT_SKDEF_VERSION = 1 +ENABLED_SKDEF_VERSIONS = frozenset([ CURRENT_SKDEF_VERSION ]) + + +class Skdef(sc.ClassDict): + """Represents the full input file 'skdef.hsd'. + + Attributes + ---------- + globals : Globals + Global settings + atomparams : AtomParameters + Various atomic parameters + oncenterparameters : OnecenterParameters + Parameters influencing the technical details of the one-center + calculation. + twocenterparameters : TwocenterParameters + Parameters influencing the technical details of the two-center + calculation. + """ + @classmethod + def fromhsd(cls, root, query): + myself = cls() + version = query.getvalue(root, "skdefversion", conv.int0) + cls._check_version(version) + node = query.getchild(root, "globals") + myself.globals = Globals.fromhsd(node, query) + node = query.getchild(root, "atomparameters") + myself.atomparameters = AtomParameters.fromhsd(node, query) + node = query.getchild(root, "onecenterparameters") + myself.onecenterparameters = OnecenterParameters.fromhsd(node, query) + node = query.getchild(root, "twocenterparameters") + myself.twocenterparameters = TwocenterParameters.fromhsd(node, query) + return myself + + @classmethod + def fromfile(cls, fileobj): + parser = HSDParser() + builder = VariableTreeBuilder() + treebuilder = HSDTreeBuilder(parser=parser, builder=builder) + openclose = isinstance(fileobj, str) + if openclose: + fp = open(fileobj, "r") + else: + fp = fileobj + tree = treebuilder.build(fp) + if openclose: + fp.close() + query = HSDQuery(checkuniqueness=True, markprocessed=True) + return cls.fromhsd(tree, query) + + + def update(self, other): + """Extends data with the data in an other skdefs. + + Parameters + ---------- + other : Skdef + Data to use for extending. + """ + if other.globals != self.globals: + raise sc.SkgenException( + "Incompatible globals, skdefs can not be merged.") + self.atomparameters.update(other.atomparameters) + + + @staticmethod + def _check_version(version): + if version not in ENABLED_SKDEF_VERSIONS: + msg = "Invalid skdef version {:d}".format(version) + raise sc.SkgenException(msg) + + + +class Globals(sc.ClassDict): + """Global settings. + + Attributes + ---------- + functional : int + DFT functional (sktools.common.FUNCTIONAL_{LDA,PBE}). + radius : int + Superposition type (sktools.common.SUPERPOSITION_{POTENTIAL,DENSITY}) + """ + @classmethod + def fromhsd(cls, root, query): + """Creates instance from a HSD-node and with given query object.""" + + xcfunctional, child = query.getvalue(root, "xcfunctional", conv.str0, + returnchild=True) + if xcfunctional not in sc.XC_FUNCTIONAL_TYPES: + raise hsd.HSDInvalidTagValueException( + "Invalid functional type '{}'".format(xcfunctional), child) + superpos, child = query.getvalue(root, "superposition", conv.str0, + returnchild=True) + if superpos not in sc.SUPERPOSITION_TYPES: + raise hsd.HSDInvalidTagValueException( + "Invalid superposition type '{}'".format(superpos), child) + + myself = cls() + myself.xcfunctional = sc.XC_FUNCTIONAL_TYPES[xcfunctional] + myself.superposition = sc.SUPERPOSITION_TYPES[superpos] + return myself + + + +class AtomParameters(sc.ClassDict): + """Atomic parameters + + Attributes + ---------- + "elementname" : ClassDict + ClassDict with fields `atomconfig` (type `AtomConfig`) and `dftbatom` + (type `DftbAtom`) fields containing those settings for the given atom. + """ + @classmethod + def fromhsd(cls, root, query): + myself = cls() + for elemnode in query.findchildren(root, "*"): + try: + atomparam = sc.ClassDict() + node = query.getchild(elemnode, "atomconfig") + atomparam.atomconfig = AtomConfig.fromhsd(node, query) + node = query.getchild(elemnode, "dftbatom") + atomparam.dftbatom = DftbAtom.fromhsd(node, query) + except sc.SkgenException as ex: + msg = "AtomParameters/{}:\n{}".format( + elemnode.tag, ex) + raise sc.SkgenException(msg) + myself[elemnode.tag] = atomparam + return myself + + +class AtomConfig(sc.ClassDict): + """Represents the configuration of a free atom. + + Attributes + ---------- + znuc : float + Nuclear charge. + mass : float + Mass of the atom. + occupations : list + Either spin polarized (by default) or spin averaged occupation. + It can be changed via the `make_spinpolarized` `make_spinaveraged` + methods. + occupations_spinpol : list + List of (nup, ndown) tuples for each shell (e.g. + [[ (1.0, 1.0), (1.0, 1.0) ], [ (3.0, 2.0), ]] for N) + occupations_spinavg : list + Same as occupations but averaged out for spin up and spin down. + valenceshells : list + List of (n, l) tuples representing the valence shells. + relativistics : int + Type of relativistics. (None, "zora") + maxang : int + Maximal angular momentum. + nelec : float + Number of electrons. + spinpolarized : bool + Whether atom is spinpolarized. + charge : float + Charge of the atom. + charged : bool + Whether atom has a net charge. + """ + + # Tolerance for treating electron populations being equal + _ELECTRON_TOL = 1e-8 + + + def __init__(self, atomicnumber, mass, occupations, valenceshells, + relativistics, charge=0.0): + super().__init__() + self.atomicnumber = atomicnumber + self.mass = mass + + # Sort valenceshells (and occupations) by ascending nn and ll + tmp = [ nn * (sc.MAX_ANGMOM + 1) + ll for nn, ll in valenceshells ] + self.valenceshells = [ valenceshells[ii] for ii in np.argsort(tmp) ] + self.occupations_spinpol = occupations + self.occupations = self.occupations_spinpol + + self.relativistics = sc.RELATIVISTICS_TYPES.get(relativistics, None) + if self.relativistics is None: + raise sc.SkgenException( + "Invalid relativistics type '{}'".format(relativistics)) + + # If any valenceshell has higher n or l as occupations are listed for, + # fill up occupations with zeros accordingly + maxl = 0 + maxn = [ 0, ] * (sc.MAX_ANGMOM + 1) + for nn, ll in valenceshells: + maxl = max(ll, maxl) + maxn[ll] = max(nn, maxn[ll]) + if maxl > len(self.occupations) - 1: + self.occupations += [ [], ] * (maxl - len(self.occupations) + 1) + for ll, occ_l in enumerate(occupations): + # At least one occupation for each angular momentum up to lmax. + if not len(occ_l): + occ_l.append(( 0.0, 0.0 )) + # Extend occupations up to highest principal quantum number in + # valence shells + if maxn[ll] - ll > len(occ_l): + occ_l.extend([ (0.0, 0.0) ] * (maxn[ll] - ll - len(occ_l))) + self.maxang = len(self.occupations) - 1 + + self.nelec = 0.0 + self.spinpolarized = False + self.occupations_spinavg = [] + for shellocc in self.occupations: + occ_l = [] + for nup, ndown in shellocc: + nn = nup + ndown + self.nelec += nn + occ_l.append(( nn / 2.0, nn / 2.0)) + self.spinpolarized = (self.spinpolarized + or abs(nup - ndown) > self._ELECTRON_TOL) + self.occupations_spinavg.append(occ_l) + self.charge = self.atomicnumber - self.nelec + if abs(self.charge - charge) > self._ELECTRON_TOL: + msg = "Mismatch between specified total charge and occupations " \ + "({:.8f} vs. {:.8f})".format(charge, self.charge) + raise sc.SkgenException(msg) + self.charged = abs(self.charge > self._ELECTRON_TOL) + + + def make_spinpolarized(self): + """Make sure `occupation` attribute represents spin polarized state.""" + self.occupations = copy.deepcopy(self.occupations_spinpol) + + + def make_spinaveraged(self): + """Make sure `occupation` attribute represents spin averaged state.""" + self.occupations = copy.deepcopy(self.occupations_spinavg) + + + @classmethod + def fromhsd(cls, root, query): + """Initializes an AtomProperties object from a HSD-tree. + + Parameters + ---------- + root : HSDTree instance + Root of the node containing the information. + query : HSDQuery instance + Object used for querying the tree. + + Returns + ------- + atomconfig : AtomProperties + Initialized Atomconfig instance. + """ + znuc, child = query.getvalue(root, "atomicnumber", conv.float0, + returnchild=True) + if znuc < 0.0 or znuc > 95.0: + raise hsd.HSDInvalidTagValueException( + msg="Invalid nuclear charge {:f}".format(znuc), + node=child) + mass, child = query.getvalue(root, "mass", conv.float0, + returnchild=True) + if mass < 0 or mass > 250.0: + raise hsd.HSDInvalidTagValueException( + msg="Invalid atomic mass {:f}".format(mass), node=child) + + occupations = [] + occnode = query.findchild(root, "occupations") + for ll, shellname in enumerate(sc.ANGMOM_TO_SHELL): + occ_l = [] + for nn in range(ll + 1, sc.MAX_PRINCIPAL_QN): + txt = "{:d}{:s}".format(nn, shellname) + shelloccnode = query.findchild(occnode, txt, optional=True) + if shelloccnode is None: + break + tmp = query.getvalue(shelloccnode, ".", conv.float1) + if len(tmp) != 2: + raise hsd.HSDInvalidTagValueException( + msg="Invalid number of occupation numbers", + node=shelloccnode) + occ_l.append((tmp[0], tmp[1])) + if len(occ_l): + occupations.append(occ_l) + + valshellnames, child = query.getvalue(root, "valenceshells", + conv.str1, returnchild=True) + valshells = [] + for valshellname in valshellnames: + try: + valshell = sc.shell_name_to_ind(valshellname) + valshells.append(valshell) + except ValueError: + raise hsd.HSDInvalidTagValueException( + msg="Invalid shell name '{}'".format(valshellname), + node=child) + + relattype, child = query.getvalue(root, "relativistics", conv.str0, + "none", returnchild=True) + relattype = relattype.lower() + if relattype not in sc.RELATIVISTICS_TYPES: + raise hsd.HSDInvalidTagValueException( + msg="Invalid relativistics type '{}'".format(relattype)) + + return cls(znuc, mass, occupations, valshells, relattype) + + + def __eq__(self, other): + if not isinstance(other, AtomConfig): + return False + if (abs(self.atomicnumber - other.atomicnumber) + > sc.INPUT_FLOAT_TOLERANCE): + return False + if abs(self.mass - other.mass) > sc.INPUT_FLOAT_TOLERANCE: + return False + if len(self.occupations_spinpol) != len(other.occupations_spinpol): + return False + for occ_l1, occ_l2 in zip(self.occupations_spinpol, + other.occupations_spinpol): + if len(occ_l1) != len(occ_l2): + return False + occ1 = np.array(occ_l1) + occ2 = np.array(occ_l2) + if np.any(np.abs(occ1 - occ2) > sc.INPUT_FLOAT_TOLERANCE): + return False + if self.valenceshells != other.valenceshells: + return False + if self.relativistics != other.relativistics: + return False + return True + + + +class DftbAtom(sc.ClassDict): + """Contains settings related to atoms in DFTB. + + Attributes + ---------- + shellresolved : bool + Whether shell resolved Hubbard U values should be used. + customizedonsites : dict + (n, l) indexed dictionary of onsite values which should be + overriden. + customizedhubbards : dict + (n, l) indexed dictionary with override values for the + Hubbard parameter. + customizedoccupations: dict + (n, l) indexed dictionary with override values for the + occupations. + densitycompression : compression object + Contains the details how density should be compressed. + wavecompressions : compression objects + Contains the type of compressions for the wavefunction. + """ + + @classmethod + def fromhsd(cls, root, query): + """Creates instance from a HSD-node and with given query object.""" + + shellresolved = query.getvalue(root, "shellresolved", conv.bool0) + customonsites_node = query.getchild(root, "customizedonsites", + optional=True) + customonsites = sc.getshellvalues(customonsites_node, query) + customhubbards_node = query.getchild(root, "customizedhubbards", + optional=True) + customhubbards = sc.getshellvalues(customhubbards_node, query) + customoccupations_node = query.getchild(root, "customizedoccupations", + optional=True) + customoccupations = sc.getshellvalues(customoccupations_node, query) + denscompr = sc.hsd_node_factory( + "density compression", compressions.COMPRESSIONS, + query.getvaluenode(root, "densitycompression"), query) + wavecomprs = sc.hsd_node_factory( + "wave compression container", compressions.COMPRESSION_CONTAINERS, + query.getvaluenode(root, "wavecompressions"), query) + myself = cls() + myself.shellresolved = shellresolved + myself.densitycompression = denscompr + myself.wavecompressions = wavecomprs + myself.customizedonsites = customonsites + myself.customizedhubbards = customhubbards + myself.customizedoccupations = customoccupations + return myself + + +class OnecenterParameters(sc.ClassDict): + """One center parameters with defaults. + + Attributes + ---------- + elementname : ClassDict + Contains one center settings in the fields `deltafilling` and + `calculator`. + """ + + _PATTERN_DEFAULT = re.compile(r"^([a-z:]+(?:,[a-z:]+)*)$", re.IGNORECASE) + + @classmethod + def fromhsd(cls, root, query): + """Returns one center parameters with substituted defaults.""" + myself = cls() + + # Parse all other nodes + for node in query.findchildren(root, "*"): + name = node.tag + try: + myself[name] = OnecenterParameter.fromhsd(node, query) + except sc.SkgenException as ex: + msg = "onecenterparameters/{}:\n{}".format(name, ex) + return myself + + +class OnecenterParameter(sc.ClassDict): + + @classmethod + def fromhsd(cls, root, query): + myself = cls() + myself.deltafilling = query.getvalue(root, "deltafilling", conv.float0) + myself.calculator = sc.hsd_node_factory( + "one-center calculator", + calculators.ONECENTER_CALCULATOR_SETTINGS, + query.getvaluenode(root, "calculator"), query) + return myself + + def __eq__(self, other): + if not isinstance(other, OnecenterParameter): + return False + if (abs(self.deltafilling - other.deltafilling) + > sc.INPUT_FLOAT_TOLERANCE): + return False + if self.calculator != other.calculator: + return False + return True + + + +class TwocenterParameters(sc.ClassDict): + """Two center parameters with defaults. + + Attributes + ---------- + elementname : ClassDict + Contains two center settings in fields `grid` and + `calculator`. + """ + + _PATTERN_DEFAULT = re.compile(r"^([a-z:]+)-([a-z:]+)$", re.IGNORECASE) + + @classmethod + def fromhsd(cls, root, query): + """Returns two center parameters with substituted defaults.""" + myself = cls() + + # Parse all other nodes + for node in query.findchildren(root, "*"): + name = node.tag + match = cls._PATTERN_DEFAULT.match(name) + if not match: + msg = "Invalid two center interaction '{}'".name + raise sc.SkgenException(msg) + name1, name2 = match.groups() + key = min(name1, name2), max(name1, name2) + try: + myself[key] = TwocenterParameter.fromhsd(node, query) + except sc.SkgenException as ex: + msg = "twocenterparameters/{}-{}:\n{}".format(name1, name2, ex) + raise sc.SkgenException(msg) + return myself + + + +class TwocenterParameter(sc.ClassDict): + + @classmethod + def fromhsd(cls, root, query): + myself = cls() + myself.grid = sc.hsd_node_factory( + "two-center grid", twocenter_grids.TWOCENTER_GRIDS, + query.getvaluenode(root, "grid"), query) + myself.calculator = sc.hsd_node_factory( + "two-center calculator", + calculators.TWOCENTER_CALCULATOR_SETTINGS, + query.getvaluenode(root, "calculator"), query) + return myself + + + +def _test_module(): + from sktools.hsd.treebuilder import HSDTreeBuilder + from sktools.hsd.query import HSDQuery + from sktools.hsd.parser import HSDParser + + parser = HSDParser(lowertagnames=True) + treebuilder = HSDTreeBuilder(parser=parser) + fp = open("skdefs.hsd", "r") + tree = treebuilder.build(fp) + fp.close() + query = HSDQuery(checkuniqueness=True, markprocessed=True) + skdefs = Skdef.fromhsd(tree, query) + print(skdefs.onecenterparameters["n"].calculator.exponents) + print(skdefs.onecenterparameters["n"].deltafilling) + + unprocessed_list = query.findunprocessednodes(tree) + for unprocessed in unprocessed_list: + print("Unprocessed element '{}' at line {:d}!".format( + unprocessed.hsdattrib[hsd.HSDATTR_TAG], + unprocessed.hsdattrib[hsd.HSDATTR_LINE] + 1)) + + +if __name__ == "__main__": + _test_module() diff --git a/sktools/src/sktools/skgen/__init__.py b/sktools/src/sktools/skgen/__init__.py new file mode 100644 index 00000000..3ef30d43 --- /dev/null +++ b/sktools/src/sktools/skgen/__init__.py @@ -0,0 +1,5 @@ +from .atom import run_atom, SkgenAtom +from .compression import run_denscomp, run_wavecomp, SkgenDenscomp, \ + SkgenWavecomp +from .twocnt import run_twocnt, SkgenTwocnt +from .sktable import run_sktable, SkgenSktable diff --git a/sktools/src/sktools/skgen/atom.py b/sktools/src/sktools/skgen/atom.py new file mode 100644 index 00000000..69cffbe2 --- /dev/null +++ b/sktools/src/sktools/skgen/atom.py @@ -0,0 +1,416 @@ +import os.path +import copy +import logging +import numpy as np +import sktools.common as sc +from . import common as ssc + + +logger = logging.getLogger("skgen.atom") + + +def run_atom(skdefs, elem, builddir, searchdirs, onecnt_binary, + eigenonly=False, eigenspinonly=False): + logger.info("Started for {}".format( + sc.capitalize_elem_name(elem))) + calculator = SkgenAtom(builddir, searchdirs, onecnt_binary) + calculator.set_input(skdefs, elem) + calculator.find_or_run_calculation(eigenonly, eigenspinonly) + logger.info("Finished") + return calculator + + +class SkgenAtom: + + def __init__(self, builddir, searchdirs, onecenter_binary): + self._builddir = builddir + self._searchdirs = searchdirs + self._onecenter_binary = onecenter_binary + self._elem = None + self._input = None + self._onecenter_searchdirs = None + self._resultdir = None + + + def set_input(self, skdefs, elem): + elemlow = elem.lower() + self._elem = elemlow + self._input = SkgenAtomInput(skdefs, elemlow) + self._onecenter_searchdirs = ssc.get_onecenter_searchdirs( + self._searchdirs, self._elem) + self._resultdir = None + + + def find_or_run_calculation(self, eigenonly=False, eigenspinonly=False): + previous_calc_dirs = ssc.get_matching_subdirectories( + self._onecenter_searchdirs, ssc.ATOM_WORKDIR_PREFIX) + resultdir = self._input.get_first_dir_with_matching_signature( + previous_calc_dirs) + if not resultdir: + resultdir = self._do_calculation(eigenonly, eigenspinonly) + if not (eigenonly or eigenspinonly): + self._input.store_signature(resultdir) + else: + logger.info("Matching calculation found " + sc.log_path(resultdir)) + self._resultdir = resultdir + + + def get_result(self): + if self._resultdir is None: + self.find_or_run_calculation() + return SkgenAtomResult(self._resultdir) + + + def get_result_directory(self): + return self._resultdir + + + def _do_calculation(self, eigenonly=False, eigenspinonly=False): + workdir = ssc.create_onecenter_workdir( + self._builddir, ssc.ATOM_WORKDIR_PREFIX, self._elem) + calculation = SkgenAtomCalculation(self._input, workdir, + self._onecenter_binary) + calculation.run_and_convert_results(eigenonly, eigenspinonly) + return workdir + + + +class SkgenAtomInput(ssc.InputWithSignature): + + SIGNATURE_FILE = ssc.ATOM_SIGNATURE_FILE + + def __init__(self, skdefs, elem): + self.elem = elem + atomparams = skdefs.atomparameters[elem] + self.atomconfig = atomparams.atomconfig + self.xcfunc = skdefs.globals.xcfunctional + self.onecentpars = skdefs.onecenterparameters[elem] + + + def get_signature(self): + signature = { + "atomconfig": self.atomconfig, + "onecentpars": self.onecentpars, + "xcfunc": self.xcfunc + } + return signature + + + +class SkgenAtomCalculation: + + def __init__(self, myinput, workdir, binary): + self._atomconfig = myinput.atomconfig + self._delta_occ = myinput.onecentpars.deltafilling + self._valence_shell_empty = self._get_valence_shell_empty( + self._atomconfig, self._delta_occ) + calculator = myinput.onecentpars.calculator + self._oncenter_calculator = ssc.OnecenterCalculatorWrapper(calculator) + self._xcfunc = myinput.xcfunc + self._workdir = workdir + self._binary = binary + + + def run_and_convert_results(self, eigenonly, eigenspinonly): + spin_needed = self._atomconfig.spinpolarized and not eigenonly + result_spin_atom = None + if eigenspinonly or spin_needed: + result_spin_atom = self._calculate_spinpolarized_atom() + result_spinavg_atom = None + if eigenonly or not eigenspinonly: + result_spinavg_atom = self._calculate_spinaveraged_atom() + if eigenonly or eigenspinonly: + return + + hubbus = self._calculate_hubbus(result_spinavg_atom, + replace_empty_with_homo=True) + self._log_substitutions(result_spinavg_atom) + self._log_hubbus(hubbus) + spinws = self._calculate_spinws(result_spinavg_atom, + replace_empty_with_homo=True) + self._log_spinws(spinws) + self._convert_results(result_spinavg_atom, result_spin_atom, hubbus, + spinws) + + + @staticmethod + def _get_valence_shell_empty(atomconfig, delta_occ): + valence_shell_empty = [ + atomconfig.occupations[ll][nn - ll - 1][0] < delta_occ + for nn, ll in atomconfig.valenceshells] + return valence_shell_empty + + + def _calculate_spinpolarized_atom(self): + workdir = os.path.join(self._workdir, "atom0_spin") + logger.info("Calculating spin polarized atom " + sc.log_path(workdir)) + self._atomconfig.make_spinpolarized() + result_spin = self._calculate_free_atom(workdir) + return result_spin + + + def _calculate_spinaveraged_atom(self): + workdir = os.path.join(self._workdir, "atom0") + logger.info("Calculating spin averaged atom " + sc.log_path(workdir)) + self._atomconfig.make_spinaveraged() + result_spinavg = self._calculate_free_atom(workdir) + return result_spinavg + + + def _calculate_free_atom(self, workdir): + output = self._oncenter_calculator.do_calculation( + self._atomconfig, self._xcfunc, None, self._binary, workdir) + result = self._collect_free_atom_result(output) + self._log_free_atom_result(result) + return result + + + def _collect_free_atom_result(self, output): + result = sc.ClassDict() + result.etot = output.get_energy() + eigvals0 = [] + occs0 = [] + for nn, ll in self._atomconfig.valenceshells: + eigval = ( output.get_eigenvalue(0, nn, ll), + output.get_eigenvalue(1, nn, ll) ) + eigvals0.append(eigval) + occ = ( output.get_occupation(0, nn, ll), + output.get_occupation(1, nn, ll) ) + occs0.append(occ) + homo0 = output.get_homo_or_lowest_nl(0) + homo1 = output.get_homo_or_lowest_nl(1) + result.valence_eigvals = np.array(eigvals0, dtype=float) + result.valence_occs = np.array(occs0, dtype=float) + result.homo = ( homo0, homo1 ) + result.homo_eigval = ( output.get_eigenvalue(0, homo0[0], homo0[1]), + output.get_eigenvalue(1, homo1[0], homo1[1]) ) + return result + + + def _calculate_hubbus(self, result_spinavg, replace_empty_with_homo): + workdir = os.path.join(self._workdir, "hubbu") + logger.info("Calculating Hubbard U values " + sc.log_path(workdir)) + shells, ihomo, energies = self._get_shells_and_energies_for_deriv_calc( + result_spinavg, replace_empty_with_homo) + sc.create_workdir(workdir) + all_derivs = self._calc_deriv_matrix(workdir, shells, energies, + spin_averaged=True) + all_derivs = 0.5 * (all_derivs + np.transpose(all_derivs)) + valence_hubbus = self._get_valence_derivs(all_derivs, ihomo, + replace_empty_with_homo) + return valence_hubbus + + + def _get_shells_and_energies_for_deriv_calc(self, result_spinavg, + replace_empty_with_homo): + spin = 0 + homoshell = result_spinavg.homo[spin] + if (homoshell not in self._atomconfig.valenceshells and + replace_empty_with_homo): + homoshell_n, homoshell_l = homoshell + shells_to_calculate = [( homoshell_n, homoshell_l )] + reference_energies = [result_spinavg.homo_eigval[spin]] + ihomo = 0 + else: + shells_to_calculate = [] + reference_energies = [] + ihomo = self._atomconfig.valenceshells.index(homoshell) + shells_to_calculate += [( nn, ll ) + for nn, ll in self._atomconfig.valenceshells] + reference_energies += [eigval[spin] + for eigval in result_spinavg.valence_eigvals] + return shells_to_calculate, ihomo, reference_energies + + + def _calc_deriv_matrix(self, workdir, shells_to_calculate, + reference_energies, spin_averaged): + ncalcshells = len(shells_to_calculate) + tmp = np.zeros(( ncalcshells, ncalcshells ), dtype=float) + if spin_averaged: + deriv_matrix = tmp + else: + deriv_matrix = ( tmp, np.array(tmp) ) + for ishell, shell_to_variate in enumerate(shells_to_calculate): + deriv = self._calc_de_shells_docc( + workdir, shells_to_calculate, reference_energies, + shell_to_variate, spin_averaged=spin_averaged) + if spin_averaged: + deriv_matrix[ishell] = deriv + else: + deriv_matrix[0][ishell] = deriv[0] + deriv_matrix[1][ishell] = deriv[1] + return deriv_matrix + + + def _get_valence_derivs(self, all_hubbus, ihomo, replace_empty_with_homo): + if not replace_empty_with_homo: + return all_hubbus + nvalshells = len(self._atomconfig.valenceshells) + # noinspection PyNoneFunctionAssignment + valence_hubbus = np.empty(( nvalshells, nvalshells ), dtype=float) + hubbu_inds = [ihomo if self._valence_shell_empty[ii] else ii + for ii in range(nvalshells)] + for ii, ii_hubbu in enumerate(hubbu_inds): + for jj, jj_hubbu in enumerate(hubbu_inds): + valence_hubbus[ii, jj] = all_hubbus[ii_hubbu, jj_hubbu] + return valence_hubbus + + + def _calculate_spinws(self, result_spinavg, replace_empty_with_homo): + workdir = os.path.join(self._workdir, "spinw") + logger.info("Calculating spinw values " + sc.log_path(workdir)) + shells, ihomo, energies = self._get_shells_and_energies_for_deriv_calc( + result_spinavg, replace_empty_with_homo) + sc.create_workdir(workdir) + all_derivs_up, all_derivs_dn = self._calc_deriv_matrix( + workdir, shells, energies, spin_averaged=False) + spinws = 0.5 * (all_derivs_up - all_derivs_dn) + spinws = 0.5 * (spinws + np.transpose(spinws)) + valence_spinws = self._get_valence_derivs(spinws, ihomo, + replace_empty_with_homo) + return valence_spinws + + + def _calc_de_shells_docc(self, workdir, derived_shells, reference_eigvals, + variated_shell, spin_averaged=False): + atomconfig = self._atomconfig + orig_occ = copy.deepcopy(atomconfig.occupations) + nvar, lvar = variated_shell + if spin_averaged: + delta_occ = [self._delta_occ / 2.0, self._delta_occ / 2.0] + else: + delta_occ = [self._delta_occ, 0.0] + + # Decide, whether backwards, forward or central difference must be + # used and set approriate deltas for occupation variation and + # prefactors + occ_varshell = orig_occ[lvar][nvar - lvar - 1][0] + if occ_varshell < self._delta_occ: + delta_occ_prefacs = [1.0, 2.0] + finite_diff_coeffs_delta = np.array([2.0, -0.5]) + finite_diff_coeff0 = -1.5 + elif occ_varshell > 2 * lvar + 1 - self._delta_occ: + delta_occ_prefacs = [-1.0, -2.0] + finite_diff_coeffs_delta = np.array([-2.0, 0.5]) + finite_diff_coeff0 = 1.5 + else: + delta_occ_prefacs = [-1.0, 1.0] + finite_diff_coeffs_delta = np.array([-0.5, 0.5]) + finite_diff_coeff0 = 0.0 + finite_diff_coeffs_delta = finite_diff_coeffs_delta / self._delta_occ + finite_diff_coeff0 = finite_diff_coeff0 / self._delta_occ + + # Calculate derivative via finite differences + tmp = finite_diff_coeff0 * np.array(reference_eigvals) + if spin_averaged: + de_shells_docc = [ tmp, ] + else: + de_shells_docc = [ tmp, np.array(tmp) ] + + for ii in range(len(delta_occ_prefacs)): + localname = "{:d}{:s}_{:d}".format(nvar, sc.ANGMOM_TO_SHELL[lvar], + ii + 1) + localworkdir = os.path.join(workdir, localname) + occs = self._atomconfig.occupations[lvar][nvar - lvar - 1] + new_occs = ( occs[0] + delta_occ_prefacs[ii] * delta_occ[0], + occs[1] + delta_occ_prefacs[ii] * delta_occ[1] ) + atomconfig.occupations[lvar][nvar - lvar - 1] = new_occs + result = self._oncenter_calculator.do_calculation( + atomconfig, self._xcfunc, None, self._binary, localworkdir) + for ss in range(len(de_shells_docc)): + e_shells = [ result.get_eigenvalue(ss, nn, ll) + for nn, ll in derived_shells] + de_shells_docc[ss] += (finite_diff_coeffs_delta[ii] + * np.array(e_shells, dtype=float)) + atomconfig.occupations = copy.deepcopy(orig_occ) + + if spin_averaged: + return de_shells_docc[0] + else: + return de_shells_docc + + + def _log_free_atom_result(self, result): + logger.debug("Total energy: {:.5f}".format(result.etot)) + logger.debug("Eigenvalues of valence orbitals:") + eigvals = result.valence_eigvals + occs = result.valence_occs + for ii, nl in enumerate(self._atomconfig.valenceshells): + nn, ll = nl + msg = " {:d}{:s}: {:13.8f} ({:6.4f}) {:13.8f} ({:6.4f})".format( + nn, sc.ANGMOM_TO_SHELL[ll], eigvals[ii][0], occs[ii][0], + eigvals[ii][1], occs[ii][1]) + logger.debug(msg) + + + def _log_substitutions(self, refcalc): + nhomo, lhomo = refcalc.homo[0] + if np.any(self._valence_shell_empty): + logger.debug("Shell substitutions:") + av = self._atomconfig.valenceshells + out = ["{:d}{:s}".format(av[ii][0], sc.ANGMOM_TO_SHELL[av[ii][1]]) + for ii in range(len(av)) if self._valence_shell_empty[ii]] + out.append("<-- {:d}{:s}".format(nhomo, sc.ANGMOM_TO_SHELL[lhomo])) + logger.debug(" ".join(out)) + else: + logger.debug("Shell substitutions: None") + + + @staticmethod + def _log_hubbus(hubbus): + logger.debug(str(hubbus)) + + + @staticmethod + def _log_spinws(spinws): + logger.debug(spinws) + + + def _convert_results(self, res_spinavg, res_spin, hubbus, spinws): + results = { + "eigenvalues": res_spinavg.valence_eigvals[:, 0], + "occupations": 2.0 * res_spinavg.valence_occs[:, 0], + "homo": np.array(res_spinavg.homo, dtype=int), + } + if res_spin is not None: + results["spinpol_energy"] = res_spin.etot - res_spinavg.etot + else: + results["spinpol_energy"] = 0.0 + results["hubbardu"] = hubbus + results["spinw"] = spinws + sc.store_as_shelf(os.path.join(self._workdir, ssc.ATOM_RESULT_FILE), + results) + + + +class SkgenAtomResult: + + def __init__(self, workdir): + self._workdir = workdir + self._result_db = sc.retrive_from_shelf( + os.path.join(workdir, ssc.ATOM_RESULT_FILE)) + + + def get_eigenvalues(self): + return self._result_db["eigenvalues"] + + + def get_occupations(self): + return self._result_db["occupations"] + + + def get_homo_nl(self): + return self._result_db["homo"] + + + def get_spinpolarization_energy(self): + return self._result_db["spinpol_energy"] + + + def get_hubbardus(self): + return self._result_db["hubbardu"] + + + def get_spinws(self): + return self._result_db["spinw"] + diff --git a/sktools/src/sktools/skgen/common.py b/sktools/src/sktools/skgen/common.py new file mode 100644 index 00000000..4117eb37 --- /dev/null +++ b/sktools/src/sktools/skgen/common.py @@ -0,0 +1,163 @@ +import os +import glob +import logging +from .. import common as sc +from .. import calculators + + +logger = logging.getLogger("skgen.common") + +SHELL_FORMAT = "{:d}{:s}" + +ATOM_WORKDIR_PREFIX = "atom." +ATOM_SIGNATURE_FILE = "_atom-inp.db" +ATOM_RESULT_FILE = "_atom-res.db" + +COMPRESSION_WORKDIR_PREFIX = "comp." +COMPRESSION_SIGNATURE_FILE = "_comp-inp.db" +DENSCOMP_RESULT_FILE = "_denscomp-res.db" +WAVECOMP_RESULT_FILE = "_wavecomp-res.db" + +TWOCNT_WORKDIR_PREFIX = "twocnt." +TWOCNT_SIGNATURE_FILE = "_twocnt_inp.db" +TWOCNT_RESULT_FILE = "_twocnt-res.db" +DIRLINK_POTDENS_PREFIX = "dir_potdens" +DIRLINK_WAVE_PREFIX = "dir_wave" + + +class OnecenterCalculatorWrapper: + + def __init__(self, calcsettings): + self._calculatorclass = get_calculator_class( + calcsettings, calculators.ONECENTER_CALCULATORS) + self._calculator_name = calcsettings.__class__.__name__ + self._calcsettings = calcsettings + + + def do_calculation(self, atomconfig, xcfunc, compressions, binary, workdir): + sc.create_workdir(workdir, reuse_existing=True) + + calculator = self._calculatorclass(workdir) + calculator.set_input(self._calcsettings, atomconfig, xcfunc, + compressions) + + logger.debug("Running {}".format(binary)) + calculator.run(binary) + result = calculator.get_result() + return result + + + def get_output(self, workdir): + calculator = self._calculatorclass(workdir) + result = calculator.get_result() + return result + + + +class TwocenterCalculatorWrapper: + + def __init__(self, calcsettings): + self._calculatorclass = get_calculator_class( + calcsettings, calculators.TWOCENTER_CALCULATORS) + self._calculator_name = calcsettings.__class__.__name__ + self._calcsettings = calcsettings + + + def do_calculation(self, superpos, functional, grid, atom1data, atom2data, + binary, workdir): + sc.create_workdir(workdir, reuse_existing=True) + calculator = self._calculatorclass(workdir) + calculator.set_input(self._calcsettings, superpos, functional, grid, + atom1data, atom2data) + + logger.debug("Running {}".format(binary)) + calculator.run(binary) + result = calculator.get_result() + return result + + + def get_output(self, workdir): + calculator = self._calculatorclass(workdir) + result = calculator.get_result() + return result + + + +class InputWithSignature: + + SIGNATURE_FILE = None + + def store_signature(self, workdir): + sc.store_as_shelf(os.path.join(workdir, self.SIGNATURE_FILE), + self.get_signature()) + + + def get_first_dir_with_matching_signature(self, search_dirs): + return sc.find_dir_with_matching_shelf( + search_dirs, self.SIGNATURE_FILE, **self.get_signature()) + + + def get_all_dirs_with_matching_signature(self, search_dirs): + return sc.get_dirs_with_matching_shelf( + search_dirs, self.SIGNATURE_FILE, **self.get_signature()) + + + def get_signature(self): + raise NotImplementedError + + + +def get_matching_subdirectories(dirs, subdirprefix): + dirglobs = [ os.path.join(mydir, subdirprefix + "*") + for mydir in dirs ] + matching_subdirs = [] + for dirglob in dirglobs: + matching_subdirs += glob.glob(dirglob) + return matching_subdirs + + +def get_onecenter_searchdirs(searchdirs, elem): + onecenter_searchdirs = [ os.path.join(dirname, get_onecenter_dirname(elem)) + for dirname in searchdirs ] + return onecenter_searchdirs + + +def get_twocenter_searchdirs(searchdirs, elem1, elem2): + twocenter_searchdirs = [ os.path.join(dirname, + get_twocenter_dirname(elem1, elem2)) + for dirname in searchdirs ] + return twocenter_searchdirs + + +def get_onecenter_dirname(elem): + return elem + + +def get_twocenter_dirname(elem1, elem2): + return "{}-{}".format(elem1, elem2) + + +def create_onecenter_workdir(builddir, workdir_prefix, elem): + workroot = os.path.join(builddir, get_onecenter_dirname(elem)) + workdir = _create_workdir(workroot, workdir_prefix) + return workdir + + +def create_twocenter_workdir(builddir, workdir_prefix, elem1, elem2): + workroot = os.path.join(builddir, get_twocenter_dirname(elem1, elem2)) + workdir = _create_workdir(workroot, workdir_prefix) + return workdir + + +def _create_workdir(workroot, workdir_prefix): + sc.create_workdir(workroot, reuse_existing=True) + workdir = sc.create_unique_workdir(workroot, workdir_prefix) + return workdir + + +def get_calculator_class(settings, registered_calculators): + for curr in registered_calculators: + if isinstance(settings, curr.settings): + return curr.calculator + raise sc.SkgenException("Unknown calculator {}".format( + settings.__class__.__name__)) diff --git a/sktools/src/sktools/skgen/compression.py b/sktools/src/sktools/skgen/compression.py new file mode 100644 index 00000000..8e06487d --- /dev/null +++ b/sktools/src/sktools/skgen/compression.py @@ -0,0 +1,290 @@ +import os.path +import logging +import sktools.common as sc +from . import common as ssc + + +logger = logging.getLogger("skgen.compression") + + +def run_denscomp(skdefs, elem, builddir, searchdirs, onecnt_binary): + logger.info("Started for {}".format(sc.capitalize_elem_name(elem))) + calculator = SkgenDenscomp( + builddir, searchdirs, onecnt_binary) + calculator.set_input(skdefs, elem) + calculator.find_or_run_calculation() + logger.info("Finished") + return calculator + + +def run_wavecomp(skdefs, elem, builddir, searchdirs, onecnt_binary): + logger.info("Started for {}".format( + sc.capitalize_elem_name(elem))) + calculator = SkgenWavecomp(builddir, searchdirs, onecnt_binary) + calculator.set_input(skdefs, elem) + calculator.find_or_run_calculation() + logger.info("Finished") + return calculator + + +class SkgenDenscomp: + + def __init__(self, builddir, searchdirs, onecenter_binary): + self._builddir = builddir + self._searchdirs = searchdirs + self._onecenter_binary = onecenter_binary + self._elem = None + self._input = None + self._onecenter_searchdirs = None + self._resultdir = None + + + def set_input(self, skdefs, elem): + elemlow = elem.lower() + self._elem = elemlow + atomparams = skdefs.atomparameters[elemlow] + atomconfig = atomparams.atomconfig + compression = atomparams.dftbatom.densitycompression + compressions = [ compression, ] * (atomconfig.maxang + 1) + xcfunc = skdefs.globals.xcfunctional + calculator = skdefs.onecenterparameters[elemlow].calculator + self._input = AtomCompressionInput(elemlow, atomconfig, compressions, + xcfunc, calculator) + self._onecenter_searchdirs = ssc.get_onecenter_searchdirs( + self._searchdirs, self._elem) + self._resultdir = None + + + def find_or_run_calculation(self): + previous_calc_dirs = ssc.get_matching_subdirectories( + self._onecenter_searchdirs, ssc.COMPRESSION_WORKDIR_PREFIX) + resultdir = self._input.get_first_dir_with_matching_signature( + previous_calc_dirs) + recalculation_need = not resultdir + if recalculation_need: + resultdir = ssc.create_onecenter_workdir( + self._builddir, ssc.COMPRESSION_WORKDIR_PREFIX, self._elem) + logger.info("Calculating compressed atom " + + sc.log_path(resultdir)) + calculation = AtomCompressionCalculation(self._input) + calculation.run(resultdir, self._onecenter_binary) + else: + logger.info("Matching calculation found " + + sc.log_path(resultdir)) + self._extract_results_if_not_present(self._input, resultdir) + if recalculation_need: + self._input.store_signature(resultdir) + self._resultdir = resultdir + + + @staticmethod + def _extract_results_if_not_present(myinput, resultdir): + resultshelf = os.path.join(resultdir, ssc.DENSCOMP_RESULT_FILE) + if sc.shelf_exists(resultshelf): + return + calculator = AtomCompressionResult(myinput.calculator) + output = calculator.get_output(resultdir) + result = { + "potentials": output.get_potentials(), + "density": output.get_density012() + } + sc.store_as_shelf(resultshelf, result) + + + def get_result(self): + if self._resultdir is None: + self.find_or_run_calculation() + return SkgenDenscompResult(self._resultdir) + + + def get_result_directory(self): + return self._resultdir + + + +class SkgenDenscompResult: + + def __init__(self, resultdir): + resultshelf = os.path.join(resultdir, ssc.DENSCOMP_RESULT_FILE) + self._results = sc.retrive_from_shelf(resultshelf) + + def get_potential(self): + return self._results["potentials"] + + def get_density(self): + return self._results["density"] + + + +class SkgenWavecomp: + + def __init__(self, builddir, searchdirs, onecenter_binary): + self._builddir = builddir + self._searchdirs = searchdirs + self._onecenter_binary = onecenter_binary + self._elem = None + self._shells_and_inputs = [] + self._onecenter_searchdirs = None + self._resultdirs = None + + + def set_input(self, skdefs, elem): + elemlow = elem.lower() + self._elem = elemlow + atomparams = skdefs.atomparameters[elemlow] + atomconfig = atomparams.atomconfig + xcfunc = skdefs.globals.xcfunctional + calculator = skdefs.onecenterparameters[elemlow].calculator + comprcontainer = atomparams.dftbatom.wavecompressions + atomcompressions = comprcontainer.getatomcompressions(atomconfig) + self._shells_and_inputs = [] + for compressions, shells in atomcompressions: + myinput = AtomCompressionInput(elemlow, atomconfig, compressions, + xcfunc, calculator) + self._shells_and_inputs.append(( shells, myinput )) + self._onecenter_searchdirs = ssc.get_onecenter_searchdirs( + self._searchdirs, self._elem) + self._resultdirs = None + + + def find_or_run_calculation(self): + resultdirs = [] + resultdir_for_nl = {} + previous_calc_dirs = ssc.get_matching_subdirectories( + self._onecenter_searchdirs, ssc.COMPRESSION_WORKDIR_PREFIX) + for shells, myinput in self._shells_and_inputs: + shellnames = [ sc.shell_ind_to_name(nn, ll) for nn, ll in shells ] + logger.info("Processing compression for shell(s) {}".format( + " ".join(shellnames))) + resultdir = myinput.get_first_dir_with_matching_signature( + previous_calc_dirs) + recalculation_needed = not resultdir + if recalculation_needed: + resultdir = ssc.create_onecenter_workdir( + self._builddir, ssc.COMPRESSION_WORKDIR_PREFIX, self._elem) + logger.info( + "Calculating compressed atom " + sc.log_path(resultdir)) + calculation = AtomCompressionCalculation(myinput) + calculation.run(resultdir, self._onecenter_binary) + else: + logger.info( + "Matching calculation found " + sc.log_path(resultdir)) + self._extract_results_if_not_present(myinput, shells, resultdir) + if recalculation_needed: + myinput.store_signature(resultdir) + resultdirs.append(resultdir) + for nn, ll in shells: + resultdir_for_nl[(nn, ll)] = resultdir + + self._resultdirs = resultdirs + self._resultdir_for_nl = resultdir_for_nl + + + @staticmethod + def _extract_results_if_not_present(myinput, shells, resultdir): + resultshelf = os.path.join(resultdir, ssc.WAVECOMP_RESULT_FILE) + if sc.shelf_exists(resultshelf): + return + calculator = AtomCompressionResult(myinput.calculator) + output = calculator.get_output(resultdir) + resultdict = {} + for nn, ll in shells: + # Needs name as shelf allows only strings as keys + shellname = sc.shell_ind_to_name(nn, ll) + resultdict[shellname] = output.get_wavefunction012(0, nn, ll) + sc.store_as_shelf(resultshelf, resultdict) + + + def get_result(self): + if self._resultdirs is None: + self.find_or_run_calculation() + return SkgenWavecompResult(self._resultdirs) + + + def get_result_directories(self): + return self._resultdirs + + + def get_result_directory_for_shell(self, nn, ll): + resdir = self._resultdir_for_nl.get(( nn, ll ), None) + if resdir is None: + msg = "No result directory for shell {:s}".format( + sc.shell_ind_to_name(nn, ll)) + raise sc.SkgenException(msg) + return resdir + + + + + +class SkgenWavecompResult: + + def __init__(self, workdirs): + self._result = {} + for workdir in workdirs: + resultshelf = os.path.join(workdir, ssc.WAVECOMP_RESULT_FILE) + curres = sc.retrive_from_shelf(resultshelf) + self._result.update(curres) + + + def get_wavefunction(self, nn, ll): + shellname = sc.shell_ind_to_name(nn, ll) + try: + wfc = self._result[shellname] + except KeyError: + msg = "Missing wavefunction {}".format(shellname) + raise sc.SkgenException(msg) + return wfc + + + +class AtomCompressionInput(ssc.InputWithSignature): + + SIGNATURE_FILE = ssc.COMPRESSION_SIGNATURE_FILE + + def __init__(self, elem, atomconfig, shell_compressions, xcfunc, + calculator): + self.elem = elem + self.atomconfig = atomconfig + self.shell_compressions = shell_compressions + self.xcfunc = xcfunc + self.calculator = calculator + + + def get_signature(self): + signature = { + "atomconfig": self.atomconfig, + "compressions": self.shell_compressions, + "xcfunc": self.xcfunc, + "calculator": self.calculator + } + return signature + + + +class AtomCompressionCalculation: + + def __init__(self, myinput): + self._atomconfig = myinput.atomconfig + self._atomconfig.make_spinaveraged() + self._shell_compressions = myinput.shell_compressions + calculator = myinput.calculator + self._onecnt_calculator = ssc.OnecenterCalculatorWrapper(calculator) + self._xcfunc = myinput.xcfunc + + + def run(self, workdir, binary): + self._onecnt_calculator.do_calculation( + self._atomconfig, self._xcfunc, self._shell_compressions, + binary, workdir) + + + +class AtomCompressionResult: + + def __init__(self, calculator): + self._onecnt_calculator = ssc.OnecenterCalculatorWrapper(calculator) + + + def get_output(self, workdir): + return self._onecnt_calculator.get_output(workdir) diff --git a/sktools/src/sktools/skgen/path.py b/sktools/src/sktools/skgen/path.py new file mode 100644 index 00000000..b30e3bb9 --- /dev/null +++ b/sktools/src/sktools/skgen/path.py @@ -0,0 +1,152 @@ +import sktools.common as sc +import re +from sktools.hsd.tree import Element, SubElement +from sktools.hsd.query import HSDQuery +from sktools.hsd.parser import HSDParser +from sktools.hsd.treebuilder import VariableTreeBuilder, HSDTreeBuilder + + +_PATTERN_ONECENTER_TAG = re.compile(r"^([a-z:]+)$", re.IGNORECASE) +_PATTERN_TWOCENTER_TAG = re.compile(r"^([a-z:]+)-([a-z:]+)$", re.IGNORECASE) + + +class SkgenPaths: + """Stores working paths used by skgen.""" + + def __init__(self, root=None, query=None): + """Initializes an SkgenPaths instance. + + Args: + root: Root of the hsd tree storing the paths (default=None). + query: Query object to use to query the path tree (default=None). + """ + if root is None: + self._root = Element("hsd") + else: + self._root = root + if query is None: + self._query = HSDQuery(checkuniqueness=True) + else: + self._query = query + self._onecenter_nodes = {} + self._twocenter_nodes = {} + self._store_nodes() + + + @classmethod + def fromhsd(cls, root, query): + """Initializes an SkgenPaths instance from an existing HSD tree. + + Args: + root: Root of the hsd tree storing the paths. + query: Query object to use to query the path tree. + + Returns: + Initialized instance. + """ + myself = cls(root, query) + return myself + + + @classmethod + def fromfile(cls, fileobj): + """Initializes an SkgenPaths instance from a file. + + Args: + fileobj: File name or file like object containing the text + representation of a path tree. + + Returns: + Initialized instance. + """ + parser = HSDParser() + builder = VariableTreeBuilder() + treebuilder = HSDTreeBuilder(parser=parser, builder=builder) + openclose = isinstance(fileobj, str) + if openclose: + fp = open(fileobj, "r") + else: + fp = fileobj + tree = treebuilder.build(fp) + if openclose: + fp.close() + query = HSDQuery(checkuniqueness=True) + myself = cls(tree, query) + return myself + + + def get_onecenter_workdir(self, elem, calctype, default): + """Delivers working directory for a onecenter calculation. + + Args: + elem: Element to process (must be lower case!) + calctype: Type of the calculation (e.g. 'atom', 'potcomp', ...) + default: Directory to return (and store), if no directory was + found in the path tree yet. + + Returns: + Working directory for the given calculation type. + """ + elemnode = self._onecenter_nodes.get(elem) + if elemnode is None: + elemnode = SubElement(self._root, elem) + self._onecenter_nodes[elem] = elemnode + workdir = self._query.getvalue(elemnode, calctype, defvalue=default) + return workdir + + + def get_twocenter_workdir(self, elem1, elem2, calctype, default): + """Delivers working directory for a two-center calculation. + + Args: + elem1: First element (must be lower case!) + elem2: Second element (must be lower case!) + calctype: Type of the calculation (e.g. 'atom', 'potcomp', ...) + default: Directory to return (and store), if no directory was + found in the path tree yet. + + Returns: + Working directory for the given calculation type. + """ + elem1, elem2 = min(elem1, elem2), max(elem1, elem2) + elemnode = self._twocenter_nodes.get(( elem1, elem2 )) + if elemnode is None: + name = elem1 + "-" + elem2 + elemnode = SubElement(self._root, name) + self._twocenter_nodes[elem1, elem2] = elemnode + workdir = self._query.getvalue(elemnode, calctype, defvalue=default) + return workdir + + + def get_paths(self): + """Returns an hsd-tree with the stored paths. + """ + return self._root + + + def _store_nodes(self): + """Sort out nodes into one-center and two-center ones. + """ + for child in self._query.findchildren(self._root, "*"): + name = child.tag + match = _PATTERN_TWOCENTER_TAG.match(name) + if match: + elem1, elem2 = match.groups() + elem1, elem2 = ( min(elem1, elem2), max(elem1, elem2) ) + if ( elem1, elem2 ) in self._twocenter_nodes: + msg = "Multiple two-center defintions for {}-{}".format( + elem1, elem2) + raise sc.SkgenException(msg) + self._twocenter_nodes[elem1, elem2] = child + else: + match = _PATTERN_ONECENTER_TAG.match(name) + if match: + elem = match.groups(0) + if elem in self._onecenter_nodes: + msg = "Multiple one-center defintions for {}".format( + elem) + raise sc.SkgenException(msg) + self._onecenter_nodes[elem] = child + else: + msg = "Invalid node name '{}'".format(name) + raise sc.SkgenException(msg) diff --git a/sktools/src/sktools/skgen/sktable.py b/sktools/src/sktools/skgen/sktable.py new file mode 100644 index 00000000..4b699f1b --- /dev/null +++ b/sktools/src/sktools/skgen/sktable.py @@ -0,0 +1,210 @@ +import logging +import numpy as np +import sktools.oldskfile +import sktools.common as sc +from .atom import run_atom +from .twocnt import run_twocnt + +logger = logging.getLogger("skgen.sktable") + + +def run_sktable(skdefs, elem1, elem2, builddir, searchdirs, onecnt_binary, + twocnt_binary, workdir, add_dummy_repulsive): + logger.info("Started for {}-{}".format( + sc.capitalize_elem_name(elem1), sc.capitalize_elem_name(elem2))) + hetero = (elem1.lower() != elem2.lower()) + prereq_atom1 = _get_sktable_atom_prereq(elem1, skdefs, builddir, searchdirs, + onecnt_binary) + if hetero: + prereq_atom2 = _get_sktable_atom_prereq(elem2, skdefs, builddir, + searchdirs, onecnt_binary) + else: + prereq_atom2 = None + prereq_twocnt = _get_sktable_twocnt_prereq( + elem1, elem2, skdefs, builddir, searchdirs, onecnt_binary, + twocnt_binary) + calculator = SkgenSktable(builddir, searchdirs) + calculator.set_input(skdefs, elem1, elem2, prereq_atom1, prereq_atom2, + prereq_twocnt) + skfiles_written = calculator.write_sktables(workdir, add_dummy_repulsive) + logger.info("Finished") + return skfiles_written + + +def _get_sktable_atom_prereq(elem, skdefs, builddir, searchdirs, onecnt_binary): + logger.info("Creating free atom prerequisite for {}".format( + sc.capitalize_elem_name(elem))) + calc_atom = run_atom(skdefs, elem, builddir, searchdirs, onecnt_binary) + dir_atom = calc_atom.get_result_directory() + result_atom = calc_atom.get_result() + return SkgenSktableAtomPrereq(dir_atom, result_atom) + + +def _get_sktable_twocnt_prereq(elem1, elem2, skdefs, builddir, searchdirs, + onecnt_binary, twocnt_binary): + logger.info("Creating twocnt prerequisite for {}-{}".format( + sc.capitalize_elem_name(elem1), sc.capitalize_elem_name(elem2))) + calc_twocnt = run_twocnt(skdefs, elem1, elem2, builddir, searchdirs, + onecnt_binary, twocnt_binary) + dir_twocnt = calc_twocnt.get_result_directory() + result_twocnt = calc_twocnt.get_result() + return SkgenSktableTwocntPrereq(dir_twocnt, result_twocnt) + + +class SkgenSktableAtomPrereq: + + def __init__(self, directory, result): + self.directory = directory + self.result = result + + + +class SkgenSktableTwocntPrereq: + + def __init__(self, directory, result): + self.directory = directory + self.result = result + + + +class SkgenSktable: + + def __init__(self, builddir, searchdirs): + self._builddir = builddir + self._searchdirs = searchdirs + self._skdefs = None + self._elem1 = None + self._elem2 = None + self._input = None + self._atom_prereqs = None + self._twocnt_prereq = None + + + def set_input(self, skdefs, elem1, elem2, atom_prereq1, atom_prereq2, + twocnt_prereq): + elem1 = elem1.lower() + elem2 = elem2.lower() + self._elem1 = min(elem1, elem2) + self._elem2 = max(elem1, elem2) + _elements_reversed = (self._elem1 != elem1) + self._skdefs = skdefs + if _elements_reversed: + self._atom_prereqs = ( atom_prereq2, atom_prereq1 ) + else: + self._atom_prereqs = ( atom_prereq1, atom_prereq2 ) + self._twocnt_prereq = twocnt_prereq + self._input = SkgenSktableInput(self._skdefs, self._elem1, self._elem2) + + + def write_sktables(self, workdir, add_dummy_repulsive): + assembly = SkgenSktableAssembly(self._input, self._atom_prereqs, + self._twocnt_prereq) + skfiles_written = assembly.write_sktables(workdir, add_dummy_repulsive) + return skfiles_written + + + +class SkgenSktableInput: + + def __init__(self, skdefs, elem1, elem2): + self.elem1 = elem1 + self.elem2 = elem2 + self.homo = (elem1 == elem2) + atomparam1 = skdefs.atomparameters[elem1] + atomparam2 = skdefs.atomparameters[elem2] + self.atomconfig1 = atomparam1.atomconfig + self.atomconfig2 = atomparam2.atomconfig + if self.homo: + dftbatom = atomparam1.dftbatom + self.shellresolved = dftbatom.shellresolved + self.custom_onsites = dftbatom.customizedonsites + self.custom_hubbards = dftbatom.customizedhubbards + self.custom_occupations = dftbatom.customizedoccupations + else: + self.shellresolved = None + self.custom_onsites = None + self.custom_hubbards = None + twocntpars = skdefs.twocenterparameters[(elem1, elem2)] + self.grid = twocntpars.grid + + + +class SkgenSktableAssembly: + + def __init__(self, myinput, atom_prereqs, twocnt_prereq): + self._input = myinput + self._atom_prereq1, self._atom_prereq2 = atom_prereqs + self._twocnt_prereq = twocnt_prereq + + + def write_sktables(self, workdir, add_dummy_repulsive): + result_twocnt = self._twocnt_prereq.result + ham = result_twocnt.get_hamiltonian() + over = result_twocnt.get_overlap() + myinput = self._input + valshells1 = myinput.atomconfig1.valenceshells + valshells2 = myinput.atomconfig2.valenceshells + grid = myinput.grid + if self._input.homo: + onsites, occs, hubbus, spinpolerr, mass = self._get_atomic_data() + if not myinput.shellresolved: + hubbus = self._override_with_homo_value( + myinput.atomconfig1, self._atom_prereq1.result, hubbus) + skfiles = sktools.oldskfile.OldSKFileSet( + grid, ham, over, valshells1, None, onsites=onsites, + spinpolerror=spinpolerr, hubbardus=hubbus, occupations=occs, + mass=mass, dummy_repulsive=add_dummy_repulsive) + else: + skfiles = sktools.oldskfile.OldSKFileSet( + grid, ham, over, valshells1, valshells2, + dummy_repulsive=add_dummy_repulsive) + files_written = skfiles.tofile(workdir, myinput.elem1, myinput.elem2) + return files_written + + + def _get_atomic_data(self): + myinput = self._input + shells = myinput.atomconfig1.valenceshells + atomresult = self._atom_prereq1.result + # Occupation can not be overriden by the users -> only defaults supplied + occs = self._get_shell_value_or_default( + shells, myinput.custom_occupations, atomresult.get_occupations()) + onsites = self._get_shell_value_or_default( + shells, myinput.custom_onsites, atomresult.get_eigenvalues()) + # SkgenAtom returns Hubbard U matrix + hubbus = atomresult.get_hubbardus() + diag_hubbus = np.diagonal(hubbus) + hubbus = self._get_shell_value_or_default( + shells, myinput.custom_hubbards, diag_hubbus) + spinpolerror = atomresult.get_spinpolarization_energy() + mass = myinput.atomconfig1.mass + return onsites, occs, hubbus, spinpolerror, mass + + + @staticmethod + def _get_shell_value_or_default(shells, shellvalues, defaults): + result = [] + for ii in range(len(shells)): + nn, ll = shells[ii] + result.append(shellvalues.get(( nn, ll ), defaults[ii])) + return result + + + @staticmethod + def _override_with_homo_value(atomconfig, atomresult, values): + shells = atomconfig.valenceshells + homo_nl_up, homo_nl_down = atomresult.get_homo_nl() + if np.any(homo_nl_up != homo_nl_down): + msg = "Different homo for spin up and down ({} vs. {})".format( + sc.shell_ind_to_name(*homo_nl_up), + sc.shell_ind_to_name(*homo_nl_down)) + raise sc.SkgenException(msg) + # Homo indices may be stored in a numpy array + homo_nl = tuple(homo_nl_up) + try: + ind = shells.index(homo_nl) + except IndexError: + msg = "Homo shell {} not among valence shells".format( + sc.shell_ind_to_name(*homo_nl)) + raise sc.SkgenException(msg) + return [ values[ind], ] * len(values) diff --git a/sktools/src/sktools/skgen/twocnt.py b/sktools/src/sktools/skgen/twocnt.py new file mode 100644 index 00000000..a33e779f --- /dev/null +++ b/sktools/src/sktools/skgen/twocnt.py @@ -0,0 +1,348 @@ +import os +import glob +import logging + +import numpy as np + +import sktools.common as sc +import sktools.radial_grid as soc +from . import common as ssc +from .compression import run_denscomp, run_wavecomp + + +logger = logging.getLogger("skgen.twocnt") + + +def run_twocnt(skdefs, elem1, elem2, builddir, searchdirs, onecnt_binary, + twocnt_binary): + logger.info("Started for {}-{}".format( + sc.capitalize_elem_name(elem1), sc.capitalize_elem_name(elem2))) + hetero = (elem1.lower() != elem2.lower()) + prereq1 = _get_compression_prereq(elem1, skdefs, builddir, searchdirs, + onecnt_binary) + if hetero: + prereq2 = _get_compression_prereq(elem2, skdefs, builddir, searchdirs, + onecnt_binary) + else: + prereq2 = None + calculator = SkgenTwocnt(builddir, searchdirs, twocnt_binary) + calculator.set_input(skdefs, elem1, elem2, prereq1, prereq2) + calculator.find_or_run_calculation() + logger.info("Finished") + return calculator + + +def _get_compression_prereq(elem, skdefs, builddir, searchdirs, onecnt_binary): + logger.info("Creating compressed atom prerequisite for {}".format( + sc.capitalize_elem_name(elem))) + calc_dens = run_denscomp(skdefs, elem, builddir, searchdirs, onecnt_binary) + dir_dens = calc_dens.get_result_directory() + result_dens = calc_dens.get_result() + calc_wave = run_wavecomp(skdefs, elem, builddir, searchdirs, onecnt_binary) + dirs_wave = calc_wave.get_result_directories() + result_wave = calc_wave.get_result() + return SkgenTwocntCompressionPrereq(dir_dens, result_dens, dirs_wave, + result_wave) + + +class SkgenTwocntCompressionPrereq: + + def __init__(self, dens_dir, dens_result, wave_dirs, wave_result): + self.dens_dir = dens_dir + self.dens_result = dens_result + self.wave_dirs = wave_dirs + self.wave_result = wave_result + + +class SkgenTwocnt: + + def __init__(self, builddir, searchdirs, twocnt_binary): + self._builddir = builddir + self._searchdirs = searchdirs + self._twocnt_binary = twocnt_binary + self._elem1 = None + self._elem2 = None + self._hetero = False + self._skdefs = None + self._input = None + self._compression_prereqs = None + self._twocenter_searchdirs = None + self._resultdir = None + + + def set_input(self, skdefs, elem1, elem2, comp_prereq1, comp_prereq2): + elem1 = elem1.lower() + elem2 = elem2.lower() + self._elem1 = min(elem1, elem2) + self._elem2 = max(elem1, elem2) + _elements_reversed = (self._elem1 != elem1) + self._hetero = (self._elem1 != self._elem2) + self._skdefs = skdefs + if _elements_reversed: + self._compression_prereqs = ( comp_prereq2, comp_prereq1 ) + else: + self._compression_prereqs = ( comp_prereq1, comp_prereq2 ) + self._input = SkgenTwocntInput(self._skdefs, self._elem1, self._elem2) + self._twocenter_searchdirs = ssc.get_twocenter_searchdirs( + self._searchdirs, self._elem1, self._elem2) + self._resultdir = None + + + def find_or_run_calculation(self): + previous_calc_dirs = ssc.get_matching_subdirectories( + self._twocenter_searchdirs, ssc.TWOCNT_WORKDIR_PREFIX) + resultdirs = self._input.get_all_dirs_with_matching_signature( + previous_calc_dirs) + calculation_needed = True + for resultdir in resultdirs: + if self._check_prereq_dir_links(resultdir): + calculation_needed = False + logger.info("Matching twocnt calculation found " + + sc.log_path(resultdir)) + break + if calculation_needed: + resultdir = ssc.create_twocenter_workdir( + self._builddir, ssc.TWOCNT_WORKDIR_PREFIX, self._elem1, + self._elem2) + logger.info("Doing twocnt calculation " + sc.log_path(resultdir)) + self._create_prereq_dir_links(resultdir,) + calculation = SkgenTwocntCalculation(self._input, + self._compression_prereqs) + calculation.run_and_convert_results(resultdir, self._twocnt_binary) + self._input.store_signature(resultdir) + self._resultdir = resultdir + + + def get_result_directory(self): + return self._resultdir + + + def get_result(self): + if self._resultdir is None: + self.find_or_run_calculation() + return SkgenTwocntResult(self._resultdir) + + + def _check_prereq_dir_links(self, workdir): + prereq1, prereq2 = self._compression_prereqs + links_ok = self._check_prereq_dir_links_for_elem(1, workdir, prereq1) + if links_ok and self._hetero: + tmp = self._check_prereq_dir_links_for_elem(2, workdir, prereq2) + links_ok = links_ok and tmp + return links_ok + + + def _check_prereq_dir_links_for_elem(self, ielem, workdir, prereq): + existing_links = self._get_existing_dir_links_for_elem(ielem, workdir) + links_to_create = self._get_prereq_dir_links_for_elem(ielem, prereq, + workdir) + if len(existing_links) != len(links_to_create): + return False + for linkname, linktarget in links_to_create: + if linkname not in existing_links: + return False + linkname = os.path.realpath(os.path.join(workdir, linkname)) + linktarget = os.path.realpath(os.path.join(workdir, linktarget)) + if not os.path.samefile(linkname, linktarget): + return False + return True + + + @staticmethod + def _get_prereq_dir_links_for_elem(ielem, prereq, workdir): + dir_links = [] + densdir = os.path.relpath(prereq.dens_dir, workdir) + linkname = "{}{:d}".format(ssc.DIRLINK_POTDENS_PREFIX, ielem) + dir_links.append(( linkname, densdir )) + for ind, wavedir in enumerate(prereq.wave_dirs): + wavedir = os.path.relpath(wavedir, workdir) + linkname = "{}{:d}.{:d}".format(ssc.DIRLINK_WAVE_PREFIX, ielem, + ind + 1) + dir_links.append(( linkname, wavedir )) + return dir_links + + + @staticmethod + def _get_existing_dir_links_for_elem(ielem, workdir): + glob1 = os.path.join(workdir, + "{}{:d}*".format(ssc.DIRLINK_POTDENS_PREFIX, + ielem)) + dir_links = glob.glob(glob1) + glob2 = os.path.join(workdir, + "{}{:d}*".format(ssc.DIRLINK_WAVE_PREFIX, ielem)) + dir_links += glob.glob(glob2) + dir_links_basename = [ os.path.basename(mydir) for mydir in dir_links + if os.path.exists(mydir) ] + return set(dir_links_basename) + + + def _delete_existing_dir_links(self, workdir): + links_to_delete = self._get_existing_dir_links_for_elem(1, workdir) + links_to_delete.update( + self._get_existing_dir_links_for_elem(2, workdir)) + for link in links_to_delete: + os.remove(os.path.join(workdir, link)) + + + def _create_prereq_dir_links(self, workdir): + prereq1, prereq2 = self._compression_prereqs + links_to_create = self._get_prereq_dir_links_for_elem(1, prereq1, + workdir) + if self._hetero: + links_to_create += self._get_prereq_dir_links_for_elem(2, prereq2, + workdir) + for linkname, linktarget in links_to_create: + os.symlink(linktarget, os.path.join(workdir, linkname)) + + + +class SkgenTwocntInput(ssc.InputWithSignature): + + SIGNATURE_FILE = ssc.TWOCNT_SIGNATURE_FILE + + def __init__(self, skdefs, elem1, elem2): + atomparam1 = skdefs.atomparameters[elem1] + atomparam2 = skdefs.atomparameters[elem2] + self.atomconfig1 = atomparam1.atomconfig + self.atomconfig2 = atomparam2.atomconfig + twocentpars = skdefs.twocenterparameters[(elem1, elem2)] + self.calculator = twocentpars.calculator + self.grid = twocentpars.grid + self.hetero = elem1 != elem2 + self.superposition = skdefs.globals.superposition + self.functional = skdefs.globals.xcfunctional + + + def get_signature(self): + signature = { + "atomconfig1": self.atomconfig1, + "atomconfig2": self.atomconfig2, + "calculator": self.calculator, + "grid": self.grid, + "hetero": self.hetero, + "superposition": self.superposition, + "functional": self.functional + } + return signature + + + +class SkgenTwocntCalculation: + + def __init__(self, myinput, prerequisites): + self._input = myinput + self._prereq1, self._prereq2 = prerequisites + self._twocnt_calculator = ssc.TwocenterCalculatorWrapper( + myinput.calculator) + + + def run_and_convert_results(self, workdir, twocnt_binary): + atom1data = self._get_atomdata(self._input.atomconfig1, self._prereq1) + if self._input.hetero: + atom2data = self._get_atomdata(self._input.atomconfig2, + self._prereq2) + else: + atom2data = None + self._twocnt_calculator.do_calculation( + self._input.superposition, self._input.functional, self._input.grid, + atom1data, atom2data, twocnt_binary, workdir) + result = self._twocnt_calculator.get_output(workdir) + self._store_results(result, workdir) + + + def _get_atomdata(self, atomconfig, atomcalcs): + atomdata = sc.ClassDict() + atomdata.potentials = atomcalcs.dens_result.get_potential() + atomdata.density = atomcalcs.dens_result.get_density() + atomdata.wavefuncs = self._get_standardized_compressed_wfcs( + atomconfig, atomcalcs.wave_result) + return atomdata + + + @staticmethod + def _get_standardized_compressed_wfcs(atomconfig, wavecomp_result): + wavefuncs = [] + waves_found_for_shell = {} + for nn, ll in atomconfig.valenceshells: + wfc012 = wavecomp_result.get_wavefunction(nn, ll) + wfc0_data = wfc012.data[:,0] + wfc0_grid = wfc012.grid + norm = wfc0_grid.dot(wfc0_data, wfc0_data) + logger.debug("Norm for wavefunc {:d}{:s}: {:f}".format( + nn, sc.ANGMOM_TO_SHELL[ll], norm)) + wfc0 = soc.GridData(wfc0_grid, wfc0_data) + sign = get_normalized_sign(nn, ll, wfc0) + logger.debug("Sign for wavefunc {:d}{:s}: {:.1f}".format( + nn, sc.ANGMOM_TO_SHELL[ll], sign)) + wfc012.data *= sign + previous_wfcs = waves_found_for_shell.get(ll, []) + if len(previous_wfcs): + coeffs = get_expansion_coefficients(wfc012, previous_wfcs) + msg = "Expansion coeffs of previous wavefuncs:" + msg += " {:f}" * len(coeffs) + logger.debug(msg.format(*coeffs)) + wfc012 = orthogonalize_wave_and_derivatives( + wfc012, previous_wfcs, coeffs) + newwave = ( nn, ll, wfc012 ) + if ll in waves_found_for_shell: + waves_found_for_shell[ll].append(newwave) + else: + waves_found_for_shell[ll] = newwave + wavefuncs.append(newwave) + return wavefuncs + + + @staticmethod + def _store_results(result, workdir): + result_file = os.path.join(workdir, ssc.TWOCNT_RESULT_FILE) + sc.store_as_shelf(result_file, hamiltonian=result.get_hamiltonian(), + overlap=result.get_overlap()) + + + +class SkgenTwocntResult: + + def __init__(self, workdir): + self._result_db = sc.retrive_from_shelf( + os.path.join(workdir, ssc.TWOCNT_RESULT_FILE)) + + + def get_hamiltonian(self): + return self._result_db["hamiltonian"] + + + def get_overlap(self): + return self._result_db["overlap"] + + + +def get_normalized_sign(nn, ll, wavefunc): + # Note: wavefunc data has shape (ngrid, 1) + rR = wavefunc.grid.rr * wavefunc.data[:,0] + imax = np.argmax(np.abs(rR)) + sign = np.sign(rR[imax]) + # Note: normalized sign should be n-independent to make sure also the + # twocenter integration program can check if the conditions are fulfilled. + normalized_sign = 1 + return float(sign / normalized_sign) + + +def get_expansion_coefficients(wavefunc, prev_wavefuncs): + coeffs = [] + for wfcprev in prev_wavefuncs: + if wavefunc.grid != wfcprev.grid: + msg = "Incompatible grids found." + raise sc.SkgenException(msg) + coeffs.append(wavefunc.grid.dot(wavefunc.data[:,0], wfcprev.data[:,0])) + return coeffs + + +def orthogonalize_wave_and_derivatives(wavefunc, prev_wavefuncs, coeffs): + if len(prev_wavefuncs) == 0: + return wavefunc + wfcnew_data = wavefunc.data.copy() + for coeff, wfcprev in zip(coeffs, prev_wavefuncs): + wfcnew_data -= coeff * wfcprev.data + norm = wavefunc.grid.dot(wfcnew_data[:,0], wfcnew_data[:,0]) + wfcnew_data /= norm + return soc.GridData(wavefunc.grid, wfcnew_data) diff --git a/sktools/src/sktools/taggedfile.py b/sktools/src/sktools/taggedfile.py new file mode 100644 index 00000000..1eb09150 --- /dev/null +++ b/sktools/src/sktools/taggedfile.py @@ -0,0 +1,119 @@ +from collections import OrderedDict +import numpy as np + + +class TaggedFile(OrderedDict): + + CONVERTER = { "real": np.float, + "integer": np.int, + "logical": lambda x: x.lower() == "t" + } + + DTYPE_NAMES = { + np.dtype("int64"): "integer", + np.dtype("float64"): "real", + np.dtype("bool"): "logical", + int: "integer", + float: "real", + bool: "logical", + str: "string", + } + + DTYPE_FORMATS = { + # Numpy 1.6.1 can't format "int64" as integers in Python 3.2 + #np.dtype("int64"): ( 3, "{:20d}"), + np.dtype("int64"): ( 3, "{:20d}"), + np.dtype("float64"): (3, "{:23.15E}"), + np.dtype("bool"): (40, "{:2s}"), + str: (72, " {:s}"), + int: " {:20d}", + float: " {:23.15E}", + bool: " {:s}", + } + + def __init__(self, initvalues=None): + if initvalues: + super().__init__(initvalues) + else: + super().__init__() + + def tofile(self, fp): + for key, value in self.items(): + if isinstance(value, np.ndarray): + dtype = value.dtype + fp.write("@{:s}:{:s}:{:d}:{:s}\n".format( + key, self.DTYPE_NAMES[dtype], len(value.shape), + ",".join([ str(dd) for dd in value.shape]))) + nitem, formstr = self.DTYPE_FORMATS[dtype] + if dtype == np.dtype("bool"): + value = np.where(value, 'T', 'F') + self._lineformattedwrite(fp, nitem, formstr, + value.ravel(order="F")) + elif isinstance(value, str): + dtype = str + nn = len(value) + fp.write("@{:s}:{:s}:{:d}:{:d}\n".format( + key, self.DTYPE_NAMES[dtype], 1, nn)) + nitem, formstr = self.DTYPE_FORMATS[dtype] + for ii in range(nitem, nn + 1, nitem): + fp.write(formstr.format(value[ii-nitem:ii]) + "\n") + remaining = nn % nitem + if remaining: + fp.write(formstr.format(value[nn-remaining:nn]) + "\n") + else: + dtype = type(value) + fp.write("@{:s}:{:s}:{:d}:\n".format( + key, self.DTYPE_NAMES[dtype], 0)) + if isinstance(value, bool): + value = "T" if value else "F" + fp.write(self.DTYPE_FORMATS[dtype].format(value)) + fp.write("\n") + + + def _lineformattedwrite(self, fp, nitem, formstr, valuelist): + nn = len(valuelist) + lineformstr = " ".join(nitem * [ formstr, ]) + "\n" + for ii in range(nitem, nn + 1, nitem): + fp.write(lineformstr.format(*valuelist[ii-nitem:ii])) + remaining = nn % nitem + if remaining: + lineformstr = " ".join(remaining * [ formstr, ]) + "\n" + fp.write(lineformstr.format(*valuelist[nn-remaining:nn])) + + + + @classmethod + def fromfile(cls, fp, transpose=False): + fname = isinstance(fp, str) + if fname: + fp = open(fp, "r") + tagvalues = [] + line = fp.readline() + tmp = [] + while line: + tagline = line + tmp = [] + line = fp.readline() + while line and line[0] != "@": + tmp += line.split() + line = fp.readline() + words = tagline.split(":") + tag = words[0][1:] + dtype = words[1] + dim = int(words[2]) + if dim: + shape = [ int(dd) for dd in words[3].split(",") ] + if dtype == "string": + value = "".join(tmp) + else: + elems = [ cls.CONVERTER[dtype](ss) for ss in tmp ] + value = np.array(elems).reshape(shape, order="F") + if transpose: + value = value.transpose() + else: + value = cls.CONVERTER[dtype](tmp[0]) + tagvalues.append((tag, value)) + if fname: + fp.close() + return cls(tagvalues) + diff --git a/sktools/src/sktools/twocenter_grids.py b/sktools/src/sktools/twocenter_grids.py new file mode 100644 index 00000000..8161929d --- /dev/null +++ b/sktools/src/sktools/twocenter_grids.py @@ -0,0 +1,46 @@ +import sktools.hsd.converter as conv +import sktools.common as sc + + +class EquidistantGrid(sc.ClassDict): + """Equidistant grid. + + Attributes + ---------- + gridstart : float + Starting point of the grid. + gridseparation : float + Distance between grid points. + maxdistance : float + Maximal grid distance. + tolerance: + Stopping criterion for grid (when represented value on the grid is + below tolerance). + """ + + @classmethod + def fromhsd(cls, node, query): + myself = cls() + myself.gridstart = query.getvalue(node, "gridstart", conv.float0) + myself.gridseparation = query.getvalue(node, "gridseparation", + conv.float0) + myself.tolerance = query.getvalue(node, "tolerance", conv.float0) + myself.maxdistance = query.getvalue(node, "maxdistance", conv.float0) + return myself + + def __eq__(self, other): + if abs(self.gridstart - other.gridstart) > sc.INPUT_FLOAT_TOLERANCE: + return False + if (abs(self.gridseparation - other.gridseparation) + > sc.INPUT_FLOAT_TOLERANCE): + return False + if abs(self.tolerance - other.tolerance) > sc.INPUT_FLOAT_TOLERANCE: + return False + if abs(self.maxdistance - other.maxdistance) > sc.INPUT_FLOAT_TOLERANCE: + return False + return True + + +TWOCENTER_GRIDS = { + "equidistantgrid": EquidistantGrid +} diff --git a/sktwocnt/CMakeLists.txt b/sktwocnt/CMakeLists.txt new file mode 100644 index 00000000..21d931ee --- /dev/null +++ b/sktwocnt/CMakeLists.txt @@ -0,0 +1,2 @@ +add_subdirectory(lib) +add_subdirectory(prog) diff --git a/sktwocnt/lib/CMakeLists.txt b/sktwocnt/lib/CMakeLists.txt new file mode 100644 index 00000000..2073ec6c --- /dev/null +++ b/sktwocnt/lib/CMakeLists.txt @@ -0,0 +1,26 @@ +set(sources-f90 + bisection.f90 + coordtrans.f90 + dftbxc.f90 + gridgenerator.f90 + gridorbital.f90 + interpolation.f90 + partition.f90 + quadrature.f90 + sphericalharmonics.f90 + twocnt.f90) + +add_library(skprogs-sktwocnt ${sources-f90}) + +target_link_libraries(skprogs-sktwocnt skprogs-common) + +set(moddir ${CMAKE_CURRENT_BINARY_DIR}/modfiles) +set_target_properties(skprogs-sktwocnt PROPERTIES Fortran_MODULE_DIRECTORY ${moddir}) +target_include_directories(skprogs-sktwocnt PUBLIC + $ + $) + +if(BUILD_SHARED_LIBS) + install(TARGETS skprogs-sktwocnt EXPORT skprogs-targets DESTINATION ${CMAKE_INSTALL_LIBDIR}) +endif() +#install(DIRECTORY ${moddir}/ DESTINATION ${CMAKE_INSTALL_MODULEDIR}) diff --git a/sktwocnt/lib/bisection.f90 b/sktwocnt/lib/bisection.f90 new file mode 100644 index 00000000..9e4fbb01 --- /dev/null +++ b/sktwocnt/lib/bisection.f90 @@ -0,0 +1,114 @@ +!> Contains routines to locate a value in an array using bisection. +module bisection + use accuracy, only : dp + implicit none + private + + public :: bisect + + !> Bisection driver. + interface bisect + module procedure bisect_real + module procedure bisect_int + end interface bisect + +contains + + !> Real case for bisection search to to find a point in an array xx(:) + !! between xx(1) and xx(size(xx)) such that element indexed ind is less than + !! the value x0 queried. + !! \param xx Array of values in monotonic order to search through. + !! \param x0 Value to locate ind for. + !! \param ind Located element such that xx(ind) < x < xx(ind). + pure subroutine bisect_real(xx, x0, ind, tol) + real(dp), intent(in) :: xx(:), x0 + integer, intent(out) :: ind + real(dp), intent(in), optional :: tol + + integer :: nn + integer :: ilower, iupper, icurr + real(dp) :: rTol ! real tolerance + logical :: ascending + + nn = size(xx) + if (nn == 0) then + ind = 0 + return + end if + + if (present(tol)) then + rTol = tol + else + rTol = epsilon(0.0_dp) + end if + + if (x0 < xx(1) - rTol) then + ind = 0 + else if (abs(x0 - xx(1)) <= rTol) then + ind = 1 + else if (abs(x0 - xx(nn)) <= rTol) then + ind = nn - 1 + else if (x0 > xx(nn) + rTol) then + ind = nn + else + ascending = (xx(nn) >= xx(1)) + ilower = 0 + icurr = nn + 1 + do while ((icurr - ilower) > 1) + iupper = (icurr + ilower) / 2 + if (ascending .eqv. (x0 >= xx(iupper) + rTol)) then + ilower = iupper + else + icurr = iupper + end if + end do + ind = ilower + end if + + end subroutine bisect_real + + + !> Integer case for bisection search to to find a point in an array xx(:) + !! between xx(1) and xx(size(xx)) such that element indexed ind is less than + !! the value x0 queried + !! \param xx Array of values in monotonic order to search through. + !! \param x0 Value to locate ind for. + !! \param ind Located element such that xx(ind) < x < xx(ind). + pure subroutine bisect_int(xx, x0, ind) + integer, intent(in) :: xx(:), x0 + integer, intent(out) :: ind + + integer :: nn + integer :: ilower, iupper, icurr + + nn = size(xx) + if (nn == 0) then + ind = 0 + return + end if + + if (x0 < xx(1)) then + ind = 0 + else if (x0 == xx(1)) then + ind = 1 + else if(x0 == xx(nn)) then + ind = nn -1 + else if(x0 > xx(nn)) then + ind = nn + else + ilower = 0 + icurr = nn + 1 + do while ((icurr - ilower) > 1) + iupper = (icurr + ilower) / 2 + if((xx(nn) >= xx(1)) .eqv. (x0 >= xx(iupper)))then + ilower = iupper + else + icurr = iupper + end if + end do + ind = ilower + end if + + end subroutine bisect_int + +end module bisection diff --git a/sktwocnt/lib/coordtrans.f90 b/sktwocnt/lib/coordtrans.f90 new file mode 100644 index 00000000..fc63a5dc --- /dev/null +++ b/sktwocnt/lib/coordtrans.f90 @@ -0,0 +1,209 @@ +module coordtrans + use accuracy + use constants + implicit none + +contains + + !> Transforms a 3 dimensional vector with coordinates in [-1,1] onto spherical + !! coordinates, using the Becke algorithm. + !! \param crd11 3d coordinate vector, each coordinate in [-1,1]. + !! \param spheric Corresponding spherical coordinates. + !! \param jacobi Jacobi determinant. + !! \sa Becke paper. + subroutine coordtrans_becke(c11, spheric, jacobi) + real(dp), intent(in) :: c11(:) + real(dp), intent(out) :: spheric(:) + real(dp), intent(out) :: jacobi + + real(dp), parameter :: rm = 1.5_dp; + real(dp) :: rtmp1, rtmp2 + + !assert(size(c11) == 3) + !assert(size(spheric) == 3) + + rtmp1 = 1.0_dp + c11(1) + rtmp2 = 1.0_dp - c11(1) + spheric(1) = rm * (rtmp1 / rtmp2) + spheric(2) = acos(c11(2)) + spheric(3) = pi * (c11(3) + 1.0_dp) + jacobi = 2.0_dp * rm**3 * rtmp1**2 / rtmp2**4 * pi + + end subroutine coordtrans_becke + + + !> Transforms a 2 dimensional vector with coordinates in [-1,1] onto spherical + !! coordinates (r, theta), using the Becke algorithm. + !! \param crd11 2d coordinate vector, each coordinate in [-1,1]. + !! \param spheric Corresponding spherical coordinates (r, theta) + !! \param jacobi Jacobi determinant. + !! \sa Becke paper. + subroutine coordtrans_becke_12(c11, spheric, jacobi) + real(dp), intent(in) :: c11(:) + real(dp), intent(out) :: spheric(:) + real(dp), intent(out) :: jacobi + + real(dp), parameter :: rm = 1.5_dp; + real(dp) :: rtmp1, rtmp2 + + !assert(size(c11) == 2) + !assert(size(spheric) == 2) + + rtmp1 = 1.0_dp + c11(1) + rtmp2 = 1.0_dp - c11(1) + spheric(1) = rm * (rtmp1 / rtmp2) + spheric(2) = acos(c11(2)) + jacobi = 2.0_dp * rm**3 * rtmp1**2 / rtmp2**4 + + end subroutine coordtrans_becke_12 + + + !> Transforms a 2 dimensional vector with coordinates in [-1,1] onto spherical + !! coordinates (theta, phi), using the Becke algorithm. + !! \param crd11 2d coordinate vector, each coordinate in [-1,1]. + !! \param spheric Corresponding spherical coordinates (theta, phi). + !! \param jacobi Jacobi determinant. + !! \sa Becke paper. + subroutine coordtrans_becke_23(c11, spheric, jacobi) + real(dp), intent(in) :: c11(:) + real(dp), intent(out) :: spheric(:) + real(dp), intent(out) :: jacobi + + !assert(size(c11) == 2) + !assert(size(spheric) == 2) + + spheric(1) = acos(c11(1)) + spheric(2) = pi * (c11(2) + 1.0_dp) + jacobi = pi + + end subroutine coordtrans_becke_23 + + + !> Transforms a 3 dimensional vector with coordinates in [-1,1] onto spherical + !! coordinates, using the Ahlrichs algorithm. + !! \param c11 3d coordinate vector, each coordinate in [-1,1]. + !! \param spheric Corresponding spherical coordinates. + !! \param jacobi Jacobi determinant. + !! \sa Ahlrichs paper. + subroutine coordtrans_ahlrichs1(c11, spheric, jacobi) + real(dp), intent(in) :: c11(:) + real(dp), intent(out) :: spheric(:) + real(dp), intent(out) :: jacobi + + real(dp), parameter :: zeta = 1.20_dp + real(dp) :: rr + + !assert(size(c11) == 3) + !assert(size(spheric) == 3) + + rr = (zeta / log(2.0_dp)) * log(2.0_dp / (1.0_dp - c11(1))) + spheric(1) = rr + spheric(2) = acos(c11(2)) + spheric(3) = pi * (c11(3) + 1.0_dp) + jacobi = (zeta / log(2.0_dp)) / (1.0_dp - c11(1)) * rr * rr * pi + + end subroutine coordtrans_ahlrichs1 + + + + !> Transforms a 3 dimensional vector with coordinates in [-1,1] onto spherical + !! coordinates, using the Ahlrichs algorithm. + !! \param c11 3d coordinate vector, each coordinate in [-1,1]. + !! \param spheric Corresponding spherical coordinates. + !! \param jacobi Jacobi determinant. + !! \sa Ahlrichs paper. + subroutine coordtrans_ahlrichs1_2d(c11, spheric, jacobi) + real(dp), intent(in) :: c11(:) + real(dp), intent(out) :: spheric(:) + real(dp), intent(out) :: jacobi + + real(dp), parameter :: zeta = 1.20_dp + real(dp) :: rr + + !assert(size(c11) == 3) + !assert(size(spheric) == 3) + + rr = (zeta / log(2.0_dp)) * log(2.0_dp / (1.0_dp - c11(1))) + spheric(1) = rr + spheric(2) = acos(c11(2)) + !spheric(3) = pi * (c11(3) + 1.0_dp) + jacobi = (zeta / log(2.0_dp)) / (1.0_dp - c11(1)) * rr * rr + + end subroutine coordtrans_ahlrichs1_2d + + + !> Transforms a 3 dimensional vector with coordinates in [-1,1] onto spherical + !! coordinates, using the Ahlrichs algorithm. + !! \param c11 3d coordinate vector, each coordinate in [-1,1]. + !! \param spheric Corresponding spherical coordinates. + !! \param jacobi Jacobi determinant. + !! \sa Ahlrichs paper. + subroutine coordtrans_ahlrichs2(c11, spheric, jacobi) + real(dp), intent(in) :: c11(:) + real(dp), intent(out) :: spheric(:) + real(dp), intent(out) :: jacobi + + real(dp), parameter :: zeta = 1.1_dp + real(dp), parameter :: alpha = 0.6_dp + real(dp) :: rr + + !assert(size(c11) == 3) + !assert(size(spheric) == 3) + + rr = (zeta / log(2.0_dp)) * (1.0_dp + c11(1))**alpha & + &* log(2.0_dp / (1.0_dp - c11(1))) + spheric(1) = rr + spheric(2) = acos(c11(2)) + spheric(3) = pi * (c11(3) + 1.0_dp) + + jacobi = (zeta * (1.0_dp + c11(1))**alpha / log(2.0_dp)) & + &* (alpha * log(2.0_dp / (1.0_dp - c11(1))) / (1.0_dp + c11(1)) & + &+ 1.0_dp / (1.0_dp - c11(1))) * rr * rr * pi + + end subroutine coordtrans_ahlrichs2 + + + + !> Transforms a 3 dimensional vector with coordinates in [-1,1] onto spherical + !! coordinates, using the Ahlrichs algorithm. + !! \param c11 3d coordinate vector, each coordinate in [-1,1]. + !! \param spheric Corresponding spherical coordinates. + !! \param jacobi Jacobi determinant. + !! \sa Ahlrichs paper. + subroutine coordtrans_ahlrichs2_2d(c11, spheric, jacobi) + real(dp), intent(in) :: c11(:) + real(dp), intent(out) :: spheric(:) + real(dp), intent(out) :: jacobi + + real(dp), parameter :: zeta = 1.1_dp + real(dp), parameter :: alpha = 0.6_dp + real(dp) :: rr + + !assert(size(c11) == 3) + !assert(size(spheric) == 3) + + rr = (zeta / log(2.0_dp)) * (1.0_dp + c11(1))**alpha & + &* log(2.0_dp / (1.0_dp - c11(1))) + spheric(1) = rr + spheric(2) = acos(c11(2)) + spheric(3) = pi * (c11(3) + 1.0_dp) + + jacobi = (zeta * (1.0_dp + c11(1))**alpha / log(2.0_dp)) & + &* (alpha * log(2.0_dp / (1.0_dp - c11(1))) / (1.0_dp + c11(1)) & + &+ 1.0_dp / (1.0_dp - c11(1))) * rr * rr + + end subroutine coordtrans_ahlrichs2_2d + + + + subroutine coordtrans_identity(c11, ctarget, jacobi) + real(dp), intent(in) :: c11(:) + real(dp), intent(out) :: ctarget(:) + real(dp), intent(out) :: jacobi + + ctarget = c11 + jacobi = 1.0_dp + + end subroutine coordtrans_identity + +end module coordtrans diff --git a/sktwocnt/lib/dftbxc.f90 b/sktwocnt/lib/dftbxc.f90 new file mode 100644 index 00000000..90c320ed --- /dev/null +++ b/sktwocnt/lib/dftbxc.f90 @@ -0,0 +1,350 @@ +module dftxc + use, intrinsic :: ieee_arithmetic + use accuracy + use constants + implicit none + private + + public :: getxcpot_ldapw91, getxcpot_ggapbe + + real(dp), parameter :: rec4pi = 1.0_dp / (4.0_dp * pi) + +contains + + subroutine getxcpot_ldapw91(rho4pi, xcpot) + real(dp), intent(in) :: rho4pi(:) + real(dp), intent(out) :: xcpot(:) + + integer :: nn, ii + real(dp), allocatable :: rho(:), rs(:) + real(dp) :: vcup, vcdn, ec, vx, ex + + nn = size(rho4pi) + allocate(rs(nn), rho(nn)) + + ! Renorm rho (incoming quantity is 4pi normed) + rho = rho4pi * rec4pi + ! Note: rho is normed to 4pi, therefore 4*pi missing in rs + rs = (3.0_dp / rho4pi)**(1.0_dp / 3.0_dp) + do ii = 1, nn + if (rho(ii) < epsilon(1.0_dp)) then + xcpot(ii) = 0.0_dp + else + call correlation_pbe(rs(ii), 0.0_dp, 0.0_dp, 0.0_dp, 0.0_dp, 0.0_dp, & + &0, ec, vcup, vcdn) + call exchange_pbe(rho(ii), 0.0_dp, 0.0_dp, 0.0_dp, 0, ex, vx) + xcpot(ii) = vcup + vx + end if + end do + + deallocate(rs, rho) + + end subroutine getxcpot_ldapw91 + + + + subroutine getxcpot_ggapbe(rho4pi, absgr4pi, laplace4pi, gr_grabsgr4pi, xcpot) + real(dp), intent(in) :: rho4pi(:) + real(dp), intent(in) :: absgr4pi(:), laplace4pi(:), gr_grabsgr4pi(:) + real(dp), intent(out) :: xcpot(:) + + real(dp), allocatable :: rho(:), absgr(:), laplace(:), gr_grabsgr(:) + real(dp), allocatable :: rs(:), fac(:), tt(:), uu(:), vv(:) + real(dp), allocatable :: ss(:), u2(:), v2(:) + real(dp) :: alpha, zeta, gg, ww + real(dp) :: ec, vcup, vcdn, ex, vx + integer :: nn, ii + + nn = size(rho4pi) + allocate(rho(nn), absgr(nn), laplace(nn), gr_grabsgr(nn)) + allocate(rs(nn), fac(nn), tt(nn), uu(nn), vv(nn), ss(nn), u2(nn), v2(nn)) + + ! Renorm rho and derivatives (incoming quantities are 4pi normed) + rho = rho4pi * rec4pi + absgr = absgr4pi / rho4pi + laplace = laplace4pi / rho4pi + gr_grabsgr = gr_grabsgr4pi / rho4pi**2 + + ! Note: rho is normed to 4pi, therefore 4*pi missing in rs + rs = (3.0_dp / rho4pi)**(1.0_dp / 3.0_dp) + zeta = 0.0_dp + gg = 1.0_dp + alpha = (4.0_dp/(9.0_dp * pi))**(1.0_dp/3.0_dp) + ! Factors for the correlation routine + fac = sqrt(pi / 4.0_dp * alpha * rs) / (2.0_dp * gg) + tt = absgr * fac + uu = gr_grabsgr * fac**3 + vv = laplace * fac**2 + ww = 0.0_dp + ! Factors for the exchange routine + fac = alpha * rs / 2.0_dp + ss = absgr * fac + u2 = gr_grabsgr * fac**3 + v2 = laplace * fac**2 + + do ii = 1, nn + if (rho(ii) < epsilon(1.0_dp)) then + xcpot(ii) = 0.0_dp + else + call correlation_pbe(rs(ii), 0.0_dp, tt(ii), uu(ii), vv(ii), ww, 1, & + &ec, vcup, vcdn) + call exchange_pbe(rho(ii), ss(ii), u2(ii), v2(ii), 1, ex, vx) + if (ieee_is_nan(vcup)) then + print *, "VCUP NAN", ii, rs(ii), tt(ii), uu(ii), vv(ii) + print *, ":", absgr(ii), gr_grabsgr(ii), laplace(ii) + stop + elseif (ieee_is_nan(vx)) then + print *, "VX NAN", ii + stop + end if + xcpot(ii) = vcup + vx + end if + end do + + deallocate(rho, absgr, laplace, gr_grabsgr) + deallocate(rs, fac, tt, uu, vv) + + end subroutine getxcpot_ggapbe + + + + SUBROUTINE CORRELATION_PBE(RS,ZET,T,UU,VV,WW,igga,ec,vc1,vc2) + + ! + ! APART FROM COSMETICS THIS IS IN FACT BURKEs FORTRAN REFERENCE IMPLEMENTATION + ! + + ! This is the PBE and PW-LDA Correlation routine. + + IMPLICIT REAL(8) (A-H,O-Z) + !---------------------------------------------------------------------- + ! INPUT: RS=SEITZ RADIUS=(3/4pi rho)^(1/3) + ! : ZET=RELATIVE SPIN POLARIZATION = (rhoup-rhodn)/rho + ! : t=ABS(GRAD rho)/(rho*2.*KS*G) -- only needed for PBE + ! : UU=(GRAD rho)*GRAD(ABS(GRAD rho))/(rho**2 * (2*KS*G)**3) + ! : VV=(LAPLACIAN rho)/(rho * (2*KS*G)**2) + ! : WW=(GRAD rho)*(GRAD ZET)/(rho * (2*KS*G)**2 + ! : UU,VV,WW, only needed for PBE potential + ! : igga=flag to do gga (0=>LSD only) + ! output: ecl=lsd correlation energy from [a] + ! : ecn=NONLOCAL PART OF CORRELATION ENERGY PER ELECTRON + ! : vcup=lsd up correlation potential + ! : vcdn=lsd dn correlation potential + ! : dvcup=nonlocal correction to vcup + ! : dvcdn=nonlocal correction to vcdn + !---------------------------------------------------------------------- + ! References: + ! [a] J.P.~Perdew, K.~Burke, and M.~Ernzerhof, + ! {\sl Generalized gradient approximation made simple}, sub. + ! to Phys. Rev.Lett. May 1996. + ! [b] J. P. Perdew, K. Burke, and Y. Wang, {\sl Real-space cutoff + ! construction of a generalized gradient approximation: The PW91 + ! density functional}, submitted to Phys. Rev. B, Feb. 1996. + ! [c] J. P. Perdew and Y. Wang, Phys. Rev. B {\bf 45}, 13244 (1992). + !---------------------------------------------------------------------- + ! bet=coefficient in gradient expansion for correlation, [a](4). + integer :: igga + parameter(thrd=1.d0/3.d0,thrdm=-thrd,thrd2=2.d0*thrd) + parameter(GAM=0.5198420997897463295344212145565d0) + parameter(thrd4=4.d0*thrd, fzz=8.d0/(9.d0*GAM)) + parameter(gamma=0.03109069086965489503494086371273d0) + parameter(bet=0.06672455060314922d0,delt=bet/gamma) + dimension u(6),p(6),s(6) + data u/ 0.03109070D0, 0.2137000D0, 7.5957000D0,& + & 3.58760000D0, 1.6382000D0, 0.4929400D0/ + data p/ 0.01554535D0, 0.2054800D0,14.1189000D0,& + & 6.19770000D0, 3.3662000D0, 0.6251700D0/ + data s/ 0.01688690D0, 0.1112500D0,10.3570000D0,& + & 3.62310000D0, 0.8802600D0, 0.4967100D0/ + !---------------------------------------------------------------------- + ! find LSD energy contributions, using [c](10) . + ! EU=unpolarized LSD correlation energy , EURS=dEU/drs + ! EP=fully polarized LSD correlation energy , EPRS=dEP/drs + ! ALFM=-spin stiffness, [c](3) , ALFRSM=-dalpha/drs . + ! F=spin-scaling factor from [c](9). + ! construct ecl, using [c](8) . + ! + + rtrs=dsqrt(rs) + Q0 = -2.D0*u(1)*(1.D0+u(2)*rtrs*rtrs) + Q1 = 2.D0*u(1)*rtrs*(u(3)+rtrs*(u(4)+rtrs*(u(5)+u(6)*rtrs))) + Q2 = DLOG(1.D0+1.D0/Q1) + Q3 = u(1)*(u(3)/rtrs+2.D0*u(4)+rtrs*(3.D0*u(5)+4.D0*u(6)*rtrs)) + EU = Q0*Q2 + EURS = -2.D0*u(1)*u(2)*Q2-Q0*Q3/(Q1*(1.d0+Q1)) + Q0 = -2.D0*p(1)*(1.D0+p(2)*rtrs*rtrs) + Q1 = 2.D0*p(1)*rtrs*(p(3)+rtrs*(p(4)+rtrs*(p(5)+p(6)*rtrs))) + Q2 = DLOG(1.D0+1.D0/Q1) + Q3 = p(1)*(p(3)/rtrs+2.D0*p(4)+rtrs*(3.D0*p(5)+4.D0*p(6)*rtrs)) + EP = Q0*Q2 + EPRS = -2.D0*p(1)*p(2)*Q2-Q0*Q3/(Q1*(1.d0+Q1)) + Q0 = -2.D0*s(1)*(1.D0+s(2)*rtrs*rtrs) + Q1 = 2.D0*s(1)*rtrs*(s(3)+rtrs*(s(4)+rtrs*(s(5)+s(6)*rtrs))) + Q2 = DLOG(1.D0+1.D0/Q1) + Q3 = s(1)*(s(3)/rtrs+2.D0*s(4)+rtrs*(3.D0*s(5)+4.D0*s(6)*rtrs)) + ALFM = Q0*Q2 + ALFRSM = -2.D0*s(1)*s(2)*Q2-Q0*Q3/(Q1*(1.d0+Q1)) + + Z4 = ZET**4 + F=((1.D0+ZET)**THRD4+(1.D0-ZET)**THRD4-2.D0)/GAM + ECL= EU*(1.D0-F*Z4)+EP*F*Z4-ALFM*F*(1.D0-Z4)/FZZ + !---------------------------------------------------------------------- + ! LSD potential from [c](A1) + ! ECRS = dEc/drs , ECZET=dEc/dzeta , FZ = dF/dzeta [c](A2-A4) + ! + ECRS = EURS*(1.D0-F*Z4)+EPRS*F*Z4-ALFRSM*F*(1.D0-Z4)/FZZ + FZ = THRD4*((1.D0+ZET)**THRD-(1.D0-ZET)**THRD)/GAM + ECZET = 4.D0*(ZET**3)*F*(EP-EU+ALFM/FZZ)& + & +FZ*(Z4*EP-Z4*EU-(1.D0-Z4)*ALFM/FZZ) + COMM = ECL -RS*ECRS/3.D0-ZET*ECZET + VCUP = COMM + ECZET + VCDN = COMM - ECZET + if(igga.eq.0)then + EC=ECL + VC1=VCUP + VC2=VCDN + return + endif + !---------------------------------------------------------------------- + ! PBE correlation energy + ! G=phi(zeta), given after [a](3) + ! DELT=bet/gamma , B=A of [a](8) + ! + G=((1.d0+ZET)**thrd2+(1.d0-ZET)**thrd2)/2.d0 + G3 = G**3 + PON=-ECL/(G3*gamma) + B = DELT/(DEXP(PON)-1.D0) + B2 = B*B + T2 = T*T + T4 = T2*T2 + Q4 = 1.D0+B*T2 + Q5 = 1.D0+B*T2+B2*T4 + ECN= G3*(BET/DELT)*DLOG(1.D0+DELT*Q4*T2/Q5) + EC = ECL + ECN + !---------------------------------------------------------------------- + ! ENERGY DONE. NOW THE POTENTIAL, using appendix E of [b]. + ! + G4 = G3*G + T6 = T4*T2 + RSTHRD = RS/3.D0 + ! GZ=((1.d0+zet)**thirdm-(1.d0-zet)**thirdm)/3.d0 + ! ckoe: hack thirdm never gets defined, but 1-1 should be zero anyway + GZ=0.0d0 + FAC = DELT/B+1.D0 + BG = -3.D0*B2*ECL*FAC/(BET*G4) + BEC = B2*FAC/(BET*G3) + Q8 = Q5*Q5+DELT*Q4*Q5*T2 + Q9 = 1.D0+2.D0*B*T2 + hB = -BET*G3*B*T6*(2.D0+B*T2)/Q8 + hRS = -RSTHRD*hB*BEC*ECRS + FACT0 = 2.D0*DELT-6.D0*B + FACT1 = Q5*Q9+Q4*Q9*Q9 + hBT = 2.D0*BET*G3*T4*((Q4*Q5*FACT0-DELT*FACT1)/Q8)/Q8 + hRST = RSTHRD*T2*hBT*BEC*ECRS + hZ = 3.D0*GZ*ecn/G + hB*(BG*GZ+BEC*ECZET) + hT = 2.d0*BET*G3*Q9/Q8 + hZT = 3.D0*GZ*hT/G+hBT*(BG*GZ+BEC*ECZET) + FACT2 = Q4*Q5+B*T2*(Q4*Q9+Q5) + FACT3 = 2.D0*B*Q5*Q9+DELT*FACT2 + hTT = 4.D0*BET*G3*T*(2.D0*B/Q8-(Q9*FACT3/Q8)/Q8) + COMM = ECN+HRS+HRST+T2*HT/6.D0+7.D0*T2*T*HTT/6.D0 + PREF = HZ-GZ*T2*HT/G + FACT5 = GZ*(2.D0*HT+T*HTT)/G + COMM = COMM-PREF*ZET-UU*HTT-VV*HT-WW*(HZT-FACT5) + DVCUP = COMM + PREF + DVCDN = COMM - PREF + VC1 = VCUP + DVCUP + VC2 = VCDN + DVCDN + ! print*,'c igga is',dvcup + + RETURN + END subroutine CORRELATION_PBE + + + subroutine exchange_pbe(rho,s,u,t,igga,EX,VX) + + ! APART FROM COSMETICS THIS IS IN FACT BURKEs FORTRAN REFERENCE IMPLEMENTATION + + ! This is the PBE and PW-LDA Exchange routine. + + implicit integer(4) (i-n) + implicit real(8) (a-h,o-z) + + parameter(thrd=1.d0/3.d0,thrd4=4.d0/3.d0) + parameter(pi=3.14159265358979323846264338327950d0) + parameter(ax=-0.738558766382022405884230032680836d0) + + parameter(um=0.21951d0,uk=0.8040d0,ul=um/uk) + + parameter(ap=1.647127d0,bp=0.980118d0,cp=0.017399d0) + parameter(aq=1.523671d0,bq=0.367229d0,cq=0.011282d0) + parameter(ah=0.19645d0,bh=7.7956d0) + parameter(ahp=0.27430d0,bhp=0.15084d0,ahq=0.004d0) + parameter(a1=0.19645d0,a2=0.27430d0,a3=0.15084d0,a4=100.d0) + parameter(a=7.79560d0,b1=0.004d0,eps=1.d-15) + + !---------------------------------------------------------------------- + !---------------------------------------------------------------------- + ! GGA EXCHANGE FOR A SPIN-UNPOLARIZED ELECTRONIC SYSTEM + !---------------------------------------------------------------------- + ! INPUT rho : DENSITY + ! INPUT S: ABS(GRAD rho)/(2*KF*rho), where kf=(3 pi^2 rho)^(1/3) + ! INPUT U: (GRAD rho)*GRAD(ABS(GRAD rho))/(rho**2 * (2*KF)**3) + ! INPUT V: (LAPLACIAN rho)/(rho*(2*KF)**2) (for U,V, see PW86(24)) + ! input igga: (=0=>don't put in gradient corrections, just LDA) + ! OUTPUT: EXCHANGE ENERGY PER ELECTRON (LOCAL: EXL, NONLOCAL: EXN, + ! TOTAL: EX) AND POTENTIAL (VX) + !---------------------------------------------------------------------- + ! References: + ! [a]J.P.~Perdew, K.~Burke, and M.~Ernzerhof, submiited to PRL, May96 + ! [b]J.P. Perdew and Y. Wang, Phys. Rev. B {\bf 33}, 8800 (1986); + ! {\bf 40}, 3399 (1989) (E). + !---------------------------------------------------------------------- + ! Formulas: e_x[unif]=ax*rho^(4/3) [LDA] + ! ax = -0.75*(3/pi)^(1/3) + ! e_x[PBE]=e_x[unif]*FxPBE(s) + ! FxPBE(s)=1+uk-uk/(1+ul*s*s) [a](13) + ! uk, ul defined after [a](13) + !---------------------------------------------------------------------- + !---------------------------------------------------------------------- + ! construct LDA exchange energy density + + exunif = ax*rho**thrd + if((igga.eq.0).or.(s.lt.eps))then + EXL=exunif + EXN=0.d0 + EX=EXL+EXN + VX= exunif*thrd4 + return + endif + !---------------------------------------------------------------------- + ! construct GGA enhancement factor + ! find first and second derivatives of f and: + ! fs=(1/s)*df/ds and fss=dfs/ds = (d2f/ds2 - (1/s)*df/ds)/s + + ! + ! PBE enhancement factors checked against NRLMOL + ! + if(igga.eq.1)then + p0 =1.d0+ul*s**2 + f =1.d0+uk-uk/p0 + fs =2.d0*uk*ul/p0**2 + fss=-4.d0*ul*s*fs/p0 + endif + + ! + + EXL= exunif + EXN= exunif*(f-1.0d0) + EX = EXL+EXN + !---------------------------------------------------------------------- + ! energy done. calculate potential from [b](24) + ! + VX = exunif*(thrd4*f-(u-thrd4*s**3)*fss-t*fs ) + ! print*,'e igga is',igga,vx,xunif*thrd4 + + + RETURN + END subroutine exchange_pbe + +end module dftxc diff --git a/sktwocnt/lib/gridgenerator.f90 b/sktwocnt/lib/gridgenerator.f90 new file mode 100644 index 00000000..7137b043 --- /dev/null +++ b/sktwocnt/lib/gridgenerator.f90 @@ -0,0 +1,122 @@ +module gridgenerator + use accuracy + use quadratures + implicit none + +contains + + subroutine gengrid1_12(quads, coordtrans, grid, weights) + type(quadrature), intent(in) :: quads(2) + interface + subroutine coordtrans(oldc, newc, jacobi) + use accuracy, only : dp + real(dp), intent(in) :: oldc(:) + real(dp), intent(out) :: newc(:) + real(dp), intent(out) :: jacobi + end subroutine coordtrans + end interface + real(dp), allocatable, intent(out) :: grid(:,:) + real(dp), allocatable, intent(out) :: weights(:) + + integer :: n1, n2, nn + integer :: ind, i1, i2 + real(dp) :: coord(2), coordreal(2), jacobi + + n1 = size(quads(1)%xx) + n2 = size(quads(2)%xx) + nn = n1 * n2 + allocate(grid(nn, 2)) + allocate(weights(nn)) + ind = 1 + do i2 = 1, n2 + coord(2) = quads(2)%xx(i2) + do i1 = 1, n1 + coord(1) = quads(1)%xx(i1) + call coordtrans(coord, coordreal, jacobi) + grid(ind, 1) = coordreal(1) + grid(ind, 2) = coordreal(2) + weights(ind) = quads(1)%ww(i1) * quads(2)%ww(i2) * jacobi + ind = ind + 1 + end do + end do + + end subroutine gengrid1_12 + + + subroutine gengrid2_12(quads, coordtrans, partition, partparams, dist,& + & grid1, grid2, dots, weights) + type(quadrature), intent(in) :: quads(2) + interface + subroutine coordtrans(oldc, newc, jacobi) + use accuracy, only : dp + real(dp), intent(in) :: oldc(:) + real(dp), intent(out) :: newc(:) + real(dp), intent(out) :: jacobi + end subroutine coordtrans + function partition(r1, r2, dist, params) + use accuracy, only : dp + real(dp), intent(in) :: r1, r2, dist, params(:) + real(dp) :: partition + end function partition + end interface + real(dp), intent(in) :: partparams(:) + real(dp), intent(in) :: dist + real(dp), allocatable, intent(out) :: grid1(:,:), grid2(:,:) + real(dp), allocatable, intent(out) :: dots(:), weights(:) + + integer :: n1, n2, nn + integer :: ind, i1, i2 + real(dp) :: coord(2), coordreal(2) + real(dp) :: r1, theta1, r2a, r2b, theta2a, theta2b, rtmpa, rtmpb, jacobi + + n1 = size(quads(1)%xx) + n2 = size(quads(2)%xx) + nn = n1 * n2 + allocate(grid1(2*nn, 2)) + allocate(grid2(2*nn, 2)) + allocate(dots(2*nn)) + allocate(weights(2*nn)) + ind = 1 + do i2 = 1, n2 + coord(2) = quads(2)%xx(i2) + do i1 = 1, n1 + coord(1) = quads(1)%xx(i1) + call coordtrans(coord, coordreal, jacobi) + r1 = coordreal(1) + theta1 = coordreal(2) + rtmpa = dist * dist + r1 * r1 + rtmpb = 2.0_dp * r1 * dist * cos(theta1) + r2a = sqrt(rtmpa - rtmpb) ! dist > 0 + r2b = sqrt(rtmpa + rtmpb) ! dist < 0 + rtmpa = -0.5_dp * (dist * dist + r2a * r2a - r1 * r1) / (dist * r2a) + rtmpb = 0.5_dp * (dist * dist + r2b * r2b - r1 * r1) / (dist * r2b) + + !! Make sure, we are not sliding out from [-1,1] range for acos + rtmpa = min(rtmpa, 1.0_dp) + rtmpa = max(rtmpa, -1.0_dp) + rtmpb = min(rtmpb, 1.0_dp) + rtmpb = max(rtmpb, -1.0_dp) + theta2a = acos(rtmpa) + theta2b = acos(rtmpb) + + grid1(ind, 1) = r1 + grid1(ind, 2) = theta1 + grid1(ind+nn, 1) = r2b + grid1(ind+nn, 2) = theta2b + grid2(ind, 1) = r2a + grid2(ind, 2) = theta2a + grid2(ind+nn, 1) = r1 + grid2(ind+nn, 2) = theta1 + dots(ind) = cos(theta1 - theta2a) + dots(ind+nn) = cos(theta2b - theta1) + + rtmpa = quads(1)%ww(i1) * quads(2)%ww(i2) * jacobi + weights(ind) = rtmpa * partition(r1, r2a, dist, partparams) + weights(ind+nn) = rtmpa * partition(r1, r2b, -dist, partparams) + ind = ind + 1 + end do + end do + + end subroutine gengrid2_12 + +end module gridgenerator diff --git a/sktwocnt/lib/gridorbital.f90 b/sktwocnt/lib/gridorbital.f90 new file mode 100644 index 00000000..811d5f8a --- /dev/null +++ b/sktwocnt/lib/gridorbital.f90 @@ -0,0 +1,231 @@ +!> Implements a grid-type orbital. +module gridorbital + use accuracy + use constants + use bisection + use interpolation + implicit none + private + + public :: gridorb, gridorb2, init, destruct, getvalue, rescale + + !> Contains the data of a grid function. + type gridorb + integer :: ngrid + real(dp), allocatable :: rvalues(:), fvalues(:) + end type gridorb + + type gridorb2 + integer :: ngrid + real(dp), allocatable :: rvalues(:), fvalues(:) + real(dp) :: delta, rcut + end type gridorb2 + + type gridorb_wrap + type(gridorb), pointer :: ptr => null() + end type gridorb_wrap + + type gridorb2_wrap + type(gridorb2), pointer :: ptr => null() + end type gridorb2_wrap + + interface init + module procedure gridorb_init + module procedure gridorb2_init + end interface + + interface destruct + module procedure gridorb_destruct + module procedure gridorb2_destruct + end interface + + interface getvalue + module procedure gridorb_getvalue + module procedure gridorb2_getvalue + end interface + + interface rescale + module procedure gridorb2_rescale + end interface + + real(dp), parameter :: distfudge = 1.0_dp + integer, parameter :: ninter = 8 + integer, parameter :: nrightinter = 4 + real(dp), parameter :: deltar = 1e-4_dp + + integer, parameter :: npoint = 10000 + !real(dp), parameter :: tol = 1e-12_dp + integer, parameter :: ninter2 = 4 + integer, parameter :: nrightinter2 = 2 + +contains + + !> Initializes the grid orbital. + !! \param self initialised instance on exit. + !! \param values r,f(r) values for the grid + subroutine gridorb_init(self, rvals, fvals) + type(gridorb), intent(inout) :: self + real(dp), intent(in) :: rvals(:), fvals(:) + + !assert(size(values, dim=1) == 2) + !assert(size(values, dim=2) > 0) + + self%ngrid = size(rvals) + allocate(self%rvalues(self%ngrid)) + allocate(self%fvalues(self%ngrid)) + self%rvalues = rvals(:) + self%fvalues = fvals(:) + + end subroutine gridorb_init + + + !> Destructs the instance. + !! \param self instance. + subroutine gridorb_destruct(self) + type(gridorb), intent(inout) :: self + + deallocate(self%rvalues) + deallocate(self%fvalues) + + end subroutine gridorb_destruct + + + !> Delivers the value of the orbital + !! \param self instance. + !! \param rr radius at which to calculate the value. + !! \return rad radial part of the orbital at the given distance. + elemental function gridorb_getvalue(self, rr) result(rad) + type(gridorb), intent(in) :: self + real(dp), intent(in) :: rr + real(dp) :: rad + + integer :: ind, istart, iend + real(dp) :: rmax, f0, f1, f2, f1p, f1pp + + ! sanity check + !if (self%ngrid < ninter + 1) then + ! write (*,*) "not enough points in the orbital grid!" + ! stop + !end if + + ! Find position of the point + call bisect(self%rvalues, rr, ind, 1e-10_dp) + rmax = self%rvalues(self%ngrid) + distfudge + if (rr >= rmax) then + ! outside of the region -> 0 + rad = 0.0_dp + elseif (ind < self%ngrid) then + ! before last gridpoint + iend = min(self%ngrid, ind + nrightinter) + iend = max(iend, ninter) + istart = iend - ninter + 1 + rad = polyinter(self%rvalues(istart:iend), self%fvalues(istart:iend), rr) + else + iend = self%ngrid + istart = iend - ninter + 1 + ! calculate 1st und 2nd derivatives at the end + f1 = self%fvalues(iend) + f0 = polyinter(self%rvalues(istart:iend), self%fvalues(istart:iend), & + &self%rvalues(iend) - deltar) + f2 = polyinter(self%rvalues(istart:iend), self%fvalues(istart:iend), & + &self%rvalues(iend) + deltar) + f1p = (f2 - f0) / (2.0_dp * deltar) + f1pp = (f2 + f0 - 2.0_dp * f1) / deltar**2 + rad = poly5zero(f1, f1p, f1pp, rr - rmax, -1.0_dp * distfudge) + end if + + end function gridorb_getvalue + + + + !> Initializes the grid orbital. + !! \param self initialised instance on exit. + !! \param values r,f(r) values for the grid + subroutine gridorb2_init(self, rvals, fvals) + type(gridorb2), intent(inout) :: self + real(dp), intent(in) :: rvals(:), fvals(:) + + type(gridorb) :: orb + real(dp) :: xx, rr + integer :: ii + + !assert(size(values, dim=1) == 2) + !assert(size(values, dim=2) > 0) + + call init(orb, rvals, fvals) + self%ngrid = npoint + allocate(self%rvalues(self%ngrid)) + allocate(self%fvalues(self%ngrid)) + self%delta = pi / real(self%ngrid + 1, dp) + do ii = 1, self%ngrid + xx = cos(self%delta * real(ii, dp)) + rr = (1.0_dp - xx) / (1.0_dp + xx) + self%rvalues(ii) = rr + self%fvalues(ii) = getvalue(orb, rr) + end do + self%rcut = self%rvalues(self%ngrid) + distfudge + call destruct(orb) + + end subroutine gridorb2_init + + + !> Destructs the instance. + !! \param self instance. + subroutine gridorb2_destruct(self) + type(gridorb2), intent(inout) :: self + + deallocate(self%fvalues) + + end subroutine gridorb2_destruct + + + !> Delivers the value of the orbital + !! \param self instance. + !! \param rr radius at which to calculate the value. + !! \return rad radial part of the orbital at the given distance. + elemental function gridorb2_getvalue(self, rr) result(rad) + type(gridorb2), intent(in) :: self + real(dp), intent(in) :: rr + real(dp) :: rad + + integer :: ind, istart, iend + real(dp) :: rmax, f0, f1, f2, f1p, f1pp + real(dp) :: xx + + if (rr > self%rcut) then + rad = 0.0_dp + end if + xx = (1.0_dp - rr) / (1.0_dp + rr) + ind = floor(acos(xx) / self%delta) + if (ind < self%ngrid) then + iend = min(self%ngrid, ind + nrightinter2) + iend = max(iend, ninter2) + istart = iend - ninter2 + 1 + rad = polyinter(self%rvalues(istart:iend), self%fvalues(istart:iend), rr) + else + iend = self%ngrid + istart = iend - ninter2 + 1 + ! calculate 1st und 2nd derivatives at the end + f1 = self%fvalues(iend) + f0 = polyinter(self%rvalues(istart:iend), self%fvalues(istart:iend), & + &self%rvalues(iend) - deltar) + f2 = polyinter(self%rvalues(istart:iend), self%fvalues(istart:iend), & + &self%rvalues(iend) + deltar) + f1p = (f2 - f0) / (2.0_dp * deltar) + f1pp = (f2 + f0 - 2.0_dp * f1) / deltar**2 + rad = poly5zero(f1, f1p, f1pp, rr - rmax, -1.0_dp * distfudge) + end if + + end function gridorb2_getvalue + + + subroutine gridorb2_rescale(self, fac) + type(gridorb2), intent(inout) :: self + real(dp), intent(in) :: fac + + self%fvalues = self%fvalues * fac + + end subroutine gridorb2_rescale + + +end module gridorbital diff --git a/sktwocnt/lib/interpolation.f90 b/sktwocnt/lib/interpolation.f90 new file mode 100644 index 00000000..37cda1b8 --- /dev/null +++ b/sktwocnt/lib/interpolation.f90 @@ -0,0 +1,152 @@ +!!* Contains routines for interpolation and extrapolation +module interpolation + use accuracy + implicit none + private + + public :: poly5zero, spline3_free, polyinter + + +contains + + + !! Returns the value of a polynomial of 5th degree at x. + !! \param y0 Value of the polynom at x = dx. + !! \param y0p Value of the 1st derivative at x = dx. + !! \param y0pp Value of the 2nd derivative at x = dx. + !! \param xx The point where the polynomial should be calculated + !! \param dx The point, where the polynomials value and first two derivatives + !! should take the provided values. + !! \return Value of the polynomial at xx. + !! \details The polynomial is created with the following boundary conditions: + !! Its value, its 1st and 2nd derivatives are zero at x = 0 and agree + !! with the provided values at x = dx. + pure function poly5zero(y0, y0p, y0pp, xx, dx) result(yy) + real(dp), intent(in) :: y0 + real(dp), intent(in) :: y0p + real(dp), intent(in) :: y0pp + real(dp), intent(in) :: xx + real(dp), intent(in) :: dx + real(dp) :: yy + + real(dp) :: dx1, dx2, dd, ee, ff, xr + + dx1 = y0p * dx + dx2 = y0pp * dx * dx + dd = 10.0_dp * y0 - 4.0_dp * dx1 + 0.5_dp * dx2 + ee = -15.0_dp * y0 + 7.0_dp * dx1 - 1.0_dp * dx2 + ff = 6.0_dp * y0 - 3.0_dp * dx1 + 0.5_dp * dx2 + xr = xx / dx + yy = ((ff*xr + ee)*xr + dd)*xr*xr*xr + + end function poly5zero + + + + !! Returns the value of a free spline at a certain point. + !! \param y0 Function value at x = 0. + !! \param y0p First derivative at x = 0. + !! \param y0pp Second derivative at x = 0. + !! \param dx Second fitting point. + !! \param ydx Function value at dx. + !! \param xx Point to interpolate. + !! \return yy Value of the 3rd order polynomial at xx. + !! \param yp First derivative at xx. + !! \param ypp Second derivative at xx. + !! \details The spline is created with the following boundary conditions: + !! Its value, 1st and 2nd derivatives agree with the provided values at + !! x = 0 and its value agrees with the provided value at x = dx. + !! \note If you want the value for a derivative, you have to query them + !! both. + pure subroutine spline3_free(y0, y0p, y0pp, dx, ydx, xx, yy, yp, ypp) + real(dp), intent(in) :: y0 + real(dp), intent(in) :: y0p + real(dp), intent(in) :: y0pp + real(dp), intent(in) :: ydx + real(dp), intent(in) :: dx + real(dp), intent(in) :: xx + real(dp), intent(out), optional :: yy + real(dp), intent(out), optional :: yp + real(dp), intent(out), optional :: ypp + + real(dp) :: aa, bb, cc, dd, dx1 + + !ASSERT(present(yp) .eqv. present(ypp)) + + aa = y0 + bb = y0p + cc = 0.5_dp * y0pp + dx1 = 1.0_dp / dx + dd = (((ydx - y0)*dx1 - y0p)*dx1 - 0.5_dp*y0pp)*dx1 + if (present(yy)) then + yy = ((dd*xx + cc)*xx + bb)*xx + aa + end if + if (present(yp)) then + yp = (3.0_dp*dd*xx + 2.0_dp*cc)*xx + bb + ypp = 6.0_dp * dd * xx + 2.0_dp * cc + end if + + end subroutine spline3_free + + + + !! Polynomial interpolation through given points + !! \param xa x-coordinates of the fit points + !! \param ya y-coordinates of the fit points + !! \param xx The point, where the polynomial should be calculated + !! \return The value of the polynomial + !! \note The algorithm is based on the one in Numerical recipes. + pure function polyinter(xp, yp, xx) result(yy) + real(dp), intent(in) :: xp(:) + real(dp), intent(in) :: yp(:) + real(dp), intent(in) :: xx + real(dp) :: yy + + integer :: nn + integer :: icl, ii, mm + + real(dp) :: cc(size(xp)), dd(size(xp)) + real(dp) :: dx, dxnew, dyy, rtmp + + nn = size(xp) + + !ASSERT(nn > 1) + !ASSERT(size(yp) == nn) + + cc(:) = yp(:) + dd(:) = yp(:) + icl = 1 + dx = abs(xx - xp(icl)) + do ii = 2, nn + dxnew = abs(xx - xp(ii)) + if (dxnew < dx) then + icl = ii + dx = dxnew + end if + end do + yy = yp(icl) + icl = icl - 1 + do mm = 1, nn - 1 + do ii = 1, nn - mm + rtmp = xp(ii) - xp(ii+mm) + !if (abs(rtmp) < epsilon(1.0_dp)) then + !write (*,*) "Polint failed" + !stop + !end if + rtmp = (cc(ii+1) - dd(ii)) / rtmp + cc(ii) = (xp(ii) - xx) * rtmp + dd(ii) = (xp(ii+mm) - xx) * rtmp + end do + if (2 * icl < nn - mm) then + dyy = cc(icl + 1) + else + dyy = dd(icl) + icl = icl - 1 + end if + yy = yy + dyy + end do + + end function polyinter + + +end module interpolation diff --git a/sktwocnt/lib/partition.f90 b/sktwocnt/lib/partition.f90 new file mode 100644 index 00000000..dae74d4f --- /dev/null +++ b/sktwocnt/lib/partition.f90 @@ -0,0 +1,79 @@ +!> Conains space partioning functions. +module partition + use accuracy + implicit none + private + + public :: partition_becke, partition_becke_hetero, beckepar + + +contains + + !> Becke partition function for 2 centers. + !! \param r1 Distance from 1st center. + !! \param r2 Distance from 2nd center. + !! \param dist Distance between centers. + !! \param partparams Arbitrary dummy real array. + !! \return Value of the partition function (between [0,1]) + !! \sa A. D. Becke, J. Chem. Phys. 88, 2547 (1988). + function partition_becke(r1, r2, dist, partparams) result(res) + real(dp), intent(in) :: r1, r2, dist, partparams(:) + real(dp) :: res + + integer :: ii + + res = (r1 - r2) / abs(dist) + do ii = 1, 3 + res = 1.5_dp * res - 0.5 * res**3 + end do + res = 0.5_dp * (1.0_dp - res) + + end function partition_becke + + + !> Becke partition function for 2 heteronuclear centers. + !! \param r1 Distance from 1st center. + !! \param r2 Distance from 2nd center. + !! \param dist Distance between centers. + !! \param partparams Real array containing the parameter aij in the + !! Becke partitioning scheme. + !! \return Value of the partition function (between [0,1]) + !! \sa A. D. Becke, J. Chem. Phys. 88, 2547 (1988). + function partition_becke_hetero(r1, r2, dist, partparams) result(res) + real(dp), intent(in) :: r1, r2, dist, partparams(:) + real(dp) :: res + + integer :: ii + real(dp) :: mu + + mu = (r1 - r2) / abs(dist) + res = mu + partparams(1) * (1.0_dp - mu**2) + do ii = 1, 3 + res = 1.5_dp * res - 0.5 * res**3 + end do + res = 0.5_dp * (1.0_dp - res) + + end function partition_becke_hetero + + + !> Delivers parameter aij in the becke partition scheme for given atomic + !! radii. + !! \param r1 Radius of the first atom. + !! \param r2 Radius of the second atom. + !! \return Value of aij. + function beckepar(r1, r2) result(res) + real(dp), intent(in) :: r1, r2 + real(dp) :: res + + real(dp) :: chi, uu + + chi = sqrt(r1 / r2) + uu = (chi - 1.0_dp) / (chi + 1.0_dp) + res = uu / (uu**2 - 1.0_dp) + if (abs(res) > 0.5_dp) then + res = sign(0.5_dp, res) + end if + + end function beckepar + +end module partition diff --git a/sktwocnt/lib/quadrature.f90 b/sktwocnt/lib/quadrature.f90 new file mode 100644 index 00000000..94e94a2c --- /dev/null +++ b/sktwocnt/lib/quadrature.f90 @@ -0,0 +1,110 @@ +module quadratures + use accuracy + use constants + implicit none + + type quadrature + real(dp), allocatable :: xx(:) + real(dp), allocatable :: ww(:) + end type quadrature + + real(dp), parameter :: eps = 1e-14_dp + +contains + + !> Gauss-Legendre quadrature for integration in the interval [-1,1]. + !! \param nn Number of points for the quadrature + !! \param quad Quadrature with abscissas and weights. + !! \sa Numerical Recipes + subroutine gauss_legendre_quadrature(nn, quad) + integer, intent(in) :: nn + type(quadrature), intent(out) :: quad + + integer :: mm, ii, jj + real(dp) :: zz, z1, pp, p1, p2, p3, rj + + allocate(quad%xx(nn)) + allocate(quad%ww(nn)) + mm = (nn + 1) / 2 + do ii = 1, mm + zz = cos(pi * (real(ii, dp) - 0.25_dp) / (real(nn, dp) + 0.5_dp)) + do + p1 = 1.0_dp + p2 = 0.0_dp + do jj = 1, nn + p3 = p2 + p2 = p1 + rj = real(jj, dp) + p1 = ((2.0_dp * rj - 1.0_dp) * zz * p2 - (rj - 1.0_dp) * p3) / rj + end do + pp = real(nn, dp) * (zz * p1 - p2) / (zz * zz - 1.0_dp) + z1 = zz + zz = z1 - (p1 / pp) + if (abs(zz - z1) <= eps) then + exit + end if + end do + quad%xx(ii) = -zz + quad%xx(nn + 1 - ii) = zz + quad%ww(ii) = 2.0_dp / ((1.0_dp - zz * zz) * pp * pp) + quad%ww(nn + 1 - ii) = quad%ww(ii) + end do + + end subroutine gauss_legendre_quadrature + + + !> Gauss-Chebishev quadrature for integration in the interval [-1,1]. + !! + !! Integration of functions with Gauss-Chebishev quadrature of second kind. + !! The weights already contain 1/sqrt(1-x^2) so that it can be directly + !! used to integrate a function on [-1,1]. + !! See also: J. M. Pérez-Jordá et al., J. Chem. Phys. 100 6520 (1994). + !! + !! \param nn Number of points for the quadrature + !! \param quad Quadrature with abscissas and weights. + subroutine gauss_chebyshev_quadrature(nn, quad) + integer, intent(in) :: nn + type(quadrature), intent(out) :: quad + + integer :: ii + real(dp) :: rtmp + + allocate(quad%xx(nn)) + allocate(quad%ww(nn)) + !do ii = 1, nn + ! quad%xx(ii) = cos(pi * (real(ii, dp) - 0.5_dp) / real(nn, dp)) + !end do + !quad%ww = pi / real(nn, dp) + do ii = 1, nn + rtmp = real(ii, dp) * pi / real(nn + 1, dp) + quad%xx(ii) = cos(rtmp) + quad%ww(ii) = sin(rtmp) + end do + quad%ww = quad%ww * pi / real(nn + 1, dp) + + end subroutine gauss_chebyshev_quadrature + + + !> Trapezoidal quadrature for integration in the interval [-1,1]. + !! \param nn Number of points for the quadrature + !! \param quad Quadrature with abscissas and weights. + !! \sa Numerical Recipes + subroutine trapezoidal_quadrature(nn, quad) + integer, intent(in) :: nn + type(quadrature), intent(out) :: quad + + integer :: ii + real(dp) :: fac + + allocate(quad%xx(nn)) + allocate(quad%ww(nn)) + fac = 2.0_dp / real(nn, dp) + do ii = 1, nn + quad%xx(ii) = -1.0_dp + fac * real(ii - 1, dp) + end do + quad%ww = fac + + end subroutine trapezoidal_quadrature + + +end module quadratures diff --git a/sktwocnt/lib/sphericalharmonics.f90 b/sktwocnt/lib/sphericalharmonics.f90 new file mode 100644 index 00000000..ebff2da3 --- /dev/null +++ b/sktwocnt/lib/sphericalharmonics.f90 @@ -0,0 +1,218 @@ +!> Spherical harmonics. +module sphericalharmonics + use accuracy + implicit none + private + + public :: realtess, init, destruct, getvalue, getvalue_1d + + !> Real tessereal shperical. + type realtess + private + integer :: ll, mm + end type realtess + + interface init + module procedure realtess_init + end interface + + interface destruct + module procedure realtess_destruct + end interface + + interface getvalue + module procedure realtess_getvalue + end interface + + interface getvalue_1d + module procedure realtess_getvalue_1d + end interface + +contains + + !> Initialises realtess. + !! \param self instance. + !! \param ll angulam momentum (l) + !! \param mm magnetic quantum number (m) + subroutine realtess_init(self, ll, mm) + type(realtess), intent(inout) :: self + integer, intent(in) :: ll, mm + + self%ll = ll + self%mm = mm + + end subroutine realtess_init + + + !> Destroys the instance. + !! \param self instance. + subroutine realtess_destruct(self) + type(realtess), intent(inout) :: self + + continue + + end subroutine realtess_destruct + + + !> returns the value of the tessereal function. + !! \param self instance. + !! \param theta spherical coordinate theta. + !! \param phi spherical coordinate phi. + elemental function realtess_getvalue(self, theta, phi) result(ang) + type(realtess), intent(in) :: self + real(dp), intent(in) :: theta, phi + real(dp) :: ang + + ang = calc_realtess(self%ll, self%mm, theta, phi) + + end function realtess_getvalue + + + elemental function realtess_getvalue_1d(self, theta) result(ang) + type(realtess), intent(in) :: self + real(dp), intent(in) :: theta + real(dp) :: ang + + ang = calc_realtess_1d(self%ll, self%mm, theta) + + end function realtess_getvalue_1d + + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!! private functions +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Real tessereal spherical harmonics up to f. + !! \param ll angular momentum (l). + !! \param mm magnetic moment (m) + !! \param theta spherical coordinate theta. + !! \param phi spherical coordinate phi. + !! \return value of the real tesseral harmonics. + elemental function calc_realtess(ll, mm, theta, phi) result (rty) + integer, intent(in) :: ll + integer, intent(in) :: mm + real(dp), intent(in) :: theta, phi + real(dp) :: rty + + !assert(ll >= 0 .and. ll <= 3) + !assert(abs(mm) <= ll) + + select case (ll) + case(0) + rty = 0.2820947917738782_dp + case(1) + select case(mm) + case(-1) + rty = 0.4886025119029198_dp * sin(theta) * sin(phi) + case(0) + rty = 0.4886025119029198_dp * cos(theta) + case(1) + rty = 0.4886025119029198_dp * sin(theta) * cos(phi) + end select + case(2) + select case(mm) + case(-2) + rty = 0.5462742152960395_dp * sin(theta)**2 * sin(2.0_dp * phi) + case(-1) + rty = 1.092548430592079_dp * sin(theta) * cos(theta) * sin(phi) + case(0) + rty = 0.9461746957575600_dp * cos(theta)**2 - 0.3153915652525200_dp + case(1) + rty = 1.092548430592079_dp * sin(theta) * cos(theta) * cos(phi) + case(2) + rty = 0.5462742152960395_dp * sin(theta)**2 * cos(2.0_dp * phi) + end select + case(3) + select case (mm) + case(-3) + rty = 0.5900435899266435_dp * sin(theta)**3 * sin(3.0_dp * phi) + case(-2) + rty = 1.445305721320277_dp * sin(theta)**2 * cos(theta) & + &* sin(2.0_dp * phi) + case(-1) + rty = 0.4570457994644658_dp * sin(theta) & + &* (5.0_dp * cos(theta)**2 - 1.0_dp) * sin(phi) + case(0) + rty = 0.3731763325901155_dp * cos(theta) & + &* (5.0_dp * cos(theta)**2 - 3.0_dp) + case(1) + rty = 0.4570457994644658_dp * sin(theta) & + &* (5.0_dp * cos(theta)**2 - 1.0_dp) * cos(phi) + case(2) + rty = 1.445305721320277_dp * sin(theta)**2 * cos(theta) & + &* cos(2.0_dp * phi) + case(3) + rty = 0.5900435899266435_dp * sin(theta)**3 * cos(3.0_dp * phi) + end select + end select + + end function calc_realtess + + + !> Real tessereal spherical harmonics up to f. + !! \param ll angular momentum (l). + !! \param mm magnetic moment (m) + !! \param theta spherical coordinate theta. + !! \param phi spherical coordinate phi. + !! \return value of the real tesseral harmonics. + elemental function calc_realtess_1d(ll, mm, theta) result (rty) + integer, intent(in) :: ll + integer, intent(in) :: mm + real(dp), intent(in) :: theta + real(dp) :: rty + + !assert(ll >= 0 .and. ll <= 3) + !assert(abs(mm) <= ll) + + select case (ll) + case(0) + rty = 0.2820947917738782_dp + case(1) + select case(mm) + case(-1) + rty = 0.4886025119029198_dp * sin(theta) + case(0) + rty = 0.4886025119029198_dp * cos(theta) + case(1) + rty = 0.4886025119029198_dp * sin(theta) + end select + case(2) + select case(mm) + case(-2) + rty = 0.5462742152960395_dp * sin(theta)**2 + case(-1) + rty = 1.092548430592079_dp * sin(theta) * cos(theta) + case(0) + rty = 0.9461746957575600_dp * cos(theta)**2 - 0.3153915652525200_dp + case(1) + rty = 1.092548430592079_dp * sin(theta) * cos(theta) + case(2) + rty = 0.5462742152960395_dp * sin(theta)**2 + end select + case(3) + select case (mm) + case(-3) + rty = 0.5900435899266435_dp * sin(theta)**3 + case(-2) + rty = 1.445305721320277_dp * sin(theta)**2 * cos(theta) + case(-1) + rty = 0.4570457994644658_dp * sin(theta) & + &* (5.0_dp * cos(theta)**2 - 1.0_dp) + case(0) + rty = 0.3731763325901155_dp * cos(theta) & + &* (5.0_dp * cos(theta)**2 - 3.0_dp) + case(1) + rty = 0.4570457994644658_dp * sin(theta) & + &* (5.0_dp * cos(theta)**2 - 1.0_dp) + case(2) + rty = 1.445305721320277_dp * sin(theta)**2 * cos(theta) + case(3) + rty = 0.5900435899266435_dp * sin(theta)**3 + end select + end select + + end function calc_realtess_1d + +end module sphericalharmonics diff --git a/sktwocnt/lib/twocnt.f90 b/sktwocnt/lib/twocnt.f90 new file mode 100644 index 00000000..0b0e2d35 --- /dev/null +++ b/sktwocnt/lib/twocnt.f90 @@ -0,0 +1,368 @@ +!> Contains the twocenter integrator routines. +module twocnt + use omp_lib + use accuracy + use constants + use quadratures + use coordtrans + use gridorbital + use sphericalharmonics + use gridgenerator + use partition + use dftxc + use fifo_module + implicit none + private + + public :: twocnt_in, atomdata, integmap + public :: get_twocenter_integrals + + ! Data associated with atoms + type atomdata + integer :: nbasis + integer, allocatable :: angmoms(:) + type(gridorb2), allocatable :: rad(:), drad(:), ddrad(:) + type(gridorb2) :: pot, rho, drho, ddrho + end type atomdata + + !> Parsed input for twocnt. + type twocnt_in + logical :: hetero + logical :: density + integer :: ixc + real(dp) :: r0, dr, epsilon, maxdist + integer :: ninteg1, ninteg2 + type(atomdata) :: atom1, atom2 + end type twocnt_in + + + !> Type for mapping integrals. + type integmap + !> Nr. of all nonzero twocenter integrals between orbitals of two atoms. + integer :: ninteg + + !> Indicates for every integral the integrands: + !! + !! o type(1,ii): index of orbital on first atom for integral ii. + !! o type(2,ii): index of orbital on second atom for integral ii + !! o type(3,ii): interaction type for integral ii: (0 - sigma, 1 - pi, ...) + integer, allocatable :: type(:,:) + + !> Indicates which integral corresponds to a given (i1, i2, mm) combination, + !! where i1 and i2 are the orbital indices on the two atoms and mm the + !! interaction type. If the integral vanishes, the corresponding elemet is 0. + integer, allocatable :: index(:,:,:) + contains + procedure :: init => integmap_init + end type integmap + + +contains + + subroutine get_twocenter_integrals(inp, imap, skham, skover) + type(twocnt_in), target, intent(in) :: inp + type(integmap), intent(out) :: imap + real(dp), allocatable, intent(out) :: skham(:,:), skover(:,:) + + type(quadrature) :: quads(2) + + type(atomdata), pointer :: atom1, atom2 + type(fifo_real2) :: hamfifo, overfifo + real(dp), allocatable :: grid1(:,:), grid2(:,:) + real(dp), allocatable :: dots(:), weights(:) + real(dp), allocatable :: denserr(:) + real(dp), allocatable :: skhambuffer(:,:), skoverbuffer(:,:) + real(dp) :: beckepars(1) + real(dp) :: dist, maxdist, denserrmax, maxabs + integer :: ir, nbatch, nbatchline + logical :: converged, dynlen + + call gauss_legendre_quadrature(inp%ninteg1, quads(1)) + call gauss_legendre_quadrature(inp%ninteg2, quads(2)) + + atom1 => inp%atom1 + if (inp%hetero) then + atom2 => inp%atom2 + else + atom2 => inp%atom1 + end if + call imap%init(atom1, atom2) + + ! Calculate lines for 1 Bohr in one batch. + dist = 0.0_dp + dynlen = (inp%maxdist > 0.0_dp) + if (dynlen) then + nbatchline = ceiling(1.0_dp / inp%dr) + maxdist = inp%maxdist + real(nbatchline, dp) * inp%dr + else + maxdist = abs(inp%maxdist) + nbatchline = ceiling((maxdist - inp%r0) / inp%dr) + end if + nbatch = 0 + denserrmax = 0.0_dp + allocate(denserr(nbatchline)) + do + allocate(skhambuffer(imap%ninteg, nbatchline)) + allocate(skoverbuffer(imap%ninteg, nbatchline)) + write(*, "(A,I0,A,F6.3,A,F6.3)") "Calculating ", nbatchline,& + & " lines: r0 = ", inp%r0 + inp%dr * real(nbatch * nbatchline, dp),& + & " dr = ", inp%dr + do ir = 1, nbatchline + dist = inp%r0 + inp%dr * real(nbatch * nbatchline + ir - 1, dp) + call gengrid2_12(quads, coordtrans_becke_12, partition_becke,& + & beckepars, dist, grid1, grid2, dots, weights) + call getskintegrals(atom1, atom2, grid1, grid2, dots, weights,& + &inp%density, inp%ixc, imap, skhambuffer(:,ir), skoverbuffer(:,ir),& + & denserr(ir)) + end do + denserrmax = max(denserrmax, maxval(denserr)) + maxabs = max(maxval(abs(skhambuffer)), maxval(abs(skoverbuffer))) + if (dynlen) then + converged = (maxabs < inp%epsilon) + ! If new batch gave no contributions above tolerance: omit it and exit + if (converged .or. dist > maxdist) then + exit + end if + nbatch = nbatch + 1 + call hamfifo%push_alloc(skhambuffer) + call overfifo%push_alloc(skoverbuffer) + else + converged = .true. + call hamfifo%push_alloc(skhambuffer) + call overfifo%push_alloc(skoverbuffer) + exit + end if + end do + if (.not. converged) then + write(*, "(A,F6.2,A,ES10.3)") "Warning, maximal distance ", inp%maxdist,& + & " reached! Max integral value:", maxabs + end if + write(*, "(A,ES10.3)") "Maximal integration error:", denserrmax + + call hamfifo%popall_concat(skham) + call overfifo%popall_concat(skover) + + end subroutine get_twocenter_integrals + + + !> Calculate SK-integrals. + subroutine getskintegrals(atom1, atom2, grid1, grid2, dots, weights,& + & densitysuper, ixc, imap, skham, skover, denserr) + type(atomdata), intent(in) :: atom1, atom2 + real(dp), intent(in), target :: grid1(:,:), grid2(:,:), dots(:), weights(:) + logical, intent(in) :: densitysuper + integer, intent(in) :: ixc + type(integmap), intent(in) :: imap + real(dp), intent(out) :: skham(:), skover(:), denserr + + type(realtess) :: tes1, tes2 + real(dp), pointer :: r1(:), r2(:), theta1(:), theta2(:) + real(dp), allocatable :: radval1(:,:) + real(dp), allocatable :: radval2(:,:), radval2p(:,:), radval2pp(:,:) + real(dp), allocatable :: potval(:), densval(:) + real(dp), allocatable :: densval1p(:), densval1pp(:) + real(dp), allocatable :: densval2p(:), densval2pp(:) + real(dp), allocatable :: spherval1(:), spherval2(:) + real(dp), allocatable :: absgr(:), laplace(:), gr_grabsgr(:) + + real(dp) :: integ1, integ2, dens, prefac + integer :: ngrid + integer :: ii, i1, i2, l1, l2, mm + + r1 => grid1(:,1) + theta1 => grid1(:,2) + r2 => grid2(:,1) + theta2 => grid2(:,2) + ngrid = size(r1) + + allocate(radval1(ngrid, atom1%nbasis)) + allocate(radval2(ngrid, atom2%nbasis)) + allocate(radval2p(ngrid, atom2%nbasis)) + allocate(radval2pp(ngrid, atom2%nbasis)) + allocate(spherval1(ngrid)) + allocate(spherval2(ngrid)) + do ii = 1, size(radval1, dim=2) + radval1(:,ii) = getvalue(atom1%rad(ii), r1) + end do + do ii = 1, size(radval2, dim=2) + radval2(:,ii) = getvalue(atom2%rad(ii), r2) + radval2p(:,ii) = getvalue(atom2%drad(ii), r2) + radval2pp(:,ii) = getvalue(atom2%ddrad(ii), r2) + end do + + allocate(potval(ngrid)) + ifPotSup: if (.not. densitysuper) then + potval = getvalue(atom1%pot, r1) + getvalue(atom2%pot, r2) + else + allocate(densval(ngrid)) + densval = getvalue(atom1%rho, r1) + getvalue(atom2%rho, r2) + select case(ixc) + case(1) + call getxcpot_ldapw91(densval, potval) + case(2) + allocate(densval1p(ngrid)) + allocate(densval1pp(ngrid)) + allocate(densval2p(ngrid)) + allocate(densval2pp(ngrid)) + densval1p = getvalue(atom1%drho, r1) + densval1pp = getvalue(atom1%ddrho, r1) + densval2p = getvalue(atom2%drho, r2) + densval2pp = getvalue(atom2%ddrho, r2) + allocate(absgr(ngrid)) + allocate(laplace(ngrid)) + allocate(gr_grabsgr(ngrid)) + ! Calculate derivatives for combined density + call getderivs(densval1p, densval1pp, densval2p, densval2pp, r1, r2,& + &dots, absgr, laplace, gr_grabsgr) + ! Get XC potential + call getxcpot_ggapbe(densval, absgr, laplace, gr_grabsgr, potval) + case default + write(*,*) "Unknown functional type" + stop + end select + ! Add nuclear and coulomb potential + potval = potval + getvalue(atom1%pot, r1) + getvalue(atom2%pot, r2) + end if ifPotSup + + denserr = 0.0_dp + do ii = 1, imap%ninteg + i1 = imap%type(1, ii) + l1 = atom1%angmoms(i1) + i2 = imap%type(2, ii) + l2 = atom2%angmoms(i2) + mm = imap%type(3, ii) - 1 + call init(tes1, l1, mm) + call init(tes2, l2, mm) + spherval1 = getvalue_1d(tes1, theta1) + spherval2 = getvalue_1d(tes2, theta2) + integ1 = gethamiltonian(radval1(:,i1), radval2(:,i2), & + &radval2p(:,i2), radval2pp(:,i2), r2, l2, spherval1, & + &spherval2, potval, weights) + integ2 = getoverlap(radval1(:,i1), radval2(:,i2), spherval1, & + &spherval2, weights) + dens = getdensity(radval1(:,i1), radval2(:,i2), spherval1, & + &spherval2, weights) + if (mm == 0) then + prefac = 2.0_dp * pi + else + prefac = pi + end if + skham(ii) = prefac * integ1 + skover(ii) = prefac * integ2 + dens = prefac * dens + denserr = max(denserr, abs(dens - 2.0_dp) / 2.0_dp) + end do + + end subroutine getskintegrals + + + + + + + function getoverlap(rad1, rad2, spher1, spher2, weights) result(res) + real(dp), intent(in) :: rad1(:), rad2(:), spher1(:), spher2(:), weights(:) + real(dp) :: res + + res = sum(rad1 * rad2 * spher1 * spher2 * weights) + + end function getoverlap + + + function getdensity(rad1, rad2, spher1, spher2, weights) result(res) + real(dp), intent(in) :: rad1(:), rad2(:), spher1(:), spher2(:), weights(:) + real(dp) :: res + + res = sum(((rad1 * spher1)**2 + (rad2 * spher2)**2) * weights) + + end function getdensity + + + function gethamiltonian(rad1, rad2, rad2p, rad2pp, r2, l2, spher1, spher2, & + &pot, weights) result(res) + real(dp), intent(in) :: rad1(:), rad2(:), rad2p(:), rad2pp(:), r2(:) + integer, intent(in) :: l2 + real(dp), intent(in) :: spher1(:), spher2(:), pot(:), weights(:) + real(dp) :: res + + res = sum((rad1 * spher1) & + &* (-0.5_dp * rad2pp & + &- rad2p / r2 & + &+ 0.5_dp * l2 * (l2 + 1) * rad2 / r2**2& + &+ pot * rad2) & + &* spher2 * weights) + + end function gethamiltonian + + + + subroutine getderivs(drho1, d2rho1, drho2, d2rho2, r1, r2, dots, & + &absgr, laplace, gr_grabsgr) + real(dp), intent(in) :: drho1(:), d2rho1(:), drho2(:), d2rho2(:) + real(dp), intent(in) :: r1(:), r2(:), dots(:) + real(dp), intent(out) :: absgr(:), laplace(:), gr_grabsgr(:) + + integer :: nn + real(dp), allocatable :: f1(:), f2(:) + + nn = size(drho1) + allocate(f1(nn), f2(nn)) + f1 = drho1 + dots * drho2 + f2 = drho2 + dots * drho1 + absgr = sqrt(drho1 * f1 + drho2 * f2) + laplace = d2rho1 + d2rho2 + 2.0_dp * (drho1 / r1 + drho2 / r2) + where (absgr > epsilon(1.0_dp)) + gr_grabsgr = (d2rho1 * f1 * f1 + d2rho2 * f2 * f2 & + &+(1.0_dp - dots**2) * drho1 * drho2 * (drho2 / r1 + drho1 / r2)) & + &/ absgr + elsewhere + gr_grabsgr = 0.0_dp + end where + + end subroutine getderivs + + + !> Initializes the twocenter integration map based on the basis on two atoms. + !! \param self Instance. + !! \param atom1 Properties of atom1. + !! \param atom2 Properties of atom2. + subroutine integmap_init(self, atom1, atom2) + class(integmap), intent(out) :: self + type(atomdata), intent(in) :: atom1, atom2 + + integer :: mmax, ninteg, ind, i1, l1, i2, l2, mm + + mmax = min(maxval(atom1%angmoms), maxval(atom2%angmoms)) + allocate(self%index(atom1%nbasis, atom2%nbasis, mmax+1)) + self%index = 0 + ninteg = 0 + do i1 = 1, atom1%nbasis + l1 = atom1%angmoms(i1) + do i2 = 1, atom2%nbasis + l2 = atom2%angmoms(i2) + do mm = 0, min(l1, l2) + print *, l1, l2, mm + ninteg = ninteg + 1 + self%index(i1, i2, mm+1) = ninteg + end do + end do + end do + self%ninteg = ninteg + allocate(self%type(3, ninteg)) + ind = 0 + do i1 = 1, atom1%nbasis + l1 = atom1%angmoms(i1) + do i2 = 1, atom2%nbasis + l2 = atom2%angmoms(i2) + do mm = 1, min(l1, l2) + 1 + ind = ind + 1 + self%type(:, ind) = [ i1, i2, mm ] + end do + end do + end do + + end subroutine integmap_init + + +end module twocnt + diff --git a/sktwocnt/prog/CMakeLists.txt b/sktwocnt/prog/CMakeLists.txt new file mode 100644 index 00000000..e897711b --- /dev/null +++ b/sktwocnt/prog/CMakeLists.txt @@ -0,0 +1,11 @@ +set(sources-f90 + cmdargs.f90 + input.f90 + main.f90 + output.f90) + +add_executable(sktwocnt ${sources-f90}) + +target_link_libraries(sktwocnt skprogs-sktwocnt) + +install(TARGETS sktwocnt EXPORT skprogs-targets DESTINATION ${CMAKE_INSTALL_BINDIR}) diff --git a/sktwocnt/prog/cmdargs.f90 b/sktwocnt/prog/cmdargs.f90 new file mode 100644 index 00000000..32aa64f2 --- /dev/null +++ b/sktwocnt/prog/cmdargs.f90 @@ -0,0 +1,32 @@ +module cmdargs + implicit none + + character(*), parameter :: programName = 'sktwocnt' + character(*), parameter :: programVersion = '0.9' + + +contains + + subroutine parse_command_arguments() + + integer :: nArgs, argLen + character(:), allocatable :: arg + + nArgs = command_argument_count() + if (nArgs > 0) then + call get_command_argument(1, length=argLen) + allocate(character(argLen) :: arg) + call get_command_argument(1, arg) + select case (arg) + case ('--version') + write(*, '(A,1X,A)') programName, programVersion + stop + case default + write(*, '(A,A,A)') "Invalid command line argument '", arg, "'" + error stop + end select + end if + + end subroutine parse_command_arguments + +end module cmdargs diff --git a/sktwocnt/prog/input.f90 b/sktwocnt/prog/input.f90 new file mode 100644 index 00000000..237e3028 --- /dev/null +++ b/sktwocnt/prog/input.f90 @@ -0,0 +1,255 @@ +module input + use accuracy + use gridorbital + use twocnt, only: twocnt_in, atomdata + implicit none + private + + public :: readinput + + integer, parameter :: maxlen = 1024 + character(len=*), parameter :: lineformat = "(A1024)" + character, parameter :: comment = "#" + +contains + + subroutine readinput(inp, inputfile) + type(twocnt_in), intent(out) :: inp + character(*), intent(in) :: inputfile + + integer :: fp, iline + character(maxlen) :: line, buffer1, buffer2 + integer :: iostat + integer, allocatable :: potcomps(:) + logical :: readradderivs + + fp = 14 + open(fp, file=inputfile, form="formatted", action="read") + !! General part + iline = 0 + call nextline_(fp, iline, line) + read(line, *, iostat=iostat) buffer1, buffer2 + call checkerror_(inputfile, line, iline, iostat) + if (buffer1 /= "hetero" .and. buffer1 /= "homo") then + call error_("Wrong interaction (must be hetero or homo)", inputfile, & + &line, iline) + end if + inp%hetero = (buffer1 == "hetero") + select case (buffer2) + case("potential") + inp%density = .false. + inp%ixc = 0 + case("density_lda") + inp%density = .true. + inp%ixc = 1 + case("density_pbe") + inp%density = .true. + inp%ixc = 2 + case default + call error_("Wrong superposition mode (must be potential, density_lda & + &or density_pbe", inputfile, line, iline) + end select + + call nextline_(fp, iline, line) + read(line, *, iostat=iostat) inp%r0, inp%dr, inp%epsilon, inp%maxdist + call checkerror_(inputfile, line, iline, iostat) + + call nextline_(fp, iline, line) + read(line, *, iostat=iostat) inp%ninteg1, inp%ninteg2 + call checkerror_(inputfile, line, iline, iostat) + + if (inp%density) then + allocate(potcomps(2)) + potcomps = [ 2, 3 ] + else + allocate(potcomps(3)) + potcomps = [ 2, 3, 4 ] + end if + readradderivs = .not. inp%hetero + call readatom_(inputfile, fp, iline, potcomps, inp%density, readradderivs, & + &inp%atom1) + if (inp%hetero) then + call readatom_(inputfile, fp, iline, potcomps, inp%density, .true., & + &inp%atom2) + end if + + close(fp) + + end subroutine readinput + + + + subroutine readatom_(fname, fp, iline, potcomps, density, radderivs, atom) + character(*), intent(in) :: fname + integer, intent(in) :: fp + integer, intent(inout) :: iline + integer, intent(in) :: potcomps(:) + logical, intent(in) :: density, radderivs + type(atomdata), intent(out) :: atom + + character(maxlen) :: line, buffer + real(dp), allocatable :: data(:,:), potval(:) + real(dp) :: vals(1) + integer :: ii, iostat, imax + + + call nextline_(fp, iline, line) + read(line, *, iostat=iostat) atom%nbasis + call checkerror_(fname, line, iline, iostat) + + allocate(atom%angmoms(atom%nbasis)) + allocate(atom%rad(atom%nbasis)) + if (radderivs) then + allocate(atom%drad(atom%nbasis)) + allocate(atom%ddrad(atom%nbasis)) + end if + do ii = 1, atom%nbasis + call nextline_(fp, iline, line) + read(line, *, iostat=iostat) buffer, atom%angmoms(ii) + call checkerror_(fname, line, iline, iostat) + if (radderivs) then + call readdata_(buffer, [ 1, 3, 4, 5 ], data) + call init(atom%rad(ii), data(:,1), data(:,2)) + call init(atom%drad(ii), data(:,1), data(:,3)) + call init(atom%ddrad(ii), data(:,1), data(:,4)) + else + call readdata_(buffer, [ 1, 3 ], data) + call init(atom%rad(ii), data(:,1), data(:,2)) + end if + ! Check if wave function follows the sign convention + ! (positive where abs(r * R(r)) has its maximum) + imax = maxloc(abs(data(:,1) * data(:,2)), dim=1) + if (data(imax,2) < 0.0_dp) then + write(*, "(A,F5.2,A)") "Wave function negative at the maximum of& + & radial probability (r =", data(imax,1), " Bohr)" + write(*, "(A)") "Please change the sign of the wave function (and of& + & its derivatives)!" + write(*, "(A,A,A)") "File: '", trim(buffer), "'" + stop + end if + end do + call checkangmoms_(atom%angmoms) + + call nextline_(fp, iline, line) + read(line, *, iostat=iostat) buffer + call checkerror_(fname, line, iline, iostat) + call readdata_(buffer, [ 1, 3, 4, 5 ], data) + allocate(potval(size(data, dim=1))) + potval = 0.0_dp + do ii = 1, size(potcomps) + potval = potval + data(:,potcomps(ii)) + end do + call init(atom%pot, data(:,1), potval) + + call nextline_(fp, iline, line) + read(line, *, iostat=iostat) buffer + call checkerror_(fname, line, iline, iostat) + if (density) then + call readdata_(buffer, [ 1, 3, 4, 5 ], data) + call init(atom%rho, data(:,1), data(:,2)) + call init(atom%drho, data(:,1), data(:,3)) + call init(atom%ddrho, data(:,1), data(:,4)) + else + if (trim(line) /= "noread") then + write(*,"(A,I0,A)") "Line ", iline, & + &" ignored since density is not needed." + end if + end if + + end subroutine readatom_ + + + subroutine readdata_(fname, cols, data) + character(*), intent(in) :: fname + integer, intent(in) :: cols(:) + real(dp), allocatable, intent(out) :: data(:,:) + + real(dp), allocatable :: tmp(:) + character(maxlen) :: line + integer :: ngrid, ii, fp, iline, iostat + + fp = 12 + allocate(tmp(maxval(cols))) + iline = 1 + open(fp, file=fname, action="read", form="formatted") + call nextline_(fp, iline, line) + read(line, *, iostat=iostat) ngrid + call checkerror_(fname, line, iline, iostat) + allocate(data(ngrid, size(cols))) + do ii = 1, ngrid + call nextline_(fp, iline, line) + read(line, *, iostat=iostat) tmp(:) + call checkerror_(fname, line, iline, iostat) + data(ii,:) = tmp(cols) + end do + close(fp) + deallocate(tmp) + + end subroutine readdata_ + + + + subroutine nextline_(fp, iline, line) + integer, intent(in) :: fp + integer, intent(inout) :: iline + character(maxlen), intent(out) :: line + + integer :: ii + character(maxlen) :: buffer + + do while (.true.) + iline = iline + 1 + read(fp, lineformat) buffer + ii = index(buffer, comment) + if (ii == 0) then + line = adjustl(buffer) + else + line = adjustl(buffer(1:ii-1)) + end if + if (len_trim(line) > 0) then + exit + end if + end do + + end subroutine nextline_ + + + + subroutine checkangmoms_(angmoms) + integer, intent(in) :: angmoms(:) + + integer :: ii + + if (maxval(angmoms) > 4) then + write(*,*) "Only angular momentum up to 'f' is allowed." + stop + end if + + end subroutine checkangmoms_ + + + subroutine checkerror_(fname, line, iline, iostat) + character(*), intent(in) :: fname, line + integer, intent(in) :: iline, iostat + + if (iostat /= 0) then + call error_("Bad syntax", fname, line, iline) + end if + + end subroutine checkerror_ + + + subroutine error_(txt, fname, line, iline) + character(*), intent(in) :: txt, fname, line + integer, intent(in) :: iline + + write(*,"(A,A)") "!!! Parsing error: ", txt + write(*,"(2X,A,A)") "File: ", trim(fname) + write(*,"(2X,A,I0)") "Line number: ", iline + write(*,"(2X,A,A,A)") "Line: '", trim(line), "'" + stop + end subroutine error_ + + + +end module input diff --git a/sktwocnt/prog/main.f90 b/sktwocnt/prog/main.f90 new file mode 100644 index 00000000..0b0a474d --- /dev/null +++ b/sktwocnt/prog/main.f90 @@ -0,0 +1,21 @@ +program main + use accuracy + use input + use twocnt + use output + use cmdargs + implicit none + + type(twocnt_in) :: inp + type(integmap) :: imap + real(dp), allocatable :: skham(:,:), skover(:,:) + + + call parse_command_arguments() + call readinput(inp, "sktwocnt.in") + write(*, "(A)") "Input done." + call get_twocenter_integrals(inp, imap, skham, skover) + write(*, "(A)") "Twocnt done." + call write_sktables(skham, skover) + +end program main diff --git a/sktwocnt/prog/output.f90 b/sktwocnt/prog/output.f90 new file mode 100644 index 00000000..f50b608a --- /dev/null +++ b/sktwocnt/prog/output.f90 @@ -0,0 +1,48 @@ +!> Output routines for the sktwocnt code. +module output + use accuracy + implicit none + private + + public :: write_sktables + + ! Maximal angular momentum in the old and the extended old SK file. + integer, parameter :: LMAX_OLD = 2 + integer, parameter :: LMAX_EXTENDED = 3 + + +contains + + subroutine write_sktables(skham, skover) + real(dp), intent(in) :: skham(:,:), skover(:,:) + + call write_sktable_("at1-at2.ham.dat", skham) + call write_sktable_("at1-at2.over.dat", skover) + + end subroutine write_sktables + + + !> Helper routine writing the SK files. + !! \param fname File name. + !! \param sktable Slater-Koster type integrals (Hamiltonian or overlap). + subroutine write_sktable_(fname, sktable) + character(*), intent(in) :: fname + real(dp), intent(in) :: sktable(:,:) + + integer :: fp, ninteg, nline + character(11) :: formstr + + ninteg = size(sktable, dim=1) + print *, "NINTEG:", ninteg + nline = size(sktable, dim=2) + write(formstr, "(A,I0,A)") "(", ninteg, "ES21.12)" + fp = 14 + open(fp, file=fname, status="replace", action="write") + write(fp, "(I0)") nline + write(fp, formstr) sktable + close(fp) + + end subroutine write_sktable_ + + +end module output diff --git a/slateratom/CMakeLists.txt b/slateratom/CMakeLists.txt new file mode 100644 index 00000000..21d931ee --- /dev/null +++ b/slateratom/CMakeLists.txt @@ -0,0 +1,2 @@ +add_subdirectory(lib) +add_subdirectory(prog) diff --git a/slateratom/lib/CMakeLists.txt b/slateratom/lib/CMakeLists.txt new file mode 100644 index 00000000..f5180ec1 --- /dev/null +++ b/slateratom/lib/CMakeLists.txt @@ -0,0 +1,33 @@ +set(sources-f90 + broyden.f90 + core_overlap.f90 + coulomb_hfex.f90 + coulomb_potential.f90 + density.f90 + densitymatrix.f90 + dft.f90 + diagonalizations.f90 + globals.f90 + hamiltonian.f90 + input.f90 + integration.f90 + numerical_differentiation.f90 + output.f90 + total_energy.f90 + utilities.f90 + zora_routines.f90) + +add_library(skprogs-slateratom ${sources-f90}) + +target_link_libraries(skprogs-slateratom skprogs-common Libxc::xcf90 Libxc::xc) + +set(moddir ${CMAKE_CURRENT_BINARY_DIR}/modfiles) +set_target_properties(skprogs-slateratom PROPERTIES Fortran_MODULE_DIRECTORY ${moddir}) +target_include_directories(skprogs-slateratom PUBLIC + $ + $) + +if(BUILD_SHARED_LIBS) + install(TARGETS skprogs-slateratom EXPORT skprogs-targets DESTINATION ${CMAKE_INSTALL_LIBDIR}) +endif() +#install(DIRECTORY ${moddir}/ DESTINATION ${CMAKE_INSTALL_MODULEDIR}) diff --git a/slateratom/lib/broyden.f90 b/slateratom/lib/broyden.f90 new file mode 100644 index 00000000..5906fba7 --- /dev/null +++ b/slateratom/lib/broyden.f90 @@ -0,0 +1,479 @@ +module broyden + use accuracy + implicit none + private + + public :: mixing_driver + +contains + + ! This is the main driver for simple and broyden mixers, both mix one + ! big one-dimensional array. + subroutine mixing_driver(pot_old,pot_new,max_l,num_alpha,& + &poly_order,problemsize,iter,broyden,mixing_factor) + + integer, intent(in) :: max_l,num_alpha(0:),poly_order(0:),problemsize,iter + logical, intent(in) :: broyden + real(dp), intent(in) :: mixing_factor + + integer :: actualsize,titer + real(dp) :: pot_old(:,0:,:,:),pot_new(:,0:,:,:) + real(dp), allocatable :: vecin(:),vecout(:) + integer :: ii,jj,kk,ll,mm,nn,oo,pp + + allocate(vecout(10000)) + allocate(vecin(10000)) + vecout=0.0d0 + vecin=0.0d0 + + pp=0 + do ii=1,2 + do jj=0,max_l + do kk=1,num_alpha(jj)*poly_order(jj) + do ll=1,problemsize + pp=pp+1 + vecin(pp)=pot_old(ii,jj,kk,ll) + vecout(pp)=pot_new(ii,jj,kk,ll) + end do + end do + end do + end do + + if (pp>10000) then + write(*,*) 'Static dimensions in broyden_mixer too small',pp + STOP + end if + + titer=iter + ! broyden returns if iter==0 + if (iter==0) titer=1 + + if (broyden) then + call broyden_mixer(titer,mixing_factor,10000,vecin,vecout) + else + call simple_mix(vecin,vecout,mixing_factor) + end if + + pp=0 + do ii=1,2 + do jj=0,max_l + ! do kk=1,problemsize + do kk=1,num_alpha(jj)*poly_order(jj) + do ll=1,problemsize + pp=pp+1 + ! cof_alt(ii,jj,kk,ll)=vecin(pp) + ! cof_neu(ii,jj,kk,ll)=vecout(pp) + pot_new(ii,jj,kk,ll)=vecin(pp) + end do + end do + end do + end do + + deallocate(vecout) + deallocate(vecin) + + end subroutine mixing_driver + +! +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + SUBROUTINE BROYDEN_mixer(NITER,ALPHA,JTOP,VECIN,VECOUT) + +! This is the Broyden routine as also implemented in the old DFTB code. + + IMPLICIT REAL*8 (A-H,O-Z) + IMPLICIT INTEGER (I-N) +! +!************************************************************ +!* THE VECTORS UI(MAXSIZ) AND VTI(MAXSIZ) ARE JOHNSON'S * +!* U(OF I ) AND DF(TRANSPOSE), RESPECTIVELY. THESE ARE * +!* CONTINUALLY UPDATED. ALL ITERATIONS ARE S7ORED ON TAPE * +!* 32 . THIS IS DONE TO PREVENT THE PROHIBITIVE STORAGE * +!* COSTS ASSOCIATED WITH HOLDING ONTO THE ENTIRE JACOBIAN. * +!* VECTOR TL IS THE VT OF EARLIER ITERATIONS. VECTOR F IS: * +!* VECTOR(OUTPUT) - VECTOR(IN). VECTOR DF IS: F(M+1)-F(M) * +!* FINALLY,VECTOR DUMVI(MAXSIZ) IS THE PREDICTED VECTOR. * +!* ON RETURN, VECIN CONTAINS THE NEW TRIAL VECTOR. * +!************************************************************ +!* FOR THE CRAY2-CIVIC ENVIRONMENT , FILES 32 AND 31 * +!* SHOULD BE INTRODUCED IN THE LINK STATEMENT. * +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + PARAMETER (ZERO=0.0D0,ONE=1.0D0,IMATSZ=40,maxsiz=10000) +! formerly IMATSZ=90 +! +! ADDED PARAMETER MAXITER. POREZAG, MAY 1995 +! + PARAMETER(MAXITER=15) +! +! replaced writing to disk by storing values in +! arrays UNIT31, UNIT32 hajnal@scientist.com 2000-10-4 +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! +! CHARACTER*7 NAMES +! +! SCRATCH COMMON BLOCK FOR LOCAL VARIABLES +! + DIMENSION VECIN(*),VECOUT(*) + DIMENSION F(MAXSIZ),UI(MAXSIZ),VTI(MAXSIZ),T1(MAXSIZ),& + & VECTOR(MAXSIZ,2),DUMVI(MAXSIZ),DF(MAXSIZ) +! DIMENSION NAMES(3) + DIMENSION A(IMATSZ,IMATSZ),B(IMATSZ,IMATSZ),CM(IMATSZ) + DIMENSION D(IMATSZ,IMATSZ),W(IMATSZ) + DIMENSION UNIT31(MAXSIZ,2),UNIT32(MAXSIZ,2,MAXITER+15) +! DATA NAMES/'BROYD01','BROYD02','BROYD03'/ + REAL*8 UAMIX,WTMP + INTEGER ILASTIT + common /broyd/ uamix, w, WTMP, unit31, unit32, ilastit + save +! +! PRINT *,'IN MIXING, WHERE ARE YOU?' +! +! NEW LINES JULY 1996 +! + IF (JTOP .GT. MAXSIZ) THEN + PRINT *,'BROYDEN: JTOP > MAXSIZ' + STOP + END IF +! +! NEW LINES POREZAG, MAY 1995 +! + ITER=NITER + IF(NITER.GT.MAXITER)ITER=MOD(ITER,MAXITER)+1 + IF(ITER.EQ.0)RETURN +! +! END NEW LINES +! +! OPEN(66,FILE=NAMES(1),STATUS='UNKNOWN',FORM='FORMATTED') +! REWIND(66) +! OPEN(31,FILE=NAMES(2),STATUS='UNKNOWN',FORM='UNFORMATTED') +! OPEN(32,FILE=NAMES(3),STATUS='UNKNOWN',FORM='UNFORMATTED') +! REWIND(31) +! REWIND(32) + +! IF(ITER.EQ.1)THEN +! ENDFILE 31 +! ENDFILE 32 +! END IF +! +! +!++++++ SET UP THE VECTOR OF THE CURRENT ITERATION FOR MIXING ++++++ +! +! FOR THIS METHOD WE HAVE ONLY SAVED INPUT/OUTPUT CHG. DENSITIES, + DO 38 K=1,JTOP + VECTOR(K,1)= VECIN(K) + 38 VECTOR(K,2)= VECOUT(K) +!++++++ END OF PROGRAM SPECIFIC LOADING OF VECTOR FROM MAIN ++++++++ +! +! IVSIZ IS THE LENGTH OF THE VECTOR + IVSIZ=JTOP +! IF(ITER.LT.3)WRITE( 6,1001)IVSIZ + IF(IVSIZ.GT.MAXSIZ)THEN + PRINT *,'MIXING: EXCEEDED MAXIMAL VECTOR LENGTH' + STOP + END IF +! +! +!******************* BEGIN BROYDEN'S METHOD ********************** +! +! WEIGHTING FACTOR FOR THE ZEROTH ITERATION + W0=0.01D0 +! +! F: THE DIFFERENCE OF PREVIOUS OUTPUT AND INPUT VECTORS +! DUMVI: A DUMMY VECTOR, HERE IT IS THE PREVIOUS INPUT VECTOR +! REWIND(31) +! READ(31,END=119,ERR=119)AMIX,LASTIT + IF (ITER .EQ. 1) THEN + GOTO 119 + ELSE + AMIX=UAMIX + LASTIT=ILASTIT + END IF +! READ(31)(F(K),K=1,IVSIZ) + DO k=1,IVSIZ + F(k)=UNIT31(K,1) + END DO +! READ(31)(DUMVI(K),K=1,IVSIZ) + DO k=1,IVSIZ + DUMVI(k)=UNIT31(K,2) + END DO +! IF(ITER.EQ.1 .AND. LASTIT.GT.1)THEN +! READ(31)LTMP,((A(I,J),I=1,LTMP),J=1,LTMP) +! READ(31)(W(I),I=1,LTMP) +! ENDIF +! +! ALPHA(OR AMIX)IS SIMPLE MIXING PARAMETERS +! WRITE(66,1002)AMIX,ITER+1 +! + DO 104 K=1,IVSIZ + DUMVI(K)=VECTOR(K,1)-DUMVI(K) + 104 DF(K)=VECTOR(K,2)-VECTOR(K,1)-F(K) + DO 114 K=1,IVSIZ + 114 F(K)=VECTOR(K,2)-VECTOR(K,1) +! +! FOR I-TH ITER.,DFNORM IS ( F(I) MINUS F(I-1) ), USED FOR NORMALIZATION +! + DFNORM=ZERO + FNORM=ZERO + DO 113 K=1,IVSIZ + DFNORM=DFNORM + DF(K)*DF(K) + 113 FNORM=FNORM + F(K)*F(K) + DFNORM=SQRT(DFNORM) + FNORM=SQRT(FNORM) +! WRITE(66,'('' DFNORM '',E12.6,'' FNORM '',E12.6)')DFNORM,FNORM +! + FAC2=ONE/DFNORM + FAC1=AMIX*FAC2 +! + DO 105 K=1,IVSIZ + UI(K) = FAC1*DF(K) + FAC2*DUMVI(K) + 105 VTI(K)= FAC2*DF(K) +! +!*********** CALCULATION OF COEFFICIENT MATRICES ************* +!*********** AND THE SUM FOR CORRECTIONS ************* +! +! RECALL: A(I,J) IS A SYMMETRIC MATRIX +! : B(I,J) IS THE INVERSE OF [ W0**2 I + A ] +! + LASTIT=LASTIT+1 + LASTM1=LASTIT-1 + LASTM2=LASTIT-2 +! +! DUMVI IS THE U(OF I) AND T1 IS THE VT(OF I) +! FROM THE PREVIOUS ITERATIONS +! REWIND(32) +! WRITE(66,1003)LASTIT,LASTM1 + IF(LASTIT.GT.2)THEN + DO 500 J=1,LASTM2 +! READ(32)(DUMVI(K),K=1,IVSIZ) + DO k=1,IVSIZ + DUMVI(k)=UNIT32(k,1,J) + END DO +! READ(32)(T1(K),K=1,IVSIZ) + DO k=1,IVSIZ + T1(k)=UNIT32(k,2,J) + END DO +! + AIJ=ZERO + CMJ=ZERO + DO 501 K=1,IVSIZ + CMJ=CMJ + T1(K)*F(K) + 501 AIJ=AIJ + T1(K)*VTI(K) + A(LASTM1,J)=AIJ + A(J,LASTM1)=AIJ + CM(J)=CMJ + 500 CONTINUE + ENDIF +! + AIJ=ZERO + CMJ=ZERO + DO 106 K=1,IVSIZ + CMJ= CMJ + VTI(K)*F(K) + 106 AIJ= AIJ + VTI(K)*VTI(K) + A(LASTM1,LASTM1)=AIJ + CM(LASTM1)=CMJ +! +! WRITE(32)(UI(K),K=1,IVSIZ) + DO k=1,IVSIZ + UNIT32(k,1,LASTM1)=UI(k) + END DO +! WRITE(32)(VTI(K),K=1,IVSIZ) + DO k=1,IVSIZ + UNIT32(k,2,LASTM1)=VTI(k) + END DO +! REWIND(32) +! +! THE WEIGHTING FACTORS FOR EACH ITERATION HAVE BEEN CHOSEN +! EQUAL TO ONE OVER THE R.M.S. ERROR. THIS NEED NOT BE THE CASE. + IF(FNORM .GT. 1.0D-7)THEN + WTMP=0.010D0/FNORM + ELSE + WTMP=1.0D5 + END IF + IF(WTMP.LT. 1.00D0) then + WTMP=1.00D0 + end if +! print *,wtmp,lastm1,w(lastm1) + W(LASTM1)=WTMP +! WRITE(66,'('' WEIGHTING SET = '',E12.6)')WTMP +! +! +! WITH THE CURRENT ITERATIONS F AND VECTOR CALCULATED, +! WRITE THEM TO UNIT 31 FOR USE LATER. +! REWIND(31) +! WRITE(31)AMIX,LASTIT + UAMIX=AMIX + ILASTIT=LASTIT +! WRITE(31)(F(K),K=1,IVSIZ) + DO k=1,IVSIZ + UNIT31(K,1)=F(k) + END DO +! WRITE(31)(VECTOR(K,1),K=1,IVSIZ) + DO k=1,IVSIZ + UNIT31(K,2)=VECTOR(K,1) + END DO +! WRITE(31)LASTM1,((A(I,J),I=1,LASTM1),J=1,LASTM1) +! WRITE(31)(W(I),I=1,LASTM1) +! +! SET UP AND CALCULATE BETA MATRIX + DO 506 LM=1,LASTM1 + DO 507 LN=1,LASTM1 + D(LN,LM)= A(LN,LM)*W(LN)*W(LM) + 507 B(LN,LM)= ZERO + B(LM,LM)= ONE + 506 D(LM,LM)= W0**2 + A(LM,LM)*W(LM)*W(LM) +! + CALL INVERSE(D,B,LASTM1) +! +! CALCULATE THE VECTOR FOR THE NEW ITERATION + DO 505 K=1,IVSIZ + 505 DUMVI(K)= VECTOR(K,1) + AMIX*F(K) +! + DO 504 I=1,LASTM1 +! READ(32)(UI(K),K=1,IVSIZ) + DO k=1,IVSIZ + UI(k)=UNIT32(k,1,I) + END DO +! READ(32)(VTI(K),K=1,IVSIZ) + DO k=1,IVSIZ + VTI(k)=UNIT32(k,2,I) + END DO + GMI=ZERO + DO 503 IP=1,LASTM1 + 503 GMI=GMI + CM(IP)*B(IP,I)*W(IP) + DO 504 K=1,IVSIZ + 504 DUMVI(K)=DUMVI(K)-GMI*UI(K)*W(I) +! END OF THE CALCULATION OF DUMVI, THE NEW VECTOR +! +! REWIND(31) +! REWIND(32) +! + GOTO 120 +! IF THIS IS THE FIRST ITERATION, THEN LOAD +! F=VECTOR(OUT)-VECTOR(IN) AND VECTOR(IN) + 119 CONTINUE +! PRINT*,'SIMPLE MIXING THIS ITERATION' +! REWIND(31) + LASTIT=1 + AMIX=ALPHA +! WRITE(31)AMIX,LASTIT + UAMIX=AMIX + ILASTIT=LASTIT + DO 101 K=1,IVSIZ + 101 F(K)=VECTOR(K,2)-VECTOR(K,1) +! WRITE(31)(F(K),K=1,IVSIZ) + DO k=1,IVSIZ + UNIT31(K,1)=F(k) + END DO +! WRITE(31)(VECTOR(K,1),K=1,IVSIZ) + DO k=1,IVSIZ + UNIT31(K,2)=VECTOR(K,1) + END DO +! +! SINCE WE ARE ON THE FIRST ITERATION, SIMPLE MIX THE VECTOR. + DO 102 K=1,IVSIZ + 102 DUMVI(K)= VECTOR(K,1) + AMIX*F(K) +! WRITE( 6,1000) + 120 CONTINUE +! +! CLOSE(31,STATUS='KEEP') +! CLOSE(32,STATUS='KEEP') +! +!************* THE END OF THE BROYDEN METHOD ************** +! +!+++++++ PROGRAM SPECIFIC CODE OF RELOADING ARRAYS +++++++++ +! +! NEED TO UNLOAD THE NEW VECTOR INTO THE APPROPRIATE ARRAYS. + DO 606 K=1,JTOP + VECIN(K)=DUMVI(K) + 606 CONTINUE +! +!+++++++++ END OF PROGRAM SPECIFIC RELOADING OF ARRAYS +++++++++ +! +! WRITE(66,1004)ITER+1 +! CLOSE(66) + RETURN +! + 1000 FORMAT(' ----> STRAIGHT MIXING ON THIS ITERATION') + 1001 FORMAT(' IN MIXING: IVSIZ =',I7,/) + 1002 FORMAT(' IN MIXING: SIMPLE MIX PARAMETER',1(F10.6,',')& + & ,' FOR ITER=',I5) + 1003 FORMAT(' CURRENT ITER= ',I5,' INCLUDES VALUES FROM ITER=',I5) + 1004 FORMAT(10X,'DENSITY FOR ITERATION',I4,' PREPARED') + END subroutine broyden_mixer +! +! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + SUBROUTINE INVERSE(A,B,M) + IMPLICIT REAL*8 (A-H,O-Z) + IMPLICIT INTEGER (I-N) + +! ============================================================= +! +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + PARAMETER (IMATSZ=40) +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! + DIMENSION A(IMATSZ,IMATSZ),B(IMATSZ,IMATSZ) + DIMENSION TD(IMATSZ),AD(IMATSZ),BD(IMATSZ) + SAVE +! +! SUBROUTINE TO PREFORM GAUSSIAN ELIMINATION +! NO ZEROS ALONG THE DIAGONAL +! + N=M + IF(N.GT.IMATSZ)THEN + PRINT *,'INVERT: MATRIX A TOO LARGE' + STOP + END IF +! + DO 14 I=1,N + ATMP=A(I,I) + IF(ABS(ATMP) .LT. 1.0D-08)THEN +! WRITE(66,'('' INVERT: MATRIX HAS ZERO DIAGONAL'', +! & '' ELEMENT IN THE '',I4,'' ROW'')')I + STOP + ENDIF + 14 CONTINUE +! + IF(N.EQ.1) GO TO 605 +! + DO 23 I=1,N +! + DO 35 J=1,N + 35 TD(J)=A(J,I)/A(I,I) +! +! TD(I)=(0.0E+00,0.0E+00) + TD(I)=0.0D0 +! + DO 71 K=1,N + BD(K)=B(I,K) + 71 AD(K)=A(I,K) +! + DO 601 K=1,N + DO 601 J=1,N + B(J,K)=B(J,K)-(TD(J)*BD(K)) + 601 A(J,K)=A(J,K)-(TD(J)*AD(K)) +! + 23 CONTINUE +! + DO 603 I=1,N + DO 603 J=1,N + 603 B(J,I)=B(J,I)/A(J,J) +! + RETURN +! + 605 B(1,1)=1.0D0/A(1,1) + RETURN + END subroutine inverse +! + + ! Simple mix, nothing else. + subroutine simple_mix(alt,neu,factor) + real(dp), intent(inout) :: alt(:) + real(dp), intent(in) :: neu(:), factor + + +! simple mix + alt=factor*neu+(1.0d0-factor)*alt + + end subroutine simple_mix + +end module broyden diff --git a/slateratom/lib/core_overlap.f90 b/slateratom/lib/core_overlap.f90 new file mode 100644 index 00000000..d766d858 --- /dev/null +++ b/slateratom/lib/core_overlap.f90 @@ -0,0 +1,393 @@ +module core_overlap + use accuracy + use constants + use utilities + use integration + implicit none + private + + public :: overlap, kinetic, nuclear, moments, v, confinement + +contains + + subroutine overlap(s,max_l,num_alpha,alpha,poly_order) + + ! Overlap matrix elements, see rmp_32_186_1960.pdf eqn. 5 and eqn. 19 + + + ! Definition of the primitive basis functions based on Roothaan: + ! R_{\lambda p}=1/sqrt((2n_{\lambda p})!)* + ! (2*\zeta_{\lambda p})**(n_{\lambda p}+0.5)* + ! r**(n_{\lambda p}-1)*exp(-\zeta_{\lambda p}*r) + ! + ! For every exponent \zeta_{\lambda p} there are num_power coefficients, + ! each connected to one r**(n_{\lambda p}-1). The sum over all + ! coefficients, e.g. implicitely \zeta and r**n, gives the usual DFTB + ! basis function. + ! + ! Note: in DFTB one usually has r**(n+l-1) explicitely, here the angular + ! momentum index l is implicit. Result: + ! for l=0, e.g. s, n_{\lambda p}=0,1,...,num_power + ! for l=1, e.g. p, n_{\lambda p}=1,2,...,num_power+1 + ! for l=2, e.g. d, n_{\lambda p}=2,3,...,num_power+2 + ! + + real(dp), intent(out) :: s(0:,:,:) + integer, intent(in) :: max_l + integer, intent(in) :: num_alpha(0:) + integer, intent(in) :: poly_order(0:) + real(dp), intent(in) :: alpha(0:,:) + integer :: ii,jj,kk,ll,mm,nn,oo,pp,nlp,nlq + real(dp) :: alpha1 + + s=0.0d0 + + ! These loops define the indizes S_{\lambda p q} + ! p=alpha1/n=0+l,alpha1/n=1+l,...,alpha2/n=0+l,alpha2/n=1+l... + ! + ! write(*,*) 'max_l',max_l + ! write(*,*) 'num_alpha',num_alpha + ! write(*,*) 'poly_order',poly_order + ! write(*,'(A)') 'ii jj ll kk mm nn oo' + do ii=0,max_l + nn=0 + do jj=1,num_alpha(ii) + do ll=1,poly_order(ii) + nn=nn+1 + oo=0 + nlp=ll+ii + do kk=1,num_alpha(ii) + alpha1=0.5d0*(alpha(ii,jj)+alpha(ii,kk)) + do mm=1,poly_order(ii) + oo=oo+1 + nlq=mm+ii + ! write(*,'(I2,I2,I2,I2,I2,I2,I2)') ii,jj,ll,kk,mm,nn,oo + ! + ! use ll+ii and mm+ii becaue of DFTB basis function definition + s(ii,nn,oo)=1.0d0/sqrt(v(alpha(ii,jj),2*nlp)*& + &v(alpha(ii,kk),2*nlq))*v(alpha1,nlp+nlq) + end do + end do + end do + end do + end do + + ! write(*,*) 'OVERLAP' + ! write(*,*) s + + end subroutine overlap + + subroutine nuclear(u,max_l,num_alpha,alpha,poly_order) + + ! Nuclear attraction matrix elements, see rmp_32_186_1960.pdf eqn. 5 and eqn.19 + + + real(dp), intent(out) :: u(0:,:,:) + integer, intent(in) :: max_l + integer, intent(in) :: num_alpha(0:) + integer, intent(in) :: poly_order(0:) + real(dp), intent(in) :: alpha(0:,:) + integer :: ii,jj,kk,ll,mm,nn,oo,pp,nlp,nlq + real(dp) :: alpha1 + + u=0.0d0 + + do ii=0,max_l + nn=0 + do jj=1,num_alpha(ii) + do ll=1,poly_order(ii) + nn=nn+1 + oo=0 + nlp=ll+ii + do kk=1,num_alpha(ii) + alpha1=0.5d0*(alpha(ii,jj)+alpha(ii,kk)) + do mm=1,poly_order(ii) + oo=oo+1 + nlq=mm+ii + u(ii,nn,oo)=2.0d0/sqrt(v(alpha(ii,jj),2*nlp)*& + &v(alpha(ii,kk),2*nlq))*v(alpha1,nlp+nlq-1) + end do + end do + end do + end do + end do + + ! write(*,*) 'NUCLEAR' + ! write(*,*) u + + end subroutine nuclear + + ! WARNING: a finite nucleus is a bad idea with the currently implemented ZORA, + ! because the integration by parts done there does certainly fail with a finite + ! nucleus. Second: this routine does not even work without ZORA, unknown bug. + ! + ! subroutine nuclear_finite(u,nuc,max_l,num_alpha,alpha,poly_order) + !! simple finite nucleus + !! v=-Z/(2R_0)*(3-r^2/R_0^2) for r<=R_0 + !! v=-Z/r for r>R_0 + ! + ! implicit none + ! + ! real(dp), intent(out) :: u(0:,:,:) + ! integer, intent(in) :: max_l,nuc + ! integer, intent(in) :: num_alpha(0:) + ! integer, intent(in) :: poly_order(0:) + ! real(dp), intent(in) :: alpha(0:,:) + ! integer :: ii,jj,kk,ll,mm,nn,oo,pp,nlp,nlq + ! real(dp) :: alpha1,alpha2,part1,part2,part3,part4,part5,part6,r0,normalization + ! integer :: iso(109) + ! DATA iso/& + ! &1, 4, 7, 9, 11, 12, 14, 16, 19, 20, 23, 24, 27, 28, 31, 32, 35, 40, 39, 40,& + ! &45, 48, 51, 52, 55, 56, 59, 58, 63, 64, 69, 74, 75, 80, 79, 84, 85, 88, 89,& + ! &90, 93, 98, 98, 102, 103, 106, 107, 114, 115, 120, 121, 130, 127, 132, 133,& + ! &138, 139, 140, 141, 144, 145, 152, 153, 158, 159, 162, 162, 168, 169, 174, & + ! &175, 180, 181, 184, 187, 192, 193, 195, 197, 202, 205, 208, 209, 209, 210,& + ! &222, 223, 226, 227, 232, 231, 238, 237, 244, 243, 247, 247, 251, 252, 257,& + ! &258, 259, 262, 261, 262, 263, 262, 265, 266/ + ! + ! r0=sqrt(5.0d0/3.0d0)*(0.836*(iso(nuc)**(1.0d0/3.0d0))+0.570)*1.0d-5/0.529177d0 + ! + ! write(*,'(A,E)') 'FINITE NUCLEUS MODEL, RADIUS ',r0 + ! + ! u=0.0d0 + ! + ! do ii=0,max_l + ! nn=0 + ! do jj=1,num_alpha(ii) + ! do ll=1,poly_order(ii) + ! nn=nn+1 + ! oo=0 + ! nlp=ll+ii + ! do kk=1,num_alpha(ii) + ! alpha1=0.5d0*(alpha(ii,jj)+alpha(ii,kk)) + ! alpha2=-(alpha(ii,jj)+alpha(ii,kk)) + ! do mm=1,poly_order(ii) + ! oo=oo+1 + ! nlq=mm+ii + ! + ! normalization=float(2**(nlp+nlq+1))/& + ! sqrt(v(alpha(ii,jj),2*nlp)*v(alpha(ii,kk),2*nlq)) + ! + ! part1=exp_int(alpha2,nlp+nlq-1,r0)-exp_int(alpha2,nlp+nlq-1,0.0d0) + ! part2=(exp_int(alpha2,nlp+nlq,r0)-& + ! &exp_int(alpha2,nlp+nlq,0.0d0))*3.0d0/(2.0d0*r0) + ! part3=(exp_int(alpha2,nlp+nlq+2,r0)-& + ! &exp_int(alpha2,nlp+nlq+2,0.0d0))/(2.0d0*(r0**3)) + ! + ! u(ii,nn,oo)=2.0d0/sqrt(v(alpha(ii,jj),2*nlp)*& + ! &v(alpha(ii,kk),2*nlq))*v(alpha1,nlp+nlq-1)& + ! &-normalization*(+part1-part2+part3) + ! write(*,*) 'part1',part1 + ! write(*,*) 'part2',part2 + ! write(*,*) 'part3',part3 + ! write(*,*) 'norma',normalization + ! end do + ! end do + ! end do + ! end do + ! end do + ! + ! write(*,*) 'NUCLEAR FINITE' + ! write(*,*) u + ! + ! end subroutine nuclear_finite + + subroutine kinetic(t,max_l,num_alpha,alpha,poly_order) + + ! Kinetic matrix elements, see rmp_32_186_1960.pdf eqn. 5 and eqn. 19 + + real(dp), intent(out) :: t(0:,:,:) + integer, intent(in) :: max_l + integer, intent(in) :: num_alpha(0:) + integer, intent(in) :: poly_order(0:) + real(dp), intent(in) :: alpha(0:,:) + integer :: ii,jj,kk,ll,mm,nn,oo,pp,nlp,nlq + real(dp) :: alpha1 + + t=0.0d0 + + do ii=0,max_l + nn=0 + do jj=1,num_alpha(ii) + do ll=1,poly_order(ii) + nn=nn+1 + oo=0 + nlp=ll+ii + do kk=1,num_alpha(ii) + alpha1=0.5d0*(alpha(ii,jj)+alpha(ii,kk)) + do mm=1,poly_order(ii) + oo=oo+1 + nlq=mm+ii + t(ii,nn,oo)=0.5d0*alpha(ii,jj)*alpha(ii,kk)/& + &sqrt(v(alpha(ii,jj),2*nlp)*v(alpha(ii,kk),2*nlq))*& + &(v(alpha1,nlp+nlq)-& + &(w(alpha(ii,jj),ii,nlp)+w(alpha(ii,kk),ii,nlq))*& + &v(alpha1,nlp+nlq-1)+& + &(w(alpha(ii,jj),ii,nlp)*w(alpha(ii,kk),ii,nlq))*& + &v(alpha1,nlp+nlq-2)& + &) + end do + end do + end do + end do + end do + + ! write(*,*) 'KINETIC' + ! write(*,*) t + + end subroutine kinetic + + subroutine confinement(vconf,max_l,num_alpha,alpha,poly_order,& + &conf_r0,conf_power) + + ! Analytic matrix elements of confining potential + ! No checking for power, e.g. power==0 or power<0 etc. ! + + real(dp), intent(out) :: vconf(0:,:,:) + integer, intent(in) :: max_l,conf_power(0:) + integer, intent(in) :: num_alpha(0:) + integer, intent(in) :: poly_order(0:) + real(dp), intent(in) :: alpha(0:,:),conf_r0(0:) + integer :: ii,jj,kk,ll,mm,nn,oo,pp,nlp,nlq + real(dp) :: alpha1 + + vconf=0.0d0 + + do ii=0,max_l + if (conf_power(ii)/=0) then + nn=0 + do jj=1,num_alpha(ii) + do ll=1,poly_order(ii) + nn=nn+1 + oo=0 + nlp=ll+ii + do kk=1,num_alpha(ii) + alpha1=0.5d0*(alpha(ii,jj)+alpha(ii,kk)) + do mm=1,poly_order(ii) + oo=oo+1 + nlq=mm+ii + vconf(ii,nn,oo)=1.0d0/sqrt(v(alpha(ii,jj),2*nlp)*& + &v(alpha(ii,kk),2*nlq))/(conf_r0(ii)*2.0d0)**conf_power(ii)*& + &v(alpha1,nlp+nlq+conf_power(ii)) + end do + end do + end do + end do + end if + end do + + ! write(*,*) 'CONFINEMENT' + ! write(*,*) vconf + + end subroutine confinement + + subroutine moments(moment,max_l,num_alpha,alpha,poly_order,problemsize,cof,& + &power) + + ! Arbitrary moments of electron distribution, e.g. expectation values + ! of , etc.; this is implemented analytically for arbitrary + ! powers + + real(dp), intent(out) :: moment(:,0:,:) + integer, intent(in) :: max_l,problemsize + integer, intent(in) :: num_alpha(0:) + integer, intent(in) :: poly_order(0:),power + real(dp), intent(in) :: alpha(0:,:),cof(:,0:,:,:) + integer :: ii,jj,kk,ll,mm,nn,oo,pp,nlp,nlq + real(dp) :: alpha1 + + moment=0.0d0 + + ! only computed for p-functions and higher + if (power>-3) then + do ii=0,max_l + do pp=1,num_alpha(ii)*poly_order(ii) + nn=0 + do jj=1,num_alpha(ii) + do ll=1,poly_order(ii) + nn=nn+1 + oo=0 + nlp=ll+ii + do kk=1,num_alpha(ii) + alpha1=0.5d0*(alpha(ii,jj)+alpha(ii,kk)) + do mm=1,poly_order(ii) + oo=oo+1 + nlq=mm+ii + + moment(1,ii,pp)=moment(1,ii,pp)+1.0d0/sqrt(v(alpha(ii,jj),2*nlp)*& + &v(alpha(ii,kk),2*nlq))/(2.0d0**power)*& + &v(alpha1,nlp+nlq+power)*cof(1,ii,nn,pp)*cof(1,ii,oo,pp) + + moment(2,ii,pp)=moment(2,ii,pp)+1.0d0/sqrt(v(alpha(ii,jj),2*nlp)*& + &v(alpha(ii,kk),2*nlq))/(2.0d0**power)*& + &v(alpha1,nlp+nlq+power)*cof(2,ii,nn,pp)*cof(2,ii,oo,pp) + + end do + end do + end do + end do + end do + end do + else if (power==-3) then + do ii=1,max_l + do pp=1,num_alpha(ii)*poly_order(ii) + nn=0 + do jj=1,num_alpha(ii) + do ll=1,poly_order(ii) + nn=nn+1 + oo=0 + nlp=ll+ii + do kk=1,num_alpha(ii) + alpha1=0.5d0*(alpha(ii,jj)+alpha(ii,kk)) + do mm=1,poly_order(ii) + oo=oo+1 + nlq=mm+ii + + moment(1,ii,pp)=moment(1,ii,pp)+1.0d0/sqrt(v(alpha(ii,jj),2*nlp)*& + &v(alpha(ii,kk),2*nlq))/(2.0d0**power)*& + &v(alpha1,nlp+nlq+power)*cof(1,ii,nn,pp)*cof(1,ii,oo,pp) + + moment(2,ii,pp)=moment(2,ii,pp)+1.0d0/sqrt(v(alpha(ii,jj),2*nlp)*& + &v(alpha(ii,kk),2*nlq))/(2.0d0**power)*& + &v(alpha1,nlp+nlq+power)*cof(2,ii,nn,pp)*cof(2,ii,oo,pp) + + end do + end do + end do + end do + end do + end do + end if + + ! write(*,*) 'MOMENT' + ! write(*,*) moment + + end subroutine moments + + function v(x,i) ! V_{i}(x) + + ! Auxilliary function, see rmp_32_186_1960.pdf eqn. 20 + + real(dp), intent(in) :: x + integer, intent(in) :: i + real(dp) :: v + + v=fak(i)/(x**(i+1)) + + return + end function v + + function w(x,i,j) ! W_{ij}(x) + + ! Auxilliary function, see rmp_32_186_1960.pdf eqn. 20 + + real(dp), intent(in) :: x + integer, intent(in) :: i,j + real(dp) :: w + + w=2.0d0*float((j-i-1))/x + + return + end function w + +end module core_overlap diff --git a/slateratom/lib/coulomb_hfex.f90 b/slateratom/lib/coulomb_hfex.f90 new file mode 100644 index 00000000..65ff8f83 --- /dev/null +++ b/slateratom/lib/coulomb_hfex.f90 @@ -0,0 +1,309 @@ +module coulomb_hfex + use accuracy + use constants + use utilities + use core_overlap + implicit none + private + + public :: coulomb, hfex + + +contains + + subroutine coulomb(j,max_l,num_alpha,alpha,poly_order,u,s) + + ! Coulomb supermatrix, see rmp_32_186_1960.pdf eqn. 6 and eqn. 21 + + + real(dp), intent(out) :: j(0:,:,:,0:,:,:) + integer, intent(in) :: max_l + integer, intent(in) :: num_alpha(0:) + integer, intent(in) :: poly_order(0:) + real(dp), intent(in) :: alpha(0:4,10) + real(dp), intent(in) :: u(0:,:,:) + real(dp), intent(in) :: s(0:,:,:) + real(dp) :: alpha1,alpha2 + integer :: ii,jj,kk,ll,mm,nn,oo,pp,qq,rr,ss,tt,uu,vv,ww,xx,yy,zz + integer :: nlpq,nmrs + + j=0.0d0 + + do ii=0,max_l + ss=0 + do jj=1,num_alpha(ii) + do kk=1,poly_order(ii) + ss=ss+1 + tt=0 + do ll=1,num_alpha(ii) + do mm=1,poly_order(ii) + tt=tt+1 + do nn=0,max_l + uu=0 + do oo=1,num_alpha(nn) + do pp=1,poly_order(nn) + uu=uu+1 + vv=0 + do qq=1,num_alpha(nn) + do rr=1,poly_order(nn) + vv=vv+1 + + alpha1=(alpha(ii,jj)+alpha(ii,ll))/& + &(alpha(nn,oo)+alpha(nn,qq)) + alpha2=(alpha(nn,oo)+alpha(nn,qq))/& + &(alpha(ii,jj)+alpha(ii,ll)) + nlpq=kk+mm+2*ii + nmrs=pp+rr+2*nn + + j(ii,ss,tt,nn,uu,vv)=& + &u(ii,ss,tt)*s(nn,uu,vv)*& + &c(nlpq-1,nmrs,alpha1)+& + &u(nn,uu,vv)*s(ii,ss,tt)*& + &c(nmrs-1,nlpq,alpha2) + ! write(*,'(A,F12.8,6I3)') 'j ',j(ii,ss,tt,nn,uu,vv),ii,ss,tt,nn,uu,vv + ! write(*,'(A,F12.8,3I3)') 's1',s(ii,ss,tt),ii,ss,tt + ! write(*,'(A,F12.8,3I3)') 's2',s(nn,uu,vv),nn,uu,vv + ! write(*,'(A,F12.8,3I3)') 'u1',u(ii,ss,tt),ii,ss,tt + ! write(*,'(A,F12.8,3I3)') 'u2',u(nn,uu,vv),nn,uu,vv + ! write(*,'(A,F12.8,2I3,F12.8)') 'c1',c(kk+mm+2*ii-1,pp+rr+2*nn,alpha1),& + ! &kk+mm+2*ii-1,pp+rr+2*nn,alpha1 + ! write(*,'(A,F12.8,2I3,F12.8)') 'c2',c(pp+rr+2*nn-1,kk+mm+2*ii,alpha2),& + ! &pp+rr+2*ii-1,kk+mm+2*nn,alpha2 + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + + ! do ii=0,max_l + ! do jj=0,max_l + ! j(ii,:,:,jj,:,:)=j(ii,:,:,jj,:,:)/& + ! &((2.0d0*float(ii)+1.0d0)*(2.0d0*float(jj)+1.0d0)) + ! end do + ! end do + + ! write(*,*) 'COULOMB' + ! write(*,*) j + + end subroutine coulomb + + subroutine hfex(k,max_l,num_alpha,alpha,poly_order,problemsize) + + ! HF Exchange supermatrix, see rmp_32_186_1960.pdf eqn. 7/8 and eqn. 21 + + + real(dp), intent(out) :: k(0:,:,:,0:,:,:) + integer, intent(in) :: max_l + integer, intent(in) :: num_alpha(0:) + integer, intent(in) :: poly_order(0:) + real(dp), intent(in) :: alpha(0:4,10) + real(dp),allocatable :: knu(:,:,:,:,:,:,:) + real(dp) :: alpha1,alpha2,alpha3,alpha4,beta1,beta2,beta3,beta4 + real(dp) :: pre,t1,t2,t3,t4 + integer :: ii,jj,kk,ll,mm,nn,oo,pp,qq,rr,ss,tt,uu,vv,ww,xx,yy,zz + integer :: nu,problemsize + integer :: nlp,nlq,nmr,nms + + allocate(knu(0:max_l,problemsize,problemsize,0:max_l,problemsize,& + &problemsize,0:2*max_l+2)) + + k=0.0d0 + knu=0.0d0 + + ! Build knu according to eqn. 8 + + do ii=0,max_l + ss=0 + do jj=1,num_alpha(ii) + do kk=1,poly_order(ii) + ss=ss+1 + tt=0 + do ll=1,num_alpha(ii) + do mm=1,poly_order(ii) + tt=tt+1 + do nn=0,max_l + uu=0 + do oo=1,num_alpha(nn) + do pp=1,poly_order(nn) + uu=uu+1 + vv=0 + do qq=1,num_alpha(nn) + do rr=1,poly_order(nn) + vv=vv+1 + + alpha1=0.5d0*(alpha(ii,jj)+alpha(nn,oo)) + alpha2=0.5d0*(alpha(ii,ll)+alpha(nn,qq)) + alpha3=0.5d0*(alpha(ii,jj)+alpha(nn,qq)) + alpha4=0.5d0*(alpha(ii,ll)+alpha(nn,oo)) + beta1=alpha1/alpha2 + beta2=alpha2/alpha1 + beta3=alpha3/alpha4 + beta4=alpha4/alpha3 + nlp=kk+ii + nlq=mm+ii + nmr=pp+nn + nms=rr+nn + + pre=1.0d0/sqrt(v(alpha(ii,jj),2*(kk+ii))*& + & v(alpha(ii,ll),2*(mm+ii))*& + & v(alpha(nn,oo),2*(pp+nn))*& + & v(alpha(nn,qq),2*(rr+nn))) + + do nu=abs(ii-nn),ii+nn,2 + + t1=v(alpha1,nlp+nmr-nu-1)*v(alpha2,nlq+nms+nu)*& + &c(nlp+nmr-nu-1,nlq+nms+nu,beta1) + t2=v(alpha2,nlq+nms-nu-1)*v(alpha1,nlp+nmr+nu)*& + &c(nlq+nms-nu-1,nlp+nmr+nu,beta2) + t3=v(alpha3,nlp+nms-nu-1)*v(alpha4,nlq+nmr+nu)*& + &c(nlp+nms-nu-1,nlq+nmr+nu,beta3) + t4=v(alpha4,nlq+nmr-nu-1)*v(alpha3,nlp+nms+nu)*& + &c(nlq+nmr-nu-1,nlp+nms+nu,beta4) + + knu(ii,ss,tt,nn,uu,vv,nu)=pre*(t1+t2+t3+t4) + + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + + ! Build k according to eqn. 7 + + do ii=0,max_l + ss=0 + do jj=1,num_alpha(ii) + do kk=1,poly_order(ii) + ss=ss+1 + tt=0 + do ll=1,num_alpha(ii) + do mm=1,poly_order(ii) + tt=tt+1 + do nn=0,max_l + uu=0 + do oo=1,num_alpha(nn) + do pp=1,poly_order(nn) + uu=uu+1 + vv=0 + do qq=1,num_alpha(nn) + do rr=1,poly_order(nn) + vv=vv+1 + + do nu=abs(ii-nn),ii+nn,2 + + k(ii,ss,tt,nn,uu,vv)=k(ii,ss,tt,nn,uu,vv)+& + &almn(ii,nn,nu)*knu(ii,ss,tt,nn,uu,vv,nu) + + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + + ! do ii=0,max_l + ! do jj=0,max_l + ! k(ii,:,:,jj,:,:)=k(ii,:,:,jj,:,:)/& + ! &((2.0d0*float(ii)+1.0d0)*(2.0d0*float(jj)+1.0d0)) + ! end do + ! end do + + + ! write(*,*) 'HF EXCHANGE' + ! write(*,*) k + + end subroutine hfex + + function c(alpha,beta,t) + + ! Auxilliary function, see rmp_32_186_1960.pdf eqn. 22 and eqn. 23 + + integer, intent(in) :: alpha + integer, intent(in) :: beta + real(dp), intent(in) :: t + real(dp) :: c,factor + real(dp), allocatable :: carray(:,:) + integer :: ii,jj + + ! early return if index smaller than zero + + if (alpha<0) then + c=0.0d0 + return + end if + + if (beta<0) then + c=0.0d0 + return + end if + + allocate(carray(0:alpha,0:beta)) + + factor=1.0d0/(1.0d0+t) + + ! Overall this is naive, the matrix could be reused to some extent ... + ! OTOH, the matrices are relatively small. + + ! first handle Kronecker delta, three cases + carray(0,0)=factor + do ii=1,alpha + carray(ii,0)=factor*(t*carray(ii-1,0)+1.0d0) + end do + do ii=1,beta + carray(0,ii)=factor*(carray(0,ii-1)) + end do + + ! now build up from 1 + do ii=1,alpha + do jj=1,beta + carray(ii,jj)=factor*(t*carray(ii-1,jj)+carray(ii,jj-1)) + end do + end do + + c=carray(alpha,beta) + + return + end function c + + function a(rho) + + ! Auxilliary function, see rmp_32_186_1960.pdf eqn. 9 + + + integer, intent(in) :: rho + real(dp) :: a + + a=fak(rho)/((fak(rho/2))**2) + + end function a + + function almn(lambda,mu,nu) + + ! Auxilliary function, see rmp_32_186_1960.pdf eqn. 9 + + + integer, intent(in) :: lambda,mu,nu + real(dp) :: almn + + almn=a(lambda+mu-nu)*a(lambda-mu+nu)*a(mu-lambda+nu)/& + &(float(lambda+mu+nu+1)*a(lambda+mu+nu)) + + end function almn + +end module coulomb_hfex diff --git a/slateratom/lib/coulomb_potential.f90 b/slateratom/lib/coulomb_potential.f90 new file mode 100644 index 00000000..ec9cad7f --- /dev/null +++ b/slateratom/lib/coulomb_potential.f90 @@ -0,0 +1,113 @@ +module coulomb_potential + +! the routines in this module server output purposes only +! during SCF except in the ZORA case, but even then the Coulomb matrix +! (J supermatrix) elements are calculated directly + + use accuracy + use utilities + use integration + use core_overlap + implicit none + private + + public :: cou_pot + +contains + + subroutine cou_pot(p,max_l,num_alpha,poly_order,alpha,problemsize,& + &num_points,abcissa,cpot) + ! calculate coulomb potential on arbitraty set of points + ! by analytical evaluation of the integrals indicated + ! _ _ + ! | | + ! | 1 r 2 rmax | + ! V(r)= 4*PI * | - int * r' * rho(r') + int r' * rho (r') | + ! | r 0 r | + ! |_ _| + ! help1 help2 + + implicit none + + real(dp), intent(in) :: p(0:,:,:),abcissa(:),alpha(0:,:) + integer, intent(in) :: max_l,num_alpha(0:),poly_order(0:),num_points + integer, intent(in) :: problemsize + real(dp), intent(out) :: cpot(:) + real(dp), allocatable :: help1(:,:,:,:),help2(:,:,:,:) + real(dp) :: alpha1 + integer :: ii,jj,kk,ll,mm,nn,oo,pp,nlp,nlq + + allocate(help1(num_points,0:max_l,problemsize,problemsize)) + allocate(help2(num_points,0:max_l,problemsize,problemsize)) + + help1=0.0d0 + help2=0.0d0 + cpot=0.0d0 + + ! get integrals for pairs of basis functions + do ii=0,max_l + ll=0 + do jj=1,num_alpha(ii) + do kk=1,poly_order(ii) + ll=ll+1 + oo=0 + nlp=kk+ii + do mm=1,num_alpha(ii) + + ! exp_int has no notion of implicit "-" of alpha + alpha1=-(alpha(ii,jj)+alpha(ii,mm)) + + do nn=1,poly_order(ii) + oo=oo+1 + nlq=nn+ii + + ! integrals as indicated in comment, no normalization + do pp=1,num_points + help1(pp,ii,ll,oo)=(exp_int(alpha1,nlp+nlq,abcissa(pp))-& + &exp_int(alpha1,nlp+nlq,0.0d0))/abcissa(pp) + help2(pp,ii,ll,oo)=& + &-exp_int(alpha1,nlp+nlq-1,abcissa(pp)) + end do + + ! add normalization of basis functions + ! watch out for 2**(nlp+nlq+1) needed because variable integration ranges + help1(:,ii,ll,oo)=help1(:,ii,ll,oo)*float(2**(nlp+nlq+1))/& + &sqrt(v(alpha(ii,jj),2*nlp)*v(alpha(ii,mm),2*nlq)) + help2(:,ii,ll,oo)=help2(:,ii,ll,oo)*float(2**(nlp+nlq+1))/& + &sqrt(v(alpha(ii,jj),2*nlp)*v(alpha(ii,mm),2*nlq)) + + end do + end do + end do + end do + end do + + ! now actually get potential, multiply with density matrix + do pp=1,num_points + do ii=0,max_l + ll=0 + do jj=1,num_alpha(ii) + do kk=1,poly_order(ii) + ll=ll+1 + oo=0 + do mm=1,num_alpha(ii) + do nn=1,poly_order(ii) + oo=oo+1 + cpot(pp)=cpot(pp)+p(ii,ll,oo)*& + &(help1(pp,ii,ll,oo)+help2(pp,ii,ll,oo)) + end do + end do + end do + end do + end do + end do + + ! write(*,*) 'CPOT' + ! write(*,*) cpot + + deallocate(help1) + deallocate(help2) + + end subroutine cou_pot + +end module coulomb_potential diff --git a/slateratom/lib/density.f90 b/slateratom/lib/density.f90 new file mode 100644 index 00000000..2496f7e7 --- /dev/null +++ b/slateratom/lib/density.f90 @@ -0,0 +1,702 @@ +module density + use accuracy + use utilities + implicit none + private + + public :: density_at_point, density_at_point_1st, density_at_point_2nd + public :: wavefunction, wavefunction_1st, wavefunction_2nd + public :: basis, basis_1st, basis_2nd + public :: basis_times_basis, basis_times_basis_1st, basis_times_basis_2nd + public :: basis_1st_times_basis_1st, basis_2nd_times_basis_2nd + public :: basis_times_basis_times_r2, basis_times_basis_1st_times_r2, & + &basis_times_basis_2nd_times_r2, basis_times_basis_1st_times_r, & + &basis_1st_times_basis_1st_times_r2 + +contains + + function density_at_point(p,max_l,num_alpha,poly_order,alpha,r) + + ! Calculate electron density at a radial point in space + + real(dp), intent(in) :: p(0:,:,:),r,alpha(0:,:) + integer, intent(in) :: max_l,num_alpha(0:),poly_order(0:) + real(dp) :: density_at_point + integer :: ii,jj,kk,ll,mm,nn,oo,start + + density_at_point=0.0d0 + + do ii=0,max_l + ll=0 + do jj=1,num_alpha(ii) + do kk=1,poly_order(ii) + ll=ll+1 + + ! set global index correctly + oo=ll-1 + do mm=jj,num_alpha(ii) + + ! catch start index for polynomials, different depending on alpha block + start=1 + if (mm==jj) start=kk + + do nn=start,poly_order(ii) + oo=oo+1 + + if (ll==oo) then + density_at_point=density_at_point+p(ii,ll,oo)*& + &basis_times_basis(alpha(ii,jj),kk,alpha(ii,mm),nn,ii,r) + end if + + if (ll/=oo) then + density_at_point=density_at_point+2.0d0*p(ii,ll,oo)*& + &basis_times_basis(alpha(ii,jj),kk,alpha(ii,mm),nn,ii,r) + end if + + end do + end do + end do + end do + end do + + end function density_at_point + + function density_at_point_1st(p,max_l,num_alpha,poly_order,alpha,r) + + ! Calculate 1st derivative at a radial point in space analytically + + + real(dp), intent(in) :: p(0:,:,:),r,alpha(0:,:) + integer, intent(in) :: max_l,num_alpha(0:),poly_order(0:) + real(dp) :: density_at_point_1st + integer :: ii,jj,kk,ll,mm,nn,oo,start + + density_at_point_1st=0.0d0 + ! + ! do ii=0,max_l + ! ll=0 + ! do jj=1,num_alpha(ii) + ! do kk=1,poly_order(ii) + ! ll=ll+1 + ! oo=0 + ! do mm=1,num_alpha(ii) + ! do nn=1,poly_order(ii) + ! oo=oo+1 + ! density_at_point_1st=density_at_point_1st+p(ii,ll,oo)*(& + !! &basis(alpha(ii,jj),kk,ii,r)*basis_1st(alpha(ii,mm),nn,ii,r)& + !! &+basis_1st(alpha(ii,jj),kk,ii,r)*basis(alpha(ii,mm),nn,ii,r)) + ! &basis_times_basis_1st(alpha(ii,jj),kk,alpha(ii,mm),nn,ii,r)+& + ! &basis_times_basis_1st(alpha(ii,mm),nn,alpha(ii,jj),kk,ii,r)) + ! end do + ! end do + ! end do + ! end do + ! end do + + do ii=0,max_l + ll=0 + do jj=1,num_alpha(ii) + do kk=1,poly_order(ii) + ll=ll+1 + + ! set global index correctly + oo=ll-1 + do mm=jj,num_alpha(ii) + + ! catch start index for polynomials, different depending on alpha block + start=1 + if (mm==jj) start=kk + + do nn=start,poly_order(ii) + oo=oo+1 + + if (ll==oo) then + density_at_point_1st=density_at_point_1st+p(ii,ll,oo)*(& + &basis_times_basis_1st(alpha(ii,jj),kk,alpha(ii,mm),nn,ii,r)+& + &basis_times_basis_1st(alpha(ii,mm),nn,alpha(ii,jj),kk,ii,r)) + end if + + if (ll/=oo) then + density_at_point_1st=density_at_point_1st+2.0d0*p(ii,ll,oo)*(& + &basis_times_basis_1st(alpha(ii,jj),kk,alpha(ii,mm),nn,ii,r)+& + &basis_times_basis_1st(alpha(ii,mm),nn,alpha(ii,jj),kk,ii,r)) + end if + + end do + end do + end do + end do + end do + + end function density_at_point_1st + + function density_at_point_2nd(p,max_l,num_alpha,poly_order,alpha,r) + + ! Calculate 2nd derivative at a radial point in space analytically + + + real(dp), intent(in) :: p(0:,:,:),r,alpha(0:,:) + integer, intent(in) :: max_l,num_alpha(0:),poly_order(0:) + real(dp) :: density_at_point_2nd + integer :: ii,jj,kk,ll,mm,nn,oo,start + + density_at_point_2nd=0.0d0 + ! + ! do ii=0,max_l + ! ll=0 + ! do jj=1,num_alpha(ii) + ! do kk=1,poly_order(ii) + ! ll=ll+1 + ! oo=0 + ! do mm=1,num_alpha(ii) + ! do nn=1,poly_order(ii) + ! oo=oo+1 + ! density_at_point_2nd=density_at_point_2nd+p(ii,ll,oo)*(& + ! &basis_times_basis_2nd(alpha(ii,jj),kk,alpha(ii,mm),nn,ii,r)+& + ! &+2.0d0*basis_1st_times_basis_1st(alpha(ii,jj),kk,alpha(ii,mm),nn,ii,r)+& + ! &basis_times_basis_2nd(alpha(ii,mm),nn,alpha(ii,jj),kk,ii,r)) + ! end do + ! end do + ! end do + ! end do + ! end do + + do ii=0,max_l + ll=0 + do jj=1,num_alpha(ii) + do kk=1,poly_order(ii) + ll=ll+1 + + ! set global index correctly + oo=ll-1 + do mm=jj,num_alpha(ii) + + ! catch start index for polynomials, different depending on alpha block + start=1 + if (mm==jj) start=kk + + do nn=start,poly_order(ii) + oo=oo+1 + + if (ll==oo) then + density_at_point_2nd=density_at_point_2nd+p(ii,ll,oo)*(& + &basis_times_basis_2nd(alpha(ii,jj),kk,alpha(ii,mm),nn,ii,r)+& + &+2.0d0*basis_1st_times_basis_1st(alpha(ii,jj),kk,alpha(ii,mm),& + &nn,ii,r)+& + &basis_times_basis_2nd(alpha(ii,mm),nn,alpha(ii,jj),kk,ii,r)) + end if + + if (ll/=oo) then + density_at_point_2nd=density_at_point_2nd+2.0d0*p(ii,ll,oo)*(& + &basis_times_basis_2nd(alpha(ii,jj),kk,alpha(ii,mm),nn,ii,r)+& + &+2.0d0*basis_1st_times_basis_1st(alpha(ii,jj),kk,alpha(ii,mm),& + &nn,ii,r)+& + &basis_times_basis_2nd(alpha(ii,mm),nn,alpha(ii,jj),kk,ii,r)) + end if + + end do + end do + end do + end do + end do + + end function density_at_point_2nd + + function wavefunction(cof,alpha,num_alpha,poly_order,ang,r) + + ! Calculate value of wavefunction at a radial point in space + + + integer, intent(in) :: num_alpha(0:),poly_order(0:) + integer, intent(in) :: ang + real(dp), intent(in) :: cof(:),alpha(0:,:),r + real(dp) :: wavefunction + integer :: ii,jj,kk + + wavefunction=0.0d0 + kk=0 + + do ii=1,num_alpha(ang) + do jj=1,poly_order(ang) + kk=kk+1 + ! write(*,'(3I3,F12.6,I3,F12.6)') ang,ii,jj,alpha(ang,ii),jj+ang,cof(kk) + wavefunction=wavefunction+cof(kk)*basis(alpha(ang,ii),jj,ang,r) + end do + end do + + end function wavefunction + + function wavefunction_1st(cof,alpha,num_alpha,poly_order,ang,r) + + ! Calculate value of 1st derivative of wavefunction at a radial point in + ! space analytically + + + integer, intent(in) :: num_alpha(0:),poly_order(0:) + integer, intent(in) :: ang + real(dp), intent(in) :: cof(:),alpha(0:,:),r + real(dp) :: wavefunction_1st + integer :: ii,jj,kk + + wavefunction_1st=0.0d0 + kk=0 + + do ii=1,num_alpha(ang) + do jj=1,poly_order(ang) + kk=kk+1 + wavefunction_1st=wavefunction_1st+cof(kk)*basis_1st(alpha(ang,ii),jj,ang,r) + end do + end do + + end function wavefunction_1st + + function wavefunction_2nd(cof,alpha,num_alpha,poly_order,ang,r) + + ! Calculate value of 2nd derivative of wavefunction at a radial point in + ! space analytically + + + integer, intent(in) :: num_alpha(0:),poly_order(0:) + integer, intent(in) :: ang + real(dp), intent(in) :: cof(:),alpha(0:,:),r + real(dp) :: wavefunction_2nd + integer :: ii,jj,kk + + wavefunction_2nd=0.0d0 + kk=0 + + do ii=1,num_alpha(ang) + do jj=1,poly_order(ang) + kk=kk+1 + wavefunction_2nd=wavefunction_2nd+cof(kk)*basis_2nd(alpha(ang,ii),jj,ang,r) + end do + end do + + end function wavefunction_2nd + + function basis(alpha,poly_order,l,r) + + ! Value of a primitive Slater basis function at a radial point in space + ! See rmp_32_186_1960.pdf eqn. 3 + + + integer, intent(in) :: l,poly_order + real(dp), intent(in) :: alpha,r + real(dp) :: basis,normalization + + normalization=(2.0d0*alpha)**(poly_order+l)*sqrt(2.0d0*alpha)/& + &sqrt(fak(2*(poly_order+l))) + + ! catch 0^0 + if ((r==0.0d0).and.((poly_order+l-1)==0)) then + basis=normalization*exp(-alpha*r) + else + basis=normalization*r**(poly_order+l-1)*exp(-alpha*r) + end if + + end function basis + + function basis_1st(alpha,poly_order,l,r) + + ! Value of 1st derivative of a primitive Slater basis function at a radial + ! point in space + + + integer, intent(in) :: l,poly_order + real(dp), intent(in) :: alpha,r + real(dp) :: basis_1st,normalization + + normalization=(2.0d0*alpha)**(poly_order+l)*sqrt(2.0d0*alpha)/& + &sqrt(fak(2*(poly_order+l))) + + ! catch 0^0, setting 0^0=1 and 0^-1=0.0 + if ((r==0.0d0).and.((poly_order+l-1)==0)) then + basis_1st=normalization*(-alpha*exp(-alpha*r)) + else if ((r==0.0d0).and.((poly_order+l-2)==0)) then + basis_1st=normalization*(float(poly_order+l-1)*& + &exp(-alpha*r)-alpha*r**(poly_order+l-1)*exp(-alpha*r)) + else + basis_1st=normalization*(float(poly_order+l-1)*r**(poly_order+l-2)*& + &exp(-alpha*r)-alpha*r**(poly_order+l-1)*exp(-alpha*r)) + end if + + end function basis_1st + + function basis_2nd(alpha,poly_order,l,r) + + ! Value of 2nd derivative of a primitive Slater basis function at a radial + ! point in space + + + integer, intent(in) :: l,poly_order + real(dp), intent(in) :: alpha,r + real(dp) :: basis_2nd,normalization + + normalization=(2.0d0*alpha)**(poly_order+l)*sqrt(2.0d0*alpha)/& + &sqrt(fak(2*(poly_order+l))) + + ! catch 0^0 + if ((r==0.0d0).and.((poly_order+l-3)==0)) then + basis_2nd=normalization*(float(poly_order+l-1)*float(poly_order+l-2)*& + &exp(-alpha*r)) + else if ((r==0.0d0).and.((poly_order+l-2)==0)) then + basis_2nd=normalization*(-2.0d0*alpha*float(poly_order+l-1)*& + &exp(-alpha*r)) + else if ((r==0.0d0).and.((poly_order+l-1)==0)) then + basis_2nd=normalization*(alpha**2*exp(-alpha*r)) + else + basis_2nd=normalization*(float(poly_order+l-1)*float(poly_order+l-2)*& + &r**(poly_order+l-3)*exp(-alpha*r)-2.0d0*alpha*float(poly_order+l-1)*& + &r**(poly_order+l-2)*exp(-alpha*r)+alpha**2*r**(poly_order+l-1)*& + &exp(-alpha*r)) + end if + + end function basis_2nd + + function basis_times_basis(alpha,poly1,beta,poly2,l,r) + ! Value of a product of two primitive Slater basis functions at a radial + ! point in space + ! r^(m-1)*e^(-alpha*r)*r^(n-1)*exp(-beta*r)=r^(m+n-2)*exp(-(alpha+beta)*r) + + + integer, intent(in) :: l,poly1,poly2 + real(dp), intent(in) :: alpha,beta,r + real(dp) :: basis_times_basis,normalization1,normalization2 + real(dp) :: ab + integer :: m,n + + m=poly1+l + n=poly2+l + ab=-(alpha+beta) + + normalization1=(2.0d0*alpha)**(m)*sqrt(2.0d0*alpha)/& + &sqrt(fak(2*m)) + normalization2=(2.0d0*beta)**(n)*sqrt(2.0d0*beta)/& + &sqrt(fak(2*n)) + + + ! catch 0^0 + if ((r==0.0d0).and.((m+n-2)==0)) then + basis_times_basis=normalization1*normalization2*exp(ab*r) + else + basis_times_basis=normalization1*normalization2*& + &r**(m+n-2)*exp(ab*r) + end if + + if (abs(basis_times_basis)<1.0d-20) basis_times_basis=0.0d0 + + end function basis_times_basis + + function basis_times_basis_1st(alpha,poly1,beta,poly2,l,r) + ! evaluation of product of a basis function with first the derivative of another + ! basis function + ! beta and poly2 are the arguments of the derivative + + + integer, intent(in) :: l,poly1,poly2 + real(dp), intent(in) :: alpha,beta,r + real(dp) :: basis_times_basis_1st,normalization1,normalization2 + real(dp) :: ab + integer :: m,n + + m=poly1+l + n=poly2+l + ab=-(alpha+beta) + + normalization1=(2.0d0*alpha)**(m)*sqrt(2.0d0*alpha)/& + &sqrt(fak(2*m)) + normalization2=(2.0d0*beta)**(n)*sqrt(2.0d0*beta)/& + &sqrt(fak(2*n)) + + ! WARNING: without summing negative and positive contributions independently + ! zora becomes completely unstable ! + + ! catch 0^0, setting 0^0=1 and 0^1=0 + if ((r==0.0d0).and.((m+n-2)==0)) then + basis_times_basis_1st=normalization1*normalization2*& + &(-beta)*exp(ab*r) + else if ((r==0.0d0).and.((m+n-3)==0)) then + basis_times_basis_1st=normalization1*normalization2*& + &(float(n-1))*exp(ab*r) + else + basis_times_basis_1st=normalization1*normalization2*& + &(float(n-1)*r**(m+n-3)-beta*r**(n+m-2))*exp(ab*r) + end if + + if (abs(basis_times_basis_1st)<1.0d-20) basis_times_basis_1st=0.0d0 + + end function basis_times_basis_1st + + function basis_times_basis_2nd(alpha,poly1,beta,poly2,l,r) + ! evaluation of product of a basis function with the second derivative of + ! another basis function + ! beta and poly2 are the arguments of the derivative + + + integer, intent(in) :: l,poly1,poly2 + real(dp), intent(in) :: alpha,beta,r + real(dp) :: basis_times_basis_2nd,normalization1,normalization2 + real(dp) :: ab,positive,negative + integer :: m,n + + m=poly1+l + n=poly2+l + ab=-(alpha+beta) + + normalization1=(2.0d0*alpha)**(m)*sqrt(2.0d0*alpha)/& + &sqrt(fak(2*m)) + normalization2=(2.0d0*beta)**(n)*sqrt(2.0d0*beta)/& + &sqrt(fak(2*n)) + + ! WARNING: without summing negative and positive contributions independently + ! zora becomes completely unstable ! + positive=float((n-1)*(n-2))*r**(m+n-4)+beta**2*r**(m+n-2) + negative=float(2*(n-1))*beta*r**(n+m-3) + + basis_times_basis_2nd=normalization1*normalization2*& + &(positive-negative)*exp(ab*r) + + if (abs(basis_times_basis_2nd)<1.0d-20) basis_times_basis_2nd=0.0d0 + + end function basis_times_basis_2nd + + function basis_1st_times_basis_1st(alpha,poly1,beta,poly2,l,r) + ! evaluation of product of a first derivatives of basis functions + + + integer, intent(in) :: l,poly1,poly2 + real(dp), intent(in) :: alpha,beta,r + real(dp) :: basis_1st_times_basis_1st,normalization1,normalization2 + real(dp) :: ab,positive,negative + integer :: m,n + + m=poly1+l + n=poly2+l + ab=-(alpha+beta) + + normalization1=(2.0d0*alpha)**(m)*sqrt(2.0d0*alpha)/& + &sqrt(fak(2*m)) + normalization2=(2.0d0*beta)**(n)*sqrt(2.0d0*beta)/& + &sqrt(fak(2*n)) + + ! WARNING: without summing negative and positive contributions independently + ! zora becomes completely unstable ! + + ! catch 0^0 + if ((r==0.0d0).and.((m+n-2)==0)) then + positive=alpha*beta + else if ((r==0.0d0).and.((m+n-4)==0)) then + positive=float((m-1)*(n-1)) + else + positive=float((m-1)*(n-1))*r**(m+n-4)+& + &alpha*beta*r**(m+n-2) + end if + + if ((r==0.0d0).and.((m+n-3)==0)) then + negative=(alpha*float(n-1)+beta*float(m-1)) + else + negative=(alpha*float(n-1)+beta*float(m-1))*r**(m+n-3) + end if + + basis_1st_times_basis_1st=normalization1*normalization2*& + &(positive-negative)*exp(ab*r) + + if (abs(basis_1st_times_basis_1st)<1.0d-20) basis_1st_times_basis_1st=0.0d0 + + end function basis_1st_times_basis_1st + + function basis_2nd_times_basis_2nd(alpha,poly1,beta,poly2,l,r) + ! evaluation of product of a first derivatives of basis functions + + + integer, intent(in) :: l,poly1,poly2 + real(dp), intent(in) :: alpha,beta,r + real(dp) :: basis_2nd_times_basis_2nd,normalization1,normalization2 + real(dp) :: ab,positive,negative + integer :: m,n + + m=poly1+l + n=poly2+l + ab=-(alpha+beta) + + normalization1=(2.0d0*alpha)**(m)*sqrt(2.0d0*alpha)/& + &sqrt(fak(2*m)) + normalization2=(2.0d0*beta)**(n)*sqrt(2.0d0*beta)/& + &sqrt(fak(2*n)) + + ! WARNING: without summing negative and positive contributions independently + ! zora becomes completely unstable ! + positive=float((m-1)*(m-2)*(n-1)*(n-2))*r**(n+m-6)+& + &r**(m+n-4)*(beta**2*float((m-1)*(m-2))+alpha**2*float((n-1)*(n-2))+& + &alpha*beta*float(4*(m-1)*(n-1)))+& + &alpha**2*beta**2*r**(m+n-2) + + negative=r**(m+n-5)*(beta*float(2*(n-1)*(m-1)*(m-2))+& + &alpha*float(2*(m-1)*(n-1)*(n-2)))+& + &r**(m+n-3)*(alpha*beta**2*float(2*(m-1))+& + &beta*alpha**2*float(2*(n-1))) + + basis_2nd_times_basis_2nd=normalization1*normalization2*& + &(positive-negative)*exp(ab*r) + + if (abs(basis_2nd_times_basis_2nd)<1.0d-20) basis_2nd_times_basis_2nd=0.0d0 + + end function basis_2nd_times_basis_2nd + + function basis_times_basis_times_r2(alpha,poly1,beta,poly2,l,r) + ! evaluation of product of two basis functions and r^2 in one go + ! r^(m-1)*e^(-alpha*r)*r^(n-1)*exp(-beta*r) *r^2=r^(m+n)*exp(-(alpha+beta)*r) + + + integer, intent(in) :: l,poly1,poly2 + real(dp), intent(in) :: alpha,beta,r + real(dp) :: basis_times_basis_times_r2,normalization1,normalization2 + real(dp) :: ab + integer :: m,n + + m=poly1+l + n=poly2+l + ab=-(alpha+beta) + + normalization1=(2.0d0*alpha)**(m)*sqrt(2.0d0*alpha)/& + &sqrt(fak(2*m)) + normalization2=(2.0d0*beta)**(n)*sqrt(2.0d0*beta)/& + &sqrt(fak(2*n)) + + basis_times_basis_times_r2=normalization1*normalization2*& + &r**(m+n)*exp(ab*r) + + if (abs(basis_times_basis_times_r2)<1.0d-20) basis_times_basis_times_r2=0.0d0 + + end function basis_times_basis_times_r2 + + function basis_times_basis_1st_times_r2(alpha,poly1,beta,poly2,l,r) + ! evaluation of product of a basis function with first the derivative of another + ! basis function and r^2 + ! beta and poly2 are the arguments of the derivative + + + integer, intent(in) :: l,poly1,poly2 + real(dp), intent(in) :: alpha,beta,r + real(dp) :: basis_times_basis_1st_times_r2,normalization1,normalization2 + real(dp) :: ab + integer :: m,n + + m=poly1+l + n=poly2+l + ab=-(alpha+beta) + + normalization1=(2.0d0*alpha)**(m)*sqrt(2.0d0*alpha)/& + &sqrt(fak(2*m)) + normalization2=(2.0d0*beta)**(n)*sqrt(2.0d0*beta)/& + &sqrt(fak(2*n)) + + ! WARNING: without summing negative and positive contributions independently + ! zora becomes completely unstable ! + basis_times_basis_1st_times_r2=normalization1*normalization2*& + &(float(n-1)*r**(m+n-1)-beta*r**(n+m))*exp(ab*r) + + if (abs(basis_times_basis_1st_times_r2)<1.0d-20) & + &basis_times_basis_1st_times_r2=0.0d0 + + end function basis_times_basis_1st_times_r2 + + function basis_times_basis_2nd_times_r2(alpha,poly1,beta,poly2,l,r) + ! evaluation of product of a basis function with the second derivative of + ! another basis function and r^2 + ! beta and poly2 are the arguments of the derivative + + + integer, intent(in) :: l,poly1,poly2 + real(dp), intent(in) :: alpha,beta,r + real(dp) :: basis_times_basis_2nd_times_r2,normalization1,normalization2 + real(dp) :: ab,positive,negative + integer :: m,n + + m=poly1+l + n=poly2+l + ab=-(alpha+beta) + + normalization1=(2.0d0*alpha)**(m)*sqrt(2.0d0*alpha)/& + &sqrt(fak(2*m)) + normalization2=(2.0d0*beta)**(n)*sqrt(2.0d0*beta)/& + &sqrt(fak(2*n)) + + ! WARNING: without summing negative and positive contributions independently + ! zora becomes completely unstable ! + positive=float((n-1)*(n-2))*r**(m+n-2)+beta**2*r**(m+n) + negative=float(2*(n-1))*beta*r**(n+m-1) + + basis_times_basis_2nd_times_r2=normalization1*normalization2*& + &(positive-negative)*exp(ab*r) + + if (abs(basis_times_basis_2nd_times_r2)<1.0d-20) & + &basis_times_basis_2nd_times_r2=0.0d0 + + end function basis_times_basis_2nd_times_r2 + + function basis_times_basis_1st_times_r(alpha,poly1,beta,poly2,l,r) + ! evaluation of product of a basis function with first the derivative of another + ! basis function and r + ! beta and poly2 are the arguments of the derivative + + + integer, intent(in) :: l,poly1,poly2 + real(dp), intent(in) :: alpha,beta,r + real(dp) :: basis_times_basis_1st_times_r,normalization1,normalization2 + real(dp) :: ab + integer :: m,n + + m=poly1+l + n=poly2+l + ab=-(alpha+beta) + + normalization1=(2.0d0*alpha)**(m)*sqrt(2.0d0*alpha)/& + &sqrt(fak(2*m)) + normalization2=(2.0d0*beta)**(n)*sqrt(2.0d0*beta)/& + &sqrt(fak(2*n)) + + ! WARNING: without summing negative and positive contributions independently + ! zora becomes completely unstable ! + basis_times_basis_1st_times_r=normalization1*normalization2*& + &(float(n-1)*r**(m+n-2)-beta*r**(n+m-1))*exp(ab*r) + + if (abs(basis_times_basis_1st_times_r)<1.0d-20) & + &basis_times_basis_1st_times_r=0.0d0 + + end function basis_times_basis_1st_times_r + + function basis_1st_times_basis_1st_times_r2(alpha,poly1,beta,poly2,l,r) + ! evaluation of product of a first derivatives of basis functions and r^2 + + + integer, intent(in) :: l,poly1,poly2 + real(dp), intent(in) :: alpha,beta,r + real(dp) :: basis_1st_times_basis_1st_times_r2,normalization1,normalization2 + real(dp) :: ab,positive,negative + integer :: m,n + + m=poly1+l + n=poly2+l + ab=-(alpha+beta) + + normalization1=(2.0d0*alpha)**(m)*sqrt(2.0d0*alpha)/& + &sqrt(fak(2*m)) + normalization2=(2.0d0*beta)**(n)*sqrt(2.0d0*beta)/& + &sqrt(fak(2*n)) + + ! WARNING: without summing negative and positive contributions independently + ! zora becomes completely unstable ! + positive=float((m-1)*(n-1))*r**(m+n-2)+& + &alpha*beta*r**(m+n) + negative=(alpha*float(n-1)+beta*float(m-1))*r**(m+n-1) + + basis_1st_times_basis_1st_times_r2=normalization1*normalization2*& + &(positive-negative)*exp(ab*r) + + if (abs(basis_1st_times_basis_1st_times_r2)<1.0d-20) & + &basis_1st_times_basis_1st_times_r2=0.0d0 + + end function basis_1st_times_basis_1st_times_r2 + +end module density diff --git a/slateratom/lib/densitymatrix.f90 b/slateratom/lib/densitymatrix.f90 new file mode 100644 index 00000000..0bde7f43 --- /dev/null +++ b/slateratom/lib/densitymatrix.f90 @@ -0,0 +1,42 @@ +module densitymatrix + use accuracy + use constants + use utilities + implicit none + private + + public :: densmatrix + +contains + + subroutine densmatrix(problemsize,max_l,occ,cof,p) + + ! Get density matrix from wavefunction coefficients. + + real(dp), intent(in) :: cof(:,0:,:,:),occ(:,0:,:) + integer, intent(in) :: problemsize,max_l + real(dp), intent(out) :: p(:,0:,:,:) + integer :: ii,jj,kk,ll,mm + + p=0.0d0 + + do ii=1,2 + do jj=0,max_l + do kk=1,problemsize + do ll=kk,problemsize + do mm=1,problemsize + p(ii,jj,kk,ll)=p(ii,jj,kk,ll)+occ(ii,jj,mm)*& + &cof(ii,jj,kk,mm)*cof(ii,jj,ll,mm) + p(ii,jj,ll,kk)=p(ii,jj,kk,ll) + end do + end do + end do + end do + end do + + ! write(*,*) 'DENSITY MATRIX' + ! write(*,*) p + + end subroutine densmatrix + +end module densitymatrix diff --git a/slateratom/lib/dft.f90 b/slateratom/lib/dft.f90 new file mode 100644 index 00000000..c8981fd8 --- /dev/null +++ b/slateratom/lib/dft.f90 @@ -0,0 +1,889 @@ +module dft + use, intrinsic :: iso_c_binding, only : c_size_t + use accuracy + use constants + use density + use integration + use xc_f90_lib_m + implicit none + private + + public :: dft_start_pot, density_grid, dft_exc_energy, dft_vxc_energy + public :: dft_exc_matrixelement, xalpha, pbe_driver + public :: check_accuracy + public :: derive, radial_divergence, derive1_5, derive2_5 + +contains + + subroutine dft_start_pot(abcissa,num_mesh_points,nuc,vxc) + + ! Total potential to initialize a DFT calculation from Thomas-Fermi + ! Theory. this does not work as intended in the current code, since + ! we do not have a numerical Coulomb-Potential. + + ! Generalized Thomas-Fermi atomic potential + ! as published by R. Latter, Phys. Rev. 99, 510 (1955). + ! and implemented in Dirk Porezags scfatom + + real(dp), intent(in) :: abcissa(:) + integer, intent(in) :: nuc,num_mesh_points + real(dp), intent(out) :: vxc(:,:) + real(dp) :: b,t,x,rtx + integer :: ii + + b= (0.69395656d0/float(nuc))**(1.0d0/3.0d0) + + do ii=1,num_mesh_points + + x= abcissa(ii)/b + rtx= sqrt(x) + + t= float(nuc)/(1.0d0+rtx*(0.02747d0-x*(0.1486d0-0.007298d0*x))& + &+x*(1.243d0+x*(0.2302d0+0.006944d0*x))); + if (t < 1.0d0) t= 1.0d0 + + vxc(ii,1)= (t/abcissa(ii))/2.0d0 + vxc(ii,2)= (t/abcissa(ii))/2.0d0 + + end do + + end subroutine dft_start_pot + + subroutine density_grid(p,max_l,num_alpha,poly_order,alpha,num_mesh_points,& + &abcissa, dzdr, d2zdr2, dz, xcnr, rho,drho,ddrho,vxc,exc,xalpha_const) + + ! Calculate and store density and density derivatives on radial grid. + ! Also calculate and store exchange-correlation potential and energy + ! density on grid. + + real(dp), intent(in) :: p(:,0:,:,:),abcissa(:),alpha(0:,:) + integer, intent(in) :: max_l,num_alpha(0:),poly_order(0:),num_mesh_points + real(dp), intent(in) :: dzdr(:), d2zdr2(:) + real(dp), intent(in) :: dz,xalpha_const + integer, intent(in) :: xcnr + real(dp), intent(out) :: rho(:,:),drho(:,:),ddrho(:,:),vxc(:,:),exc(:) + real(dp) :: rhotot,rhodiff,drhotot,ddrhotot,drhodiff,ddrhodiff + integer :: ii,jj,kk,ll,mm,nn,oo + type(xc_f90_pointer_t) :: xcfunc_x, xcfunc_c, xcinfo + real(dp), allocatable :: tmprho(:,:), ex(:), ec(:), vx(:,:), vc(:,:) + real(dp), allocatable :: tmpsigma(:,:), vxsigma(:,:), vcsigma(:,:) + real(dp), allocatable :: tmpv(:), tmpv2(:) + integer :: ispin, ispin2, isigma + real(dp), parameter :: rec4pi = 1.0_dp / (4.0_dp * pi) + + + if (xcnr==0) return + if (xcnr == 2) then + call xc_f90_func_init(xcfunc_x, xcinfo, XC_LDA_X, XC_POLARIZED) + call xc_f90_func_init(xcfunc_c, xcinfo, XC_LDA_C_PW, XC_POLARIZED) + elseif (xcnr == 3) then + call xc_f90_func_init(xcfunc_x, xcinfo, XC_GGA_X_PBE, XC_POLARIZED) + call xc_f90_func_init(xcfunc_c, xcinfo, XC_GGA_C_PBE, XC_POLARIZED) + end if + + do ii=1,num_mesh_points + + rho(ii,1)=density_at_point(p(1,:,:,:),max_l,num_alpha,poly_order,alpha,& + &abcissa(ii)) + rho(ii,2)=density_at_point(p(2,:,:,:),max_l,num_alpha,poly_order,alpha,& + &abcissa(ii)) + + end do + + rho = max(rho, 0.0_dp) + !rho(:,:) = sign(max(abs(rho), 1e-14_dp), rho) + !drho(ii,:) = sign(max(abs(drho(ii,:)), 1e-14_dp), drho(ii,:)) + !ddrho(ii,:) = sign(max(abs(ddrho(ii,:)), 1e-14_dp), ddrho(ii,:)) + !if (abs(rho(ii,1))<1.0d-16) rho(ii,1)=0.0d0 + !if (abs(rho(ii,2))<1.0d-16) rho(ii,2)=0.0d0 + !if (abs(drho(ii,1))<1.0d-16) drho(ii,1)=0.0d0 + !if (abs(drho(ii,2))<1.0d-16) drho(ii,2)=0.0d0 + !if (abs(ddrho(ii,1))<1.0d-16) ddrho(ii,1)=0.0d0 + !if (abs(ddrho(ii,2))<1.0d-16) ddrho(ii,2)=0.0d0 + + if (xcnr > 2) then + + !call derive2_5(rho(:,1), dz, ddrho(:,1), dzdr, d2zdr2, drho(:,1)) + !call derive2_5(rho(:,2), dz, ddrho(:,2), dzdr, d2zdr2, drho(:,2)) + + do ii = 1, num_mesh_points + + drho(ii,1)=density_at_point_1st(p(1,:,:,:),max_l,num_alpha,poly_order,& + &alpha,abcissa(ii)) + drho(ii,2)=density_at_point_1st(p(2,:,:,:),max_l,num_alpha,poly_order,& + &alpha,abcissa(ii)) + + ddrho(ii,1)=density_at_point_2nd(p(1,:,:,:),max_l,num_alpha,poly_order,& + &alpha,abcissa(ii)) + ddrho(ii,2)=density_at_point_2nd(p(2,:,:,:),max_l,num_alpha,poly_order,& + &alpha,abcissa(ii)) + end do + + end if + + ! divide by 4*pi to catch different normalization of spherical harmonics + if (xcnr==1) then + do ii = 1, num_mesh_points + rhotot = (rho(ii,1) + rho(ii,2)) * rec4pi + rhodiff = (rho(ii,1) - rho(ii,2)) * rec4pi + call xalpha(rhotot,rhodiff,vxc(ii,:),exc(ii),xalpha_const) + end do + + else if (xcnr==2) then + nn = size(rho, dim=1) + allocate(tmprho(2, nn)) + allocate(ex(nn)) + allocate(ec(nn)) + allocate(vx(2, nn)) + allocate(vc(2, nn)) + tmprho(:,:) = transpose(rho) * rec4pi + call xc_f90_lda_exc_vxc(xcfunc_x, nn, tmprho(1,1), ex(1), vx(1,1)) + call xc_f90_lda_exc_vxc(xcfunc_c, nn, tmprho(1,1), ec(1), vc(1,1)) + vxc(:,:) = transpose(vx + vc) + exc = ec + ex +!!! OLD hand coded XC version +! do ii = 1, num_mesh_points +! rhotot = (rho(ii,1) + rho(ii,2)) * rec4pi +! rhodiff = (rho(ii,1) - rho(ii,2)) * rec4pi +! call pbe_driver(0,rhotot,0.0d0,0.0d0,& +! &rhodiff,0.0d0,0.0d0,0.0d0,vxc(ii,:),exc(ii)) +! end do +!!! + else if (xcnr==3) then + nn = size(rho, dim=1) + allocate(tmprho(2, nn)) + allocate(ex(nn)) + allocate(ec(nn)) + allocate(vx(2, nn)) + allocate(vc(2, nn)) + allocate(tmpsigma(3, nn)) + allocate(vxsigma(3, nn)) + allocate(vcsigma(3, nn)) + allocate(tmpv(nn)) + allocate(tmpv2(nn)) + tmprho(:,:) = transpose(rho) * rec4pi + tmpsigma(1,:) = drho(:,1) * drho(:,1) * rec4pi * rec4pi + tmpsigma(2,:) = drho(:,1) * drho(:,2) * rec4pi * rec4pi + tmpsigma(3,:) = drho(:,2) * drho(:,2) * rec4pi * rec4pi + call xc_f90_gga_exc_vxc(xcfunc_x, nn, tmprho(1,1), tmpsigma(1,1),& + & ex(1), vx(1,1), vxsigma(1,1)) + call xc_f90_gga_exc_vxc(xcfunc_c, nn, tmprho(1,1), tmpsigma(1,1), ec(1), & + &vc(1,1), vcsigma(1,1)) + vxc = transpose(vx + vc) + do ispin = 1, 2 + ispin2 = 3 - ispin ! the other spin + isigma = 2 * ispin - 1 ! 1 for spin up, 3 for spin down + tmpv(:) = (vxsigma(isigma,:) + vcsigma(isigma,:)) & + & * drho(:,ispin) * rec4pi + call radial_divergence(tmpv, abcissa, dz, tmpv2, dzdr) + vxc(:,ispin) = vxc(:,ispin) - 2.0_dp * tmpv2 + tmpv(:) = (vxsigma(2,:) + vcsigma(2,:)) & + & * drho(:,ispin2) * rec4pi + call radial_divergence(tmpv, abcissa, dz, tmpv2, dzdr) + vxc(:,ispin) = vxc(:,ispin) - tmpv2 + end do + exc = ex + ec +!!! OLD: hand coded xc-version +! do ii = 1, num_mesh_points +! rhotot = (rho(ii,1) + rho(ii,2)) * rec4pi +! rhodiff = (rho(ii,1) - rho(ii,2)) * rec4pi +! drhotot=(drho(ii,1)+drho(ii,2))/4.0d0/pi +! ddrhotot=(ddrho(ii,1)+ddrho(ii,2))/4.0d0/pi +! drhodiff=(drho(ii,1)-drho(ii,2))/4.0d0/pi +! ddrhodiff=(ddrho(ii,1)-ddrho(ii,2))/4.0d0/pi +! call pbe_driver(1,rhotot,drhotot,ddrhotot,& +! &rhodiff,drhodiff,ddrhodiff,abcissa(ii),vxc(ii,:),exc(ii)) +! end do +!!! + + else + + write(*,'(A,I2,A)') 'XCNR= ',xcnr,' not implemented' + STOP + + end if + + + call xc_f90_func_end(xcfunc_x) + call xc_f90_func_end(xcfunc_c) + + end subroutine density_grid + + subroutine dft_exc_energy(num_mesh_points,rho,exc,weight,abcissa,& + &xcnr,exc_energy) + + ! Calculate DFT Exc energy from energy density and electron density on + ! grid. + + real(dp),intent(out) :: exc_energy + real(dp), intent(in) :: rho(:,:),weight(:),exc(:),abcissa(:) + integer, intent(in) :: num_mesh_points,xcnr + integer :: ii,jj,kk,ll,mm,nn,oo + real(dp) :: rhotot,rhodiff + + exc_energy=0.0d0 + + do ii=1,num_mesh_points + + exc_energy=exc_energy+weight(ii)*exc(ii)*(rho(ii,1)+rho(ii,2))*& + &abcissa(ii)**2 + + end do + + ! + ! For usual DFT functionals E_xc=\int \rho \eps(\rho,\zeta) d^3r + ! so there is only one exchange-correlation energy density \eps(\rho,\zeta) and + ! exc_energy could be a scalar without problems. + ! + + end subroutine dft_exc_energy + + subroutine dft_vxc_energy(num_mesh_points,rho,vxc,weight,abcissa,& + &xcnr,vxc_energy) + ! vxc contribution for double counting correction + + real(dp),intent(out) :: vxc_energy(2) + real(dp), intent(in) :: rho(:,:),weight(:),vxc(:,:),abcissa(:) + integer, intent(in) :: num_mesh_points,xcnr + integer :: ii,jj,kk,ll,mm,nn,oo + real(dp) :: rhotot,rhodiff + + vxc_energy=0.0d0 + + do ii=1,num_mesh_points + + vxc_energy(1)=vxc_energy(1)+weight(ii)*vxc(ii,1)*(rho(ii,1))*& + &abcissa(ii)**2 + vxc_energy(2)=vxc_energy(2)+weight(ii)*vxc(ii,2)*(rho(ii,2))*& + &abcissa(ii)**2 + + end do + + + end subroutine dft_vxc_energy + + subroutine dft_exc_matrixelement(num_mesh_points,weight,abcissa,rho,vxc,& + &xcnr,alpha1,poly1,alpha2,poly2,l,exc_matrixelement) + + ! Calculate a single matrix element of the exchange correlation potential. + + real(dp),intent(out) :: exc_matrixelement(2) + real(dp), intent(in) :: weight(:),abcissa(:),rho(:,:),vxc(:,:) + real(dp), intent(in) :: alpha1,alpha2 + integer, intent(in) :: num_mesh_points,xcnr + integer, intent(in) :: poly1,poly2,l + real(dp) :: basis + integer :: ii,jj,kk,ll,mm,nn,oo + + exc_matrixelement=0.0d0 + + do ii=1,num_mesh_points + + basis=basis_times_basis_times_r2(alpha1,poly1,alpha2,poly2,l,abcissa(ii)) + + exc_matrixelement(1)=exc_matrixelement(1)-weight(ii)*vxc(ii,1)*basis + + exc_matrixelement(2)=exc_matrixelement(2)-weight(ii)*vxc(ii,2)*basis + + end do + + + end subroutine dft_exc_matrixelement + + subroutine xalpha(rhotot,rhodiff,vxc,exc,alpha) + + ! Xalpha potential and energy density. + + ! alpha=2/3 recovers the Gaspar/Kohn/Sham functional commonly used as + ! exchange part in most current LSDA and GGA functionals + ! the original Slater exchange is recoverd with alpha=1 + + real(dp), intent(in) :: rhotot,rhodiff,alpha + real(dp), intent(out) :: exc,vxc(2) + real(dp) :: third,fourthird,vfac,cx,fzeta,dfzeta,eps0,eps1,spinpart,zeta + + third=1.0d0/3.0d0 + fourthird=4.0d0/3.0d0 + vfac=2.0d0**third + cx=0.75d0*(3.d0/pi)**third + + if (abs(rhotot)<1.0d-12) then + exc=0.0d0 + vxc(1)=0.0d0 + vxc(2)=0.0d0 + return + end if + + zeta=rhodiff/rhotot + + if (abs(zeta)>1.0d12) write(*,*) 'ZETA LARGE IN X-ALPHA' + + fzeta=((1.0d0+zeta)**fourthird+(1.0d0-zeta)**fourthird-2.0d0)/(2.0d0*(vfac-1.0d0)) + dfzeta=fourthird*((1.0d0+zeta)**third-(1.0d0-zeta)**third)/(2.0d0*(vfac-1.0d0)) + + eps0=-3.0d0/2.0d0*alpha*cx*rhotot**third + eps1=vfac*eps0 + + exc=eps0+(eps1-eps0)*fzeta + + spinpart=(eps1-eps0)*dfzeta*(1.0d0-zeta) + + vxc(1)=fourthird*exc+spinpart + vxc(2)=fourthird*exc-spinpart + + end subroutine xalpha + + subroutine pbe_driver(xcnr,rho,drho,ddrho,zeta,dzeta,ddzeta,r,vxc,exc) + + ! Driver for the PBE routines. Note: this does a lot of Voodoo but seems + ! to work. + + integer, intent(in) :: xcnr + real(dp), intent(in) :: rho,drho,ddrho,zeta,dzeta,ddzeta,r + real(dp), intent(out) :: vxc(2),exc + real(dp) :: z,dz,rs,alfa,gg,t,u,v,w,vc(2),rho1,rho2,drho1,drho2,ec + real(dp) :: ddrho1,ddrho2,rs1,rs2,s1,s2,u1,u2,eps,t1,t2,ex(2),vx(2) + integer :: igga,idft + + igga=xcnr + + if(abs(rho).lt.1.d-14)then + vxc(1)=0.0d0 + vxc(2)=0.0d0 + exc=0.0d0 + return + endif + + ! FROM BURKEs FORTRAN REFERENCE SOURCE + ! + ! Now do correlation + ! zet=(up-dn)/rho + ! g=phi(zeta) + ! rs=(3/(4pi*rho))^(1/3)=local Seitz radius=alpha/fk + ! sk=Ks=Thomas-Fermi screening wavevector=sqrt(4fk/pi) + ! twoksg=2*Ks*phi + ! t=correlation dimensionless gradient=|grad rho|/(2*Ks*phi*rho) + ! uu=delgrad/(rho^2*twoksg^3) + ! rholap=Laplacian + ! vv=Laplacian/(rho*twoksg^2) + ! ww=(|grad up|^2-|grad dn|^2-zet*|grad rho|^2)/(rho*twoksg)^2 + ! ec=lsd correlation energy + ! vcup=lsd up correlation potential + ! vcdn=lsd down correlation potential + ! h=gradient correction to correlation energy + ! dvcup=gradient correction to up correlation potential + ! dvcdn=gradient correction to down correlation potential + + alfa=(4.d0/(9.d0*pi))**(1.d0/3.d0) + + eps=1.d0-1.0d-12 + z=zeta/rho + if(z.ge. eps) z= eps + if(z.le.-eps) z=-eps + dz=(dzeta*rho-zeta*drho)/rho**2 + + rs=(4.d0*pi*rho/3.d0)**(-1.d0/3.d0) + gg=((1+z)**(2.d0/3.d0)+(1-z)**(2.d0/3.d0))/2.d0 + t=dabs(drho)/rho*dsqrt(pi/4.d0*alfa*rs)/(2.d0*gg) + u=dabs(drho)*ddrho/(rho**2)*(dsqrt(pi/4.d0*alfa*rs)/(2.d0*gg))**3 + v=(ddrho+2.d0/r*drho)/rho * (dsqrt(pi/4.d0*alfa*rs)/(2.d0*gg))**2 + w=drho*dz/rho*(dsqrt(pi/4.d0*alfa*rs)/(2.d0*gg))**2 + call correlation(rs,z,t,u,v,w,igga,ec,vc(1),vc(2)) + + ! rho1=up electron desnity + rho1 =(rho+zeta)/2.d0 + + ! rho2=down electron desnity + rho2 =(rho-zeta)/2.d0 + + ! derivatives + drho1 =(drho+dzeta)/2.d0 + drho2 =(drho-dzeta)/2.d0 + ddrho1=(ddrho+ddzeta)/2.d0 + ddrho2=(ddrho-ddzeta)/2.d0 + + ! FROM BURKEs FORTRAN REFERENCE SOURCE + ! + ! PBE exchange + ! use Ex[up,dn]=0.5*(Ex[2*up]+Ex[2*dn]) (i.e., exact spin-scaling) + ! do up exchange + ! fk=local Fermi wavevector for 2*up=(3 pi^2 (2up))^(1/3) + ! s=dimensionless density gradient=|grad rho|/ (2*fk*rho)_(rho=2*up) + ! u=delgrad/(rho^2*(2*fk)**3)_(rho=2*up) + ! v=Laplacian/(rho*(2*fk)**2)_(rho=2*up) + ! + ! Wigner-Seitz Radii of up (rs1) and down (rs2) electrons + ! + ! actually this should be rs=((4*pi*rho)/3)**(-1/3) + ! but s is calculated correctly later compared to Burkes comments + + rs1=(8.d0*pi*rho1/3.d0)**(-1.d0/3.d0) + rs2=(8.d0*pi*rho2/3.d0)**(-1.d0/3.d0) + + ! alfa=(4.d0/(9.d0*pi))**(1.d0/3.d0) + + s1=dabs(drho1)*(alfa*rs1/2.d0)/rho1 + s2=dabs(drho2)*(alfa*rs2/2.d0)/rho2 + u1=dabs(drho1)*ddrho1/(rho1**2)*(alfa*rs1/2.d0)**3 + u2=dabs(drho2)*ddrho2/(rho2**2)*(alfa*rs2/2.d0)**3 + t1=(ddrho1+2.d0/r*drho1)/rho1*(alfa*rs1/2.d0)**2 + t2=(ddrho2+2.d0/r*drho2)/rho2*(alfa*rs2/2.d0)**2 + + ! + ! use 2.d0*rho1 and 2.d0*rho2 because of spin scaling, see Burkes comment + ! + call exchange(2.d0*rho1,s1,u1,t1,igga,ex(1),vx(1)) + call exchange(2.d0*rho2,s2,u2,t2,igga,ex(2),vx(2)) + + exc=0.5d0*((1.d0+z)*ex(1)+(1.d0-z)*ex(2))+ec + + vxc(1)=vx(1)+vc(1) + vxc(2)=vx(2)+vc(2) + + end subroutine pbe_driver + + SUBROUTINE CORRELATION(RS,ZET,T,UU,VV,WW,igga,ec,vc1,vc2) + + ! + ! APART FROM COSMETICS THIS IS IN FACT BURKEs FORTRAN REFERENCE IMPLEMENTATION + ! + + ! This is the PBE and PW-LDA Correlation routine. + + IMPLICIT REAL*8 (A-H,O-Z) + !---------------------------------------------------------------------- + ! INPUT: RS=SEITZ RADIUS=(3/4pi rho)^(1/3) + ! : ZET=RELATIVE SPIN POLARIZATION = (rhoup-rhodn)/rho + ! : t=ABS(GRAD rho)/(rho*2.*KS*G) -- only needed for PBE + ! : UU=(GRAD rho)*GRAD(ABS(GRAD rho))/(rho**2 * (2*KS*G)**3) + ! : VV=(LAPLACIAN rho)/(rho * (2*KS*G)**2) + ! : WW=(GRAD rho)*(GRAD ZET)/(rho * (2*KS*G)**2 + ! : UU,VV,WW, only needed for PBE potential + ! : igga=flag to do gga (0=>LSD only) + ! output: ecl=lsd correlation energy from [a] + ! : ecn=NONLOCAL PART OF CORRELATION ENERGY PER ELECTRON + ! : vcup=lsd up correlation potential + ! : vcdn=lsd dn correlation potential + ! : dvcup=nonlocal correction to vcup + ! : dvcdn=nonlocal correction to vcdn + !---------------------------------------------------------------------- + ! References: + ! [a] J.P.~Perdew, K.~Burke, and M.~Ernzerhof, + ! {\sl Generalized gradient approximation made simple}, sub. + ! to Phys. Rev.Lett. May 1996. + ! [b] J. P. Perdew, K. Burke, and Y. Wang, {\sl Real-space cutoff + ! construction of a generalized gradient approximation: The PW91 + ! density functional}, submitted to Phys. Rev. B, Feb. 1996. + ! [c] J. P. Perdew and Y. Wang, Phys. Rev. B {\bf 45}, 13244 (1992). + !---------------------------------------------------------------------- + ! bet=coefficient in gradient expansion for correlation, [a](4). + integer :: igga + parameter(thrd=1.d0/3.d0,thrdm=-thrd,thrd2=2.d0*thrd) + parameter(GAM=0.5198420997897463295344212145565d0) + parameter(thrd4=4.d0*thrd, fzz=8.d0/(9.d0*GAM)) + parameter(gamma=0.03109069086965489503494086371273d0) + parameter(bet=0.06672455060314922d0,delt=bet/gamma) + dimension u(6),p(6),s(6) + data u/ 0.03109070D0, 0.2137000D0, 7.5957000D0,& + & 3.58760000D0, 1.6382000D0, 0.4929400D0/ + data p/ 0.01554535D0, 0.2054800D0,14.1189000D0,& + & 6.19770000D0, 3.3662000D0, 0.6251700D0/ + data s/ 0.01688690D0, 0.1112500D0,10.3570000D0,& + & 3.62310000D0, 0.8802600D0, 0.4967100D0/ + !---------------------------------------------------------------------- + ! find LSD energy contributions, using [c](10) . + ! EU=unpolarized LSD correlation energy , EURS=dEU/drs + ! EP=fully polarized LSD correlation energy , EPRS=dEP/drs + ! ALFM=-spin stiffness, [c](3) , ALFRSM=-dalpha/drs . + ! F=spin-scaling factor from [c](9). + ! construct ecl, using [c](8) . + ! + + rtrs=dsqrt(rs) + Q0 = -2.D0*u(1)*(1.D0+u(2)*rtrs*rtrs) + Q1 = 2.D0*u(1)*rtrs*(u(3)+rtrs*(u(4)+rtrs*(u(5)+u(6)*rtrs))) + Q2 = DLOG(1.D0+1.D0/Q1) + Q3 = u(1)*(u(3)/rtrs+2.D0*u(4)+rtrs*(3.D0*u(5)+4.D0*u(6)*rtrs)) + EU = Q0*Q2 + EURS = -2.D0*u(1)*u(2)*Q2-Q0*Q3/(Q1*(1.d0+Q1)) + Q0 = -2.D0*p(1)*(1.D0+p(2)*rtrs*rtrs) + Q1 = 2.D0*p(1)*rtrs*(p(3)+rtrs*(p(4)+rtrs*(p(5)+p(6)*rtrs))) + Q2 = DLOG(1.D0+1.D0/Q1) + Q3 = p(1)*(p(3)/rtrs+2.D0*p(4)+rtrs*(3.D0*p(5)+4.D0*p(6)*rtrs)) + EP = Q0*Q2 + EPRS = -2.D0*p(1)*p(2)*Q2-Q0*Q3/(Q1*(1.d0+Q1)) + Q0 = -2.D0*s(1)*(1.D0+s(2)*rtrs*rtrs) + Q1 = 2.D0*s(1)*rtrs*(s(3)+rtrs*(s(4)+rtrs*(s(5)+s(6)*rtrs))) + Q2 = DLOG(1.D0+1.D0/Q1) + Q3 = s(1)*(s(3)/rtrs+2.D0*s(4)+rtrs*(3.D0*s(5)+4.D0*s(6)*rtrs)) + ALFM = Q0*Q2 + ALFRSM = -2.D0*s(1)*s(2)*Q2-Q0*Q3/(Q1*(1.d0+Q1)) + + Z4 = ZET**4 + F=((1.D0+ZET)**THRD4+(1.D0-ZET)**THRD4-2.D0)/GAM + ECL= EU*(1.D0-F*Z4)+EP*F*Z4-ALFM*F*(1.D0-Z4)/FZZ + !---------------------------------------------------------------------- + ! LSD potential from [c](A1) + ! ECRS = dEc/drs , ECZET=dEc/dzeta , FZ = dF/dzeta [c](A2-A4) + ! + ECRS = EURS*(1.D0-F*Z4)+EPRS*F*Z4-ALFRSM*F*(1.D0-Z4)/FZZ + FZ = THRD4*((1.D0+ZET)**THRD-(1.D0-ZET)**THRD)/GAM + ECZET = 4.D0*(ZET**3)*F*(EP-EU+ALFM/FZZ)& + & +FZ*(Z4*EP-Z4*EU-(1.D0-Z4)*ALFM/FZZ) + COMM = ECL -RS*ECRS/3.D0-ZET*ECZET + VCUP = COMM + ECZET + VCDN = COMM - ECZET + if(igga.eq.0)then + EC=ECL + VC1=VCUP + VC2=VCDN + return + endif + !---------------------------------------------------------------------- + ! PBE correlation energy + ! G=phi(zeta), given after [a](3) + ! DELT=bet/gamma , B=A of [a](8) + ! + G=((1.d0+ZET)**thrd2+(1.d0-ZET)**thrd2)/2.d0 + G3 = G**3 + PON=-ECL/(G3*gamma) + B = DELT/(DEXP(PON)-1.D0) + B2 = B*B + T2 = T*T + T4 = T2*T2 + Q4 = 1.D0+B*T2 + Q5 = 1.D0+B*T2+B2*T4 + ECN= G3*(BET/DELT)*DLOG(1.D0+DELT*Q4*T2/Q5) + EC = ECL + ECN + !---------------------------------------------------------------------- + ! ENERGY DONE. NOW THE POTENTIAL, using appendix E of [b]. + ! + G4 = G3*G + T6 = T4*T2 + RSTHRD = RS/3.D0 + ! GZ=((1.d0+zet)**thirdm-(1.d0-zet)**thirdm)/3.d0 + ! ckoe: hack thirdm never gets defined, but 1-1 should be zero anyway + GZ=0.0d0 + FAC = DELT/B+1.D0 + BG = -3.D0*B2*ECL*FAC/(BET*G4) + BEC = B2*FAC/(BET*G3) + Q8 = Q5*Q5+DELT*Q4*Q5*T2 + Q9 = 1.D0+2.D0*B*T2 + hB = -BET*G3*B*T6*(2.D0+B*T2)/Q8 + hRS = -RSTHRD*hB*BEC*ECRS + FACT0 = 2.D0*DELT-6.D0*B + FACT1 = Q5*Q9+Q4*Q9*Q9 + hBT = 2.D0*BET*G3*T4*((Q4*Q5*FACT0-DELT*FACT1)/Q8)/Q8 + hRST = RSTHRD*T2*hBT*BEC*ECRS + hZ = 3.D0*GZ*ecn/G + hB*(BG*GZ+BEC*ECZET) + hT = 2.d0*BET*G3*Q9/Q8 + hZT = 3.D0*GZ*hT/G+hBT*(BG*GZ+BEC*ECZET) + FACT2 = Q4*Q5+B*T2*(Q4*Q9+Q5) + FACT3 = 2.D0*B*Q5*Q9+DELT*FACT2 + hTT = 4.D0*BET*G3*T*(2.D0*B/Q8-(Q9*FACT3/Q8)/Q8) + COMM = ECN+HRS+HRST+T2*HT/6.D0+7.D0*T2*T*HTT/6.D0 + PREF = HZ-GZ*T2*HT/G + FACT5 = GZ*(2.D0*HT+T*HTT)/G + COMM = COMM-PREF*ZET-UU*HTT-VV*HT-WW*(HZT-FACT5) + DVCUP = COMM + PREF + DVCDN = COMM - PREF + VC1 = VCUP + DVCUP + VC2 = VCDN + DVCDN + ! print*,'c igga is',dvcup + + END subroutine correlation + + subroutine exchange(rho,s,u,t,igga,EX,VX) + + ! APART FROM COSMETICS THIS IS IN FACT BURKEs FORTRAN REFERENCE IMPLEMENTATION + + ! This is the PBE and PW-LDA Exchange routine. + + implicit integer*4 (i-n) + implicit real*8 (a-h,o-z) + + parameter(thrd=1.d0/3.d0,thrd4=4.d0/3.d0) + parameter(pi=3.14159265358979323846264338327950d0) + parameter(ax=-0.738558766382022405884230032680836d0) + + parameter(um=0.21951d0,uk=0.8040d0,ul=um/uk) + + parameter(ap=1.647127d0,bp=0.980118d0,cp=0.017399d0) + parameter(aq=1.523671d0,bq=0.367229d0,cq=0.011282d0) + parameter(ah=0.19645d0,bh=7.7956d0) + parameter(ahp=0.27430d0,bhp=0.15084d0,ahq=0.004d0) + parameter(a1=0.19645d0,a2=0.27430d0,a3=0.15084d0,a4=100.d0) + parameter(a=7.79560d0,b1=0.004d0,eps=1.d-15) + + !---------------------------------------------------------------------- + !---------------------------------------------------------------------- + ! GGA EXCHANGE FOR A SPIN-UNPOLARIZED ELECTRONIC SYSTEM + !---------------------------------------------------------------------- + ! INPUT rho : DENSITY + ! INPUT S: ABS(GRAD rho)/(2*KF*rho), where kf=(3 pi^2 rho)^(1/3) + ! INPUT U: (GRAD rho)*GRAD(ABS(GRAD rho))/(rho**2 * (2*KF)**3) + ! INPUT V: (LAPLACIAN rho)/(rho*(2*KF)**2) (for U,V, see PW86(24)) + ! input igga: (=0=>don't put in gradient corrections, just LDA) + ! OUTPUT: EXCHANGE ENERGY PER ELECTRON (LOCAL: EXL, NONLOCAL: EXN, + ! TOTAL: EX) AND POTENTIAL (VX) + !---------------------------------------------------------------------- + ! References: + ! [a]J.P.~Perdew, K.~Burke, and M.~Ernzerhof, submiited to PRL, May96 + ! [b]J.P. Perdew and Y. Wang, Phys. Rev. B {\bf 33}, 8800 (1986); + ! {\bf 40}, 3399 (1989) (E). + !---------------------------------------------------------------------- + ! Formulas: e_x[unif]=ax*rho^(4/3) [LDA] + ! ax = -0.75*(3/pi)^(1/3) + ! e_x[PBE]=e_x[unif]*FxPBE(s) + ! FxPBE(s)=1+uk-uk/(1+ul*s*s) [a](13) + ! uk, ul defined after [a](13) + !---------------------------------------------------------------------- + !---------------------------------------------------------------------- + ! construct LDA exchange energy density + + exunif = ax*rho**thrd + if((igga.eq.0).or.(s.lt.eps))then + EXL=exunif + EXN=0.d0 + EX=EXL+EXN + VX= exunif*thrd4 + return + endif + !---------------------------------------------------------------------- + ! construct GGA enhancement factor + ! find first and second derivatives of f and: + ! fs=(1/s)*df/ds and fss=dfs/ds = (d2f/ds2 - (1/s)*df/ds)/s + + ! + ! PBE enhancement factors checked against NRLMOL + ! + if(igga.eq.1)then + p0 =1.d0+ul*s**2 + f =1.d0+uk-uk/p0 + fs =2.d0*uk*ul/p0**2 + fss=-4.d0*ul*s*fs/p0 + endif + + ! + + EXL= exunif + EXN= exunif*(f-1.0d0) + EX = EXL+EXN + !---------------------------------------------------------------------- + ! energy done. calculate potential from [b](24) + ! + VX = exunif*(thrd4*f-(u-thrd4*s**3)*fss-t*fs ) + ! print*,'e igga is',igga,vx,xunif*thrd4 + + + END subroutine exchange + + subroutine check_accuracy(weight,abcissa,num_mesh_points,max_l,& + &num_alpha,alpha,poly_order) + + ! Test integration to check the accuracy of the radial mesh by + ! integrating the square of a primitive Slater basis function which are + ! analytically normalized to 1.0d0 ! + + real(dp), intent(in) :: weight(:),abcissa(:),alpha(0:,:) + integer, intent(in) :: num_mesh_points,max_l,num_alpha(0:),poly_order(0:) + real(dp) :: value + integer :: ii,jj,kk,ll + + do ii=0,max_l + do jj=1,num_alpha(ii) + do kk=1,poly_order(ii) + value=0.0d0 + do ll=1,num_mesh_points + + value=value+weight(ll)*abcissa(ll)**2*& + &basis(alpha(ii,jj),kk,ii,abcissa(ll))**2 + + end do + if (abs(1.0d0-value)>1.0d-12) then + write(*,'(A,F12.6,I3,E12.3)') 'WARNING: Integration bad for basis & + &function ',alpha(ii,jj),kk+ii-1,abs(1.0d0-value) + write(*,'(A)') 'Accuracy is not better than 1.0d-12' + end if + end do + end do + end do + + end subroutine check_accuracy + + + subroutine radial_divergence(ff, rr, dr, rdiv, jacobi) + real(dp), intent(in) :: ff(:) + real(dp), intent(in) :: rr(:) + real(dp), intent(in) :: dr + real(dp), intent(out) :: rdiv(:) + real(dp), intent(in), optional :: jacobi(:) + + call derive1_5(ff, dr, rdiv, jacobi) + rdiv = rdiv + 2.0_dp / rr * ff + + end subroutine radial_divergence + + + subroutine derive(ff, dx, jacobi) + real(dp), intent(inout) :: ff(:) + real(dp), intent(in) :: dx + real(dp), intent(in), optional :: jacobi(:) + + real(dp), allocatable :: tmp1(:) + integer :: nn + + nn = size(ff) + allocate(tmp1(nn)) + tmp1(:) = ff + ff(2:nn-1) = (ff(3:nn) - ff(1:nn-2)) / (2.0 * dx) + ff(1) = (tmp1(2) - tmp1(1)) / dx + ff(nn) = (tmp1(nn) - tmp1(nn-1)) / dx + if (present(jacobi)) then + ff = ff * jacobi + end if + + end subroutine derive + + + subroutine derive1_5(ff, dx, dfdx, dudx) + real(dp), intent(in) :: ff(:) + real(dp), intent(in) :: dx + real(dp), intent(out) :: dfdx(:) + real(dp), intent(in), optional :: dudx(:) + + integer, parameter :: np = 5 + integer, parameter :: nleft = np / 2 + integer, parameter :: nright = nleft + integer, parameter :: imiddle = nleft + 1 + real(dp), parameter :: dxprefac = 12.0_dp + real(dp), parameter :: coeffs(np, np) = & + reshape([ & + &-25.0_dp, 48.0_dp, -36.0_dp, 16.0_dp, -3.0_dp, & + & -3.0_dp, -10.0_dp, 18.0_dp, -6.0_dp, 1.0_dp, & + & 1.0_dp, -8.0_dp, 0.0_dp, 8.0_dp, -1.0_dp, & + & -1.0_dp, 6.0_dp, -18.0_dp, 10.0_dp, 3.0_dp, & + & 3.0_dp, -16.0_dp, 36.0_dp, -48.0_dp, 25.0_dp ], [ np, np ]) + + integer :: ngrid + integer :: ii + + ngrid = size(ff) + do ii = 1, nleft + dfdx(ii) = dot_product(coeffs(:,ii), ff(1:np)) + end do + do ii = nleft + 1, ngrid - nright + dfdx(ii) = dot_product(coeffs(:,imiddle), ff(ii-nleft:ii+nright)) + end do + do ii = ngrid - nright + 1, ngrid + dfdx(ii) = dot_product(coeffs(:,np-(ngrid-ii)), ff(ngrid-np+1:ngrid)) + end do + + if (present(dudx)) then + dfdx = dfdx * (dudx / (dxprefac * dx)) + else + dfdx = dfdx / (dxprefac * dx) + end if + + end subroutine derive1_5 + + + + subroutine derive2_5(ff, dx, d2fdx2, dudx, d2udx2, dfdx) + real(dp), intent(in) :: ff(:) + real(dp), intent(in) :: dx + real(dp), intent(out) :: d2fdx2(:) + real(dp), intent(in), optional :: dudx(:), d2udx2(:) + real(dp), intent(out), target, optional :: dfdx(:) + + integer, parameter :: np = 5 + integer, parameter :: nleft = np / 2 + integer, parameter :: nright = nleft + integer, parameter :: imiddle = nleft + 1 + real(dp), parameter :: dxprefac = 12.0_dp + real(dp), parameter :: coeffs(np, np) = & + reshape([ & + & 35.0_dp, -104.0_dp, 114.0_dp, -56.0_dp, 11.0_dp, & + & 11.0_dp, -20.0_dp, 6.0_dp, 4.0_dp, -1.0_dp, & + & -1.0_dp, 16.0_dp, -30.0_dp, 16.0_dp, -1.0_dp, & + & -1.0_dp, 4.0_dp, 6.0_dp, -20.0_dp, 11.0_dp, & + & 11.0_dp, -56.0_dp, 114.0_dp, -104.0_dp, 35.0_dp ], [ np, np ]) + + integer :: ngrid + integer :: ii + real(dp), allocatable, target :: dfdxlocal(:) + real(dp), pointer :: pdfdx(:) + + ngrid = size(ff) + if (present(dfdx)) then + pdfdx => dfdx + elseif (present(d2udx2)) then + allocate(dfdxlocal(ngrid)) + pdfdx => dfdxlocal + end if + + do ii = 1, nleft + d2fdx2(ii) = dot_product(coeffs(:,ii), ff(1:np)) + end do + do ii = nleft + 1, ngrid - nright + d2fdx2(ii) = dot_product(coeffs(:,imiddle), ff(ii-nleft:ii+nright)) + end do + do ii = ngrid - nright + 1, ngrid + d2fdx2(ii) = dot_product(coeffs(:,np-(ngrid-ii)), ff(ngrid-np+1:ngrid)) + end do + + if (present(dudx)) then + d2fdx2 = d2fdx2 * (dudx * dudx / (dxprefac * dx * dx)) + else + d2fdx2 = d2fdx2 / (dxprefac * dx * dx) + end if + + if (present(d2udx2) .or. present(dfdx)) then + call derive1_5(ff, dx, pdfdx) + if (present(d2udx2)) then + d2fdx2 = d2fdx2 + pdfdx * d2udx2 + end if + if (present(dfdx) .and. present(dudx)) then + dfdx = dfdx * dudx + end if + end if + + end subroutine derive2_5 + + + ! subroutine grad_test(p,max_l,num_alpha,poly_order,alpha,num_mesh_points,& + ! &abcissa,xcnr,rho,drho,ddrho,vxc,exc) + ! + ! implicit none + ! + ! real(dp), intent(in) :: p(:,0:,:,:),abcissa(:),alpha(0:,:) + ! integer, intent(in) :: max_l,num_alpha(0:),poly_order(0:),num_mesh_points + ! integer, intent(in) :: xcnr + ! real(dp), intent(out) :: rho(:,:),drho(:,:),ddrho(:,:),vxc(:,:),exc(:) + ! real(dp) :: rhotot,rhodiff,drhotot,ddrhotot + ! integer :: ii,jj,kk,ll,mm,nn,oo + ! + ! do ii=1,500 + ! + ! rho(1,ii)=density_at_point(p(1,:,:,:),max_l,num_alpha,poly_order,alpha,& + ! &0.01d0*ii) + ! rho(2,ii)=density_at_point(p(2,:,:,:),max_l,num_alpha,poly_order,alpha,& + ! &0.01d0*ii) + ! + ! drho(1,ii)=density_at_point_1st(p(1,:,:,:),max_l,num_alpha,poly_order,& + ! &alpha,0.01d0*ii) + ! drho(2,ii)=density_at_point_1st(p(2,:,:,:),max_l,num_alpha,poly_order,& + ! &alpha,0.01d0*ii) + ! + ! ddrho(1,ii)=density_at_point_2nd(p(1,:,:,:),max_l,num_alpha,poly_order,& + ! &alpha,0.01d0*ii) + ! ddrho(2,ii)=density_at_point_2nd(p(2,:,:,:),max_l,num_alpha,poly_order,& + ! &alpha,0.01d0*ii) + ! + ! write(*,'(F12.4,3F20.8)') ii*0.01d0,rho(1,ii),drho(1,ii),ddrho(1,ii) + ! end do + ! STOP + ! + ! end subroutine grad_test + +end module dft diff --git a/slateratom/lib/diagonalizations.f90 b/slateratom/lib/diagonalizations.f90 new file mode 100644 index 00000000..cd7b2087 --- /dev/null +++ b/slateratom/lib/diagonalizations.f90 @@ -0,0 +1,894 @@ +module diagonalizations + use accuracy + implicit none + private + + public :: diagonalize_overlap, diagonalize + + contains + + subroutine diagonalize_overlap(max_l,num_alpha,poly_order,s) + +! Diagonalize overlap matrix to check for linear dependency of basis +! set. Implicitely ewevge is called, but with a unit matrix instead of +! a real overlap. + + integer, intent(in) :: max_l,num_alpha(0:),poly_order(0:) + real(dp), intent(in) :: s(0:,:,:) + real(dp), allocatable :: temp1(:,:),temp2(:),dummy2(:,:),dummy1(:) + integer :: ii,jj,diagsize,kk,ll,ier + + do jj=0,max_l + + diagsize=num_alpha(jj)*poly_order(jj) + + allocate(temp1(diagsize,diagsize)) + allocate(temp2(diagsize)) + allocate(dummy2(diagsize,diagsize)) + allocate(dummy1(diagsize)) + temp1=0.0d0 + temp2=0.0d0 + dummy1=0.0d0 + dummy2=0.0d0 + + do kk=1,diagsize + do ll=1,diagsize + temp1(kk,ll)=s(jj,kk,ll) + end do + dummy2(kk,kk)=1.0d0 + end do + + call ewevge(diagsize,diagsize,diagsize,& + &temp1,dummy2,temp2,dummy1,1,-1,ier) + + if (ier /= 0) then + write(*,*) 'Error in Diagonalization',ier + STOP + end if + + write(*,'(A,I3,A,E16.8)') 'Smallest eigenvalue of overlap for l= ',jj,& + &' : ',temp2(1) + + if (temp2(1)<1.0d-10) then + write(*,'(A)') ' ' + write(*,'(A)') 'Basis set is nearly linear dependent, reduction necessary' + write(*,'(A)') ' ' + STOP + end if + + deallocate(temp1) + deallocate(temp2) + deallocate(dummy2) + deallocate(dummy1) + + end do + write(*,*) ' ' + + end subroutine diagonalize_overlap + + subroutine diagonalize(max_l,num_alpha,poly_order,f,s,cof_neu,eigval) + +! This is a driver for ewevge. The idea is that the matrices +! are allocated in the main program for the maximum size of the problem +! but ewevge is only fed with a matrix of the current size of the +! eigenproblem. + + integer, intent(in) :: max_l,num_alpha(0:),poly_order(0:) + real(dp), intent(in) :: f(:,0:,:,:),s(0:,:,:) + real(dp) :: cof_neu(:,0:,:,:),eigval(:,0:,:) + real(dp), allocatable :: temp1(:,:),temp2(:),dummy2(:,:),dummy1(:) + integer :: ii,jj,diagsize,kk,ll,ier + + do ii=1,2 + do jj=0,max_l + + diagsize=num_alpha(jj)*poly_order(jj) + + allocate(temp1(diagsize,diagsize)) + allocate(temp2(diagsize)) + allocate(dummy2(diagsize,diagsize)) + allocate(dummy1(4*diagsize)) + temp1=0.0d0 + temp2=0.0d0 + dummy1=0.0d0 + dummy2=0.0d0 + + do kk=1,diagsize + do ll=1,diagsize + temp1(kk,ll)=f(ii,jj,kk,ll) + dummy2(kk,ll)=s(jj,kk,ll) + end do + end do + + call ewevge(diagsize,diagsize,diagsize,& + &temp1,dummy2,temp2,dummy1,1,-1,ier) + + if (ier /= 0) then + write(*,*) 'Error in Diagonalization',ier + STOP + end if + + do kk=1,diagsize + do ll=1,diagsize + cof_neu(ii,jj,kk,ll)=temp1(kk,ll) + end do + eigval(ii,jj,kk)=temp2(kk) + end do + + deallocate(temp1) + deallocate(temp2) + deallocate(dummy2) + deallocate(dummy1) + + end do + end do + + end subroutine diagonalize + + +! +! ********************************************************************** +! +! This is a collection of subroutines designated to solve the real*8 +! general symmetric eigenvalue problem with or without eigenvectors. +! The routines have been taken from different freeware FORTRAN +! libraries and optimized by hand (or eye ?! ;-)). Most of the +! optimizations have been done with respect to stride minimization +! for the innermost loops of the subroutines. Problems with +! bugs, roaches and other lifestock please report to +! +! Dirk Porezag porezag@physik.tu-chemnitz.de +! +! or to your nearest pest control agency (I doubt they will help). +! Have fun !! +! +! Copyright for this file by Dirk Porezag +! Washington, DC, Janurary 8th, 1995 +! +! Modifications with some fortran90 features by ckoe +! +! ********************************************************************** +! +! SUBROUTINE EWEVGE +! ================= +! +! ********************************************************************** +! +! Evevge calculates eigenvalues and eigenvectors of the general +! symmetric eigenvalue problem. +! +! Method: * A*C = E*S*C +! * Choleski decomposition S = R'*R +! * A*C = E*R'*R*C -> INV(R')*A*C = E*R*C +! * Transformation Y = R*C -> C = INV(R)*Y +! * Solve INV(R')*A*INV(R)*Y = E*Y (Householder + IQL) +! * Back transformation C = INV(R)*Y +! * Sorting of eigenvalues and eigenvectors +! +! Parameters: +! +! NA (I) : Dimension of A +! NB (I) : Dimension of B +! N (I) : Dimension of Problem +! A (I) : Matrix A (lower triangle) +! (O) : Eigenvector matrix +! B (I) : Matrix B (lower triangle) +! (O) : R where B = R'*R (upper triangle) +! EW (O) : Eigenvalues +! H (-) : Auxiliary vector +! IEV (I) : 0: No eigenvectors +! IORD (I) : 1: Descending order of eigenvalues +! -1: Ascending order of eigenvalues +! otherwise: no sorting +! IER (O) : Error indication +! 0: No error +! K: (K <= N) B is not positive definite +! K: (K > N) Convergence failure for eigenvalue +! (K-N), (K-N-1) eigenvalues are correct +! +! ********************************************************************** +! + SUBROUTINE EWEVGE (NA,NB,N,A,B,EW,H,IEV,IORD,IER) + use accuracy + IMPLICIT NONE + integer, intent(in) :: NA,NB,N + integer, intent(in) :: iev,iord + integer :: IER,ii,i,j + real(dp) :: a,b,ew,h,eps +! IMPLICIT REAL*8 (A-H,O-Z) + DIMENSION A(NA,N),B(NB,N),EW(N),H(N) +! +! do i=1,n +! do j=1,n +! write(*,*) 'we',i,j,a(i,j),b(i,j) +! end do +! end do + IER = 0 + EPS = 0.0_dp + CALL CHOLES(N,B,NB,IER) + IF (IER .NE. 0) RETURN + CALL MATRAF(N,A,NA,B,NB,H) + CALL TRIDIA(NA,N,EW,H,A,IEV) + CALL IQLDIA(NA,N,EW,H,A,IEV,IER) + IF (IER .GT. 0) IER = IER+N + IF (IER .NE. 0) RETURN + IF (IEV .NE. 0) CALL BACKTR(N,N,B,NB,A,NA,A,NA,H) + II = 0 + IF (IEV .NE. 0) II = 1 + CALL SORTVC(NA,N,N,EW,A,IORD,II,H) + RETURN + END SUBROUTINE EWEVGE +! +! ****************************************************************** +! +! SUBROUTINE CHOLES +! ================= +! +! ****************************************************************** +! +! Choles calculates the Choleski decomposition B = R' * R of B +! into an upper triangle matrix R for the symmetric positive +! definite Matrix B. The elements of the main diagonal are +! stored inverted. +! +! Parameters: +! +! N (I) : Dimension of problem +! B (I) : Matrix B (lower triangle) +! (O) : Matrix R (upper triangle), inverted main diagonal +! NB (I) : Dimension of B +! ICHO (I) : ICHO - 1 is the dimension of the submatrix that +! is available as Choleski decomposition ( < 1 = 1) +! (O) : Row number where decomposition failed (0 if success) +! +! ****************************************************************** +! + SUBROUTINE CHOLES (N,B,NB,ICHO) + use accuracy + IMPLICIT NONE + integer :: N,NB,ICHO,i,ii,j,K,i1 + real(dp) :: B,d,s +! IMPLICIT REAL*8 (A-H,O-Z) + DIMENSION B(NB,N) +! + IF (ICHO .GT. N) GOTO 200 + IF (ICHO .LT. 1) ICHO = 1 + DO I = ICHO,N + I1 = I - 1 + DO J = I,N + S = B(J,I) + DO K = 1,I1 + S = S - B(K,I) * B(K,J) + END DO + IF (I .NE. J) GOTO 40 + IF (S .LE. 0.0_dp) GOTO 100 + S = 1.0_dp / SQRT(S) + D = S + GOTO 60 + 40 S = S * D + 60 B(I,J) = S + END DO + END DO + ICHO = 0 + GOTO 200 + 100 ICHO = I + 200 RETURN + END SUBROUTINE CHOLES +! +! ****************************************************************** +! +! SUBROUTINE MATRAF +! ================= +! +! ****************************************************************** +! +! Matraf calculates out of the symmetric matrix A and the +! upper triangular matrix R the product INV(R') * A * INV(R), +! where the main diagonal of R is given inverted. +! +! Parameters: +! +! N (I) : Dimension of problem +! A (I) : Matrix A (lower triangle) +! (O) : Transformed matrix (lower triangle) +! NA (I) : Dimension of A +! B (I) : Matrix R (upper triangle), inverted main diagonal +! NB (I) : Dimension of B +! +! ********************************************************************* +! + SUBROUTINE MATRAF (N,A,NA,B,NB,H) + use accuracy + IMPLICIT NONE + integer :: N,NA,NB,i,j,ii,k,i1 + real(dp) :: A,B,H,s,d +! IMPLICIT REAL*8 (A-H,O-Z) + DIMENSION A(NA,N),B(NB,N),H(N) +! +! FILL MATRIX +! + DO I = 1,N + DO J = I+1,N + A(I,J) = A(J,I) + END DO + END DO +! +! CALCULATION OF A = INV(R') * A +! + DO I = 1,N + I1 = I-1 + D = B(I,I) + DO J = 1,N + S = A(I,J) + DO K = 1,I1 + S = S - B(K,I) * A(K,J) + END DO + A(I,J) = S * D + END DO + END DO +! +! CALCULATION OF A = A * INV(R) (USE BUFFER FOR STRIDE OPTIMIZATION) +! + DO I = 1,N + I1 = I-1 + D = B(I,I) + DO J = I,N + H(J) = A(J,I) + END DO + DO K = 1,I1 + S = B(K,I) + DO J = I,N + H(J) = H(J) - S * A(J,K) + END DO + END DO + DO J = I,N + A(J,I) = H(J) * D + END DO + END DO + RETURN + END SUBROUTINE MATRAF +! +! ****************************************************************** +! +! SUBROUTINE TRIDIA +! ================= +! +! ****************************************************************** +! +! Tridiagonalization of a given symmetric matrix A using Householder +! +! Parameters: +! +! NM (I) : Dimension of A +! N (I) : Dimension of problem +! D (O) : Diagonal of tridiagonal matrix +! E (O) : Subdiagonal of tridiagonal matrix (E(1) = 0.0) +! A (I) : Matrix A (lower triangle) +! (O) : Transformation Matrix +! IEV (I) : 0: No eigenvectors +! +! ****************************************************************** +! + SUBROUTINE TRIDIA (NM,N,D,E,A,IEV) + use accuracy + IMPLICIT NONE + integer :: NM,N,iev,i,j,ii,K,JP1,L + real(dp) :: A,D,E,H,HH,G,F,scale +! IMPLICIT REAL*8 (A-H,O-Z) + DIMENSION A(NM,N),D(N),E(N) +! + DO I = 1,N + D(I) = A(N,I) + END DO + IF (N .EQ. 1) GOTO 510 +! +! FOR I = N STEP -1 UNTIL 2 DO +! + DO II = 2,N + I = N + 2 - II + L = I - 1 + H = 0.0_dp + SCALE = 0.0_dp + IF (L .LT. 2) GOTO 130 +! +! SCALE ROW +! + DO K = 1,L + SCALE = SCALE + ABS(D(K)) + END DO +! + IF (SCALE .NE. 0.0_dp) GOTO 140 + 130 E(I) = D(L) + DO J = 1,L + D(J) = A(L,J) + A(I,J) = 0.0_dp + A(J,I) = 0.0_dp + END DO + GOTO 290 +! + 140 DO K = 1,L + D(K) = D(K) / SCALE + H = H + D(K) * D(K) + END DO + F = D(L) + G = -SIGN(SQRT(H),F) + E(I) = SCALE * G + H = H - F * G + D(L) = F - G +! +! FORM A * U +! + DO J = 1,L + E(J) = 0.0_dp + END DO + DO J = 1,L + F = D(J) + A(J,I) = F + G = E(J) + A(J,J) * F + JP1 = J + 1 + DO K = JP1,L + G = G + A(K,J) * D(K) + E(K) = E(K) + A(K,J) * F + END DO + E(J) = G + END DO +! +! FORM P +! + F = 0.0_dp + DO J = 1,L + E(J) = E(J) / H + F = F + E(J) * D(J) + END DO + HH = F / (H + H) +! +! FORM Q +! + DO J = 1,L + E(J) = E(J) - HH * D(J) + END DO +! +! FORM REDUCED A +! + DO J = 1,L + F = D(J) + G = E(J) + DO K = J,L + A(K,J) = A(K,J) - F * E(K) - G * D(K) + END DO + D(J) = A(L,J) + A(I,J) = 0.0_dp + END DO +! +! DONE WITH THIS TRANSFORMATION +! + 290 D(I) = H + END DO +! +! ACCUMULATION OF TRANSFORMATION MATRICES +! + IF (IEV .EQ. 0) GOTO 600 + DO I = 2,N + L = I - 1 + A(N,L) = A(L,L) + A(L,L) = 1.0_dp + H = D(I) + IF (H .EQ. 0.0_dp) GOTO 380 + DO K = 1,L + D(K) = A(K,I) / H + END DO + DO J = 1,L + G = 0.0_dp + DO K = 1,L + G = G + A(K,I) * A(K,J) + END DO + DO K = 1,L + A(K,J) = A(K,J) - G * D(K) + END DO + END DO +! + 380 DO K = 1,L + A(K,I) = 0.0_dp + END DO + END DO + 510 DO I = 1,N + D(I) = A(N,I) + A(N,I) = 0.0_dp + END DO + GOTO 700 +! +! DEAL WITH EIGENVALUES ONLY +! + 600 DO I = 1,N + D(I) = A(I,I) + END DO +! + 700 A(N,N) = 1.0_dp + E(1) = 0.0_dp + RETURN + END SUBROUTINE TRIDIA +! +! ****************************************************************** +! +! SUBROUTINE IQLDIA +! ================= +! +! ****************************************************************** +! +! Iqldia calculates eigenvalues and eigenvectors of a tridiagonal +! matrix using the QL algorithm with implicit shifting. +! +! Parameters: +! +! NM (I) : Dimension of Z +! N (I) : Dimension of the problem +! D (I) : Diagonal of tridiagonal matrix +! (O) : Eigenvalues +! E (I) : Subdiagonal of tridiagonal matrix +! Z (I) : Transformation matrix +! (O) : Eigenvectors according to Z +! IEV (I) : 0: No eigenvectors +! IER (O) : Error indication +! 0: no error +! K: Convergence failure for the eigenvalue +! number k, k-1 eigenvalues are correct +! +! ********************************************************************** +! + SUBROUTINE IQLDIA (NM,N,D,E,Z,IEV,IER) + use accuracy + IMPLICIT NONE + integer :: NM,N,iev,ier,i,j,ii,k,M,L,MM1,KK,MML + real(dp) :: E,Z,D,DD,P,G,R,S,T,PSI,PSJ,F,B,C,anorm + real(dp) :: big,eps4,eps,epss +! IMPLICIT REAL*8 (A-H,O-Z) + DIMENSION D(N),E(N),Z(NM,N) +! + IER = 0 + IF (N .EQ. 1) RETURN +! +! GET MACHINE EPSILON AND BIG +! + EPS = 1.0e-2_dp + 10 IF ((1.0_dp + EPS) .EQ. 1.0_dp) GOTO 20 + EPS = 0.5_dp * EPS + GOTO 10 + 20 EPS = 2.0_dp * EPS + EPSS = SQRT(EPS) + EPS4 = EPS * 1.0e-4_dp + BIG = 1.0_dp/EPS4 +! + ANORM = 0.0_dp + R = 0.0_dp + DO I = 2, N + S = E(I) + E(I-1) = S + S = ABS(S) + P = ABS(D(I-1)) + R + S + IF (P .GT. ANORM) ANORM = P + R = S + END DO + P = ABS(D(N)) + R + IF (P .GT. ANORM) ANORM = P + E(N) = 0.0_dp + DO 250 L = 1, N + J = 0 +! +! LOOK FOR SMALL SUBDIAGONAL ELEMENT +! + 50 DO M = L, N-1 + DD = ABS(D(M)) + ABS(D(M+1)) + IF (ABS(E(M)) .LE. (EPS * DD)) GOTO 70 + IF (ABS(E(M)) .LE. (EPS4 * ANORM)) GOTO 70 + END DO + M = N + 70 P = D(L) + MM1 = M - 1 + IF (M .EQ. L) GOTO 250 + IF (J .EQ. 30) GOTO 900 + J = J + 1 +! +! FORM SHIFT. THIS IS A SLIGHTLY ADVANCED FORM OF SHIFTING MAKING +! THE ROUTINE ABOUT 20 PERCENT FASTER THAN THE USUAL STUFF. +! + G = (D(L+1) - P) / (2.0_dp * E(L)) + R = SQRT (G * G + 1.0_dp) + S = P - E(L) / (G + SIGN (R, G)) + IF (M .EQ. L+1) GOTO 120 + T = S + R = MAX(ABS(S),(ANORM / N)) + DO I = 1, 6 + PSI = D(M) - T + PSJ = -1.0_dp + DO 90 KK = L, MM1 + K = L + MM1 - KK + IF (ABS(PSI) .GE. (EPS * ABS(E(K)))) GOTO 80 + PSI = BIG + PSJ = BIG * BIG + GOTO 90 + 80 P = E(K) / PSI + PSI = D(K) - T - P * E(K) + PSJ = P * P * PSJ - 1.0_dp + 90 CONTINUE + IF (ABS(PSJ) .LE. EPS4) GOTO 120 + P = PSI / PSJ + C = P + IF (ABS(P) .GT. (0.5_dp * R)) C = SIGN(R,P) + T = T - C + IF (ABS(P) .LE. (EPSS * R)) GOTO 110 + END DO + GOTO 120 + 110 S = T + 120 G = D(M) - S + S = 1.0_dp + C = 1.0_dp + P = 0.0_dp + MML = M - L +! +! FOR I = M - 1 STEP -1 UNTIL L DO +! + DO 200 II = 1, MML + I = M - II + F = S * E(I) + B = C * E(I) +! +! SAFE CALCULATION OF SQRT(G * G + F * F) AND SIMILAR STUFF +! + IF (ABS(F) .LT. ABS(G)) GOTO 150 + C = G / F + R = SQRT(1.0_dp + C * C) + E(I+1) = F * R + S = 1.0_dp / R + C = C * S + GOTO 160 + 150 S = F / G + R = SQRT (1.0_dp + S * S) + E(I+1) = G * R + C = 1.0_dp / R + S = S * C + 160 G = D(I+1) - P + R = (D(I) - G) * S + 2.0_dp * C * B + P = S * R + D(I+1) = G + P + G = C * R - B + IF (IEV .EQ. 0) GOTO 200 +! +! FORM VECTOR +! + DO K = 1,N + F = Z(K,I+1) + B = Z(K,I) + Z(K,I+1) = S * B + C * F + Z(K,I) = C * B - S * F + END DO + 200 CONTINUE + D(L) = D(L) - P + E(L) = G + E(M) = 0.0_dp + GOTO 50 + 250 CONTINUE + RETURN + 900 IER = L + RETURN + END SUBROUTINE IQLDIA +! +! ****************************************************************** +! +! This is another version of Iqldia using a less sophisticated +! shifting algorithm. It is much simpler but 20 percent slower. +! +! ****************************************************************** +! +! SUBROUTINE IQLDIA (NM,N,D,E,Z,IEV,IER) +! IMPLICIT REAL*8 (A-H,O-Z) +! DIMENSION D(N),E(N),Z(NM,N) +! +! IER = 0 +! IF (N .EQ. 1) RETURN +! DO 10 I = 2, N +! E(I-1) = E(I) +! 10 CONTINUE +! E(N) = 0.0d0 +! DO 250 L = 1, N +! ITER = 0 +! +! LOOK FOR SMALL SUBDIAGONAL ELEMENT +! +! 100 DO 110 M = L, N-1 +! DD = ABS(D(M)) + ABS(D(M+1)) +! IF ((ABS(E(M)) + DD) .EQ. DD) GOTO 120 +! 110 CONTINUE +! M = N +! 120 IF (M .EQ. L) GOTO 250 +! IF (ITER .EQ. 30) GOTO 900 +! ITER = ITER + 1 +! +! FORM SHIFT +! +! G = (D(L+1) - D(L)) / (2.0 * E(L)) +! R = SQRT (G * G + 1.0) +! G = D(M) - D(L) + E(L) / (G + SIGN(R,G)) +! S = 1.0 +! C = 1.0 +! P = 0.0 +! +! FOR I = M - 1 STEP -1 UNTIL L DO +! +! DO 200 II = 1, M-L +! I = M - II +! F = S * E(I) +! B = C * E(I) +! +! SAFE CALCULATION OF SQRT(G * G + F * F) AND SIMILAR STUFF +! +! IF (ABS(F) .LT. ABS(G)) GOTO 150 +! C = G / F +! R = SQRT(1.0 + C * C) +! E(I+1) = F * R +! S = 1.0 / R +! C = C * S +! GOTO 160 +! 150 S = F / G +! R = SQRT (1.0d0 + S * S) +! E(I+1) = G * R +! C = 1.0d0 / R +! S = S * C +! 160 G = D(I+1) - P +! R = (D(I) - G) * S + 2.0d0 * C * B +! P = S * R +! D(I+1) = G + P +! G = C * R - B +! IF (IEV .EQ. 0) GOTO 200 +! +! FORM VECTOR +! +! DO 180 K = 1, N +! F = Z(K,I+1) +! Z(K,I+1) = S * Z(K,I) + C * F +! Z(K,I) = C * Z(K,I) - S * F +! 180 CONTINUE +! 200 CONTINUE +! D(L) = D(L) - P +! E(L) = G +! E(M) = 0.0d0 +! GOTO 100 +! 250 CONTINUE +! RETURN +! 900 IER = L +! RETURN +! END +! +! ****************************************************************** +! +! SUBROUTINE BACKTR +! ================= +! +! ****************************************************************** +! +! Backtr solves the system R * X = Y (R upper triangular matrix), +! where the main diagonal of R is given inverted. +! +! Parameters: +! N (I) : Dimension of problem +! M (I) : Number of columns in X and Y +! R (I) : Matrix R (upper triangle) +! NR (I) : Dimension of R +! X (O) : Matrix X (solution of system) +! NX (I) : Dimension of X +! Y (I) : Matrix Y (right side) +! NY (I) : Dimension of Y +! H (I) : Auxiliary vector +! +! ********************************************************************** +! + SUBROUTINE BACKTR (N,M,R,NR,X,NX,Y,NY,H) + use accuracy + IMPLICIT NONE + integer :: N,M,NR,NX,NY,i,j,ii,I1,K + real(dp) :: R,X,Y,H,D,S +! IMPLICIT REAL*8 (A-H,O-Z) + DIMENSION R(NR,N),X(NX,M),Y(NY,M),H(N) +! +! CALCULATION OF X = INV(R) * Y +! + DO II = 1,N + I = N + 1 - II + I1 = I + 1 + D = R(I,I) + DO J= I,N + H(J)= R(I,J) + END DO + DO J = 1,M + S = Y(I,J) + DO K = I1,N + S = S - H(K) * X(K,J) + END DO + X(I,J) = S * D + END DO + END DO + RETURN + END SUBROUTINE BACKTR +! +! ****************************************************************** +! +! SUBROUTINE SORTVC +! ================= +! +! ****************************************************************** +! +! Sortvc sorts D and (if required) E and the columns of Q. +! +! Prameters: +! +! NM (I) : Dimension of Q +! N (I) : Dimension of problem (size of one vector in Q) +! NQ (I) : Number of elements in D (or columns in Q) +! D (I) : Vector to sort +! (O) : Sorted vector +! Q (I) : Matrix to sort (vectors in columns) +! (O) : Sorted matrix (vectors in columns) +! M (I) : 1: Descending order in D +! -1: Ascending order in D +! otherwise: no sorting +! IEV (I) : 0: No sorting of Q and E +! 1: Sorting of Q, no sorting of E +! 2: Sorting of Q and E +! E (I) : Additional Vector to sort +! (O) : Sorted additional vector +! +! ********************************************************************** +! + SUBROUTINE SORTVC (NM,N,NQ,D,Q,M,IEV,E) + use accuracy + IMPLICIT NONE + integer :: NM,M,NQ,IEV,i,j,ii,KK,K,N + real(dp) :: D,Q,E,H,S +! IMPLICIT REAL*8 (A-H,O-Z) + LOGICAL LMIN,LMAX + DIMENSION D(NQ),E(NQ),Q(NM,NQ) +! + IF (NQ .LT. 2) RETURN + LMAX = (M .EQ. 1) + LMIN = (M .EQ. -1) + IF (.NOT. (LMAX .OR. LMIN)) RETURN + DO 40 KK = 2,NQ + K = KK - 1 + J = K + H = D(K) +! +! FIND EXTREMUM +! + DO 10 I = KK,NQ + S = D(I) + IF (LMIN .AND. (S .GE. H)) GOTO 10 + IF (LMAX .AND. (S .LE. H)) GOTO 10 + J = I + H = S + 10 CONTINUE + IF (J .EQ. K) GOTO 40 +! +! SORT D +! + D(J) = D(K) + D(K) = H + IF (IEV .EQ. 0) GOTO 40 +! +! SORT Q +! + DO I = 1,N + H = Q(I,K) + Q(I,K) = Q(I,J) + Q(I,J) = H + END DO + IF (IEV .LT. 2) GOTO 40 +! +! SORT E +! + H = E(K) + E(K) = E(J) + E(J) = H + 40 CONTINUE + RETURN + END SUBROUTINE SORTVC + +end module diagonalizations diff --git a/slateratom/lib/globals.f90 b/slateratom/lib/globals.f90 new file mode 100644 index 00000000..957bd82c --- /dev/null +++ b/slateratom/lib/globals.f90 @@ -0,0 +1,124 @@ +module globals + use accuracy + implicit none + + real(dp) :: conf_r0(0:4) ! confinement radius + integer :: conf_power(0:4) ! power of confinement + real(dp) :: alpha(0:4,10) ! exponents + integer :: occ_shells(0:4) ! number of occupied shells + integer :: num_alpha(0:4) ! number of exponents in each shell + integer :: poly_order(0:4) ! highest polynomial order + l in each shell + integer :: nuc ! nuclear charge + integer :: max_l ! maximum angular momentum + integer :: maxiter ! maximum number of SCF calculations + logical :: generate_alpha ! generate alphas automatically + logical :: eigprint ! print eigenvectors to stdout + real(dp) :: min_alpha ! smallest exponent if generate_alpha + real(dp) :: max_alpha ! largest exponent if generate_alpha + integer :: num_occ ! maximal occupied shell + integer :: num_power ! maximum number of coefficients + integer :: num_alphas ! maximum number of exponents + real(dp), allocatable :: occ(:,:,:) ! occupation numbers + + real(dp), allocatable :: s(:,:,:) ! overlap supervector + real(dp), allocatable :: u(:,:,:) ! nucleus-electron supervector + real(dp), allocatable :: t(:,:,:) ! kinetic supervector + real(dp), allocatable :: vconf(:,:,:) ! confinement supervector + + real(dp), allocatable :: j(:,:,:,:,:,:) ! coulomb supermatrix + real(dp), allocatable :: k(:,:,:,:,:,:) ! (hf) exchange supermatrix + + real(dp), allocatable :: cof(:,:,:,:) ! wavefunction coefficients + real(dp) :: change_max ! relative changes during scf + real(dp), allocatable :: p(:,:,:,:) ! density matrix supervector + + real(dp), allocatable :: f(:,:,:,:) ! fock matrix supervector + real(dp), allocatable :: pot_new(:,:,:,:) ! potential matrix supervector + real(dp), allocatable :: pot_old(:,:,:,:) ! potential matrix supervector + + real(dp), allocatable :: eigval(:,:,:) ! eigenvalues + real(dp), allocatable :: eigval_scaled(:,:,:) ! zora scaled eigenvalues + + real(dp) :: total_ene,kinetic_energy,nuclear_energy,conf_energy + real(dp) :: coulomb_energy,exchange_energy + + integer :: xcnr ! switch exchange-correlation + real(dp) :: xalpha_const ! exchange parameter for X-Alpha exchange + + integer :: num_mesh_points ! number of numerical integration points + real(dp), allocatable :: weight(:) ! numerical integration weights + real(dp), allocatable :: abcissa(:) ! numerical integration abcissas + real(dp), allocatable :: dzdr(:) ! dz/dr + real(dp), allocatable :: d2zdr2(:) ! d2z/dr2 + real(dp) :: dz ! step width in linear coordinates + real(dp), allocatable :: rho(:,:) ! density on grid + real(dp), allocatable :: drho(:,:) ! 1st deriv. of density on grid + real(dp), allocatable :: ddrho(:,:) ! 2nd deriv. of density on grid + real(dp), allocatable :: vxc(:,:) ! xc potential on grid + real(dp), allocatable :: exc(:) ! exc energy density on grid + + logical :: zora,final + + logical :: broyden ! switch broyden/simplemix + real(dp) :: mixing_factor ! mixing factor + real(dp) :: zora_ekin ! zora kinetic energy contribution to total energy + + integer :: problemsize + +contains + + subroutine allocate_globals + + ! Allocate all the variables in the globals module + + allocate(weight(num_mesh_points)) + allocate(abcissa(num_mesh_points)) + allocate(dzdr(num_mesh_points)) + allocate(d2zdr2(num_mesh_points)) + allocate(rho(num_mesh_points,2)) + allocate(drho(num_mesh_points,2)) + allocate(ddrho(num_mesh_points,2)) + allocate(exc(num_mesh_points)) + allocate(vxc(num_mesh_points,2)) + + allocate(s(0:max_l,problemsize,problemsize)) + allocate(u(0:max_l,problemsize,problemsize)) + allocate(t(0:max_l,problemsize,problemsize)) + allocate(vconf(0:max_l,problemsize,problemsize)) + allocate(f(2,0:max_l,problemsize,problemsize)) + allocate(pot_old(2,0:max_l,problemsize,problemsize)) + allocate(pot_new(2,0:max_l,problemsize,problemsize)) + write(*,'(A,I0,A)') 'Size of one Supervectors is ',size(s),' & + &double precision elements' + + allocate(eigval(2,0:max_l,problemsize)) + allocate(eigval_scaled(2,0:max_l,problemsize)) + + allocate(j(0:max_l,problemsize,problemsize,0:max_l,problemsize,problemsize)) + allocate(k(0:max_l,problemsize,problemsize,0:max_l,problemsize,problemsize)) + write(*,'(A,I0,A)') 'Size of one Supermatrix is ',size(j),' & + &double precision elements' + + write(*,'(A,I3)') 'MAXIMUM SIZE OF EIGENPROBLEM IS ',problemsize + write(*,'(A)') ' ' + + ! first index reserved for spin + ! fourth index of cof is the eigenvalue index, see densmatrix build + allocate(cof(2,0:max_l,problemsize,problemsize)) + allocate(p(2,0:max_l,problemsize,problemsize)) + + weight=0.0d0 + abcissa=0.0d0 + rho=0.0d0 + drho=0.0d0 + ddrho=0.0d0 + + eigval=0.0d0 + eigval_scaled=0.0d0 + + cof=0.0d0 + p=0.0d0 + + end subroutine allocate_globals + +end module globals diff --git a/slateratom/lib/grid_differentiation_sign_1.txt b/slateratom/lib/grid_differentiation_sign_1.txt new file mode 100644 index 00000000..433a693d --- /dev/null +++ b/slateratom/lib/grid_differentiation_sign_1.txt @@ -0,0 +1,40 @@ +> r(z)=a*(1+cos(pi*z))/(1-cos(pi*z)); + a (1 + cos(pi z)) + r(z) = ----------------- + 1 - cos(pi z) +> simplify(diff(a*(1+cos(pi*z))/(1-cos(pi*z)),z)); +> + 2 a sin(pi z) pi + - ---------------------------- + 2 + 1 - 2 cos(pi z) + cos(pi z) +> z(r)=1/pi*arccos((r-a)/(r+a)); + /r - a\ + arccos|-----| + \r + a/ + z(r) = ------------- + pi +> simplify(diff(1/pi*arccos((r-a)/(r+a)),r)); + a + - --------------------------- + (1/2) + 2 / r a \ + pi (r + a) |--------| + | 2| + \(r + a) / +> simplify(diff(simplify(diff(a*(1+cos(pi*z))/(1-cos(pi*z)),z)),z)); + 2 + 2 (cos(pi z) + 2) a pi + ---------------------------- + 2 + 1 - 2 cos(pi z) + cos(pi z) +> simplify(diff(diff(1/pi*arccos((r-a)/(r+a)),r),r)); + (a + 3 r) a + ------------------------------- + (1/2) + 3 / r a \ + 2 pi (r + a) r |--------| + | 2| + \(r + a) / + + diff --git a/slateratom/lib/grid_differentiation_sign_2.txt b/slateratom/lib/grid_differentiation_sign_2.txt new file mode 100644 index 00000000..a1503f85 --- /dev/null +++ b/slateratom/lib/grid_differentiation_sign_2.txt @@ -0,0 +1,40 @@ +> r(z)=a*(1-cos(pi*z))/(1+cos(pi*z)); + a (1 - cos(pi z)) + r(z) = ----------------- + 1 + cos(pi z) +> simplify(diff(a*(1-cos(pi*z))/(1+cos(pi*z)),z)); +> + 2 a sin(pi z) pi + ---------------------------- + 2 + 1 + 2 cos(pi z) + cos(pi z) +> z(r)=1/pi*arccos((a-r)/(r+a)); + /-r + a\ + arccos|------| + \r + a / + z(r) = -------------- + pi +> simplify(diff(1/pi*arccos((a-r)/(r+a)),r)); + a + --------------------------- + (1/2) + 2 / r a \ + pi (r + a) |--------| + | 2| + \(r + a) / +> simplify(diff(simplify(diff(a*(1-cos(pi*z))/(1+cos(pi*z)),z)),z)); + 2 + 2 (cos(pi z) - 2) a pi + - ---------------------------- + 2 + 1 + 2 cos(pi z) + cos(pi z) +> simplify(diff(diff(1/pi*arccos((a-r)/(r+a)),r),r)); + (a + 3 r) a + - ------------------------------- + (1/2) + 3 / r a \ + 2 pi (r + a) r |--------| + | 2| + \(r + a) / + + diff --git a/slateratom/lib/hamiltonian.f90 b/slateratom/lib/hamiltonian.f90 new file mode 100644 index 00000000..c07653de --- /dev/null +++ b/slateratom/lib/hamiltonian.f90 @@ -0,0 +1,269 @@ +module hamiltonian + use accuracy + use constants + use dft + use broyden + use utilities + use zora_routines + implicit none + private + + public :: build_fock, build_coulomb_matrix + public :: build_hf_ex_matrix, build_dft_exc_matrix + +contains + + subroutine build_fock(iter,t,u,nuc,vconf,j,k,p,max_l,num_alpha,poly_order,& + &problemsize,xcnr,num_mesh_points,weight,abcissa,rho,vxc,alpha,pot_old,& + &pot_new,zora,broyden,mixing_factor,f) + + ! Main driver routine for Fock matrix build-up. Calls also mixer with + ! potential matrix. + + real(dp), intent(in) :: t(0:,:,:),u(0:,:,:),j(0:,:,:,0:,:,:),k(0:,:,:,0:,:,:) + real(dp), intent(in) :: vconf(0:,:,:) + real(dp), intent(in) :: p(:,0:,:,:),weight(:),abcissa(:),alpha(0:,:),rho(:,:) + real(dp), intent(in) :: pot_old(:,0:,:,:),vxc(:,:),mixing_factor + real(dp), intent(out) :: f(:,0:,:,:),pot_new(:,0:,:,:) + integer, intent(in) :: max_l,num_alpha(0:),poly_order(0:),problemsize,nuc,xcnr + integer, intent(in) :: num_mesh_points,iter + logical, intent(in) :: zora,broyden + real(dp), allocatable :: j_matrix(:,:,:),k_matrix(:,:,:,:),p_total(:,:,:) + real(dp), allocatable :: t_zora(:,:,:,:) + integer :: ii,jj,kk,ll,mm,nn,oo,pp,qq,rr,ss,tt,uu,vv,ww,biter + + f=0.0d0 + + allocate(j_matrix(0:max_l,problemsize,problemsize)) + allocate(k_matrix(2,0:max_l,problemsize,problemsize)) + allocate(p_total(0:max_l,problemsize,problemsize)) + allocate(t_zora(2,0:max_l,problemsize,problemsize)) + p_total=0.0d0 + t_zora=0.0d0 + + ! form total densitymatrix supervector + do ii=0,max_l + do jj=1,problemsize + do kk=1,problemsize + p_total(ii,jj,kk)=p(1,ii,jj,kk)+p(2,ii,jj,kk) + end do + end do + end do + + ! build coulomb and exchange potential matrices + + call build_coulomb_matrix(j,p_total,max_l,num_alpha,poly_order,alpha,j_matrix) + + if (xcnr==0) then + call build_hf_ex_matrix(k,p,max_l,num_alpha,poly_order,alpha,k_matrix) + else + call build_dft_exc_matrix(max_l,num_alpha,poly_order,alpha,& + &num_mesh_points,abcissa,weight,rho,vxc,xcnr,k_matrix) + end if + + ! build mixer input + + pot_new(1,:,:,:)=-float(nuc)*u(:,:,:)+j_matrix(:,:,:)-k_matrix(1,:,:,:) + pot_new(2,:,:,:)=-float(nuc)*u(:,:,:)+j_matrix(:,:,:)-k_matrix(2,:,:,:) + + + ! mixer + biter=int((iter)/40) + call mixing_driver(pot_old,pot_new,max_l,num_alpha,& + &poly_order,problemsize,iter-biter*40,broyden,mixing_factor) + +! Not sure: before or after mixer .... ? Potential .ne. Matrix elements +! Should be irrelevant once self-consistency is reached + if (zora) then + + call zora_t_correction(1,t_zora,max_l,num_alpha,alpha,poly_order,& + &num_mesh_points,weight,abcissa,vxc,rho,nuc,p,problemsize) + + end if + + + ! finally build Fock matrix + do ii=0,max_l + ss=0 + do jj=1,num_alpha(ii) + do kk=1,poly_order(ii) + ss=ss+1 + tt=0 + do ll=1,num_alpha(ii) + do mm=1,poly_order(ii) + tt=tt+1 + + f(1,ii,ss,tt)=t(ii,ss,tt)+pot_new(1,ii,ss,tt)+vconf(ii,ss,tt) + f(2,ii,ss,tt)=t(ii,ss,tt)+pot_new(2,ii,ss,tt)+vconf(ii,ss,tt) + + if (zora) then + f(1,ii,ss,tt)=f(1,ii,ss,tt)+t_zora(1,ii,ss,tt) + f(2,ii,ss,tt)=f(2,ii,ss,tt)+t_zora(2,ii,ss,tt) + end if + + end do + end do + end do + end do + end do + + ! write(*,*) 'FOCK MATRIX' + ! write(*,*) f + + deallocate(j_matrix) + deallocate(k_matrix) + deallocate(p_total) + deallocate(t_zora) + + end subroutine build_fock + + subroutine build_coulomb_matrix(j,p,max_l,num_alpha,poly_order,alpha,j_matrix) + + ! Build Coulomb matrix to be added to the Fock matrix from Coulomb Supermatrix + ! by multiplying with density matrix supervector + + real(dp), intent(in) :: j(0:,:,:,0:,:,:),p(0:,:,:) + real(dp), intent(in) :: alpha(0:,:) + integer, intent(in) :: max_l,num_alpha(0:),poly_order(0:) + real(dp), intent(out) :: j_matrix(0:,:,:) + integer :: ii,jj,kk,ll,mm,nn,oo,pp,qq,rr,ss,tt,uu,vv,ww + + j_matrix=0.0d0 + + do ii=0,max_l + ss=0 + do jj=1,num_alpha(ii) + do kk=1,poly_order(ii) + ss=ss+1 + tt=0 + do ll=1,num_alpha(ii) + do mm=1,poly_order(ii) + tt=tt+1 + do nn=0,max_l + uu=0 + do oo=1,num_alpha(nn) + do pp=1,poly_order(nn) + uu=uu+1 + vv=0 + do qq=1,num_alpha(nn) + do rr=1,poly_order(nn) + vv=vv+1 + + ! multiply coulomb supermatrix with total densitymatrix supervector + j_matrix(ii,ss,tt)=j_matrix(ii,ss,tt)+& + &j(ii,ss,tt,nn,uu,vv)*p(nn,uu,vv) + + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + + end subroutine build_coulomb_matrix + + subroutine build_hf_ex_matrix(k,p,max_l,num_alpha,poly_order,alpha,k_matrix) + + ! Build Hartree-Fock exchange matrix to be added to the Fock matrix from + ! supermatrix by multiplying with density matrix supervector + + real(dp), intent(in) :: k(0:,:,:,0:,:,:),p(:,0:,:,:) + real(dp), intent(in) :: alpha(0:,:) + integer, intent(in) :: max_l,num_alpha(0:),poly_order(0:) + real(dp), intent(out) :: k_matrix(:,0:,:,:) + integer :: ii,jj,kk,ll,mm,nn,oo,pp,qq,rr,ss,tt,uu,vv,ww + + k_matrix=0.0d0 + + do ii=0,max_l + ss=0 + do jj=1,num_alpha(ii) + do kk=1,poly_order(ii) + ss=ss+1 + tt=0 + do ll=1,num_alpha(ii) + do mm=1,poly_order(ii) + tt=tt+1 + do nn=0,max_l + uu=0 + do oo=1,num_alpha(nn) + do pp=1,poly_order(nn) + uu=uu+1 + vv=0 + do qq=1,num_alpha(nn) + do rr=1,poly_order(nn) + vv=vv+1 + + ! multiply hf exchange supermatrix with densitymatrix supervector per spin + k_matrix(1,ii,ss,tt)=k_matrix(1,ii,ss,tt)+& + &k(ii,ss,tt,nn,uu,vv)*p(1,nn,uu,vv) + k_matrix(2,ii,ss,tt)=k_matrix(2,ii,ss,tt)+& + &k(ii,ss,tt,nn,uu,vv)*p(2,nn,uu,vv) + + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + + end subroutine build_hf_ex_matrix + + subroutine build_dft_exc_matrix(max_l,num_alpha,poly_order,alpha,& + &num_mesh_points,abcissa,weight,rho,vxc,xcnr,k_matrix) + + ! Build DFT exchange matrix to be added to the Fock matrix by calculating + ! the single matrix elements and putting them together + + real(dp), intent(in) :: alpha(0:,:) + integer, intent(in) :: max_l,num_alpha(0:),poly_order(0:),xcnr,num_mesh_points + real(dp), intent(in) :: weight(:),abcissa(:),rho(:,:),vxc(:,:) + real(dp), intent(out) :: k_matrix(:,0:,:,:) + integer :: ii,jj,kk,ll,mm,nn,oo,pp,qq,rr,ss,tt,uu,vv,ww,start + real(dp) :: exc_matrixelement(2) + + k_matrix=0.0d0 + exc_matrixelement=0.0d0 + + do ii=0,max_l + ss=0 + do jj=1,num_alpha(ii) + do kk=1,poly_order(ii) + ss=ss+1 + + tt=ss-1 + do ll=jj,num_alpha(ii) + + start=1 + if (ll==jj) start=kk + + do mm=start,poly_order(ii) + tt=tt+1 + + call dft_exc_matrixelement(num_mesh_points,weight,abcissa,rho,& + &vxc,xcnr,alpha(ii,jj),kk,& + &alpha(ii,ll),mm,ii,exc_matrixelement) + + k_matrix(1,ii,ss,tt)=exc_matrixelement(1) + k_matrix(2,ii,ss,tt)=exc_matrixelement(2) + k_matrix(1,ii,tt,ss)=exc_matrixelement(1) + k_matrix(2,ii,tt,ss)=exc_matrixelement(2) + + end do + end do + end do + end do + end do + + + end subroutine build_dft_exc_matrix + +end module hamiltonian diff --git a/slateratom/lib/input.f90 b/slateratom/lib/input.f90 new file mode 100644 index 00000000..c13ceaa2 --- /dev/null +++ b/slateratom/lib/input.f90 @@ -0,0 +1,287 @@ +!!* Read input from stdin +module input + use accuracy + implicit none + private + + public :: read_input_1, read_input_2, echo_input + +contains + + subroutine read_input_1(nuc,max_l,occ_shells,maxiter,poly_order,& + &min_alpha,max_alpha,num_alpha,generate_alpha,alpha,& + &conf_r0,conf_power,num_occ,num_power,num_alphas,xcnr,& + &eigprint,zora,broyden,mixing_factor,xalpha_const) + + ! Read in everything except occupation numbers. + + integer :: ii,jj + integer, intent(out) :: nuc,max_l,maxiter,conf_power(0:),num_occ,num_power + integer, intent(out) :: num_alphas,xcnr + logical, intent(out) :: generate_alpha,eigprint,zora,broyden + real(dp), intent(out) :: conf_r0(0:),min_alpha,max_alpha,mixing_factor + real(dp), intent(out) :: alpha(0:,:),xalpha_const + integer, intent(out) :: occ_shells(0:),num_alpha(0:),poly_order(0:) + + + write(*,'(A)') 'Enter nuclear charge, maximal angular momentum (s=0), & + &max. SCF, ZORA' + read(*,*) nuc,max_l,maxiter,zora + + write(*,'(A)') 'Enter XC functional, 0=HF, 1=X-Alpha, 2=PW-LDA, 3=PBE' + read(*,*) xcnr + if (xcnr==0) write(*,'(A)') 'WARNING: ONLY CORRECT FOR CLOSED SHELL 1S !' + if ((xcnr==0).and.zora) then + write(*,'(A)') 'ZORA only available for DFT !' + STOP + end if + if (xcnr==1) then + write(*,'(A)') 'Enter empirical parameter for X-Alpha exchange' + read(*,*) xalpha_const + end if + + if (max_l>4) then + write(*,'(A)') 'Sorry, l=',max_l,' is a bit too large. No nuclear weapons& + &allowed.' + STOP + end if + + write(*,'(A)') 'Enter Confinement: r_0 and integer power, power=0 -> off' + do ii=0,max_l + write(*,'(A,I3)') 'l=',ii + read(*,*) conf_r0(ii),conf_power(ii) + end do + + write(*,'(A)') 'Enter number of occupied shells for each angular momentum' + do ii=0,max_l + write(*,'(A,I3)') 'l=',ii + read(*,*) occ_shells(ii) + end do + + write(*,'(A)') 'Enter number of exponents and polynomial coefficients for each angular momentum' + do ii=0,max_l + write(*,'(A,I3)') 'l=',ii + read(*,*) num_alpha(ii),poly_order(ii) + if (num_alpha(ii)>10) then + write(*,'(A)') ' Sorry, num_alpha must be smaller than 11.' + STOP + end if + end do + + ! write(*,'(A)') 'Enter number of exponents for each angular momentum' + ! do ii=0,max_l + ! write(*,'(A,I3)') 'l=',ii + ! read(*,*) num_alpha(ii) + ! if (num_alpha(ii)>10) then + ! write(*,'(A)') ' Sorry, num_alpha must be smaller than 11.' + ! STOP + ! end if + ! end do + + write(*,'(A)') 'Do you want to generate the exponents ? .true./.false.' + read(*,*) generate_alpha + + if (generate_alpha) then + ! generate alphas + ! + do ii=0,max_l + write(*,'(A)') 'Enter smallest exponent and largest exponent.' + read(*,*) min_alpha,max_alpha + ! + call gen_alphas(min_alpha,max_alpha,num_alpha(ii),alpha(ii,:)) + end do + else + do ii=0,max_l + write(*,'(A,I3,A,I3,A)') 'Enter ',num_alpha(ii),'exponents for l=',& + &ii,' one per line' + do jj=1,num_alpha(ii) + read(*,*) alpha(ii,jj) + end do + end do + end if + + num_occ=0 + do ii=0,max_l + num_occ=max(num_occ,occ_shells(ii)) + end do + + num_power=0 + do ii=0,max_l + num_power=max(num_power,poly_order(ii)) + end do + + num_alphas=0 + do ii=0,max_l + num_alphas=max(num_alphas,num_alpha(ii)) + end do + + write(*,'(A)') 'Print Eigenvectors ? .true./.false.' + read(*,*) eigprint + + write(*,'(A)') ' Use Broyden mixer ? .true./.false. and mixing parameter <1' + read(*,*) broyden,mixing_factor + + end subroutine read_input_1 + + subroutine read_input_2(occ,max_l,occ_shells, qnvalorbs) + + ! Read in occupation numbers. + + real(dp), intent(out) :: occ(:,0:,:) + integer, intent(in) :: max_l,occ_shells(0:) + integer, intent(out) :: qnvalorbs(:,0:) + integer :: ii,jj + + write(*,'(A)') 'Enter the occupation numbers for each angular momentum& + & and shell, up and down in one row' + + occ=0.0d0 + + write(*,'(A)') ' ' + write(*,'(A)') 'UP Electrons DOWN Electrons' + do ii=0,max_l + do jj=1,occ_shells(ii) + write(*,'(A,I3,A,I3)') 'l= ',ii,' and shell ',jj + read(*,*) occ(1,ii,jj),occ(2,ii,jj) + end do + end do + + write(*,"(A)") "Quantum numbers of wavefunctions to be written:" + do ii = 0, max_l + write(*, "(A,I0,A)") "l= ", ii, ": from to" + read(*,*) qnvalorbs(:, ii) + qnvalorbs(:,ii) = (/ minval(qnvalorbs(:,ii)), maxval(qnvalorbs(:,ii)) /) + qnvalorbs(:,ii) = qnvalorbs(:,ii) - ii + end do + + end subroutine read_input_2 + + subroutine echo_input(nuc,max_l,occ_shells,maxiter,poly_order,num_alpha,& + &alpha,conf_r0,conf_power,occ,num_occ,num_power,& + &num_alphas,xcnr,zora,num_mesh_points,xalpha_const) + + ! Echo completed input to stdout. + + integer :: ii,jj + integer, intent(in) :: nuc,max_l,maxiter,conf_power(0:),num_occ,num_power + integer, intent(in) :: num_alphas,xcnr,num_mesh_points + real(dp), intent(in) :: conf_r0(0:),occ(:,0:,:) + real(dp), intent(in) :: alpha(0:,:),xalpha_const + integer, intent(in) :: occ_shells(0:),num_alpha(0:),poly_order(0:) + logical, intent(in) :: zora + + write(*,'(A)') ' ' + write(*,'(A)') '--------------' + write(*,'(A)') 'INPUT SUMMARY ' + write(*,'(A)') '--------------' + + if (zora) write(*,'(A)') 'SCALAR RELATIVISTIC ZORA CALCULATION' + if (.not.zora) write(*,'(A)') 'NON-RELATIVISTIC CALCULATION' + write(*,'(A)') ' ' + write(*,'(A,I3)') 'Nuclear Charge: ',nuc + if (xcnr==0) write(*,'(A,I3)') 'HF Exchange, only correct for closed shell !' + if (xcnr==1) write(*,'(A,F12.8)') 'X-Alpha, alpha= ',xalpha_const + if (xcnr==2) write(*,'(A,I3)') 'LDA, Perdew-Wang Parametrization' + if (xcnr==3) write(*,'(A,I3)') 'PBE' + write(*,'(A,I1)') 'Max. angular momentum: ',max_l + write(*,'(A,I5)') 'Number of points for numerical radial integration: ',& + &num_mesh_points + + write(*,'(A)') ' ' + do ii=0,max_l + write(*,'(A,I1,A,I2)') 'Occupied Shells for l=',ii,': ',occ_shells(ii) + end do + + write(*,'(A)') ' ' + do ii=0,max_l + write(*,'(A,I1,A,I2)') 'Number of Polynomial Coeff. for l=',ii,': ',poly_order(ii) + end do + + write(*,'(A)') ' ' + do ii=0,max_l + write(*,'(A,I1)') 'Exponents for l=',ii + do jj=1,num_alpha(ii) + write(*,'(F12.8)') alpha(ii,jj) + end do + end do + + write(*,'(A)') ' ' + write(*,'(A)') 'Occupation Numbers UP/DWN' + do ii=0,max_l + do jj=1,occ_shells(ii) + write(*,'(A,I1,A,I2,A,2F12.8)') 'Angular Momentum ',ii,' Shell ',jj,& + &': ',occ(1,ii,jj),occ(2,ii,jj) + end do + end do + ! + ! write(*,'(A)') ' ' + ! write(*,'(A)') 'Occupation Numbers DWN' + ! do ii=0,max_l + ! do jj=1,occ_shells(ii) + ! write(*,'(A,I1,A,I2,A,F12.8)') 'Angular Momentum ',ii,' Shell ',jj,& + ! &': ',occ(2,ii,jj) + ! end do + ! end do + + write(*,'(A)') ' ' + ! write(*,'(A,F12.8,A,I1)') 'Confining Radius is ',conf_r0,' a.u. with power of ',conf_power + do ii=0,max_l + if (conf_power(ii)/=0) then + write(*,'(A,I3,A,E15.7,A,I3)') 'l= ',ii,', r0= ',conf_r0(ii),' power= ',& + conf_power(ii) + else + write(*,'(A,I3,A)') 'l= ',ii,' no confinement ' + end if + end do + + write(*,'(A)') ' ' + write(*,'(A,I2,A)') 'There are at maximum ',num_occ,' occ. shells for one l' + write(*,'(A,I2,A)') 'There are at maximum ',num_power,' coefficients for one& + & exponent' + write(*,'(A,I2,A)') 'There are at maximum ',num_alphas,' exponents' + + write(*,'(A)') ' ' + write(*,'(A)') '------------------' + write(*,'(A)') 'END INPUT SUMMARY ' + write(*,'(A)') '------------------' + write(*,'(A)') ' ' + + end subroutine echo_input + + subroutine gen_alphas(min_alpha,max_alpha,num_alpha,alpha) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! Generate alpha coefficients for Slater expansion + ! + ! min_alpha : smallest alpha + ! max_alpha : largest alpha + ! num_alpha : number of alphas + ! alpha : output, generated alphas + ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + implicit none + + integer :: ii + real(dp), intent(in) :: min_alpha,max_alpha + real(dp) :: alpha(10) + integer :: num_alpha + real(dp) :: beta(10),f + do ii=1,10 + alpha(ii)=0.0_dp + end do + alpha(1)=min_alpha + if (num_alpha==1) return + f=(max_alpha/alpha(1))**(1.0d0/FLOAT((num_alpha-1))) + do ii=1,(num_alpha-1) + alpha(1+ii)=alpha(ii)*f + end do + do ii=1,num_alpha + beta(num_alpha+1-ii)=alpha(ii) + end do + do ii=1,num_alpha + alpha(ii)=beta(ii) + end do + return + end subroutine gen_alphas + +end module input diff --git a/slateratom/lib/integration.f90 b/slateratom/lib/integration.f90 new file mode 100644 index 00000000..5f0b742c --- /dev/null +++ b/slateratom/lib/integration.f90 @@ -0,0 +1,247 @@ +module integration + use accuracy + use constants + use utilities + implicit none + private + + public :: gauss_chebyshev_becke_mesh + public :: get_abcissas, get_abcissas_z_1st, get_abcissas_z_2nd + public :: reverse_abcissas, reverse_abcissas_1st, reverse_abcissas_2nd + public :: exp_int + +contains + + subroutine gauss_chebyshev_becke_mesh(N,nuc,w,r, dzdr, d2zdr2, dz) + + ! Generate Beckes Gauss-Chebyschev mesh, e.g. radial points and weights. + + integer, intent(in) :: N ! number of mesh points + integer, intent(in) :: nuc ! nuclear charge + real(dp), intent(out) :: w(:) ! weight factors of mesh + real(dp), intent(out) :: r(:) ! radii of abcissas, Becke mapping ! + real(dp), intent(out) :: dzdr(:) ! dz/dr + real(dp), intent(out) :: d2zdr2(:) ! d^2 z / dr^2 + real(dp), intent(out) :: dz + + real(dp), allocatable :: fak(:) ! determinental factor of mapping + real(dp), allocatable :: x(:) + real(dp) :: temp + integer :: ii + real(dp) :: zz, cosz, cosz2, sinz + ! + allocate(x(N)) + allocate(fak(N)) + ! + temp=pi/float(N+1) + dz = temp + ! + do ii=1,N + zz = dz * real(ii, dp) + cosz = cos(zz) + cosz2 = cosz * cosz + sinz = sqrt(1.0_dp - cosz2) + ! NOTE prefactor + x(ii)=(-1.0_dp) * cosz ! gauss-chebyshev abcissas + r(ii)= (1.0_dp + x(ii)) / (1.0_dp - x(ii)) * bragg(nuc) + !dzdr(ii) = (1.0_dp + 2.0_dp * cos(zz) + cos(zz)**2) & + ! &/ (2.0_dp * bragg(nuc) * sin(zz)) + dzdr(ii) = (1.0_dp + cosz)**2 / (2.0_dp * bragg(nuc) * sinz) + d2zdr2(ii) = ((2.0_dp + cosz - cosz2) * (1.0_dp + cosz)**2) & + &/ (4.0_dp * bragg(nuc)**2 * (-1.0_dp + cosz) * sinz) + + ! r**2 times first derivative of x -> r mapping function + w(ii)=temp*(sin(float(ii)*temp)) + ! fak(ii)=2.0_dp*r(ii)**2*bragg(nuc)/(1.0_dp-x(ii))**2 + fak(ii)=2.0_dp*bragg(nuc)/(1.0_dp-x(ii))**2 + + ! put fak into weight + w(ii)=w(ii)*fak(ii) + end do + + deallocate(x) + deallocate(fak) + + end subroutine gauss_chebyshev_becke_mesh + + subroutine get_abcissas(N,nuc,r,step) + ! r(x)=bragg*(1-x)/(1+x) + ! x(z)=cos(pi*z) + ! r(x(z))=bragg*(1-cos(pi*z))/(1+cos(pi*z)), z=ii/(N+1) + + integer, intent(in) :: N ! number of mesh points + integer, intent(in) :: nuc ! nuclear charge + real(dp), intent(out) :: r(:) ! radii of abcissas, Becke mapping ! + integer, intent(out) :: step ! generator step size + real(dp), allocatable :: x(:) + integer :: ii + + allocate(x(N)) + + step=pi/float(N+1) + + do ii=1,N + + ! NOTE prefactor + x(ii)=(-1.0_dp)*cos(step*float(ii)) ! gauss-chebyshev abcissas + r(ii)=(1.0_dp+x(ii))/(1.0_dp-x(ii))*bragg(nuc) + + end do + + deallocate(x) + + end subroutine get_abcissas + + subroutine get_abcissas_z_1st(N,nuc,dr,step) + ! 1st derivative of r(x(z)) with respect to z, see + ! grid_differentiation_sign_2.txt + + integer, intent(in) :: N ! number of mesh points + integer, intent(in) :: nuc ! nuclear charge + real(dp), intent(out) :: dr(:) ! 1st dderiv. of abcissas, Becke mapping ! + integer, intent(out) :: step ! generator step size + integer :: ii + + step=pi/float(N+1) + + do ii=1,N + + dr(ii)=2.0d0*bragg(nuc)*pi*sin(step*float(ii))/& + &(1.0d0+2.0d0*cos(step*float(ii))+cos(step*float(ii))**2) + + end do + + end subroutine get_abcissas_z_1st + + subroutine get_abcissas_z_2nd(N,nuc,ddr,step) + ! 2nd derivative of r(x) with respect to x, see + ! grid_differentiation_sign_2.txt + + integer, intent(in) :: N ! number of mesh points + integer, intent(in) :: nuc ! nuclear charge + real(dp), intent(out) :: ddr(:) ! 2nd deriv. of abcissas, Becke mapping ! + integer, intent(out) :: step ! generator step size + integer :: ii + + step=pi/float(N+1) + + do ii=1,N + + ddr(ii)=(-2.0d0*bragg(nuc)*pi**2)*(cos(step*float(ii))-2.0d0)/& + &(1.0d0+2.0d0*cos(step*float(ii))+cos(step*float(ii))**2) + + end do + + end subroutine get_abcissas_z_2nd + + function reverse_abcissas(nuc,r) + ! z(x(r)) reverse mapping function, see + ! grid_differentiation_sign_2.txt + ! + ! z=1/pi*arccos((a-r)/(a+r)) + + integer, intent(in) :: nuc ! nuclear charge + real(dp), intent(in) :: r ! radii of abcissas, Becke mapping ! + real(dp) :: reverse_abcissas + + reverse_abcissas=1.0d0/pi*acos((bragg(nuc)-r)/(bragg(nuc)+r)) + + end function reverse_abcissas + + function reverse_abcissas_1st(nuc,r) + ! 1st derivative of z(x(r)) reverse mapping function with resp. to r, see + ! grid_differentiation_sign_2.txt + ! + ! be careful: can easily overflow + + integer, intent(in) :: nuc ! nuclear charge + real(dp), intent(in) :: r ! radii of abcissas, Becke mapping ! + real(dp) :: reverse_abcissas_1st + + reverse_abcissas_1st=1.0d0/pi*sqrt(bragg(nuc)/r)/(r+bragg(nuc)) + + end function reverse_abcissas_1st + + function reverse_abcissas_2nd(nuc,r) + ! 2nd derivative of z(x(r)) reverse mapping function with resp. to r, see + ! grid_differentiation_sign_2.txt + ! + ! be careful: can easily overflow + + integer, intent(in) :: nuc ! nuclear charge + real(dp), intent(in) :: r ! radii of abcissas, Becke mapping ! + real(dp) :: reverse_abcissas_2nd + + reverse_abcissas_2nd=-1.0d0/(2.0d0*pi)*sqrt(bragg(nuc)/r)/r*& + &(bragg(nuc)+3.0d0*r)/(bragg(nuc)+r)**2 + + end function reverse_abcissas_2nd + + FUNCTION bragg(nuc) + + INTEGER :: nuc + REAL(dp) :: bragg,braggd(110) + DATA braggd/& + &1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,& + &1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,& + &1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,& + &1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,& + &1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,& + &1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,& + &1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,& + &1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,& + &1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,& + &1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,& + &1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,& + &1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,1.0_dp,& + &1.0_dp,1.0_dp/ + bragg=braggd(nuc) + RETURN + END FUNCTION bragg + + function exp_int(alpha,power,r) + ! evaluate \int x**power*exp(alpha*x) dx at point r + ! for formula see Bronstein + ! assumes alpha<0 and power=>0 ! + ! WATCH OUT FOR SIGN OF alpha ! + + real(dp), intent(in) :: alpha,r + integer, intent(in) :: power + real(dp) :: exp_int + integer :: ii + + exp_int=0.0d0 + + ! catch power<0 + if (power<0) then + write(*,*) 'NEGATIVE POWERS NOT IMPLEMENTED !' + STOP + end if + + ! catch alpha>0 + if (alpha>0.0d0) then + write(*,*) 'POSITIVE ALPHAS NOT IMPLEMENTED !' + STOP + end if + + ! catch r=0 + if (r==0.0d0) then + exp_int=fak(power)/(alpha**(power+1))*(-1.0d0)**(power) + return + end if + + ! catch r=infty and alpha<0 (should always be !) + if (abs(alpha*r)>75.0d0) then + exp_int=0.0d0 + return + end if + + exp_int=1.0d0/alpha*exp(alpha*r) + + do ii=1,power + exp_int=1.0d0/alpha*r**ii*exp(alpha*r)-float(ii)/alpha*exp_int + end do + + end function exp_int + +end module integration diff --git a/slateratom/lib/numerical_differentiation.f90 b/slateratom/lib/numerical_differentiation.f90 new file mode 100644 index 00000000..6fb63722 --- /dev/null +++ b/slateratom/lib/numerical_differentiation.f90 @@ -0,0 +1,162 @@ +module numerical_differentiation + use accuracy + use constants + use utilities + use integration + implicit none + private + + public :: numerical_1st_derivative, six_point + + +contains + + subroutine numerical_1st_derivative(num_mesh_points,abcissa,nuc,step,& + &input,output) + + integer, intent(in) :: num_mesh_points,nuc + real(dp), intent(in) :: input(:),step,abcissa(:) + real(dp), intent(out) :: output(:) + real(dp) :: stencil(6) + integer :: ii + + output=0.0d0 + stencil=0.0d0 + + ! handle lower mesh bound + + do ii=1,6 + stencil(ii)=input(ii) + end do + + output(1)=six_point(stencil,1,0,step) + output(2)=six_point(stencil,1,1,step) + + ! handle upper mesh bound + + do ii=1,6 + stencil(ii)=input(num_mesh_points-6+ii) + end do + + output(num_mesh_points-2)=six_point(stencil,1,3,step) + output(num_mesh_points-1)=six_point(stencil,1,4,step) + output(num_mesh_points)=six_point(stencil,1,5,step) + + ! handle rest of mesh + + do ii=3,num_mesh_points-3 + + stencil(1)=input(ii-2) + stencil(2)=input(ii-1) + stencil(3)=input(ii) + stencil(4)=input(ii+1) + stencil(5)=input(ii+2) + stencil(6)=input(ii+3) + + output(ii)=six_point(stencil,1,2,step) + + end do + + ! now remember: df(x)/dx=df(z)/dz*dz/dx, e.g. x is the abcissa which is + ! not equally spaced and z is the generating variable of the Becke mesh + ! which is equally spaced; so multiply by dz/dx + + do ii=1,num_mesh_points + + output(ii)=output(ii)*reverse_abcissas_1st(nuc,abcissa(ii)) + + end do + + end subroutine numerical_1st_derivative + + function six_point(points,k,offset,h) + !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + ! + ! Numerical k-th derivative of tabulated function from six point + ! formula; Bickley, Math. Gaz. vol. 25 (1941) 19-27 + ! Abramowitz, Stegun, Handbook of Mathematical functions + ! The function is assumed to be tabulated on equally spaced abcissas + ! + ! INPUT: points contains the six function values + ! k order of derivative, 0, , <1>, , + call moments(moment(:,:,1,:),max_l,num_alpha,alpha,poly_order,problemsize,& + &cof,-3) + call moments(moment(:,:,2,:),max_l,num_alpha,alpha,poly_order,problemsize,& + &cof,-1) + ! call moments(moment(:,:,3,:),max_l,num_alpha,alpha,poly_order,problemsize,& + ! &cof,0) + call moments(moment(:,:,4,:),max_l,num_alpha,alpha,poly_order,problemsize,& + &cof,1) + call moments(moment(:,:,5,:),max_l,num_alpha,alpha,poly_order,problemsize,& + &cof,2) + + write(*,'(A)') 'WAVEFUNCTION EXPECTATION VALUES' + write(*,'(A)') '-------------------------------' + write(*,'(A)') ' ' + + write(*,*) 'UP Electrons' + write(*,'(A)') ' ' + do ii=1,5 + if (ii/=3) then + write(*,'(A,I2,A)') ', ' + do jj=0,max_l + write(*,'(A,I3)') 'l= ',jj + do kk=1,num_alpha(jj)*poly_order(jj) + write(*,'(F12.4)') moment(1,jj,ii,kk) + end do + write(*,'(A)') ' ' + write(*,'(A)') ' ' + end do + write(*,'(A)') ' ' + end if + end do + + write(*,'(A)') ' ' + write(*,'(A)') ' ' + + write(*,*) 'DOWN Electrons' + write(*,'(A)') ' ' + do ii=1,5 + if (ii/=3) then + write(*,'(A,I2,A)') ', ' + do jj=0,max_l + write(*,'(A,I3)') 'l= ',jj + do kk=1,num_alpha(jj)*poly_order(jj) + write(*,'(F12.4)') moment(2,jj,ii,kk) + end do + write(*,'(A)') ' ' + write(*,'(A)') ' ' + end do + write(*,'(A)') ' ' + end if + end do + + deallocate(moment) + + end subroutine write_moments + + subroutine write_potentials_file_standard(num_mesh_points,abcissa,weight,& + &vxc,rho,nuc,p,max_l,num_alpha,poly_order,alpha,problemsize) + ! write potentials and mesh info to file on standard (internal) integration mesh + ! in principle one could read in the points from another file to have + ! other meshes ! + + + real(dp), intent(in) :: abcissa(:),weight(:),vxc(:,:),p(:,0:,:,:),alpha(0:,:) + real(dp), intent(in) :: rho(:,:) + integer, intent(in) :: num_mesh_points,nuc,max_l,num_alpha(0:) + integer, intent(in) :: poly_order(0:),problemsize + real(dp), allocatable :: cpot(:),ptot(:,:,:),rhotot(:) + real(dp) :: ecou,enuc,vxcint(2) + integer :: ii + + allocate(cpot(num_mesh_points)) + allocate(ptot(0:max_l,problemsize,problemsize)) + allocate(rhotot(num_mesh_points)) + + cpot=0.0d0 + ptot=0.0d0 + rhotot=0.0d0 + ecou=0.0d0 + enuc=0.0d0 + vxcint=0.0d0 + + ptot(:,:,:)=p(1,:,:,:)+p(2,:,:,:) + rhotot(:)=rho(:,1)+rho(:,2) + + call cou_pot(ptot(:,:,:),max_l,num_alpha,poly_order,alpha,problemsize,& + &num_mesh_points,abcissa,cpot) + + open(95,FILE='pot.dat',FORM='formatted',STATUS='unknown') + write(95,'(A)') '# 1st line: number of mesh points' + write(95,'(A)') '# abcissa weight nuclear coulomb dft-vxc_up dft-vxc_down' + write(95,'(I0)') num_mesh_points + + do ii=1,num_mesh_points + write(95,'(6ES21.12E3)') abcissa(ii), weight(ii), & + &float(-nuc) / abcissa(ii), cpot(ii), vxc(ii,1), vxc(ii,2) + end do + close(95) + + do ii=1,num_mesh_points + ecou=ecou+weight(ii)*rhotot(ii)*cpot(ii)*abcissa(ii)**2 + enuc=enuc-weight(ii)*rhotot(ii)*float(nuc)*abcissa(ii) + vxcint(1)=vxcint(1)+weight(ii)*rho(ii,1)*vxc(ii,1)*abcissa(ii)**2 + vxcint(2)=vxcint(2)+weight(ii)*rho(ii,2)*vxc(ii,2)*abcissa(ii)**2 + end do + + write(*,'(A,F18.6)') 'Nuc. attr. energy from potential in pot.dat: ',& + &enuc + write(*,'(A,F18.6)') 'Coulomb energy from potential in pot.dat: ',& + &0.5d0*ecou + write(*,'(A,2F18.6)') 'V_xc integrals from pot.dat, Up/Dwn: ',& + &vxcint(1),vxcint(2) + + deallocate(cpot) + deallocate(ptot) + deallocate(rhotot) + + end subroutine write_potentials_file_standard + + + subroutine write_densities_file_standard(num_mesh_points,abcissa,weight,& + &rho,drho,ddrho) + ! write potentials and mesh info to file on standard (internal) integration mesh + ! in principle one could read in the points from another file to have + ! other meshes ! + + + real(dp), intent(in) :: abcissa(:),weight(:) + real(dp), intent(in) :: rho(:,:),drho(:,:),ddrho(:,:) + integer, intent(in) :: num_mesh_points + real(dp) :: enumber,zeta,r_seitz + integer :: ii + + open(95,FILE='dens.dat',FORM='formatted',STATUS='unknown') + write(95,'(A)') '# 1st line: number of mesh points' + write(95,'(A)') '# rho and r_seitz are calculated from total density' + write(95,'(A)') '# zeta and r_seitz only correct of rho > 1d-12' + write(95,'(A)') '' + write(95,'(A)') '# abcissa weight rho drho ddrho zeta r_seitz' + write(95,'(I0)') num_mesh_points + + enumber=0.0d0 + + ! note division of total density by 4*pi in calculation of r_seitz + ! commonly r_seitz=((4*pi*rho)/3)**(-1/3) but our rho is from the + ! radial part only and the angular part must be taken into account + ! explicitely; during integration this happens implicitely, see enumber + + do ii=1,num_mesh_points + + if ((rho(ii,1)+rho(ii,2))>1.0d-12) then + zeta=(rho(ii,1)-rho(ii,2))/(rho(ii,1)+rho(ii,2)) + r_seitz=(4.0d0*pi/3.0d0*((rho(ii,1)+rho(ii,2))/4.0d0/pi))**(-1.0d0/3.0d0) + else + zeta=0.0d0 + r_seitz=0.0d0 + end if + + write(95,'(7ES21.12E3)') abcissa(ii), weight(ii), rho(ii,1)+rho(ii,2), & + &drho(ii,1)+drho(ii,2), ddrho(ii,1)+ddrho(ii,2), zeta, r_seitz + enumber=enumber+weight(ii) * (rho(ii,1)+rho(ii,2)) * abcissa(ii)**2 + end do + + close(95) + + write(*,'(A,F18.6)') 'Total number of electrons from dens.dat : ',enumber + + end subroutine write_densities_file_standard + + + + subroutine write_waves_file_standard(num_mesh_points,abcissa,weight,& + &alpha,num_alpha,poly_order,max_l,problemsize,occ, qnvalorbs, cof) + ! write potentials and mesh info to file on standard (internal) integration mesh + ! in principle one could read in the points from another file to have + ! other meshes ! + + + real(dp), intent(in) :: abcissa(:),weight(:), alpha(0:,:) + real(dp), intent(in) :: occ(:,0:,:) + integer, intent(in) :: num_mesh_points,num_alpha(0:),poly_order(0:),max_l + integer, intent(in) :: problemsize + integer, intent(in) :: qnvalorbs(:,0:) + real(dp), intent(inout) :: cof(:,0:,:,:) + + real(dp), allocatable :: coftot(:) + real(dp) :: xx, val + integer :: ii,jj,kk,ll,mm, ispin, imax + character(20) :: fname + real(dp), allocatable :: wavedata(:) + + allocate(wavedata(num_mesh_points)) + allocate(coftot(problemsize)) + + do jj = 0, max_l + mm = 0 + do kk = 1, num_alpha(jj) + do ll = 1, poly_order(jj) + mm = mm + 1 + if (mm < qnvalorbs(1, jj) .or. mm > qnvalorbs(2, jj)) then + cycle + end if + do ispin = 1, 2 + if (ispin == 1) then + write(fname, "(A,I2.2,A,A)") "wave_", mm + jj, orbnames(jj), & + & "_up.dat" + else + write(fname, "(A,I2.2,A,A)") "wave_", mm + jj, orbnames(jj), & + & "_dn.dat" + end if + open(95, file=fname, form='formatted', status='unknown') + write(95,'(A)') '# 1st line: number of mesh points' + write(95,'(A)') '# abcissa weight wavefunction wavefunction_1st& + & wavefunction_2nd' + write(95,'(I0)') num_mesh_points + write(95,'(A,I3,A,I3,A,F8.4)') '# Principal QN= ', mm, ' , l= ', & + &jj,' , Occupation= ', occ(1,jj,mm) + occ(2,jj,mm) + + coftot(:) = cof(ispin,jj,:,mm) + + do ii = 1, num_mesh_points + xx = abcissa(ii) + wavedata(ii) = wavefunction(coftot, alpha, num_alpha, & + & poly_order, jj, xx) + end do + imax = maxloc(abs(abcissa * wavedata), dim=1) + if (wavedata(imax) < 0.0_dp) then + coftot = -coftot + cof(1,jj,:,mm) = coftot + write(*, "(A,I3,A,I3)") "Changing wavefunction sign: n =", & + & mm + jj, ", l =", jj + end if + + do ii = 1, num_mesh_points + xx = abcissa(ii) + write(95,'(5ES21.12E3)') xx, weight(ii), & + & wavefunction( & + & coftot, alpha, num_alpha, poly_order, jj, xx), & + & wavefunction_1st( & + & coftot, alpha, num_alpha, poly_order, jj, xx), & + & wavefunction_2nd( & + & coftot, alpha, num_alpha, poly_order, jj, xx) + end do + close(95) + end do + end do + end do + end do + + deallocate(coftot) + deallocate(wavedata) + + end subroutine write_waves_file_standard + + + + subroutine cusp_values(max_l,occ,cof,p,alpha,num_alpha,poly_order,nuc) + + + integer, intent(in) :: max_l,num_alpha(0:),poly_order(0:),nuc + real(dp), intent(in) :: cof(:,0:,:,:),alpha(0:,:),occ(:,0:,:),p(:,0:,:,:) + integer :: ii + + write(*,'(A)') 'Cusp Values ' + write(*,'(A)') '------------' + + ii=0 + + write(*,'(A,F14.6)') '1s, UP ',& + &-wavefunction_1st(cof(1,ii,:,1),alpha,num_alpha,poly_order,ii,0.0d0)/& + &wavefunction(cof(1,ii,:,1),alpha,num_alpha,poly_order,ii,0.0d0) + write(*,'(A,F14.6)') '1s, DWN ',& + &-wavefunction_1st(cof(2,ii,:,1),alpha,num_alpha,poly_order,ii,0.0d0)/& + &wavefunction(cof(2,ii,:,1),alpha,num_alpha,poly_order,ii,0.0d0) + + write(*,'(A,F14.6)') 'Total density UP ',& + &-density_at_point_1st(p(1,:,:,:),max_l,num_alpha,poly_order,alpha,0.0d0)& + &/density_at_point(p(1,:,:,:),max_l,num_alpha,poly_order,alpha,0.0d0)/2.0d0 + write(*,'(A,F14.6)') 'Total density DWN ',& + &-density_at_point_1st(p(2,:,:,:),max_l,num_alpha,poly_order,alpha,0.0d0)& + &/density_at_point(p(2,:,:,:),max_l,num_alpha,poly_order,alpha,0.0d0)/2.0d0 + + write(*,'(A)') ' ' + + end subroutine cusp_values + + + + subroutine write_energies_tagged(ekin, enuc, ecoul, exc, econf, etot, zora,& + & eigvals, occ) + real(dp), intent(in) :: ekin, enuc, ecoul, exc, etot, econf + logical, intent(in) :: zora + real(dp), intent(in) :: eigvals(:,0:,:), occ(:,0:,:) + + integer :: fp + type(TaggedWriter) :: twriter + + call init(twriter) + fp = 95 + open(fp, file="energies.tag", status="replace", action="write") + call writetag(twriter, fp, "zora", zora) + call writetag(twriter, fp, "kinetic_energy", ekin) + call writetag(twriter, fp, "nuclear_energy", enuc) + call writetag(twriter, fp, "coulomb_energy", 0.5d0*ecoul) + call writetag(twriter, fp, "xc_energy", exc) + call writetag(twriter, fp, "confinement_energy", econf) + call writetag(twriter, fp, "total_energy", etot) + !! Transposing eigenvalues to appear in a more convinient order + call writetag(twriter, fp, "eigenlevels_up", transpose(eigvals(1,:,:))) + call writetag(twriter, fp, "eigenlevels_dn", transpose(eigvals(2,:,:))) + call writetag(twriter, fp, "occupations_up", transpose(occ(1,:,:))) + call writetag(twriter, fp, "occupations_dn", transpose(occ(2,:,:))) + close(fp) + + end subroutine write_energies_tagged + + + subroutine write_wave_coeffs_file(max_l, num_alpha, poly_order, cof, & + &alpha, occ, qnvalorbs) + integer, intent(in) :: max_l + integer, intent(in) :: num_alpha(0:), poly_order(0:) + real(dp), intent(in) :: cof(:,0:,:,:), alpha(0:,:), occ(:,0:,:) + integer, intent(in) :: qnvalorbs(:,0:) + + integer :: fp, ii, ll, ncoeff + type(TaggedWriter) :: twriter + character(20) :: fname + real(dp), allocatable :: coeffs(:,:) + + call init(twriter) + fp = 95 + do ll = 0, max_l + ncoeff = poly_order(ll) * num_alpha(ll) + allocate(coeffs(poly_order(ll), num_alpha(ll))) + do ii = 1, num_alpha(ll) * poly_order(ll) + if (ii < qnvalorbs(1, ll) .or. ii > qnvalorbs(2, ll)) then + cycle + end if + write(fname, "(A,I2.2,A,A)") "coeffs_", ii + ll, orbnames(ll), ".tag" + open(fp, file=fname, status="replace", action="write") + call writetag(twriter, fp, "exponents", alpha(ll,:num_alpha(ll))) + call convcoeffs(cof(1,ll,:,ii), alpha(ll,:num_alpha(ll)), ll, coeffs) + call writetag(twriter, fp, "coefficients", coeffs) + call writetag(twriter, fp, "occupation", sum(occ(:, ll, ii))) + close(fp) + end do + deallocate(coeffs) + end do + + contains + + subroutine convcoeffs(cof, alpha, angmom, normcoeffs) + real(dp), intent(in) :: cof(:), alpha(:) + integer, intent(in) :: angmom + real(dp), intent(out) :: normcoeffs(:,:) + + integer :: npow, nalpha, ialpha, ipow + real(dp) :: aa, normfac + + npow = size(normcoeffs, dim=1) + nalpha = size(normcoeffs, dim=2) + normcoeffs = reshape(cof, [ npow, nalpha ]) + do ialpha = 1, nalpha + aa = alpha(ialpha) + do ipow = 1, npow + normfac = (2.0_dp * aa)**(ipow + angmom) * sqrt(2.0_dp * aa) & + &/ sqrt(fak(2 * (ipow + angmom))) + normcoeffs(ipow, ialpha) = normfac * normcoeffs(ipow, ialpha) + end do + end do + + end subroutine convcoeffs + + + end subroutine write_wave_coeffs_file + + +end module output diff --git a/slateratom/lib/total_energy.f90 b/slateratom/lib/total_energy.f90 new file mode 100644 index 00000000..ee4e0b43 --- /dev/null +++ b/slateratom/lib/total_energy.f90 @@ -0,0 +1,240 @@ +module totalenergy + use accuracy + use constants + use dft + implicit none + private + + public :: total_energy, zora_total_energy + +contains + + subroutine total_energy(t,u,nuc,vconf,j,k,p,max_l,num_alpha,poly_order,& + &problemsize,xcnr,num_mesh_points,weight,abcissa,rho,exc,& + &kinetic,nuclear,coulomb,exchange,confinement,etot) + + ! Calculate total energy for non-ZORA calculations + + real(dp), intent(in) :: t(0:,:,:),u(0:,:,:),j(0:,:,:,0:,:,:),k(0:,:,:,0:,:,:) + real(dp), intent(in) :: vconf(0:,:,:),abcissa(:) + real(dp), intent(in) :: p(:,0:,:,:),weight(:),rho(:,:),exc(:) + integer, intent(in) :: max_l,num_alpha(0:),poly_order(0:),problemsize,nuc,xcnr + integer, intent(in) :: num_mesh_points + real(dp), intent(out) :: etot,kinetic,nuclear,coulomb,exchange,confinement + real(dp) :: dummy1,dummy2,dummy3 + integer :: ii,jj,kk,ll,mm,nn,oo,pp,qq,rr,ss,tt,uu,vv,ww + real(dp), allocatable :: p_total(:,:,:) + + allocate(p_total(0:max_l,problemsize,problemsize)) + p_total=0.0d0 + + etot=0.0d0 + kinetic=0.0d0 + nuclear=0.0d0 + confinement=0.0d0 + coulomb=0.0d0 + exchange=0.0d0 + dummy1=0.0d0 + dummy2=0.0d0 + + ! Build total density matrix + do ii=0,max_l + do jj=1,problemsize + do kk=1,problemsize + p_total(ii,jj,kk)=p(1,ii,jj,kk)+p(2,ii,jj,kk) + end do + end do + end do + + ! get total energy + + call core_hamiltonian_energies(t,u,vconf,p_total,max_l,num_alpha,& + &poly_order,nuc,kinetic,nuclear,confinement) + + dummy1=nuclear+kinetic+confinement + + call coulomb_hf_ex_energy(j,k,p_total,max_l,num_alpha,poly_order,xcnr,& + &coulomb,exchange) + + if (xcnr>0) then + + exchange=0.0d0 + call dft_exc_energy(num_mesh_points,rho,exc,weight,abcissa,& + &xcnr,exchange) + + end if + + ! make sure total energy breakdown agrees with total energy + + if (xcnr==0) then + etot=dummy1+0.5d0*coulomb+0.5d0*exchange + else + etot=dummy1+0.5d0*coulomb+exchange + end if + + ! write(*,*) 'TOTAL ENERGY',hf_total_energy + + end subroutine total_energy + + subroutine zora_total_energy(t,u,nuc,vconf,j,k,p,max_l,num_alpha,poly_order,& + &problemsize,xcnr,num_mesh_points,weight,abcissa,rho,exc,vxc,& + &eigval_scaled,occ,kinetic,nuclear,coulomb,exchange,confinement,etot) + + ! Calculate total energy for ZORA, note that total energy is not well defined + ! here ... + + real(dp), intent(in) :: t(0:,:,:),u(0:,:,:),j(0:,:,:,0:,:,:),k(0:,:,:,0:,:,:) + real(dp), intent(in) :: vconf(0:,:,:),abcissa(:),eigval_scaled(:,0:,:) + real(dp), intent(in) :: occ(:,0:,:) + real(dp), intent(in) :: p(:,0:,:,:),weight(:),rho(:,:),exc(:),vxc(:,:) + integer, intent(in) :: max_l,num_alpha(0:),poly_order(0:),problemsize,nuc,xcnr + integer, intent(in) :: num_mesh_points + real(dp), intent(out) :: etot,kinetic,nuclear,coulomb,exchange,confinement + real(dp) :: dummy1,dummy2,dummy3(2),eigsum + integer :: ii,jj,kk,ll,mm,nn,oo,pp,qq,rr,ss,tt,uu,vv,ww + real(dp), allocatable :: p_total(:,:,:) + + allocate(p_total(0:max_l,problemsize,problemsize)) + p_total=0.0d0 + + etot=0.0d0 + kinetic=0.0d0 + nuclear=0.0d0 + confinement=0.0d0 + coulomb=0.0d0 + exchange=0.0d0 + dummy1=0.0d0 + dummy2=0.0d0 + eigsum=0.0d0 + + ! Build total density matrix + do ii=0,max_l + do jj=1,problemsize + do kk=1,problemsize + p_total(ii,jj,kk)=p(1,ii,jj,kk)+p(2,ii,jj,kk) + end do + end do + end do + + ! get total energy + + call core_hamiltonian_energies(t,u,vconf,p_total,max_l,num_alpha,& + &poly_order,nuc,kinetic,nuclear,confinement) + + ! sum of occupied eigenvalues + do ii=1,2 + do jj=0,max_l + do kk=1,problemsize + eigsum=eigsum+eigval_scaled(ii,jj,kk)*occ(ii,jj,kk) + end do + end do + end do + + kinetic=eigsum + + call coulomb_hf_ex_energy(j,k,p_total,max_l,num_alpha,poly_order,xcnr,& + &coulomb,exchange) + + exchange=0.0d0 + call dft_exc_energy(num_mesh_points,rho,exc,weight,abcissa,& + &xcnr,exchange) + + call dft_vxc_energy(num_mesh_points,rho,vxc,weight,abcissa,& + &xcnr,dummy3) + + dummy2=dummy3(1)+dummy3(2) + + etot=eigsum-0.5d0*coulomb+exchange-dummy2 + + ! write(*,*) 'ZORA TOTAL ENERGY' + + end subroutine zora_total_energy + + subroutine coulomb_hf_ex_energy(j,k,p_total,max_l,num_alpha,poly_order,xcnr,& + &coulomb,exchange) + + ! get Hartee-Fock exchange and Coulomb contributions to total energy + ! by multiplying j and k supermatrixes with the density matrix supervector + ! twice + + real(dp), intent(in) :: j(0:,:,:,0:,:,:),k(0:,:,:,0:,:,:) + real(dp), intent(in) :: p_total(0:,:,:) + integer, intent(in) :: max_l,num_alpha(0:),poly_order(0:),xcnr + real(dp), intent(out) :: coulomb,exchange + integer :: ii,jj,kk,ll,mm,nn,oo,pp,qq,rr,ss,tt,uu,vv,ww + + + do ii=0,max_l + ss=0 + do jj=1,num_alpha(ii) + do kk=1,poly_order(ii) + ss=ss+1 + tt=0 + do ll=1,num_alpha(ii) + do mm=1,poly_order(ii) + tt=tt+1 + do nn=0,max_l + uu=0 + do oo=1,num_alpha(nn) + do pp=1,poly_order(nn) + uu=uu+1 + vv=0 + do qq=1,num_alpha(nn) + do rr=1,poly_order(nn) + vv=vv+1 + + coulomb=coulomb+p_total(ii,ss,tt)*j(ii,ss,tt,nn,uu,vv)*& + &p_total(nn,uu,vv) + + if (xcnr==0) then + exchange=exchange-0.5d0*p_total(ii,ss,tt)*& + &k(ii,ss,tt,nn,uu,vv)*p_total(nn,uu,vv) + end if + + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + + end subroutine coulomb_hf_ex_energy + + subroutine core_hamiltonian_energies(t,u,vconf,p_total,max_l,num_alpha,& + &poly_order,nuc,kinetic,nuclear,confinement) + + ! Core Hamiltonian contributions to total energy by multiplying the + ! t,u,vconf supervectors with the density matrix supervector once + + real(dp), intent(in) :: t(0:,:,:),u(0:,:,:) + real(dp), intent(in) :: vconf(0:,:,:) + real(dp), intent(in) :: p_total(0:,:,:) + integer, intent(in) :: max_l,num_alpha(0:),poly_order(0:),nuc + real(dp), intent(out) :: kinetic,nuclear,confinement + integer :: ii,jj,kk,ll,mm,nn,oo,pp,qq,rr,ss,tt,uu,vv,ww + + do ii=0,max_l + ss=0 + do jj=1,num_alpha(ii) + do kk=1,poly_order(ii) + ss=ss+1 + tt=0 + do ll=1,num_alpha(ii) + do mm=1,poly_order(ii) + tt=tt+1 + kinetic=kinetic+t(ii,ss,tt)*p_total(ii,ss,tt) + nuclear=nuclear-float(nuc)*u(ii,ss,tt)*p_total(ii,ss,tt) + confinement=confinement+vconf(ii,ss,tt)*p_total(ii,ss,tt) + end do + end do + end do + end do + end do + + end subroutine core_hamiltonian_energies + +end module totalenergy diff --git a/slateratom/lib/utilities.f90 b/slateratom/lib/utilities.f90 new file mode 100644 index 00000000..d16d066f --- /dev/null +++ b/slateratom/lib/utilities.f90 @@ -0,0 +1,155 @@ +module utilities + use accuracy + use constants + implicit none + private + + public :: check_convergence, check_electron_number, vector_length + public :: fak, polcart, cartpol, dscalar + +contains + + subroutine check_convergence(pot_old,pot_new,max_l,problemsize,iter,& + &change_max,final) + + ! check SCF convergence + + real(dp), intent(out) :: change_max + real(dp), intent(in) :: pot_old(:,0:,:,:),pot_new(:,0:,:,:) + integer, intent(in) :: max_l,problemsize,iter + logical, intent(out) :: final + integer ii,jj,kk,ll + + change_max=0.0d0 + if (iter<3) then + final=.false. + end if + + do ii=1,2 + do jj=0,max_l + do kk=1,problemsize + do ll=1,problemsize + change_max=max(change_max,& + &abs(pot_old(ii,jj,kk,ll)-pot_new(ii,jj,kk,ll))) + end do + end do + end do + end do + + if (change_max<1.0d-8) then + final=.true. + end if + + end subroutine check_convergence + + subroutine check_electron_number(cof,s,occ,max_l,num_alpha,poly_order,& + &problemsize) + + ! check conservation of electron number during SCF + ! if this fluctuates you are in deep trouble + + real(dp) :: cof(:,0:,:,:) + real(dp), intent(in) :: s(0:,:,:),occ(:,0:,:) + integer, intent(in) :: max_l,num_alpha(0:),poly_order(0:),problemsize + integer :: ii,jj,kk,ll,mm,nn,oo,pp,qq + real(dp) :: electron_number + real(dp) :: scaling + + ! get actual number per shell by multiplying dens matrix and overlap + do mm=1,2 + do ii=0,max_l + do qq=1,problemsize + electron_number=0.0d0 + ll=0 + do jj=1,num_alpha(ii) + do kk=1,poly_order(ii) + ll=ll+1 + pp=0 + do nn=1,num_alpha(ii) + do oo=1,poly_order(ii) + pp=pp+1 + + electron_number=electron_number+& + &occ(mm,ii,qq)*cof(mm,ii,ll,qq)*cof(mm,ii,pp,qq)*s(ii,ll,pp) + + end do + end do + end do + end do + + if (abs(occ(mm,ii,qq)-electron_number)>1.0d-8) then + write(*,*) 'Electron number fluctuation',& + &occ(mm,ii,qq)-electron_number + end if + + end do + end do + end do + + end subroutine check_electron_number + + function vector_length(vector,size) + + real(dp) :: vector_length + real(dp), intent(in) :: vector(:) + integer, intent(in) :: size + integer :: ii + + vector_length=0.0d0 + + do ii=1,size + vector_length=vector_length+vector(ii)*vector(ii) + end do + + vector_length=sqrt(vector_length) + + end function vector_length + + FUNCTION fak(n) + REAL(dp) :: fak + INTEGER :: n + INTEGER :: h + fak = 1.0_dp + DO h = 1,n + fak = fak*dble(h) + END DO + RETURN + END function fak + ! + SUBROUTINE polcart(r,zeta,phi,vec) + ! zeta=cos(theta) + REAL(dp) :: vec(3),r,zeta,phi,s_teta + s_teta=SQRT(1.0_dp-zeta*zeta) + vec(3)=r*zeta + vec(2)=r*s_teta*SIN(phi) + vec(1)=r*s_teta*COS(phi) + RETURN + END subroutine polcart + ! + SUBROUTINE cartpol(vec1,vec2,vec3,r,zeta,phi) + REAL(dp) :: eps, tol + PARAMETER ( eps=1.d-8 ) + PARAMETER ( tol=1.d-8 ) + REAL(dp) :: vec(3), r, zeta, phi,vec1,vec2,vec3 + !c external dscalar + vec(1)=vec1 + vec(2)=vec2 + vec(3)=vec3 + r = SQRT(dscalar(vec,vec)) + IF(((ABS(vec(1)).LT.eps).AND.(ABS(vec(2)).LT.eps))) & + & phi = 0.0_dp + IF(.NOT.((ABS(vec(1)).LT.eps).AND.(ABS(vec(2)).LT.eps))) & + & phi = ATAN2(vec(2),vec(1)) + IF((ABS(r).LT.eps)) zeta = 0.0_dp + IF(.NOT.(ABS(r).LT.eps)) zeta = vec(3)/r + RETURN + END subroutine cartpol + ! + FUNCTION dscalar(r1,r2) + REAL(dp) :: r1(3), r2(3), dscalar + dscalar = r1(1)*r2(1)+r1(2)*r2(2)+r1(3)*r2(3) + RETURN + END function dscalar + +end module utilities + diff --git a/slateratom/lib/zora_routines.f90 b/slateratom/lib/zora_routines.f90 new file mode 100644 index 00000000..b6f26f74 --- /dev/null +++ b/slateratom/lib/zora_routines.f90 @@ -0,0 +1,337 @@ +module zora_routines + use accuracy + use constants + use coulomb_potential +! use numerical_differentiation + use density + implicit none + private + + public :: zora_t_correction,scaled_zora + +contains + + subroutine zora_t_correction(mode,t,max_l,num_alpha,alpha,poly_order,& + &num_mesh_points,weight,abcissa,vxc,rho,nuc,p,problemsize) + + ! ZORA relativistic correction to kinetic energy matrix elements + ! mode=1: correction to kinetic energy matrix elements + ! mode=2: additional terms for scaling matrix elements + + real(dp), intent(out) :: t(:,0:,:,:) + integer, intent(in) :: max_l,num_mesh_points,mode + integer, intent(in) :: num_alpha(0:),nuc,problemsize + integer, intent(in) :: poly_order(0:) + real(dp), intent(in) :: alpha(0:,:),weight(:),abcissa(:),vxc(:,:),rho(:,:) + real(dp), intent(in) :: p(:,0:,:,:) + real(dp), allocatable :: kappa(:,:),kappa2(:,:),vtot(:,:) + integer :: ii,jj,kk,ll,mm,nn,oo,pp,start + + allocate(kappa(2,num_mesh_points)) + allocate(kappa2(2,num_mesh_points)) + allocate(vtot(2,num_mesh_points)) + + t=0.0d0 + + call potential_to_mesh(num_mesh_points,abcissa,& + &vxc,rho,nuc,p,max_l,num_alpha,poly_order,alpha,problemsize,vtot) + + call kappa_to_mesh(num_mesh_points,vtot,kappa,kappa2) + + do ii=0,max_l + nn=0 + do jj=1,num_alpha(ii) + do ll=1,poly_order(ii) + nn=nn+1 + + oo=nn-1 + do kk=jj,num_alpha(ii) + + start=1 + if (kk==jj) start=ll + + do mm=start,poly_order(ii) + oo=oo+1 + + ! kinetic energy correction depends on spin via potential + + if (mode==1) then + + t(1,ii,nn,oo)=kinetic_part_1(num_mesh_points,weight,abcissa,& + &kappa(1,:),alpha(ii,jj),ll,alpha(ii,kk),& + &mm,ii)+kinetic_part_2(num_mesh_points,weight,abcissa,& + &kappa(1,:),alpha(ii,jj),ll,alpha(ii,kk),& + &mm,ii)*dfloat(ii*(ii+1)) + + t(2,ii,nn,oo)=kinetic_part_1(num_mesh_points,weight,abcissa,& + &kappa(2,:),alpha(ii,jj),ll,alpha(ii,kk),& + &mm,ii)+kinetic_part_2(num_mesh_points,weight,abcissa,& + &kappa(2,:),alpha(ii,jj),ll,alpha(ii,kk),& + &mm,ii)*dfloat(ii*(ii+1)) + + end if + + if (mode==2) then + + ! calculate matrix elements needed for scaled ZORA + ! prefactor 1/2 is included as the same subroutines as for t are + ! used + + t(1,ii,nn,oo)=kinetic_part_1(num_mesh_points,weight,abcissa,& + &kappa2(1,:),alpha(ii,jj),ll,alpha(ii,kk),& + &mm,ii)+kinetic_part_2(num_mesh_points,weight,abcissa,& + &kappa2(1,:),alpha(ii,jj),ll,alpha(ii,kk),& + &mm,ii)*dfloat(ii*(ii+1)) + + t(2,ii,nn,oo)=kinetic_part_1(num_mesh_points,weight,abcissa,& + &kappa2(2,:),alpha(ii,jj),ll,alpha(ii,kk),& + &mm,ii)+kinetic_part_2(num_mesh_points,weight,abcissa,& + &kappa2(2,:),alpha(ii,jj),ll,alpha(ii,kk),& + &mm,ii)*dfloat(ii*(ii+1)) + + end if + + t(1,ii,oo,nn)=t(1,ii,nn,oo) + t(2,ii,oo,nn)=t(2,ii,nn,oo) + + end do + end do + end do + end do + end do + +! write(*,'(A)') 'SR-ZORA KINETIC ENERGY CORRECTION' + + deallocate(kappa) + deallocate(kappa2) + deallocate(vtot) + + end subroutine zora_t_correction + + subroutine scaled_zora(eigval,max_l,num_alpha,alpha,& + &poly_order,problemsize,num_mesh_points,weight,abcissa,& + &vxc,rho,nuc,p,t,cof,occ,eigval_scaled,zora_ekin) + + integer, intent(in) :: max_l,num_alpha(0:),poly_order(0:),problemsize + real(dp), intent(in) :: eigval(:,0:,:),alpha(0:,:),cof(:,0:,:,:) + real(dp), intent(in) :: occ(:,0:,:),t(0:,:,:) + integer, intent(in) :: num_mesh_points,nuc + real(dp), intent(in) :: weight(:),abcissa(:),vxc(:,:),rho(:,:),p(:,0:,:,:) + real(dp), intent(out) :: eigval_scaled(:,0:,:),zora_ekin + real(dp), allocatable :: zscale(:,:,:,:),zscale2(:,:,:,:) + real(dp) :: dummy1,dummy2,tsol2,zora_ekin1,zora_ekin2 + integer :: ii,jj,kk,ll,mm,nn,oo,pp,qq,rr,ss,tt,uu,vv,ww + + allocate(zscale(2,0:max_l,problemsize,problemsize)) + allocate(zscale2(2,0:max_l,problemsize,problemsize)) + zscale=0.0d0 + zscale2=0.0d0 + eigval_scaled=0.0d0 + zora_ekin=0.0d0 + zora_ekin1=0.0d0 + zora_ekin2=0.0d0 + tsol2=1.0_dp/sol**2 + + call zora_t_correction(1,zscale,max_l,num_alpha,alpha,poly_order,& + &num_mesh_points,weight,abcissa,vxc,rho,nuc,p,problemsize) + call zora_t_correction(2,zscale2,max_l,num_alpha,alpha,poly_order,& + &num_mesh_points,weight,abcissa,vxc,rho,nuc,p,problemsize) + +! First get scaled eigenvalues + +! Sum over all angular momenta + do ii=0,max_l +! Sum over all eigenvectors + do jj=1,num_alpha(ii)*poly_order(ii) + oo=0 + dummy1=0.0d0 + dummy2=0.0d0 +! sum over all basis functions in alpha and polynomial, i.e. prim. Slaters + do kk=1,num_alpha(ii) + do ll=1,poly_order(ii) + oo=oo+1 + pp=0 +! other sum over all basis functions in alpha and polynomial, i.e. prim. Slaters + do mm=1,num_alpha(ii) + do nn=1,poly_order(ii) + pp=pp+1 +! occupation numbers do not enter here + dummy1=dummy1+cof(1,ii,pp,jj)*cof(1,ii,oo,jj)*& + &tsol2*(zscale(1,ii,oo,pp)+& + &0.5d0*(zscale2(1,ii,oo,pp)+t(ii,oo,pp))) + dummy2=dummy2+cof(2,ii,pp,jj)*cof(2,ii,oo,jj)*& + &tsol2*(zscale(2,ii,oo,pp)+& + &0.5d0*(zscale2(2,ii,oo,pp)+t(ii,oo,pp))) + end do + end do + end do + end do + + + + eigval_scaled(1,ii,jj)=eigval(1,ii,jj)/(1.0d0+dummy1) + eigval_scaled(2,ii,jj)=eigval(2,ii,jj)/(1.0d0+dummy2) + end do + end do + +! Now ZORA kinetic energy + + dummy1=0.0d0 + dummy2=0.0d0 +! Sum over all angular momenta + do ii=0,max_l +! Sum over all eigenvectors + do jj=1,num_alpha(ii)*poly_order(ii) + oo=0 +! sum over all basis functions in alpha and polynomial, i.e. prim. Slaters + do kk=1,num_alpha(ii) + do ll=1,poly_order(ii) + oo=oo+1 + pp=0 +! other sum over all basis functions in alpha and polynomial, i.e. prim. Slaters + do mm=1,num_alpha(ii) + do nn=1,poly_order(ii) + pp=pp+1 +! dummy contains the non-relativistic kinetic energy operator applied +! to the relativistic ZORA wavefunction, debug only +! dummy1=dummy1+occ(1,ii,jj)*cof(1,ii,pp,jj)*cof(1,ii,oo,jj)*t(ii,oo,pp) +! dummy2=dummy2+occ(2,ii,jj)*cof(2,ii,pp,jj)*cof(2,ii,oo,jj)*t(ii,oo,pp) + zora_ekin1=zora_ekin1+& + &occ(1,ii,jj)*cof(1,ii,pp,jj)*cof(1,ii,oo,jj)*& + &(t(ii,oo,pp)+zscale(1,ii,oo,pp)-& + &eigval_scaled(1,ii,jj)*tsol2*(0.5d0*(& + &zscale2(1,ii,oo,pp)+t(ii,oo,pp))+zscale(1,ii,oo,pp))) + zora_ekin2=zora_ekin2+& + &occ(2,ii,jj)*cof(2,ii,pp,jj)*cof(2,ii,oo,jj)*& + &(t(ii,oo,pp)+zscale(2,ii,oo,pp)-& + &eigval_scaled(2,ii,jj)*tsol2*(0.5d0*(& + &zscale2(2,ii,oo,pp)+t(ii,oo,pp))+zscale(2,ii,oo,pp))) + end do + end do + end do + end do + end do + end do +! write(*,*) 'SCAL2 ',dummy1,dummy2,zora_ekin1,zora_ekin2 + + zora_ekin=zora_ekin1+zora_ekin2 + + deallocate(zscale) + deallocate(zscale2) + + end subroutine scaled_zora + + function kinetic_part_1(num_mesh_points,weight,abcissa,kappa,& + &alpha1,poly1,alpha2,poly2,l) + + ! get 0.5*\int_0^\inf r^2 kappa (d/dr R_A) (d/dr R_B) dr + ! pass either up or down total potential as kappa + + real(dp), intent(in) :: weight(:),abcissa(:),kappa(:) + real(dp), intent(in) :: alpha1,alpha2 + integer, intent(in) :: num_mesh_points + integer, intent(in) :: poly1,poly2,l + integer :: ii,jj,kk,ll,mm,nn,oo + real(dp) :: kinetic_part_1 + + kinetic_part_1=0.0d0 + + do ii=1,num_mesh_points + + kinetic_part_1=kinetic_part_1+weight(ii)*kappa(ii)*& + &basis_1st_times_basis_1st_times_r2(alpha1,poly1,alpha2,poly2,l,abcissa(ii)) + + end do + + kinetic_part_1=kinetic_part_1*0.5d0 + + end function kinetic_part_1 + + function kinetic_part_2(num_mesh_points,weight,abcissa,kappa,alpha1,& + &poly1,alpha2,poly2,l) + + ! get \int_0^\inf R_B R_A kappa dr; multiply by l(l+1) in calling routine + ! pass either up or down total potential as kappa + + real(dp), intent(in) :: weight(:),abcissa(:),kappa(:) + real(dp), intent(in) :: alpha1,alpha2 + integer, intent(in) :: num_mesh_points + integer, intent(in) :: poly1,poly2,l + integer :: ii,jj,kk,ll,mm,nn,oo + real(dp) :: kinetic_part_2 + + kinetic_part_2=0.0d0 + + do ii=1,num_mesh_points + + kinetic_part_2=kinetic_part_2+weight(ii)*kappa(ii)*& + &basis_times_basis(alpha1,poly1,alpha2,poly2,l,abcissa(ii)) + + end do + + kinetic_part_2=kinetic_part_2*0.5d0 + + end function kinetic_part_2 + + subroutine kappa_to_mesh(num_mesh_points,vtot,kappa,kappa2) + + ! kappa=V/(2*c^2-V), V total potential, c speed of light + ! kappa2=kappa^2, i.e. square of kappa + + integer, intent(in) :: num_mesh_points + real(dp), intent(in) :: vtot(:,:) + real(dp), intent(out) :: kappa(:,:),kappa2(:,:) + integer :: ii + + real(dp), parameter :: tsol2 =2.0_dp*sol**2 + + do ii=1,num_mesh_points + + kappa(1,ii)=vtot(1,ii)/(tsol2-vtot(1,ii)) + kappa(2,ii)=vtot(2,ii)/(tsol2-vtot(2,ii)) + + kappa2(1,ii)=kappa(1,ii)**2 + kappa2(2,ii)=kappa(2,ii)**2 + + end do + + end subroutine kappa_to_mesh + + subroutine potential_to_mesh(num_mesh_points,abcissa,& + &vxc,rho,nuc,p,max_l,num_alpha,poly_order,alpha,problemsize,vtot) + + ! get total potential on mesh, spinpolarized + + real(dp), intent(in) :: abcissa(:),vxc(:,:),p(:,0:,:,:),alpha(0:,:) + real(dp), intent(in) :: rho(:,:) + integer, intent(in) :: num_mesh_points,nuc,max_l,num_alpha(0:) + integer, intent(in) :: poly_order(0:),problemsize + real(dp), intent(out) :: vtot(:,:) + real(dp), allocatable :: cpot(:),ptot(:,:,:) + integer :: ii + + allocate(cpot(num_mesh_points)) + allocate(ptot(0:max_l,problemsize,problemsize)) + + cpot=0.0d0 + ptot=0.0d0 + vtot=0.0d0 + + ptot(:,:,:)=p(1,:,:,:)+p(2,:,:,:) + + call cou_pot(ptot(:,:,:),max_l,num_alpha,poly_order,alpha,problemsize,& + &num_mesh_points,abcissa,cpot) + + do ii=1,num_mesh_points + + vtot(1,ii)=-float(nuc)/abcissa(ii)+cpot(ii)+vxc(ii,1) + vtot(2,ii)=-float(nuc)/abcissa(ii)+cpot(ii)+vxc(ii,2) + + end do + + deallocate(cpot) + deallocate(ptot) + + end subroutine potential_to_mesh +! +end module zora_routines diff --git a/slateratom/prog/CMakeLists.txt b/slateratom/prog/CMakeLists.txt new file mode 100644 index 00000000..5693fe3d --- /dev/null +++ b/slateratom/prog/CMakeLists.txt @@ -0,0 +1,9 @@ +set(sources-f90 + cmdargs.f90 + main.f90) + +add_executable(slateratom ${sources-f90}) + +target_link_libraries(slateratom skprogs-slateratom) + +install(TARGETS slateratom EXPORT skprogs-targets DESTINATION ${CMAKE_INSTALL_BINDIR}) diff --git a/slateratom/prog/cmdargs.f90 b/slateratom/prog/cmdargs.f90 new file mode 100644 index 00000000..b1510c21 --- /dev/null +++ b/slateratom/prog/cmdargs.f90 @@ -0,0 +1,32 @@ +module cmdargs + implicit none + + character(*), parameter :: programName = 'slateratom' + character(*), parameter :: programVersion = '0.9' + + +contains + + subroutine parse_command_arguments() + + integer :: nArgs, argLen + character(:), allocatable :: arg + + nArgs = command_argument_count() + if (nArgs > 0) then + call get_command_argument(1, length=argLen) + allocate(character(argLen) :: arg) + call get_command_argument(1, arg) + select case (arg) + case ('--version') + write(*, '(A,1X,A)') programName, programVersion + stop + case default + write(*, '(A,A,A)') "Invalid command line argument '", arg, "'" + error stop + end select + end if + + end subroutine parse_command_arguments + +end module cmdargs diff --git a/slateratom/prog/main.f90 b/slateratom/prog/main.f90 new file mode 100644 index 00000000..1d8b9648 --- /dev/null +++ b/slateratom/prog/main.f90 @@ -0,0 +1,213 @@ +program HFAtom + use accuracy + use globals + use integration + use input + use core_overlap + use coulomb_hfex + use densitymatrix + use hamiltonian + use diagonalizations + use output + use totalenergy + use density + use dft + use utilities + use zora_routines + use cmdargs + implicit none + + integer :: iter + integer, allocatable :: qnvalorbs(:,:) + + call parse_command_arguments() + call read_input_1(nuc,max_l,occ_shells,maxiter,poly_order,& + &min_alpha,max_alpha,num_alpha,generate_alpha,alpha,& + &conf_r0,conf_power,num_occ,num_power,num_alphas,xcnr,& + &eigprint,zora,broyden,mixing_factor,xalpha_const) + + problemsize=num_power*num_alphas + +! first index reserved for spin + allocate(occ(2,0:max_l,problemsize)) + allocate(qnvalorbs(2, 0:max_l)) + + call read_input_2(occ,max_l,occ_shells, qnvalorbs) + +! fix number of mesh points depending on nuclear charge + num_mesh_points=500 + if (nuc>10) num_mesh_points=750 + if (nuc>18) num_mesh_points=1000 + if (nuc>36) num_mesh_points=1250 + if (nuc>54) num_mesh_points=1500 + + call echo_input(nuc,max_l,occ_shells,maxiter,poly_order,num_alpha,alpha,& + &conf_r0,conf_power,occ,num_occ,num_power,num_alphas,xcnr,zora,& + &num_mesh_points,xalpha_const) + +! allocate global stuff and zero out + call allocate_globals + +! generate radial integration mesh + call gauss_chebyshev_becke_mesh(num_mesh_points,nuc,weight,abcissa, dzdr, & + &d2zdr2, dz) + +! check mesh accuracy + call check_accuracy(weight,abcissa,num_mesh_points,max_l,& + &num_alpha,alpha,poly_order) + + if (xcnr >= 2) then + write (*, "(A,/)") "LDA/PBE ROUTINES: LIBXC IMPLEMENTATION" + end if +!!! OLD hand-coded xc implementation +! if (xcnr == 2) then +! write (*, "(A,/)") "LDA ROUTINES: BURKE IMPLEMENTATION" +! end if +! if (xcnr == 3) then +! write (*, "(A,/)") "PBE ROUTINES: BURKE IMPLEMENTATION" +! end if +! if (xcnr > 3) then +! write (*, "(A,/)") "STOP: Only xcnr <=3 supported without libxc" +! end if +!!! + + +! Build supervectors + + write(*,'(A)') 'Startup: Building Supervectors' + call overlap(s,max_l,num_alpha,alpha,poly_order) + call nuclear(u,max_l,num_alpha,alpha,poly_order) + call kinetic(t,max_l,num_alpha,alpha,poly_order) + call confinement(vconf,max_l,num_alpha,alpha,poly_order,conf_r0,conf_power) + +! test for linear dependency + call diagonalize_overlap(max_l,num_alpha,poly_order,s) + +! Build supermatrices + + write(*,'(A)') 'Startup: Building Supermatrices' + call coulomb(j,max_l,num_alpha,alpha,poly_order,u,s) + if (xcnr==0) call hfex(k,max_l,num_alpha,alpha,poly_order,problemsize) + +! convergence flag + final=.false. + +! dft start potential + if (xcnr>0) call dft_start_pot(abcissa,num_mesh_points,nuc,vxc) + +! build initial fock matrix, core hamiltonian only + write(*,'(A)') 'Startup: Building Initial Fock Matrix' + write(*,'(A)') ' ' + +! do not confuse mixer + pot_old=0.0d0 + +! kinetic energy, nuclear-electron, and confinement matrix elements +! which are constant during SCF + call build_fock(0,t,u,nuc,vconf,j,k,p,max_l,num_alpha,poly_order,problemsize,& + &xcnr,num_mesh_points,weight,abcissa,rho,vxc,alpha,pot_old,pot_new,& + &zora,broyden,mixing_factor,f) + + do iter=1,maxiter + + write(*,'(A,I5)') 'Iteration :',iter + + pot_old=pot_new + +! diagonalize + call diagonalize(max_l,num_alpha,poly_order,f,s,cof,eigval) + + +! build density matrix + call densmatrix(problemsize,max_l,occ,cof,p) + +! get electron density and derivatives and exc related potentials and +! energy densities + + call density_grid(p,max_l,num_alpha,poly_order,alpha,num_mesh_points,& + &abcissa, dzdr, d2zdr2, dz, xcnr,rho,drho,ddrho,vxc,exc,xalpha_const) + +! Build Fock matrix and get total energy during SCF + call build_fock(iter,t,u,nuc,vconf,j,k,p,max_l,num_alpha,poly_order,& + &problemsize,xcnr,num_mesh_points,weight,abcissa,rho,vxc,alpha,& + &pot_old,pot_new,zora,broyden,mixing_factor,f) + + call total_energy(t,u,nuc,vconf,j,k,p,max_l,num_alpha,poly_order,& + &problemsize,xcnr,num_mesh_points,weight,abcissa,rho,exc,& + &kinetic_energy,nuclear_energy,coulomb_energy,exchange_energy,& + &conf_energy,total_ene) + + if (.not.zora) then +! non-rel. total energy during SCF meaningless for ZORA +! but energy contributions needed once SCF converged, so surpress output + write(*,'(A,F18.6,A)') 'TOTAL ENERGY',total_ene,' Hartree' + end if + + call check_convergence(pot_old,pot_new,max_l,problemsize,iter,& + &change_max,final) + + write(*,'(A,E20.12)') 'CHANGE in potential matrix', change_max + +! converged, nuke + if (final) exit + +! check conservation of number of electrons during SCF + call check_electron_number(cof,s,occ,max_l,num_alpha,& + &poly_order,problemsize) + + write(*,*) ' ' + + end do + +! output + + if (eigprint) then + call write_eigvec(max_l,num_alpha,alpha,poly_order,& + &eigval,cof) + call write_moments(max_l,num_alpha,alpha,poly_order,problemsize,cof) + call cusp_values(max_l,occ,cof,p,alpha,num_alpha,poly_order,nuc) + end if + + + call write_eigval(max_l,num_alpha,poly_order,eigval) + call write_energies(kinetic_energy,nuclear_energy,coulomb_energy,& + &exchange_energy,conf_energy,total_ene,.false.) + + if (zora) then + call scaled_zora(eigval,max_l,num_alpha,alpha,& + &poly_order,problemsize,num_mesh_points,weight,abcissa,& + &vxc,rho,nuc,p,t,cof,occ,eigval_scaled,zora_ekin) + + write(*,'(A)') 'Scaled Scalar-Relativistic ZORA EIGENVALUES and ENERGY' + write(*,'(A)') '------------------------------------------------------' + call write_eigval(max_l,num_alpha,poly_order,eigval_scaled) + call write_energies(zora_ekin,nuclear_energy,coulomb_energy,& + &exchange_energy,conf_energy,total_ene,.true.) + end if +! + write(*,'(A,E20.12)') 'Potential Matrix Elements converged to ', change_max + write(*,'(A)') ' ' + + if (zora) then + call write_energies_tagged(zora_ekin,nuclear_energy,coulomb_energy,& + &exchange_energy,conf_energy,0.0d0,zora, eigval_scaled, occ) + else + call write_energies_tagged(kinetic_energy,nuclear_energy,coulomb_energy,& + &exchange_energy,conf_energy,total_ene,zora, eigval, occ) + end if + + call write_potentials_file_standard(num_mesh_points,abcissa,weight,& + &vxc,rho,nuc,p,max_l,num_alpha,poly_order,alpha,problemsize) + + call write_densities_file_standard(num_mesh_points,abcissa,weight,& + &rho,drho,ddrho) + + ! Write wave functions and eventually invert to have positive starting + ! gradient + call write_waves_file_standard(num_mesh_points, abcissa, weight,& + &alpha, num_alpha, poly_order,max_l, problemsize, occ, qnvalorbs, cof) + + call write_wave_coeffs_file(max_l, num_alpha, poly_order, cof, alpha, & + &occ, qnvalorbs) + +end program HFAtom diff --git a/utils/export/skprogs-activate.sh.in b/utils/export/skprogs-activate.sh.in new file mode 100644 index 00000000..b1c0e43b --- /dev/null +++ b/utils/export/skprogs-activate.sh.in @@ -0,0 +1,11 @@ +if [ -n "${PATH}" ]; then + export PATH=@CMAKE_INSTALL_FULL_BINDIR@:${PATH} +else + export PATH=@CMAKE_INSTALL_FULL_BINDIR@ +fi + +if [ -n "${PYTHONPATH}" ]; then + export PYTHONPATH=@CMAKE_INSTALL_FULL_LIBDIR@/python@PYTHON_VERSION_MAJOR_MINOR@/site-packages:${PYTHONPATH} +else + export PYTHONPATH=@CMAKE_INSTALL_FULL_LIBDIR@/python@PYTHON_VERSION_MAJOR_MINOR@/site-packages +fi diff --git a/utils/export/skprogs-config.cmake.in b/utils/export/skprogs-config.cmake.in new file mode 100644 index 00000000..156bfc57 --- /dev/null +++ b/utils/export/skprogs-config.cmake.in @@ -0,0 +1,10 @@ +@PACKAGE_INIT@ + +include(CMakeFindDependencyMacro) + +if(NOT TARGET SkProgs::sktwocnt) + if (NOT TARGET Libxc::xc) + find_dependency(Libxc) + endif() + include(${CMAKE_CURRENT_LIST_DIR}/skprogs-targets.cmake) +endif() From 90c5d59b53cb2c67f557439ba0689b792fd135ee Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Tue, 24 Nov 2020 16:55:20 +0100 Subject: [PATCH 02/17] Add mini-introduction to Readme --- README.rst | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/README.rst b/README.rst index 826fda22..9b2dc99b 100644 --- a/README.rst +++ b/README.rst @@ -58,6 +58,34 @@ Follow the usual CMake build workflow: cmake --install _build +Generating SK-files +=================== + +The basic steps of generating the electronic part of the SK-tables are as +follows: + +* Initialize the necessary environment variables by sourceing the + ``skprogs-activate.sh`` script (provided you have BASH or compatible shell, + otherwise inspect the script and set up the environment variables manually):: + + source /bin/skprogs-activate.sh + +* Then create a file ``skdef.hsd`` containing the definitions for the elements + and element pairs you wish to create. See the ``examples/`` folder for some + examples. + +* Run the ``skgen`` script to create the SK-tables. For example, in order to + generate the electronic part of the SK-tables for C, H and O with dummy (zero) + repulsives added, issue :: + + skgen -o slateratom -t sktwocnt sktable -d C,H,O C,H,O + + The SK-files will be created in the current folder. See the help (e.g. ``skgen + -h``) for additional options. + +Further documentation will be presented in a separate document later. + + License ======= From c08c97670f7c3596e99f484d89ae03dd10f6964f Mon Sep 17 00:00:00 2001 From: Tammo van der Heide Date: Tue, 16 Nov 2021 15:24:07 +0100 Subject: [PATCH 03/17] Adapt style and structure of common modules --- .gitignore | 4 +- common/lib/CMakeLists.txt | 15 +- common/lib/accuracy.F90 | 27 + common/lib/accuracy.f90 | 13 - common/lib/constants.F90 | 29 + common/lib/constants.f90 | 11 - common/lib/fifo.F90 | 10 + common/lib/fifo.f90 | 8 - common/lib/{fifo_real1.f90 => fifo_real1.F90} | 198 +++-- common/lib/{fifo_real2.f90 => fifo_real2.F90} | 189 +++-- common/lib/fifobase.F90 | 347 ++++++++ common/lib/fifobase.f90 | 332 -------- common/lib/taggedout.F90 | 738 ++++++++++++++++++ common/lib/taggedout.f90 | 548 ------------- sktools/bin/collectspinw | 19 +- sktwocnt/lib/bisection.f90 | 4 +- sktwocnt/lib/coordtrans.f90 | 6 +- sktwocnt/lib/dftbxc.f90 | 6 +- sktwocnt/lib/gridgenerator.f90 | 10 +- sktwocnt/lib/gridorbital.f90 | 6 +- sktwocnt/lib/interpolation.f90 | 4 +- sktwocnt/lib/partition.f90 | 4 +- sktwocnt/lib/quadrature.f90 | 6 +- sktwocnt/lib/sphericalharmonics.f90 | 4 +- sktwocnt/lib/twocnt.f90 | 12 +- sktwocnt/prog/input.f90 | 3 +- sktwocnt/prog/main.f90 | 3 +- sktwocnt/prog/output.f90 | 4 +- slateratom/lib/broyden.f90 | 4 +- slateratom/lib/core_overlap.f90 | 6 +- slateratom/lib/coulomb_hfex.f90 | 6 +- slateratom/lib/coulomb_potential.f90 | 2 +- slateratom/lib/density.f90 | 4 +- slateratom/lib/densitymatrix.f90 | 6 +- slateratom/lib/dft.f90 | 6 +- slateratom/lib/diagonalizations.f90 | 20 +- slateratom/lib/globals.f90 | 4 +- slateratom/lib/hamiltonian.f90 | 6 +- slateratom/lib/input.f90 | 4 +- slateratom/lib/integration.f90 | 5 +- slateratom/lib/numerical_differentiation.f90 | 6 +- slateratom/lib/output.f90 | 18 +- slateratom/lib/total_energy.f90 | 6 +- slateratom/lib/utilities.f90 | 6 +- slateratom/lib/zora_routines.f90 | 11 +- slateratom/prog/main.f90 | 3 +- 46 files changed, 1523 insertions(+), 1160 deletions(-) create mode 100644 common/lib/accuracy.F90 delete mode 100644 common/lib/accuracy.f90 create mode 100644 common/lib/constants.F90 delete mode 100644 common/lib/constants.f90 create mode 100644 common/lib/fifo.F90 delete mode 100644 common/lib/fifo.f90 rename common/lib/{fifo_real1.f90 => fifo_real1.F90} (63%) rename common/lib/{fifo_real2.f90 => fifo_real2.F90} (65%) create mode 100644 common/lib/fifobase.F90 delete mode 100644 common/lib/fifobase.f90 create mode 100644 common/lib/taggedout.F90 delete mode 100644 common/lib/taggedout.f90 diff --git a/.gitignore b/.gitignore index 193c11bf..19540097 100644 --- a/.gitignore +++ b/.gitignore @@ -4,5 +4,5 @@ *.a *.pyc __pycache__ -sktools/build - +*build/ +*_build/ \ No newline at end of file diff --git a/common/lib/CMakeLists.txt b/common/lib/CMakeLists.txt index c6a15afc..16577963 100644 --- a/common/lib/CMakeLists.txt +++ b/common/lib/CMakeLists.txt @@ -1,11 +1,11 @@ set(sources-f90 - accuracy.f90 - constants.f90 - fifo.f90 - fifo_real1.f90 - fifo_real2.f90 - fifobase.f90 - taggedout.f90) + accuracy.F90 + constants.F90 + fifo.F90 + fifo_real1.F90 + fifo_real2.F90 + fifobase.F90 + taggedout.F90) add_library(skprogs-common ${sources-f90}) @@ -18,4 +18,3 @@ target_include_directories(skprogs-common PUBLIC if(BUILD_SHARED_LIBS) install(TARGETS skprogs-common EXPORT skprogs-targets DESTINATION ${CMAKE_INSTALL_LIBDIR}) endif() -#install(DIRECTORY ${moddir}/ DESTINATION ${CMAKE_INSTALL_MODULEDIR}) diff --git a/common/lib/accuracy.F90 b/common/lib/accuracy.F90 new file mode 100644 index 00000000..2faa4e67 --- /dev/null +++ b/common/lib/accuracy.F90 @@ -0,0 +1,27 @@ +!> Contains a list of constants for the control of precision of the calculation, both for the +!! fortran numerical model and defaults for the various algorithms in the code. +!! Not all routines use the string length specifications to set their character string lengths. +module common_accuracy + + implicit none + private + + public :: dp, cp, sc, mc, lc + + !> precision of the real data type + integer, parameter :: dp = 8 + + !> precision of the complex data type + integer, parameter :: cp = dp + + !> length of a short string + integer, parameter :: sc = 10 + + !> length of a medium length string + integer, parameter :: mc = 50 + + !> length of a long string + integer, parameter :: lc = 200 + +end module common_accuracy + diff --git a/common/lib/accuracy.f90 b/common/lib/accuracy.f90 deleted file mode 100644 index 5e2aa0b3..00000000 --- a/common/lib/accuracy.f90 +++ /dev/null @@ -1,13 +0,0 @@ -!> Some global accuracy settings. -module accuracy - implicit none - public - - integer, parameter :: dp = 8 - integer, parameter :: cp = dp !* precision of the complex data type - integer, parameter :: sc = 10 !* length of a short string - integer, parameter :: mc = 50 !* length of a medium length string - integer, parameter :: lc = 200 !* length of a long string - -end module accuracy - diff --git a/common/lib/constants.F90 b/common/lib/constants.F90 new file mode 100644 index 00000000..237834c3 --- /dev/null +++ b/common/lib/constants.F90 @@ -0,0 +1,29 @@ +!> Contains a list of physical constants for the code. +module common_constants + + use common_accuracy, only : dp + + implicit none + private + + public :: pi, Bohr__AA, AA__Bohr, Hartree__eV, eV__Hartree, cc + + !> pi + real(dp), parameter :: pi = 3.14159265358979323846_dp + + !> Bohr->Angstrom + real(dp), parameter :: Bohr__AA = 0.529177249_dp + + !> Angstrom->Bohr + real(dp), parameter :: AA__Bohr = 1.0_dp / Bohr__AA + + !> Hartre -> eV + real(dp), parameter :: Hartree__eV = 27.2113845_dp + + !> eV->Hartree + real(dp), parameter :: eV__Hartree = 1.0_dp / Hartree__eV + + !> speed of light + real(dp), parameter :: cc = 137.0359997_dp + +end module common_constants diff --git a/common/lib/constants.f90 b/common/lib/constants.f90 deleted file mode 100644 index 03f27ec9..00000000 --- a/common/lib/constants.f90 +++ /dev/null @@ -1,11 +0,0 @@ -module constants - use accuracy - implicit none - - real(dp), parameter :: pi = 3.14159265358979323846_dp - real(dp), parameter :: r_Bohr = 0.529177249_dp !< Bohr radius (Å) - real(dp), parameter :: Bohr__AA = r_Bohr !< Bohr->Angstrom - real(dp), parameter :: AA__Bohr = 1.0_dp / Bohr__AA !< Angstrom->Bohr - real(dp), parameter :: Hartree = 27.2113845_dp !< H -> eV (CODATA) - real(dp), parameter :: sol = 137.0359997_dp !< Speed of Light a.u. -end module constants diff --git a/common/lib/fifo.F90 b/common/lib/fifo.F90 new file mode 100644 index 00000000..5d55c9ae --- /dev/null +++ b/common/lib/fifo.F90 @@ -0,0 +1,10 @@ +!> Provides all implemented fifos. +module common_fifo + + use common_fifo_real1 + use common_fifo_real2 + + implicit none + +end module common_fifo + diff --git a/common/lib/fifo.f90 b/common/lib/fifo.f90 deleted file mode 100644 index f9eb9976..00000000 --- a/common/lib/fifo.f90 +++ /dev/null @@ -1,8 +0,0 @@ -!> Provides all implemented fifos. -module fifo_module - use fifo_real1_module - use fifo_real2_module - implicit none - -end module fifo_module - diff --git a/common/lib/fifo_real1.f90 b/common/lib/fifo_real1.F90 similarity index 63% rename from common/lib/fifo_real1.f90 rename to common/lib/fifo_real1.F90 index c5bbb5c9..6a9dd793 100644 --- a/common/lib/fifo_real1.f90 +++ b/common/lib/fifo_real1.F90 @@ -1,76 +1,90 @@ !> Implements fifo for rank 1 real (double precision) arrays. -module fifo_real1_module - use fifobase_module +module common_fifo_real1 + + use common_fifobase, only : TFiFoBase, size + implicit none private - public :: fifo_real1, size + public :: TFiFoReal1 integer, parameter :: dp = kind(1.0d0) + !> Extended data type. - type :: mydata + type :: TMyData + real(dp), allocatable :: data(:) - end type mydata - !> Extendid fifo. - type, extends(fifobase) :: fifo_real1 + end type TMyData + + + !> Extended fifo. + type, extends(TFiFoBase) :: TFiFoReal1 + contains - procedure :: push => fifo_real1_push - procedure :: pop => fifo_real1_pop - procedure :: get => fifo_real1_get - procedure :: push_alloc => fifo_real1_push_alloc - procedure :: pop_alloc => fifo_real1_pop_alloc - procedure :: popall => fifo_real1_popall - procedure :: popall_concat => fifo_real1_popall_concat + + procedure :: push => TFiFoReal1_push + procedure :: pop => TFiFoReal1_pop + procedure :: get => TFiFoReal1_get + procedure :: push_alloc => TFiFoReal1_push_alloc + procedure :: pop_alloc => TFiFoReal1_pop_alloc + procedure :: popall => TFiFoReal1_popall + procedure :: popall_concat => TFiFoReal1_popall_concat + ! Workaround: should be private, but NAG fails to override private routines. - procedure :: datatofile => fifo_real1_datatofile - procedure :: datafromfile => fifo_real1_datafromfile - end type fifo_real1 + procedure :: datatofile => TFiFoReal1_datatofile + procedure :: datafromfile => TFiFoReal1_datafromfile + + end type TFiFoReal1 contains !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!! FIFO_REAL1 Routines +!!! TFIFOREAL1 Routines !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !> Makes a copy of item and stores it in the collection. - !! \param self Instance. + !! \param this Instance. !! \param item Item to store. - subroutine fifo_real1_push(self, item) - class(fifo_real1), intent(inout) :: self + subroutine TFiFoReal1_push(this, item) + + class(TFiFoReal1), intent(inout) :: this + real(dp), intent(in) :: item(:) class(*), pointer :: wrapper - allocate(mydata :: wrapper) + allocate(TMyData :: wrapper) select type(wrapper) - type is (mydata) - wrapper%data = item ! Automatic allocation + type is (TMyData) + wrapper%data = item end select - call self%pushptr(wrapper) + call this%pushptr(wrapper) - end subroutine fifo_real1_push + end subroutine TFiFoReal1_push !> Retrieves the next item (fifo) and removes it from the collection. - !! \param self Instance. + !! \param this Instance. !! \param item Item storing the result. - subroutine fifo_real1_pop(self, item) - class(fifo_real1), intent(inout) :: self + subroutine TFiFoReal1_pop(this, item) + + class(TFiFoReal1), intent(inout) :: this + real(dp), intent(out) :: item(:) class(*), pointer :: wrapper - call self%popptr(wrapper) + call this%popptr(wrapper) select type (wrapper) - type is (mydata) + type is (TMyData) item(:) = wrapper%data end select deallocate(wrapper) - end subroutine fifo_real1_pop + end subroutine TFiFoReal1_pop !> Retrieves the next item without removing it from the collection. @@ -80,21 +94,23 @@ end subroutine fifo_real1_pop !! the last element in the fifo had been returned, the first will be returned !! again. !! - !! \param self Instance. + !! \param this Instance. !! \param item Item storing the result. - subroutine fifo_real1_get(self, item) - class(fifo_real1), intent(inout) :: self + subroutine TFiFoReal1_get(this, item) + + class(TFiFoReal1), intent(inout) :: this + real(dp), intent(out) :: item(:) class(*), pointer :: wrapper - call self%getptr(wrapper) + call this%getptr(wrapper) select type (wrapper) - type is (mydata) + type is (TMyData) item(:) = wrapper%data end select - end subroutine fifo_real1_get + end subroutine TFiFoReal1_get !> Moves an allocatable item into the collection. @@ -103,22 +119,24 @@ end subroutine fifo_real1_get !! status of the item is moved to the collection, so that the original item is !! automatically deallocated. No temporary copy of the item is created. !! - !! \param self Instance. + !! \param this Instance. !! \param item Item to store. Deallocated on return. - subroutine fifo_real1_push_alloc(self, item) - class(fifo_real1), intent(inout) :: self + subroutine TFiFoReal1_push_alloc(this, item) + + class(TFiFoReal1), intent(inout) :: this + real(dp), allocatable, intent(inout) :: item(:) class(*), pointer :: wrapper - allocate(mydata :: wrapper) + allocate(TMyData :: wrapper) select type (wrapper) - type is (mydata) + type is (TMyData) call move_alloc(item, wrapper%data) end select - call self%pushptr(wrapper) + call this%pushptr(wrapper) - end subroutine fifo_real1_push_alloc + end subroutine TFiFoReal1_push_alloc !> Retrieves the next item (fifo) and removes it from the collection. @@ -127,22 +145,24 @@ end subroutine fifo_real1_push_alloc !! is moved from the collection to the item, so that the item will be !! automatically allocated. No temporary copy of the item is created. !! - !! \param self Instance. + !! \param this Instance. !! \param item Item storing the result. - subroutine fifo_real1_pop_alloc(self, item) - class(fifo_real1), intent(inout) :: self + subroutine TFiFoReal1_pop_alloc(this, item) + + class(TFiFoReal1), intent(inout) :: this + real(dp), allocatable, intent(out) :: item(:) class(*), pointer :: wrapper - call self%popptr(wrapper) + call this%popptr(wrapper) select type (wrapper) - type is (mydata) + type is (TMyData) call move_alloc(wrapper%data, item) end select deallocate(wrapper) - end subroutine fifo_real1_pop_alloc + end subroutine TFiFoReal1_pop_alloc !> Retrieves all items from the collection as an allocatable array and deletes @@ -151,32 +171,37 @@ end subroutine fifo_real1_pop_alloc !! \details The routine allocates an array with the given shape and an !! additional dimension with the size of the collectoin. !! - !! \param self Instance. + !! \param this Instance. !! \param itemshape Shape of the items in the collection. !! \param items Array containing the items. !! !! \warning It is the responsibility of the caller to invoke this method !! only on collections containing elements with the same shape. No checking !! of shape conformance is done. - subroutine fifo_real1_popall(self, items) - class(fifo_real1), intent(inout) :: self + subroutine TFiFoReal1_popall(this, items) + + class(TFiFoReal1), intent(inout) :: this + real(dp), allocatable, intent(out) :: items(:,:) class(*), pointer :: wrapper + integer :: itemshape(1) + + !> Auxiliary variable integer :: ii - call self%getptr(wrapper) + call this%getptr(wrapper) select type (wrapper) - type is (mydata) + type is (TMyData) itemshape(:) = shape(wrapper%data) end select - allocate(items(itemshape(1), size(self))) - do ii = 1, size(self) - call self%pop(items(:,ii)) + allocate(items(itemshape(1), size(this))) + do ii = 1, size(this) + call this%pop(items(:, ii)) end do - end subroutine fifo_real1_popall + end subroutine TFiFoReal1_popall !> Retrieves all items from the collection as an allocatable array by @@ -185,29 +210,32 @@ end subroutine fifo_real1_popall !! \details The routine allocates an array with the given shape times !! the size of the collection. !! - !! \param self Instance. + !! \param this Instance. !! \param items Array containing the items. - subroutine fifo_real1_popall_concat(self, items) - class(fifo_real1), intent(inout) :: self + subroutine TFiFoReal1_popall_concat(this, items) + + class(TFiFoReal1), intent(inout) :: this + real(dp), allocatable, intent(out) :: items(:) integer :: ii, ind, total, nn + class(*), pointer :: wrapper total = 0 - do ii = 1, size(self) - call self%getptr(wrapper) + do ii = 1, size(this) + call this%getptr(wrapper) select type (wrapper) - type is (mydata) + type is (TMyData) total = total + size(wrapper%data) end select end do allocate(items(total)) ind = 1 - do ii = 1, size(self) - call self%popptr(wrapper) + do ii = 1, size(this) + call this%popptr(wrapper) select type (wrapper) - type is (mydata) + type is (TMyData) nn = size(wrapper%data) items(ind:ind+nn-1) = wrapper%data(:) ind = ind + nn @@ -215,50 +243,56 @@ subroutine fifo_real1_popall_concat(self, items) deallocate(wrapper) end do - end subroutine fifo_real1_popall_concat + end subroutine TFiFoReal1_popall_concat !> Overrides the datatofile method of the base class. - !! \param self Instance. + !! \param this Instance. !! \param fileid Id of the file in which data should be written. !! \param filepos Position in the file, to which data should be written. !! \param data Data node to save to file. - subroutine fifo_real1_datatofile(self, fileid, filepos, data) - class(fifo_real1), intent(inout) :: self + subroutine TFiFoReal1_datatofile(this, fileid, filepos, data) + + class(TFiFoReal1), intent(inout) :: this + integer, intent(in) :: fileid, filepos + class(*), pointer, intent(inout) :: data select type (data) - type is (mydata) + type is (TMyData) write(fileid, pos=filepos) shape(data%data) write(fileid) data%data end select deallocate(data) - end subroutine fifo_real1_datatofile + end subroutine TFiFoReal1_datatofile !> Overides the datafromfile method of the base class. - !! \param self Instance. + !! \param this Instance. !! \param fileid Id of the file from which data should be read. !! \param filepos Position in the file, from which data should be read. !! \param data Data node to create from file. - subroutine fifo_real1_datafromfile(self, fileid, filepos, data) - class(fifo_real1), intent(inout) :: self + subroutine TFiFoReal1_datafromfile(this, fileid, filepos, data) + + class(TFiFoReal1), intent(inout) :: this + integer, intent(in) :: fileid, filepos + class(*), pointer, intent(out) :: data integer :: itemshape(1) - allocate(mydata :: data) + allocate(TMyData :: data) select type (data) - type is (mydata) + type is (TMyData) read(fileid, pos=filepos) itemshape allocate(data%data(itemshape(1))) read(fileid) data%data end select - end subroutine fifo_real1_datafromfile + end subroutine TFiFoReal1_datafromfile -end module fifo_real1_module +end module common_fifo_real1 diff --git a/common/lib/fifo_real2.f90 b/common/lib/fifo_real2.F90 similarity index 65% rename from common/lib/fifo_real2.f90 rename to common/lib/fifo_real2.F90 index 56bdd825..728173aa 100644 --- a/common/lib/fifo_real2.f90 +++ b/common/lib/fifo_real2.F90 @@ -1,76 +1,84 @@ !> Implements fifo for rank 2 real (double precision) arrays. -module fifo_real2_module - use fifobase_module +module common_fifo_real2 + + use common_fifobase, only : TFiFoBase, size + implicit none private - public :: fifo_real2, size + public :: TFiFoReal2 integer, parameter :: dp = kind(1.0d0) + !> Extended data type. - type :: mydata + type :: TMyData real(dp), allocatable :: data(:,:) - end type mydata + end type TMyData + !> Extendid fifo. - type, extends(fifobase) :: fifo_real2 + type, extends(TFiFoBase) :: TFiFoReal2 contains - procedure :: push => fifo_real2_push - procedure :: pop => fifo_real2_pop - procedure :: get => fifo_real2_get - procedure :: push_alloc => fifo_real2_push_alloc - procedure :: pop_alloc => fifo_real2_pop_alloc - procedure :: popall => fifo_real2_popall - procedure :: popall_concat => fifo_real2_popall_concat + procedure :: push => TFiFoReal2_push + procedure :: pop => TFiFoReal2_pop + procedure :: get => TFiFoReal2_get + procedure :: push_alloc => TFiFoReal2_push_alloc + procedure :: pop_alloc => TFiFoReal2_pop_alloc + procedure :: popall => TFiFoReal2_popall + procedure :: popall_concat => TFiFoReal2_popall_concat ! Workaround: should be private, but NAG fails to override private routines. - procedure :: datatofile => fifo_real2_datatofile - procedure :: datafromfile => fifo_real2_datafromfile - end type fifo_real2 + procedure :: datatofile => TFiFoReal2_datatofile + procedure :: datafromfile => TFiFoReal2_datafromfile + end type TFiFoReal2 contains !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!! FIFO_REAL2 Routines +!!! TFIFOREAL2 Routines !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !> Makes a copy of item and stores it in the collection. - !! \param self Instance. + !! \param this Instance. !! \param item Item to store. - subroutine fifo_real2_push(self, item) - class(fifo_real2), intent(inout) :: self + subroutine TFiFoReal2_push(this, item) + + class(TFiFoReal2), intent(inout) :: this + real(dp), intent(in) :: item(:,:) class(*), pointer :: wrapper - allocate(mydata :: wrapper) + allocate(TMyData :: wrapper) select type(wrapper) - type is (mydata) + type is (TMyData) wrapper%data = item ! Automatic allocation end select - call self%pushptr(wrapper) + call this%pushptr(wrapper) - end subroutine fifo_real2_push + end subroutine TFiFoReal2_push !> Retrieves the next item (fifo) and removes it from the collection. - !! \param self Instance. + !! \param this Instance. !! \param item Item storing the result. - subroutine fifo_real2_pop(self, item) - class(fifo_real2), intent(inout) :: self + subroutine TFiFoReal2_pop(this, item) + + class(TFiFoReal2), intent(inout) :: this + real(dp), intent(out) :: item(:,:) class(*), pointer :: wrapper - call self%popptr(wrapper) + call this%popptr(wrapper) select type (wrapper) - type is (mydata) + type is (TMyData) item(:,:) = wrapper%data end select deallocate(wrapper) - end subroutine fifo_real2_pop + end subroutine TFiFoReal2_pop !> Retrieves the next item without removing it from the collection. @@ -80,21 +88,23 @@ end subroutine fifo_real2_pop !! the last element in the fifo had been returned, the first will be returned !! again. !! - !! \param self Instance. + !! \param this Instance. !! \param item Item storing the result. - subroutine fifo_real2_get(self, item) - class(fifo_real2), intent(inout) :: self + subroutine TFiFoReal2_get(this, item) + + class(TFiFoReal2), intent(inout) :: this + real(dp), intent(out) :: item(:,:) class(*), pointer :: wrapper - call self%getptr(wrapper) + call this%getptr(wrapper) select type (wrapper) - type is (mydata) + type is (TMyData) item(:,:) = wrapper%data end select - end subroutine fifo_real2_get + end subroutine TFiFoReal2_get !> Moves an allocatable item into the collection. @@ -103,22 +113,24 @@ end subroutine fifo_real2_get !! status of the item is moved to the collection, so that the original item is !! automatically deallocated. No temporary copy of the item is created. !! - !! \param self Instance. + !! \param this Instance. !! \param item Item to store. Deallocated on return. - subroutine fifo_real2_push_alloc(self, item) - class(fifo_real2), intent(inout) :: self + subroutine TFiFoReal2_push_alloc(this, item) + + class(TFiFoReal2), intent(inout) :: this + real(dp), allocatable, intent(inout) :: item(:,:) class(*), pointer :: wrapper - allocate(mydata :: wrapper) + allocate(TMyData :: wrapper) select type (wrapper) - type is (mydata) + type is (TMyData) call move_alloc(item, wrapper%data) end select - call self%pushptr(wrapper) + call this%pushptr(wrapper) - end subroutine fifo_real2_push_alloc + end subroutine TFiFoReal2_push_alloc !> Retrieves the next item (fifo) and removes it from the collection. @@ -127,22 +139,24 @@ end subroutine fifo_real2_push_alloc !! is moved from the collection to the item, so that the item will be !! automatically allocated. No temporary copy of the item is created. !! - !! \param self Instance. + !! \param this Instance. !! \param item Item storing the result. - subroutine fifo_real2_pop_alloc(self, item) - class(fifo_real2), intent(inout) :: self + subroutine TFiFoReal2_pop_alloc(this, item) + + class(TFiFoReal2), intent(inout) :: this + real(dp), allocatable, intent(out) :: item(:,:) class(*), pointer :: wrapper - call self%popptr(wrapper) + call this%popptr(wrapper) select type (wrapper) - type is (mydata) + type is (TMyData) call move_alloc(wrapper%data, item) end select deallocate(wrapper) - end subroutine fifo_real2_pop_alloc + end subroutine TFiFoReal2_pop_alloc !> Retrieves all items from the collection as an array and deletes them. @@ -151,31 +165,36 @@ end subroutine fifo_real2_pop_alloc !! collection. The last dimension will be allocated to the size of the !! collection. !! - !! \param self Instance. + !! \param this Instance. !! \param items Array containing the items. !! !! \warning It is the responsibility of the caller to invoke this method !! only on collections containing elements with the same shape. No checking !! of shape conformance is done. - subroutine fifo_real2_popall(self, items) - class(fifo_real2), intent(inout) :: self + subroutine TFiFoReal2_popall(this, items) + + class(TFiFoReal2), intent(inout) :: this + real(dp), allocatable, intent(out) :: items(:,:,:) class(*), pointer :: wrapper + integer :: itemshape(2) + + !> Auxiliary variable integer :: ii - call self%getptr(wrapper) + call this%getptr(wrapper) select type (wrapper) - type is (mydata) + type is (TMyData) itemshape = shape(wrapper%data) end select - allocate(items(itemshape(1), itemshape(2), size(self))) - do ii = 1, size(self) - call self%pop(items(:,:,ii)) + allocate(items(itemshape(1), itemshape(2), size(this))) + do ii = 1, size(this) + call this%pop(items(:,:,ii)) end do - end subroutine fifo_real2_popall + end subroutine TFiFoReal2_popall !> Retrieves all items from the collection as an allocatable array by @@ -184,25 +203,29 @@ end subroutine fifo_real2_popall !! \details The routine allocates an array with the given shape times !! the size of the collection. !! - !! \param self Instance. + !! \param this Instance. !! \param items Array containing the items. !! !! \warning It is the responsibility of the caller to invoke this method !! only on collections containing elements with the same shape apart of their !! last dimension. No checking of shape conformance is done. - subroutine fifo_real2_popall_concat(self, items) - class(fifo_real2), intent(inout) :: self + subroutine TFiFoReal2_popall_concat(this, items) + + class(TFiFoReal2), intent(inout) :: this + real(dp), allocatable, intent(out) :: items(:,:) class(*), pointer :: wrapper + integer :: itemshape(2) + integer :: ii, ind, total, nn total = 0 - do ii = 1, size(self) - call self%getptr(wrapper) + do ii = 1, size(this) + call this%getptr(wrapper) select type (wrapper) - type is (mydata) + type is (TMyData) total = total + size(wrapper%data, dim=2) if (ii == 1) then itemshape(:) = shape(wrapper%data) @@ -211,10 +234,10 @@ subroutine fifo_real2_popall_concat(self, items) end do allocate(items(itemshape(1), total)) ind = 1 - do ii = 1, size(self) - call self%popptr(wrapper) + do ii = 1, size(this) + call this%popptr(wrapper) select type (wrapper) - type is (mydata) + type is (TMyData) nn = size(wrapper%data, dim=2) items(:,ind:ind+nn-1) = wrapper%data ind = ind + nn @@ -222,50 +245,56 @@ subroutine fifo_real2_popall_concat(self, items) deallocate(wrapper) end do - end subroutine fifo_real2_popall_concat + end subroutine TFiFoReal2_popall_concat !> Overides the datatofile method of the base class. - !! \param self Instance. + !! \param this Instance. !! \param fileid Id of the file in which data should be written. !! \param filepos Position in the file, to which data should be written. !! \param data Data node to save to file. - subroutine fifo_real2_datatofile(self, fileid, filepos, data) - class(fifo_real2), intent(inout) :: self + subroutine TFiFoReal2_datatofile(this, fileid, filepos, data) + + class(TFiFoReal2), intent(inout) :: this + integer, intent(in) :: fileid, filepos + class(*), pointer, intent(inout) :: data select type (data) - type is (mydata) + type is (TMyData) write(fileid, pos=filepos) shape(data%data) write(fileid) data%data end select deallocate(data) - end subroutine fifo_real2_datatofile + end subroutine TFiFoReal2_datatofile !> Overides the datafromfile method of the base class. - !! \param self Instance. + !! \param this Instance. !! \param fileid Id of the file from which data should be read. !! \param filepos Position in the file, from which data should be read. !! \param data Data node to create from file. - subroutine fifo_real2_datafromfile(self, fileid, filepos, data) - class(fifo_real2), intent(inout) :: self + subroutine TFiFoReal2_datafromfile(this, fileid, filepos, data) + + class(TFiFoReal2), intent(inout) :: this + integer, intent(in) :: fileid, filepos + class(*), pointer, intent(out) :: data integer :: itemshape(2) - allocate(mydata :: data) + allocate(TMyData :: data) select type (data) - type is (mydata) + type is (TMyData) read(fileid, pos=filepos) itemshape allocate(data%data(itemshape(1), itemshape(2))) read(fileid) data%data end select - end subroutine fifo_real2_datafromfile + end subroutine TFiFoReal2_datafromfile -end module fifo_real2_module +end module common_fifo_real2 diff --git a/common/lib/fifobase.F90 b/common/lib/fifobase.F90 new file mode 100644 index 00000000..9e6e980f --- /dev/null +++ b/common/lib/fifobase.F90 @@ -0,0 +1,347 @@ +!> Contains the base fifo class. +module common_fifobase + + implicit none + private + + public :: TFiFoBase, size + + + !> Returns the size of the collection. + interface size + module procedure TFiFoBase_size + end interface size + + + !> Base fifo implementation managing pointers. + type :: TFiFoBase + private + + integer :: nitem = 0 + integer :: inmemory = 0 + integer :: memorylimit = -1 + + integer :: fileid + character(len=:), allocatable :: filename + + class(TFiFoNode), pointer :: head => null() + class(TFiFoNode), pointer :: tail => null() + class(TFiFoNode), pointer :: current => null() + class(TFiFoNode), pointer :: previous => null() + + contains + + procedure :: initswap => TFiFoBase_initswap + procedure :: pushptr => TFiFoBase_pushptr + procedure :: popptr => TFiFoBase_popptr + procedure :: getptr => TFiFoBase_getptr + procedure :: getsize => TFiFoBase_size + procedure :: reset => TFiFoBase_reset + + final :: TFiFoBase_destruct + + procedure, private :: writenodedata => TFiFoBase_writenodedata + procedure, private :: readnodedata => TFiFoBase_readnodedata + procedure, private :: freeresources => TFiFoBase_freeresources + + ! Workaround: should be private, but NAG fails to override private routines. + procedure :: datafromfile => TFiFoBase_datafromfile + procedure :: datatofile => TFiFoBase_datatofile + + end type TFiFoBase + + + !> Represents one node in the fifo. + type TFiFoNode + + class(*), pointer :: data => null() + class(TFiFoNode), pointer :: next => null() + integer :: filepos = -1 + + end type TFiFoNode + + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!! FIFO Routines +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the number of items in the collection. + !! \param obj Collection instance. + !! \return Number of items. + pure function TFiFoBase_size(obj) result(res) + + class(TFiFoBase), intent(in) :: obj + integer :: res + + res = obj%nitem + + end function TFiFoBase_size + + + !> Initializes a swap for the collection. + !! + !! \details If swap is initialized for the collection, all entries above + !! a given number are written to a file, instead of keeping them in memory. + !! When the entries are read from the collection, a read buffer must be + !! allocated, so the total number of elements kept in the memory will be + !! increased by one. + !! + !! \param memorylimit Maximal number of entries to keep in memory (-1: all + !! or 0: none or any positive number). + !! \param filename Name of the swap file. + !! \param fileid File id to use for handling the swap file. + subroutine TFiFoBase_initswap(this, memorylimit, filename, fileid) + class(TFiFoBase), intent(inout) :: this + integer, intent(in) :: memorylimit + character(len=*), intent(in) :: filename + integer, intent(in) :: fileid + + if (this%memorylimit /= -1) then + stop "FIFO swap can be initialized only once" + end if + this%memorylimit = memorylimit + this%filename = filename + this%fileid = fileid + + end subroutine TFiFoBase_initswap + + + !> Pushes a pointer to the collection. + !! \param this Instance. + !! \param data Pointer to the data object. + subroutine TFiFoBase_pushptr(this, data) + class(TFiFoBase), intent(inout) :: this + class(*), pointer, intent(in) :: data + + class(TFiFoNode), pointer :: node + + allocate(node) + node%data => data + if (.not. associated(this%head)) then + this%head => node + this%current => node + else + this%tail%next => node + end if + this%tail => node + this%nitem = this%nitem + 1 + this%inmemory = this%inmemory + 1 + if (this%memorylimit /= -1 .and. this%inmemory > this%memorylimit) then + call this%writenodedata(node) + end if + + end subroutine TFiFoBase_pushptr + + + !> Pops a pointer from the collection. + !! \param this Instance. + !! \param data Pointer to the data object on return. + subroutine TFiFoBase_popptr(this, data) + class(TFiFoBase), intent(inout) :: this + class(*), pointer, intent(out) :: data + + class(TFiFoNode), pointer :: node + + if (.not. associated(this%head)) then + data => null() + return + end if + + node => this%head + this%head => node%next + if (associated(node, this%current)) then + this%current => node%next + end if + if (associated(node, this%previous)) then + nullify(this%previous) + end if + if (.not. associated(node%data)) then + call this%readnodedata(node) + end if + data => node%data + deallocate(node) + this%nitem = this%nitem - 1 + this%inmemory = this%inmemory - 1 + + end subroutine TFiFoBase_popptr + + + !> Gets a copy of a pointer from the collection. + !! \param this Instance. + !! \param data Pointer to the data object on return. + subroutine TFiFoBase_getptr(this, data) + class(TFiFoBase), intent(inout) :: this + class(*), pointer, intent(out) :: data + + if (.not. associated(this%current)) then + data => null() + return + end if + + ! If previous get read something from file, clear the buffer. + if (associated(this%previous)) then + if (this%previous%filepos /= -1 .and. associated(this%previous%data)) then + deallocate(this%previous%data) + this%inmemory = this%inmemory - 1 + end if + end if + + if (.not. associated(this%current%data)) then + call this%readnodedata(this%current) + end if + data => this%current%data + + this%previous => this%current + if (associated(this%current%next)) then + this%current => this%current%next + else + this%current => this%head + end if + + end subroutine TFiFoBase_getptr + + + !> Restets the collection to it initial (empty) state. + !! \param this Instance. + subroutine TFiFoBase_reset(this) + class(TFiFoBase), intent(inout) :: this + + call this%freeresources() + this%nitem = 0 + this%inmemory = 0 + this%memorylimit = -1 + nullify(this%head, this%tail, this%current, this%previous) + + end subroutine TFiFoBase_reset + + + !> Destructor for the class. + !! \param this Instance. + subroutine TFiFoBase_destruct(this) + type(TFiFoBase), intent(inout) :: this + + call this%freeresources() + + end subroutine TFiFoBase_destruct + + + !> Destroys the nodes in the collections and closes open files. + !! \param this Instance variable. + subroutine TFiFoBase_freeresources(this) + class(TFiFoBase), intent(inout) :: this + + class(TFiFoNode), pointer :: node + logical :: opened + + node => this%head + do while (associated(node)) + deallocate(node%data) + this%head => node%next + deallocate(node) + node => this%head + end do + + if (this%memorylimit /= -1) then + inquire(this%fileid, opened=opened) + if (opened) then + close(this%fileid, status="delete") + end if + end if + + end subroutine TFiFoBase_freeresources + + + !> Writes the data of a node to the disc and deallocates the data object. + !! \param this Instance. + !! \param node Node with the data that should be stored in a file. + !! \note This routine invokes the data types write method instead of + !! writing the data directly. + subroutine TFiFoBase_writenodedata(this, node) + class(TFiFoBase), intent(inout) :: this + class(TFiFoNode), pointer, intent(inout) :: node + + character(len=10) :: action + + inquire(this%fileid, action=action) + if (action == "UNDEFINED") then + ! No saved entries, create new swap file + open(this%fileid, file=this%filename, access="stream", status="replace",& + & action="write", form="unformatted", position="rewind") + elseif (action == "READ") then + ! Last commmand was pop/get, close file and and reopen in append mode. + close(this%fileid) + open(this%fileid, file=this%filename, access="stream", status="old",& + & action="write", form="unformatted", position="append") + end if + + inquire(this%fileid, pos=node%filepos) + call this%datatofile(this%fileid, node%filepos, node%data) + this%inmemory = this%inmemory - 1 + + end subroutine TFiFoBase_writenodedata + + + !> Reads the data of a node from file and allocates the data object. + !! \param this Instance. + !! \param node Node with the data that should be read from a file. + !! \note This routine invokes the data types read method instead of + !! reading the data directly. + subroutine TFiFoBase_readnodedata(this, node) + class(TFiFoBase), intent(inout) :: this + class(TFiFoNode), pointer, intent(inout) :: node + + character(len=10) :: action + + inquire(this%fileid, action=action) + if (action == "WRITE") then + close(this%fileid) + open(this%fileid, file=this%filename, access="stream", status="old",& + & action="read", form="unformatted") + end if + + call this%datafromfile(this%fileid, node%filepos, node%data) + this%inmemory = this%inmemory + 1 + + end subroutine TFiFoBase_readnodedata + + + !> Writes the content of a data node to a file. + !! + !! \details Extensions of the data object should rewrite it according to + !! the data they contain. + !! + !! \param this Instance. + !! \param data Pointer to a data node, will be deallocated at exit. + !! \param fileid File in which the data should be written. + !! \param filepos Position in the file, where the data must be written. + subroutine TFiFoBase_datatofile(this, fileid, filepos, data) + class(TFiFoBase), intent(inout) :: this + integer, intent(in) :: fileid, filepos + class(*), intent(inout), pointer :: data + + stop "Collection does not support swapping to file." + + end subroutine TFiFoBase_datatofile + + + !> Reads the content of a data node from a file. + !! + !! \details Extensions of the data object should rewrite it according to + !! the data they contain. + !! + !! \param this Instance. + !! \param fileid File from which the data should be read. + !! \param filepos Position in the file, where the data should be read from. + subroutine TFiFoBase_datafromfile(this, fileid, filepos, data) + class(TFiFoBase), intent(inout) :: this + integer, intent(in) :: fileid, filepos + class(*), intent(out), pointer :: data + + stop "Collection does not support swapping to file." + + end subroutine TFiFoBase_datafromfile + + +end module common_fifobase diff --git a/common/lib/fifobase.f90 b/common/lib/fifobase.f90 deleted file mode 100644 index 4d588ba8..00000000 --- a/common/lib/fifobase.f90 +++ /dev/null @@ -1,332 +0,0 @@ -!> Contains the base fifo class. -module fifobase_module - implicit none - private - - public :: fifobase, size - - - !> Returns the size of the collection. - interface size - module procedure fifo_size - end interface size - - !> Base fifo implementation managing pointers. - type :: fifobase - private - integer :: nitem = 0 - integer :: inmemory = 0 - integer :: memorylimit = -1 - class(fifonode), pointer :: head => null() - class(fifonode), pointer :: tail => null() - class(fifonode), pointer :: current => null() - class(fifonode), pointer :: previous => null() - integer :: fileid - character(:), allocatable :: filename - contains - procedure :: initswap => fifo_initswap - procedure :: pushptr => fifo_pushptr - procedure :: popptr => fifo_popptr - procedure :: getptr => fifo_getptr - procedure :: getsize => fifo_size - procedure :: reset => fifo_reset - final :: fifo_destruct - procedure, private :: writenodedata => fifo_writenodedata - procedure, private :: readnodedata => fifo_readnodedata - procedure, private :: freeresources => fifo_freeresources - ! Workaround: should be private, but NAG fails to override private routines. - procedure :: datafromfile => fifo_datafromfile - procedure :: datatofile => fifo_datatofile - end type fifobase - - !> Represents one node in the fifo. - type fifonode - class(*), pointer :: data => null() - class(fifonode), pointer :: next => null() - integer :: filepos = -1 - end type fifonode - - -contains - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!! FIFO Routines -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - !> Returns the number of items in the collection. - !! \param obj Collection instance. - !! \return Number of items. - pure function fifo_size(obj) result(res) - class(fifobase), intent(in) :: obj - integer :: res - - res = obj%nitem - - end function fifo_size - - - !> Initializes a swap for the collection. - !! - !! \details If swap is initialized for the collection, all entries above - !! a given number are written to a file, instead of keeping them in memory. - !! When the entries are read from the collection, a read buffer must be - !! allocated, so the total number of elements kept in the memory will be - !! increased by one. - !! - !! \param memorylimit Maximal number of entries to keep in memory (-1: all - !! or 0: none or any positive number). - !! \param filename Name of the swap file. - !! \param fileid File id to use for handling the swap file. - subroutine fifo_initswap(self, memorylimit, filename, fileid) - class(fifobase), intent(inout) :: self - integer, intent(in) :: memorylimit - character(*), intent(in) :: filename - integer, intent(in) :: fileid - - if (self%memorylimit /= -1) then - stop "FIFO swap can be initialized only once" - end if - self%memorylimit = memorylimit - self%filename = filename - self%fileid = fileid - - end subroutine fifo_initswap - - - !> Pushes a pointer to the collection. - !! \param self Instance. - !! \param data Pointer to the data object. - subroutine fifo_pushptr(self, data) - class(fifobase), intent(inout) :: self - class(*), pointer, intent(in) :: data - - class(fifonode), pointer :: node - - allocate(node) - node%data => data - if (.not. associated(self%head)) then - self%head => node - self%current => node - else - self%tail%next => node - end if - self%tail => node - self%nitem = self%nitem + 1 - self%inmemory = self%inmemory + 1 - if (self%memorylimit /= -1 .and. self%inmemory > self%memorylimit) then - call self%writenodedata(node) - end if - - end subroutine fifo_pushptr - - - !> Pops a pointer from the collection. - !! \param self Instance. - !! \param data Pointer to the data object on return. - subroutine fifo_popptr(self, data) - class(fifobase), intent(inout) :: self - class(*), pointer, intent(out) :: data - - class(fifonode), pointer :: node - - if (.not. associated(self%head)) then - data => null() - return - end if - - node => self%head - self%head => node%next - if (associated(node, self%current)) then - self%current => node%next - end if - if (associated(node, self%previous)) then - nullify(self%previous) - end if - if (.not. associated(node%data)) then - call self%readnodedata(node) - end if - data => node%data - deallocate(node) - self%nitem = self%nitem - 1 - self%inmemory = self%inmemory - 1 - - end subroutine fifo_popptr - - - !> Gets a copy of a pointer from the collection. - !! \param self Instance. - !! \param data Pointer to the data object on return. - subroutine fifo_getptr(self, data) - class(fifobase), intent(inout) :: self - class(*), pointer, intent(out) :: data - - if (.not. associated(self%current)) then - data => null() - return - end if - - ! If previous get read something from file, clear the buffer. - if (associated(self%previous)) then - if (self%previous%filepos /= -1 .and. associated(self%previous%data)) then - deallocate(self%previous%data) - self%inmemory = self%inmemory - 1 - end if - end if - - if (.not. associated(self%current%data)) then - call self%readnodedata(self%current) - end if - data => self%current%data - - self%previous => self%current - if (associated(self%current%next)) then - self%current => self%current%next - else - self%current => self%head - end if - - end subroutine fifo_getptr - - - !> Restets the collection to it initial (empty) state. - !! \param self Instance. - subroutine fifo_reset(self) - class(fifobase), intent(inout) :: self - - call self%freeresources() - self%nitem = 0 - self%inmemory = 0 - self%memorylimit = -1 - nullify(self%head, self%tail, self%current, self%previous) - - end subroutine fifo_reset - - - !> Destructor for the class. - !! \param self Instance. - subroutine fifo_destruct(self) - type(fifobase), intent(inout) :: self - - call self%freeresources() - - end subroutine fifo_destruct - - - !> Destroys the nodes in the collections and closes open files. - !! \param self Instance variable. - subroutine fifo_freeresources(self) - class(fifobase), intent(inout) :: self - - class(fifonode), pointer :: node - logical :: opened - - node => self%head - do while (associated(node)) - deallocate(node%data) - self%head => node%next - deallocate(node) - node => self%head - end do - - if (self%memorylimit /= -1) then - inquire(self%fileid, opened=opened) - if (opened) then - close(self%fileid, status="delete") - end if - end if - - end subroutine fifo_freeresources - - - !> Writes the data of a node to the disc and deallocates the data object. - !! \param self Instance. - !! \param node Node with the data that should be stored in a file. - !! \note This routine invokes the data types write method instead of - !! writing the data directly. - subroutine fifo_writenodedata(self, node) - class(fifobase), intent(inout) :: self - class(fifonode), pointer, intent(inout) :: node - - character(10) :: action - - inquire(self%fileid, action=action) - if (action == "UNDEFINED") then - ! No saved entries, create new swap file - open(self%fileid, file=self%filename, access="stream", status="replace",& - & action="write", form="unformatted", position="rewind") - elseif (action == "READ") then - ! Last commmand was pop/get, close file and and reopen in append mode. - close(self%fileid) - open(self%fileid, file=self%filename, access="stream", status="old",& - & action="write", form="unformatted", position="append") - end if - - inquire(self%fileid, pos=node%filepos) - call self%datatofile(self%fileid, node%filepos, node%data) - self%inmemory = self%inmemory - 1 - - end subroutine fifo_writenodedata - - - !> Reads the data of a node from file and allocates the data object. - !! \param self Instance. - !! \param node Node with the data that should be read from a file. - !! \note This routine invokes the data types read method instead of - !! reading the data directly. - subroutine fifo_readnodedata(self, node) - class(fifobase), intent(inout) :: self - class(fifonode), pointer, intent(inout) :: node - - character(10) :: action - - inquire(self%fileid, action=action) - if (action == "WRITE") then - close(self%fileid) - open(self%fileid, file=self%filename, access="stream", status="old",& - & action="read", form="unformatted") - end if - - call self%datafromfile(self%fileid, node%filepos, node%data) - self%inmemory = self%inmemory + 1 - - end subroutine fifo_readnodedata - - - !> Writes the content of a data node to a file. - !! - !! \details Extensions of the data object should rewrite it according to - !! the data they contain. - !! - !! \param self Instance. - !! \param data Pointer to a data node, will be deallocated at exit. - !! \param fileid File in which the data should be written. - !! \param filepos Position in the file, where the data must be written. - subroutine fifo_datatofile(self, fileid, filepos, data) - class(fifobase), intent(inout) :: self - integer, intent(in) :: fileid, filepos - class(*), intent(inout), pointer :: data - - stop "Collection does not support swapping to file." - - end subroutine fifo_datatofile - - - !> Reads the content of a data node from a file. - !! - !! \details Extensions of the data object should rewrite it according to - !! the data they contain. - !! - !! \param self Instance. - !! \param fileid File from which the data should be read. - !! \param filepos Position in the file, where the data should be read from. - subroutine fifo_datafromfile(self, fileid, filepos, data) - class(fifobase), intent(inout) :: self - integer, intent(in) :: fileid, filepos - class(*), intent(out), pointer :: data - - stop "Collection does not support swapping to file." - - end subroutine fifo_datafromfile - - -end module fifobase_module diff --git a/common/lib/taggedout.F90 b/common/lib/taggedout.F90 new file mode 100644 index 00000000..46a19d9c --- /dev/null +++ b/common/lib/taggedout.F90 @@ -0,0 +1,738 @@ +!> Contains routines to write out various data structures in a comprehensive tagged format. +module common_taggedout + + use common_accuracy, only : dp + + implicit none + private + + public :: TTaggedwriter, TTaggedwriter_init, writetag, lenLabel + + + !> Length of permissible tag labels. Tag names should be shorter than lenLabel! + integer, parameter :: lenLabel = 20 + + !> Max length of the format strings for individual items + integer, parameter :: lenFormStr = 20 + + + !> Tag format writer type. + type :: TTaggedwriter + character(lenFormStr) :: formReal + character(lenFormStr) :: formCmplx + character(lenFormStr) :: formInt + character(lenFormStr) :: formLogical + end type TTaggedwriter + + + !> Writes objects in a standardized tagged form to a given file. + interface writetag + module procedure TTaggedwriter_real0 + module procedure TTaggedwriter_real1 + module procedure TTaggedwriter_real2 + module procedure TTaggedwriter_real3 + module procedure TTaggedwriter_real4 + module procedure TTaggedwriter_cplx0 + module procedure TTaggedwriter_cplx1 + module procedure TTaggedwriter_cplx2 + module procedure TTaggedwriter_cplx3 + module procedure TTaggedwriter_cplx4 + module procedure TTaggedwriter_int0 + module procedure TTaggedwriter_int1 + module procedure TTaggedwriter_int2 + module procedure TTaggedwriter_int3 + module procedure TTaggedwriter_int4 + module procedure TTaggedwriter_logical0 + module procedure TTaggedwriter_logical1 + module procedure TTaggedwriter_logical2 + module procedure TTaggedwriter_logical3 + module procedure TTaggedwriter_logical4 + end interface + + +contains + + !> Initializes the tagged writer. + subroutine TTaggedwriter_init(this) + + !> Instance of a tag format writer + type(TTaggedwriter), intent(out) :: this + + !> Number of decimal, exponent, and character places + integer :: nDec, nExp, nChar + + !> Number of resulting field entries + integer :: nField + + ! example: "-3.1234567E-123 " would correspond to nDec = 7, nExp = 3, nChar = 16 + nexp = ceiling(log(maxexponent(1.0_dp) / log(10.0)) / log(10.0)) + ndec = precision(1.0_dp) + + nchar = ndec + nexp + 6 + nfield = 80 / nchar + + if (nfield == 0) then + nfield = 1 + end if + + write(this%formReal, "('(', I2.2, 'ES', I2.2, '.', I2.2, 'E', I3.3, ')')") nField, nChar,& + & nDec, nExp + + write(this%formCmplx, "('(', I2.2, '(2ES', I2.2, '.', I2.2, 'E', I3.3, '))')") nfield / 2,& + & nchar, ndec, nexp + + !! "-12345 " + nchar = digits(1) + 2 + nfield = 80 / nchar + + if (nfield == 0) then + nfield = 1 + end if + + write (this%formInt, "('(', I2.2, 'I', I2.2, ')')") nfield, nchar + + write(this%formLogical, "('(40L2)')") + + end subroutine TTaggedwriter_init + + + subroutine TTaggedwriter_real0(this, file, tag, data, optform) + + !> Instance of a tag format writer + type(TTaggedwriter), intent(in) :: this + + !> File ID + integer, intent(in) :: file + + !> Tag label + character(len=*), intent(in) :: tag + + !> Data to print + real(dp), intent(in) :: data + + !> Optional formatting string + character(lenFormStr), optional, intent(in) :: optform + + !> Actual formatting string + character(lenFormStr) :: form + + if (present(optform)) then + form = optform + else + form = this%formReal + end if + + write(file, "('@', A, ':real:0:')") trim(tag) + write(file, form) data + + end subroutine TTaggedwriter_real0 + + + subroutine TTaggedwriter_real1(this, file, tag, data, optform) + + !> Instance of a tag format writer + type(TTaggedwriter), intent(in) :: this + + !> File ID + integer, intent(in) :: file + + !> Tag label + character(len=*), intent(in) :: tag + + !> Data to print + real(dp), intent(in) :: data(:) + + !> Optional formatting string + character(lenFormStr), optional, intent(in) :: optform + + !> Actual formatting string + character(lenFormStr) :: form + + if (present(optform)) then + form = optform + else + form = this%formReal + end if + + write(file, "('@', A, ':real:1:', I0)") trim(tag), shape(data) + write(file, form) data + + end subroutine TTaggedwriter_real1 + + + subroutine TTaggedwriter_real2(this, file, tag, data, optform) + + !> Instance of a tag format writer + type(TTaggedwriter), intent(in) :: this + + !> File ID + integer, intent(in) :: file + + !> Tag label + character(len=*), intent(in) :: tag + + !> Data to print + real(dp), intent(in) :: data(:,:) + + !> Optional formatting string + character(lenFormStr), optional, intent(in) :: optform + + !> Actual formatting string + character(lenFormStr) :: form + + if (present(optform)) then + form = optform + else + form = this%formReal + end if + + write(file, "('@', A, ':real:2:', I0, ',', I0)") trim(tag), shape(data) + write(file, form) data + + end subroutine TTaggedwriter_real2 + + + subroutine TTaggedwriter_real3(this, file, tag, data, optform) + + !> Instance of a tag format writer + type(TTaggedwriter), intent(in) :: this + + !> File ID + integer, intent(in) :: file + + !> Tag label + character(len=*), intent(in) :: tag + + !> Data to print + real(dp), intent(in) :: data(:,:,:) + + !> Optional formatting string + character(lenFormStr), optional, intent(in) :: optform + + !> Actual formatting string + character(lenFormStr) :: form + + if (present(optform)) then + form = optform + else + form = this%formReal + end if + + write(file, "('@', A, ':real:3:', I0, ',', I0, ',', I0)") trim(tag), shape(data) + write(file, form) data + + end subroutine TTaggedwriter_real3 + + + subroutine TTaggedwriter_real4(this, file, tag, data, optform) + + !> Instance of a tag format writer + type(TTaggedwriter), intent(in) :: this + + !> File ID + integer, intent(in) :: file + + !> Tag label + character(len=*), intent(in) :: tag + + !> Data to print + real(dp), intent(in) :: data(:,:,:,:) + + !> Optional formatting string + character(lenFormStr), optional, intent(in) :: optform + + !> Actual formatting string + character(lenFormStr) :: form + + if (present(optform)) then + form = optform + else + form = this%formReal + end if + + write(file, "('@', A, ':real:4:', I0, ',', I0, ',', I0, ',', I0)") trim(tag), shape(data) + write(file, form) data + + end subroutine TTaggedwriter_real4 + + + subroutine TTaggedwriter_cplx0(this, file, tag, data, optform) + + !> Instance of a tag format writer + type(TTaggedwriter), intent(in) :: this + + !> File ID + integer, intent(in) :: file + + !> Tag label + character(len=*), intent(in) :: tag + + !> Data to print + complex(dp), intent(in) :: data + + !> Optional formatting string + character(lenFormStr), optional, intent(in) :: optform + + !> Actual formatting string + character(lenFormStr) :: form + + if (present(optform)) then + form = optform + else + form = this%formCmplx + end if + + write(file, "('@', A, ':complex:0:')") trim(tag) + write(file, form) data + + end subroutine TTaggedwriter_cplx0 + + + subroutine TTaggedwriter_cplx1(this, file, tag, data, optform) + + !> Instance of a tag format writer + type(TTaggedwriter), intent(in) :: this + + !> File ID + integer, intent(in) :: file + + !> Tag label + character(len=*), intent(in) :: tag + + !> Data to print + complex(dp), intent(in) :: data(:) + + !> Optional formatting string + character(lenFormStr), optional, intent(in) :: optform + + !> Actual formatting string + character(lenFormStr) :: form + + if (present(optform)) then + form = optform + else + form = this%formCmplx + end if + + write(file, "('@', A, ':complex:1:', I0)") trim(tag), shape(data) + write(file, form) data + + end subroutine TTaggedwriter_cplx1 + + + subroutine TTaggedwriter_cplx2(this, file, tag, data, optform) + + !> Instance of a tag format writer + type(TTaggedwriter), intent(in) :: this + + !> File ID + integer, intent(in) :: file + + !> Tag label + character(len=*), intent(in) :: tag + + !> Data to print + complex(dp), intent(in) :: data(:,:) + + !> Optional formatting string + character(lenFormStr), optional, intent(in) :: optform + + !> Actual formatting string + character(lenFormStr) :: form + + if (present(optform)) then + form = optform + else + form = this%formCmplx + end if + + write(file, "('@', A, ':complex:2:', I0, ',', I0)") trim(tag), shape(data) + write(file, form) data + + end subroutine TTaggedwriter_cplx2 + + + subroutine TTaggedwriter_cplx3(this, file, tag, data, optform) + + !> Instance of a tag format writer + type(TTaggedwriter), intent(in) :: this + + !> File ID + integer, intent(in) :: file + + !> Tag label + character(len=*), intent(in) :: tag + + !> Data to print + complex(dp), intent(in) :: data(:,:,:) + + !> Optional formatting string + character(lenFormStr), optional, intent(in) :: optform + + !> Actual formatting string + character(lenFormStr) :: form + + if (present(optform)) then + form = optform + else + form = this%formCmplx + end if + + write(file, "('@', A, ':complex:3:', I0, ',', I0, ',', I0)") trim(tag), shape(data) + write(file, form) data + + end subroutine TTaggedwriter_cplx3 + + + subroutine TTaggedwriter_cplx4(this, file, tag, data, optform) + + !> Instance of a tag format writer + type(TTaggedwriter), intent(in) :: this + + !> File ID + integer, intent(in) :: file + + !> Tag label + character(len=*), intent(in) :: tag + + !> Data to print + complex(dp), intent(in) :: data(:,:,:,:) + + !> Optional formatting string + character(lenFormStr), optional, intent(in) :: optform + + !> Actual formatting string + character(lenFormStr) :: form + + if (present(optform)) then + form = optform + else + form = this%formCmplx + end if + + write(file, "('@', A, ':complex:4:', I0, ',', I0, ',', I0, ',', I0)") trim(tag), shape(data) + write(file, form) data + + end subroutine TTaggedwriter_cplx4 + + + subroutine TTaggedwriter_int0(this, file, tag, data, optform) + + !> Instance of a tag format writer + type(TTaggedwriter), intent(in) :: this + + !> File ID + integer, intent(in) :: file + + !> Tag label + character(len=*), intent(in) :: tag + + !> Data to print + integer, intent(in) :: data + + !> Optional formatting string + character(lenFormStr), optional, intent(in) :: optform + + !> Actual formatting string + character(lenFormStr) :: form + + if (present(optform)) then + form = optform + else + form = this%formInt + end if + + write(file, "('@', A, ':integer:0:')") trim(tag) + write(file, form) data + + end subroutine TTaggedwriter_int0 + + + subroutine TTaggedwriter_int1(this, file, tag, data, optform) + + !> Instance of a tag format writer + type(TTaggedwriter), intent(in) :: this + + !> File ID + integer, intent(in) :: file + + !> Tag label + character(len=*), intent(in) :: tag + + !> Data to print + integer, intent(in) :: data(:) + + !> Optional formatting string + character(lenFormStr), optional, intent(in) :: optform + + !> Actual formatting string + character(lenFormStr) :: form + + if (present(optform)) then + form = optform + else + form = this%formInt + end if + + write(file, "('@', A, ':integer:1:', I0)") trim(tag), shape(data) + write(file, form) data + + end subroutine TTaggedwriter_int1 + + + subroutine TTaggedwriter_int2(this, file, tag, data, optform) + + !> Instance of a tag format writer + type(TTaggedwriter), intent(in) :: this + + !> File ID + integer, intent(in) :: file + + !> Tag label + character(len=*), intent(in) :: tag + + !> Data to print + integer, intent(in) :: data(:,:) + + !> Optional formatting string + character(lenFormStr), optional, intent(in) :: optform + + !> Actual formatting string + character(lenFormStr) :: form + + if (present(optform)) then + form = optform + else + form = this%formInt + end if + + write(file, "('@', A, ':integer:2:', I0, ',', I0)") trim(tag), shape(data) + write(file, form) data + + end subroutine TTaggedwriter_int2 + + + subroutine TTaggedwriter_int3(this, file, tag, data, optform) + + !> Instance of a tag format writer + type(TTaggedwriter), intent(in) :: this + + !> File ID + integer, intent(in) :: file + + !> Tag label + character(len=*), intent(in) :: tag + + !> Data to print + integer, intent(in) :: data(:,:,:) + + !> Optional formatting string + character(lenFormStr), optional, intent(in) :: optform + + !> Actual formatting string + character(lenFormStr) :: form + + if (present(optform)) then + form = optform + else + form = this%formInt + end if + + write(file, "('@', A, ':integer:3:', I0, ',', I0, ',', I0)") trim(tag), shape(data) + write(file, form) data + + end subroutine TTaggedwriter_int3 + + + subroutine TTaggedwriter_int4(this, file, tag, data, optform) + + !> Instance of a tag format writer + type(TTaggedwriter), intent(in) :: this + + !> File ID + integer, intent(in) :: file + + !> Tag label + character(len=*), intent(in) :: tag + + !> Data to print + integer, intent(in) :: data(:,:,:,:) + + !> Optional formatting string + character(lenFormStr), optional, intent(in) :: optform + + !> Actual formatting string + character(lenFormStr) :: form + + if (present(optform)) then + form = optform + else + form = this%formInt + end if + + write(file, "('@', A, ':integer:4:', I0, ',', I0, ',', I0, ',', I0)") trim(tag), shape(data) + write(file, form) data + + end subroutine TTaggedwriter_int4 + + + subroutine TTaggedwriter_logical0(this, file, tag, data, optform) + + !> Instance of a tag format writer + type(TTaggedwriter), intent(in) :: this + + !> File ID + integer, intent(in) :: file + + !> Tag label + character(len=*), intent(in) :: tag + + !> Data to print + logical, intent(in) :: data + + !> Optional formatting string + character(lenFormStr), optional, intent(in) :: optform + + !> Actual formatting string + character(lenFormStr) :: form + + if (present(optform)) then + form = optform + else + form = this%formLogical + end if + + write(file, "('@', A, ':logical:0:')") trim(tag) + write(file, form) data + + end subroutine TTaggedwriter_logical0 + + + subroutine TTaggedwriter_logical1(this, file, tag, data, optform) + + !> Instance of a tag format writer + type(TTaggedwriter), intent(in) :: this + + !> File ID + integer, intent(in) :: file + + !> Tag label + character(len=*), intent(in) :: tag + + !> Data to print + logical, intent(in) :: data(:) + + !> Optional formatting string + character(lenFormStr), optional, intent(in) :: optform + + !> Actual formatting string + character(lenFormStr) :: form + + if (present(optform)) then + form = optform + else + form = this%formLogical + end if + + write(file, "('@', A, ':logical:1:', I0)") trim(tag), shape(data) + write(file, form) data + + end subroutine TTaggedwriter_logical1 + + + subroutine TTaggedwriter_logical2(this, file, tag, data, optform) + + !> Instance of a tag format writer + type(TTaggedwriter), intent(in) :: this + + !> File ID + integer, intent(in) :: file + + !> Tag label + character(len=*), intent(in) :: tag + + !> Data to print + logical, intent(in) :: data(:,:) + + !> Optional formatting string + character(lenFormStr), optional, intent(in) :: optform + + !> Actual formatting string + character(lenFormStr) :: form + + if (present(optform)) then + form = optform + else + form = this%formLogical + end if + + write(file, "('@', A, ':logical:2:', I0, ',', I0)") trim(tag), shape(data) + write(file, form) data + + end subroutine TTaggedwriter_logical2 + + + subroutine TTaggedwriter_logical3(this, file, tag, data, optform) + + !> Instance of a tag format writer + type(TTaggedwriter), intent(in) :: this + + !> File ID + integer, intent(in) :: file + + !> Tag label + character(len=*), intent(in) :: tag + + !> Data to print + logical, intent(in) :: data(:,:,:) + + !> Optional formatting string + character(lenFormStr), optional, intent(in) :: optform + + !> Actual formatting string + character(lenFormStr) :: form + + if (present(optform)) then + form = optform + else + form = this%formLogical + end if + + write(file, "('@', A, ':logical:3:', I0, ',', I0, ',', I0)") trim(tag), shape(data) + write(file, form) data + + end subroutine TTaggedwriter_logical3 + + + subroutine TTaggedwriter_logical4(this, file, tag, data, optform) + + !> Instance of a tag format writer + type(TTaggedwriter), intent(in) :: this + + !> File ID + integer, intent(in) :: file + + !> Tag label + character(len=*), intent(in) :: tag + + !> Data to print + logical, intent(in) :: data(:,:,:,:) + + !> Optional formatting string + character(lenFormStr), optional, intent(in) :: optform + + !> Actual formatting string + character(lenFormStr) :: form + + if (present(optform)) then + form = optform + else + form = this%formLogical + end if + + write(file, "('@', A, ':logical:4:', I0, ',', I0, ',', I0, ',', I0)") trim(tag), shape(data) + write(file, form) data + + end subroutine TTaggedwriter_logical4 + +end module common_taggedout diff --git a/common/lib/taggedout.f90 b/common/lib/taggedout.f90 deleted file mode 100644 index d7e478b5..00000000 --- a/common/lib/taggedout.f90 +++ /dev/null @@ -1,548 +0,0 @@ -!> Contains routines to write out various data structures in a comprehensive -!! tagged format. -module taggedout - use accuracy, only : dp - implicit none - private - - public :: taggedwriter, init, writetag, taglen - - integer, parameter :: taglen = 40 - integer, parameter :: formlen = 20 - - type :: taggedwriter - character(formlen) :: form_real - character(formlen) :: form_cmplx - character(formlen) :: form_int - character(formlen) :: form_logical - end type taggedwriter - - interface init - module procedure taggedwriter_init - end interface - - !> Writes objects in a standardized tagged form to a given file. - interface writetag - module procedure taggedwriter_real0 - module procedure taggedwriter_real1 - module procedure taggedwriter_real2 - module procedure taggedwriter_real3 - module procedure taggedwriter_real4 - module procedure taggedwriter_cplx0 - module procedure taggedwriter_cplx1 - module procedure taggedwriter_cplx2 - module procedure taggedwriter_cplx3 - module procedure taggedwriter_cplx4 - module procedure taggedwriter_int0 - module procedure taggedwriter_int1 - module procedure taggedwriter_int2 - module procedure taggedwriter_int3 - module procedure taggedwriter_int4 - module procedure taggedwriter_logical0 - module procedure taggedwriter_logical1 - module procedure taggedwriter_logical2 - module procedure taggedwriter_logical3 - module procedure taggedwriter_logical4 - end interface - - -contains - - !> Initializes the tagged writer. - subroutine taggedwriter_init(self) - type(taggedwriter), intent(out) :: self - - integer :: ndec, nexp, nchar, nfield - - !! "-3.1234567E-123 ": nDec = 7, nexp = 3, nchar = 16 - nexp = ceiling(log(maxexponent(1.0_dp)/log(10.0))/log(10.0)) - ndec = precision(1.0_dp) - nchar = ndec + nexp + 6 - nfield = 80 / nchar - if (nfield == 0) then - nfield = 1 - end if - -99000 format('(', I2.2, 'ES', I2.2, '.', I2.2, 'E', I3.3, ')') - write(self%form_real, 99000) nfield, nchar, ndec, nexp - -99010 format('(', I2.2, '(2ES', I2.2, '.', I2.2, 'E', I3.3, '))') - write(self%form_cmplx, 99010) nfield/2, nchar, ndec, nexp - - !! "-12345 " - nchar = digits(1) + 2 - nfield = 80 / nchar - if (nfield == 0) then - nfield = 1 - end if - -99020 format('(', I2.2, 'I', I2.2, ')') - write (self%form_int, 99020) nfield, nchar - -99030 format('(40L2)') - write(self%form_logical, 99030) - - end subroutine taggedwriter_init - - - - subroutine taggedwriter_real0(self, file, tag, val, optform) - type(taggedwriter), intent(in) :: self - integer, intent(in) :: file - character(*), intent(in) :: tag - real(dp), intent(in) :: val - character(formlen), optional, intent(in) :: optform - - character(formlen) :: form - - if (present(optform)) then - form = optform - else - form = self%form_real - end if - -99040 format('@', A, ':real:0:') - write(file, 99040) trim(tag) - write(file, form) val - - end subroutine taggedwriter_real0 - - - - subroutine taggedwriter_real1(self, file, tag, val, optform) - type(taggedwriter), intent(in) :: self - integer, intent(in) :: file - character(len=*), intent(in) :: tag - real(dp), intent(in) :: val(:) - character(formlen), optional, intent(in) :: optform - - character(formlen) :: form - - if (present(optform)) then - form = optform - else - form = self%form_real - end if - -99050 format('@', A, ':real:1:', I0) - write(file, 99050) trim(tag), shape(val) - write(file, form) val - - end subroutine taggedwriter_real1 - - - - subroutine taggedwriter_real2(self, file, tag, val, optform) - type(taggedwriter), intent(in) :: self - integer, intent(in) :: file - character(*), intent(in) :: tag - real(dp), intent(in) :: val(:,:) - character(formlen), optional, intent(in) :: optform - - character(formlen) :: form - - if (present(optform)) then - form = optform - else - form = self%form_real - end if - -99060 format('@', A, ':real:2:', I0, ',', I0) - write(file, 99060) trim(tag), shape(val) - write(file, form) val - - end subroutine taggedwriter_real2 - - - - subroutine taggedwriter_real3(self, file, tag, val, optform) - type(taggedwriter), intent(in) :: self - integer, intent(in) :: file - character(*), intent(in) :: tag - real(dp), intent(in) :: val(:,:,:) - character(formlen), optional, intent(in) :: optform - - character(formlen) :: form - - if (present(optform)) then - form = optform - else - form = self%form_real - end if - -99070 format('@', A, ':real:3:', I0, ',', I0, ',', I0) - write(file, 99070) trim(tag), shape(val) - write(file, form) val - - end subroutine taggedwriter_real3 - - - - subroutine taggedwriter_real4(self, file, tag, val, optform) - type(taggedwriter), intent(in) :: self - integer, intent(in) :: file - character(*), intent(in) :: tag - real(dp), intent(in) :: val(:,:,:,:) - character(formlen), optional, intent(in) :: optform - - character(formlen) :: form - - if (present(optform)) then - form = optform - else - form = self%form_real - end if - -99080 format('@', A, ':real:4:', I0, ',', I0, ',', I0, ',', I0) - write(file, 99080) trim(tag), shape(val) - write(file, form) val - - end subroutine taggedwriter_real4 - - - - subroutine taggedwriter_cplx0(self, file, tag, val, optform) - type(taggedwriter), intent(in) :: self - integer, intent(in) :: file - character(*), intent(in) :: tag - complex(dp), intent(in) :: val - character(formlen), optional, intent(in) :: optform - - character(formlen) :: form - - if (present(optform)) then - form = optform - else - form = self%form_cmplx - end if - -99090 format('@', A, ':complex:0:') - write(file, 99090) trim(tag) - write(file, form) val - - end subroutine taggedwriter_cplx0 - - - - subroutine taggedwriter_cplx1(self, file, tag, val, optform) - type(taggedwriter), intent(in) :: self - integer, intent(in) :: file - character(*), intent(in) :: tag - complex(dp), intent(in) :: val(:) - character(formlen), optional, intent(in) :: optform - - character(formlen) :: form - - if (present(optform)) then - form = optform - else - form = self%form_cmplx - end if - -99100 format('@', A, ':complex:1:', I0) - write(file, 99100) trim(tag), shape(val) - write(file, form) val - - end subroutine taggedwriter_cplx1 - - - - subroutine taggedwriter_cplx2(self, file, tag, val, optform) - type(taggedwriter), intent(in) :: self - integer, intent(in) :: file - character(*), intent(in) :: tag - complex(dp), intent(in) :: val(:,:) - character(formlen), optional, intent(in) :: optform - - character(formlen) :: form - - if (present(optform)) then - form = optform - else - form = self%form_cmplx - end if - -99110 format('@', A, ':complex:2:', I0, ',', I0) - write(file, 99110) trim(tag), shape(val) - write(file, form) val - - end subroutine taggedwriter_cplx2 - - - - subroutine taggedwriter_cplx3(self, file, tag, val, optform) - type(taggedwriter), intent(in) :: self - integer, intent(in) :: file - character(*), intent(in) :: tag - complex(dp), intent(in) :: val(:,:,:) - character(formlen), optional, intent(in) :: optform - - character(formlen) :: form - - if (present(optform)) then - form = optform - else - form = self%form_cmplx - end if - -99120 format('@', A, ':complex:3:', I0, ',', I0, ',', I0) - write(file, 99120) trim(tag), shape(val) - write(file, form) val - - end subroutine taggedwriter_cplx3 - - - - subroutine taggedwriter_cplx4(self, file, tag, val, optform) - type(taggedwriter), intent(in) :: self - integer, intent(in) :: file - character(*), intent(in) :: tag - complex(dp), intent(in) :: val(:,:,:,:) - character(formlen), optional, intent(in) :: optform - - character(formlen) :: form - - if (present(optform)) then - form = optform - else - form = self%form_cmplx - end if - -99130 format('@', A, ':complex:4:', I0, ',', I0, ',', I0, ',', I0) - write(file, 99130) trim(tag), shape(val) - write(file, form) val - - end subroutine taggedwriter_cplx4 - - - - subroutine taggedwriter_int0(self, file, tag, val, optform) - type(taggedwriter), intent(in) :: self - integer, intent(in) :: file - character(*), intent(in) :: tag - integer, intent(in) :: val - character(formlen), optional, intent(in) :: optform - - character(formlen) :: form - - if (present(optform)) then - form = optform - else - form = self%form_int - end if - -99140 format('@', A, ':integer:0:') - write(file, 99140) trim(tag) - write(file, form) val - - end subroutine taggedwriter_int0 - - - - subroutine taggedwriter_int1(self, file, tag, val, optform) - type(taggedwriter), intent(in) :: self - integer, intent(in) :: file - character(*), intent(in) :: tag - integer, intent(in) :: val(:) - character(formlen), optional, intent(in) :: optform - - character(formlen) :: form - - if (present(optform)) then - form = optform - else - form = self%form_int - end if - -99150 format('@', A, ':integer:1:', I0) - write(file, 99150) trim(tag), shape(val) - write(file, form) val - - end subroutine taggedwriter_int1 - - - - subroutine taggedwriter_int2(self, file, tag, val, optform) - type(taggedwriter), intent(in) :: self - integer, intent(in) :: file - character(*), intent(in) :: tag - integer, intent(in) :: val(:,:) - character(formlen), optional, intent(in) :: optform - - character(formlen) :: form - - if (present(optform)) then - form = optform - else - form = self%form_int - end if - -99160 format('@', A, ':integer:2:', I0, ',', I0) - write(file, 99160) trim(tag), shape(val) - write(file, form) val - - end subroutine taggedwriter_int2 - - - - subroutine taggedwriter_int3(self, file, tag, val, optform) - type(taggedwriter), intent(in) :: self - integer, intent(in) :: file - character(*), intent(in) :: tag - integer, intent(in) :: val(:,:,:) - character(formlen), optional, intent(in) :: optform - - character(formlen) :: form - - if (present(optform)) then - form = optform - else - form = self%form_int - end if - -99170 format('@', A, ':integer:3:', I0, ',', I0, ',', I0) - write(file, 99170) trim(tag), shape(val) - write(file, form) val - - end subroutine taggedwriter_int3 - - - - subroutine taggedwriter_int4(self, file, tag, val, optform) - type(taggedwriter), intent(in) :: self - integer, intent(in) :: file - character(*), intent(in) :: tag - integer, intent(in) :: val(:,:,:,:) - character(formlen), optional, intent(in) :: optform - - character(formlen) :: form - - if (present(optform)) then - form = optform - else - form = self%form_int - end if - -99180 format('@', A, ':integer:4:', I0, ',', I0, ',', I0, ',', I0) - write(file, 99180) trim(tag), shape(val) - write(file, form) val - - end subroutine taggedwriter_int4 - - - - subroutine taggedwriter_logical0(self, file, tag, val, optform) - type(taggedwriter), intent(in) :: self - integer, intent(in) :: file - character(*), intent(in) :: tag - logical, intent(in) :: val - character(formlen), optional, intent(in) :: optform - - character(formlen) :: form - - if (present(optform)) then - form = optform - else - form = self%form_logical - end if - -99190 format('@', A, ':logical:0:') - write(file, 99190) trim(tag) - write(file, form) val - - end subroutine taggedwriter_logical0 - - - - subroutine taggedwriter_logical1(self, file, tag, val, optform) - type(taggedwriter), intent(in) :: self - integer, intent(in) :: file - character(*), intent(in) :: tag - logical, intent(in) :: val(:) - character(formlen), optional, intent(in) :: optform - - character(formlen) :: form - - if (present(optform)) then - form = optform - else - form = self%form_logical - end if - -99200 format('@', A, ':logical:1:', I0) - write(file, 99200) trim(tag), shape(val) - write(file, form) val - - end subroutine taggedwriter_logical1 - - - - subroutine taggedwriter_logical2(self, file, tag, val, optform) - type(taggedwriter), intent(in) :: self - integer, intent(in) :: file - character(*), intent(in) :: tag - logical, intent(in) :: val(:,:) - character(formlen), optional, intent(in) :: optform - - character(formlen) :: form - - if (present(optform)) then - form = optform - else - form = self%form_logical - end if - -99210 format('@', A, ':logical:2:', I0, ',', I0) - write(file, 99210) trim(tag), shape(val) - write(file, form) val - - end subroutine taggedwriter_logical2 - - - - subroutine taggedwriter_logical3(self, file, tag, val, optform) - type(taggedwriter), intent(in) :: self - integer, intent(in) :: file - character(*), intent(in) :: tag - logical, intent(in) :: val(:,:,:) - character(formlen), optional, intent(in) :: optform - - character(formlen) :: form - - if (present(optform)) then - form = optform - else - form = self%form_logical - end if - -99220 format('@', A, ':logical:3:', I0, ',', I0, ',', I0) - write(file, 99220) trim(tag), shape(val) - write(file, form) val - - end subroutine taggedwriter_logical3 - - - - subroutine taggedwriter_logical4(self, file, tag, val, optform) - type(taggedwriter), intent(in) :: self - integer, intent(in) :: file - character(*), intent(in) :: tag - logical, intent(in) :: val(:,:,:,:) - character(formlen), optional, intent(in) :: optform - - character(formlen) :: form - - if (present(optform)) then - form = optform - else - form = self%form_logical - end if - -99230 format('@', A, ':logical:4:', I0, ',', I0, ',', I0, ',', I0) - write(file, 99230) trim(tag), shape(val) - write(file, form) val - - end subroutine taggedwriter_logical4 - - -end module taggedout diff --git a/sktools/bin/collectspinw b/sktools/bin/collectspinw index 29602e45..96a90790 100755 --- a/sktools/bin/collectspinw +++ b/sktools/bin/collectspinw @@ -1,16 +1,23 @@ #!/usr/bin/env python3 + +''' +Module +''' + import argparse from sktools.skdef import Skdef import sktools.skgen as skgen import sktools.common as sc -HELP_TXT = """Collects spin coupling constants by iterating over the -elements defined in skdef.hsd. If the atomic calculation has been done already, -it will be reused, otherwised it is done on the fly. -""" + +USAGE = \ + '''Collects spin coupling constants by iterating over the + elements defined in skdef.hsd. If the atomic calculation has been done already, + it will be reused, otherwised it is done on the fly. + ''' SCRIPTNAME = sc.get_script_name() -SPINW_FILE_NAME = "spinw.txt" +SPINW_FILE_NAME = 'spinw.txt' def main(): @@ -37,7 +44,7 @@ def main(): def parseargs(): - parser = argparse.ArgumentParser(description=HELP_TXT) + parser = argparse.ArgumentParser(description=USAGE) parser.add_argument( "-b", "--build-dir", default="_build", dest="builddir", help="build directory (default: _build)") diff --git a/sktwocnt/lib/bisection.f90 b/sktwocnt/lib/bisection.f90 index 9e4fbb01..6e24f0a9 100644 --- a/sktwocnt/lib/bisection.f90 +++ b/sktwocnt/lib/bisection.f90 @@ -1,6 +1,8 @@ !> Contains routines to locate a value in an array using bisection. module bisection - use accuracy, only : dp + + use common_accuracy, only : dp + implicit none private diff --git a/sktwocnt/lib/coordtrans.f90 b/sktwocnt/lib/coordtrans.f90 index fc63a5dc..cd87cd1c 100644 --- a/sktwocnt/lib/coordtrans.f90 +++ b/sktwocnt/lib/coordtrans.f90 @@ -1,6 +1,8 @@ module coordtrans - use accuracy - use constants + + use common_accuracy, only : dp + use common_constants + implicit none contains diff --git a/sktwocnt/lib/dftbxc.f90 b/sktwocnt/lib/dftbxc.f90 index 90c320ed..84f5bfa7 100644 --- a/sktwocnt/lib/dftbxc.f90 +++ b/sktwocnt/lib/dftbxc.f90 @@ -1,7 +1,9 @@ module dftxc + use, intrinsic :: ieee_arithmetic - use accuracy - use constants + use common_accuracy, only : dp + use common_constants + implicit none private diff --git a/sktwocnt/lib/gridgenerator.f90 b/sktwocnt/lib/gridgenerator.f90 index 7137b043..f5910a2d 100644 --- a/sktwocnt/lib/gridgenerator.f90 +++ b/sktwocnt/lib/gridgenerator.f90 @@ -1,6 +1,8 @@ module gridgenerator - use accuracy + + use common_accuracy, only : dp use quadratures + implicit none contains @@ -9,7 +11,7 @@ subroutine gengrid1_12(quads, coordtrans, grid, weights) type(quadrature), intent(in) :: quads(2) interface subroutine coordtrans(oldc, newc, jacobi) - use accuracy, only : dp + use common_accuracy, only : dp real(dp), intent(in) :: oldc(:) real(dp), intent(out) :: newc(:) real(dp), intent(out) :: jacobi @@ -48,13 +50,13 @@ subroutine gengrid2_12(quads, coordtrans, partition, partparams, dist,& type(quadrature), intent(in) :: quads(2) interface subroutine coordtrans(oldc, newc, jacobi) - use accuracy, only : dp + use common_accuracy, only : dp real(dp), intent(in) :: oldc(:) real(dp), intent(out) :: newc(:) real(dp), intent(out) :: jacobi end subroutine coordtrans function partition(r1, r2, dist, params) - use accuracy, only : dp + use common_accuracy, only : dp real(dp), intent(in) :: r1, r2, dist, params(:) real(dp) :: partition end function partition diff --git a/sktwocnt/lib/gridorbital.f90 b/sktwocnt/lib/gridorbital.f90 index 811d5f8a..ec811d58 100644 --- a/sktwocnt/lib/gridorbital.f90 +++ b/sktwocnt/lib/gridorbital.f90 @@ -1,9 +1,11 @@ !> Implements a grid-type orbital. module gridorbital - use accuracy - use constants + + use common_accuracy, only : dp + use common_constants use bisection use interpolation + implicit none private diff --git a/sktwocnt/lib/interpolation.f90 b/sktwocnt/lib/interpolation.f90 index 37cda1b8..b6942602 100644 --- a/sktwocnt/lib/interpolation.f90 +++ b/sktwocnt/lib/interpolation.f90 @@ -1,6 +1,8 @@ !!* Contains routines for interpolation and extrapolation module interpolation - use accuracy + + use common_accuracy, only : dp + implicit none private diff --git a/sktwocnt/lib/partition.f90 b/sktwocnt/lib/partition.f90 index dae74d4f..fe1e8192 100644 --- a/sktwocnt/lib/partition.f90 +++ b/sktwocnt/lib/partition.f90 @@ -1,6 +1,8 @@ !> Conains space partioning functions. module partition - use accuracy + + use common_accuracy, only : dp + implicit none private diff --git a/sktwocnt/lib/quadrature.f90 b/sktwocnt/lib/quadrature.f90 index 94e94a2c..657e4f9c 100644 --- a/sktwocnt/lib/quadrature.f90 +++ b/sktwocnt/lib/quadrature.f90 @@ -1,6 +1,8 @@ module quadratures - use accuracy - use constants + + use common_accuracy, only : dp + use common_constants + implicit none type quadrature diff --git a/sktwocnt/lib/sphericalharmonics.f90 b/sktwocnt/lib/sphericalharmonics.f90 index ebff2da3..8025d76a 100644 --- a/sktwocnt/lib/sphericalharmonics.f90 +++ b/sktwocnt/lib/sphericalharmonics.f90 @@ -1,6 +1,8 @@ !> Spherical harmonics. module sphericalharmonics - use accuracy + + use common_accuracy, only : dp + implicit none private diff --git a/sktwocnt/lib/twocnt.f90 b/sktwocnt/lib/twocnt.f90 index 0b0e2d35..2d5ff785 100644 --- a/sktwocnt/lib/twocnt.f90 +++ b/sktwocnt/lib/twocnt.f90 @@ -1,8 +1,9 @@ !> Contains the twocenter integrator routines. module twocnt + use omp_lib - use accuracy - use constants + use common_accuracy, only : dp + use common_constants use quadratures use coordtrans use gridorbital @@ -10,7 +11,8 @@ module twocnt use gridgenerator use partition use dftxc - use fifo_module + use common_fifo + implicit none private @@ -63,11 +65,11 @@ subroutine get_twocenter_integrals(inp, imap, skham, skover) type(twocnt_in), target, intent(in) :: inp type(integmap), intent(out) :: imap real(dp), allocatable, intent(out) :: skham(:,:), skover(:,:) - + type(quadrature) :: quads(2) type(atomdata), pointer :: atom1, atom2 - type(fifo_real2) :: hamfifo, overfifo + type(TFiFoReal2) :: hamfifo, overfifo real(dp), allocatable :: grid1(:,:), grid2(:,:) real(dp), allocatable :: dots(:), weights(:) real(dp), allocatable :: denserr(:) diff --git a/sktwocnt/prog/input.f90 b/sktwocnt/prog/input.f90 index 237e3028..89191b82 100644 --- a/sktwocnt/prog/input.f90 +++ b/sktwocnt/prog/input.f90 @@ -1,5 +1,6 @@ module input - use accuracy + + use common_accuracy, only : dp use gridorbital use twocnt, only: twocnt_in, atomdata implicit none diff --git a/sktwocnt/prog/main.f90 b/sktwocnt/prog/main.f90 index 0b0a474d..3f1b3c64 100644 --- a/sktwocnt/prog/main.f90 +++ b/sktwocnt/prog/main.f90 @@ -1,5 +1,6 @@ program main - use accuracy + + use common_accuracy, only : dp use input use twocnt use output diff --git a/sktwocnt/prog/output.f90 b/sktwocnt/prog/output.f90 index f50b608a..59ae7d24 100644 --- a/sktwocnt/prog/output.f90 +++ b/sktwocnt/prog/output.f90 @@ -1,6 +1,8 @@ !> Output routines for the sktwocnt code. module output - use accuracy + + use common_accuracy, only : dp + implicit none private diff --git a/slateratom/lib/broyden.f90 b/slateratom/lib/broyden.f90 index 5906fba7..edea85b7 100644 --- a/slateratom/lib/broyden.f90 +++ b/slateratom/lib/broyden.f90 @@ -1,5 +1,7 @@ module broyden - use accuracy + + use common_accuracy, only : dp + implicit none private diff --git a/slateratom/lib/core_overlap.f90 b/slateratom/lib/core_overlap.f90 index d766d858..22923ed6 100644 --- a/slateratom/lib/core_overlap.f90 +++ b/slateratom/lib/core_overlap.f90 @@ -1,8 +1,10 @@ module core_overlap - use accuracy - use constants + + use common_accuracy, only : dp + use common_constants use utilities use integration + implicit none private diff --git a/slateratom/lib/coulomb_hfex.f90 b/slateratom/lib/coulomb_hfex.f90 index 65ff8f83..04631eec 100644 --- a/slateratom/lib/coulomb_hfex.f90 +++ b/slateratom/lib/coulomb_hfex.f90 @@ -1,8 +1,10 @@ module coulomb_hfex - use accuracy - use constants + + use common_accuracy, only : dp + use common_constants use utilities use core_overlap + implicit none private diff --git a/slateratom/lib/coulomb_potential.f90 b/slateratom/lib/coulomb_potential.f90 index ec9cad7f..13aa5d73 100644 --- a/slateratom/lib/coulomb_potential.f90 +++ b/slateratom/lib/coulomb_potential.f90 @@ -4,7 +4,7 @@ module coulomb_potential ! during SCF except in the ZORA case, but even then the Coulomb matrix ! (J supermatrix) elements are calculated directly - use accuracy + use common_accuracy, only : dp use utilities use integration use core_overlap diff --git a/slateratom/lib/density.f90 b/slateratom/lib/density.f90 index 2496f7e7..5a662524 100644 --- a/slateratom/lib/density.f90 +++ b/slateratom/lib/density.f90 @@ -1,6 +1,8 @@ module density - use accuracy + + use common_accuracy, only : dp use utilities + implicit none private diff --git a/slateratom/lib/densitymatrix.f90 b/slateratom/lib/densitymatrix.f90 index 0bde7f43..c44a852a 100644 --- a/slateratom/lib/densitymatrix.f90 +++ b/slateratom/lib/densitymatrix.f90 @@ -1,7 +1,9 @@ module densitymatrix - use accuracy - use constants + + use common_accuracy, only : dp + use common_constants use utilities + implicit none private diff --git a/slateratom/lib/dft.f90 b/slateratom/lib/dft.f90 index c8981fd8..84f925ab 100644 --- a/slateratom/lib/dft.f90 +++ b/slateratom/lib/dft.f90 @@ -1,10 +1,12 @@ module dft + use, intrinsic :: iso_c_binding, only : c_size_t - use accuracy - use constants + use common_accuracy, only : dp + use common_constants use density use integration use xc_f90_lib_m + implicit none private diff --git a/slateratom/lib/diagonalizations.f90 b/slateratom/lib/diagonalizations.f90 index cd7b2087..7493e0b8 100644 --- a/slateratom/lib/diagonalizations.f90 +++ b/slateratom/lib/diagonalizations.f90 @@ -1,5 +1,7 @@ module diagonalizations - use accuracy + + use common_accuracy, only : dp + implicit none private @@ -189,7 +191,7 @@ end subroutine diagonalize ! ********************************************************************** ! SUBROUTINE EWEVGE (NA,NB,N,A,B,EW,H,IEV,IORD,IER) - use accuracy + use common_accuracy, only : dp IMPLICIT NONE integer, intent(in) :: NA,NB,N integer, intent(in) :: iev,iord @@ -244,7 +246,7 @@ END SUBROUTINE EWEVGE ! ****************************************************************** ! SUBROUTINE CHOLES (N,B,NB,ICHO) - use accuracy + use common_accuracy, only : dp IMPLICIT NONE integer :: N,NB,ICHO,i,ii,j,K,i1 real(dp) :: B,d,s @@ -298,7 +300,7 @@ END SUBROUTINE CHOLES ! ********************************************************************* ! SUBROUTINE MATRAF (N,A,NA,B,NB,H) - use accuracy + use common_accuracy, only : dp IMPLICIT NONE integer :: N,NA,NB,i,j,ii,k,i1 real(dp) :: A,B,H,s,d @@ -370,7 +372,7 @@ END SUBROUTINE MATRAF ! ****************************************************************** ! SUBROUTINE TRIDIA (NM,N,D,E,A,IEV) - use accuracy + use common_accuracy, only : dp IMPLICIT NONE integer :: NM,N,iev,i,j,ii,K,JP1,L real(dp) :: A,D,E,H,HH,G,F,scale @@ -536,7 +538,7 @@ END SUBROUTINE TRIDIA ! ********************************************************************** ! SUBROUTINE IQLDIA (NM,N,D,E,Z,IEV,IER) - use accuracy + use common_accuracy, only : dp IMPLICIT NONE integer :: NM,N,iev,ier,i,j,ii,k,M,L,MM1,KK,MML real(dp) :: E,Z,D,DD,P,G,R,S,T,PSI,PSJ,F,B,C,anorm @@ -781,8 +783,8 @@ END SUBROUTINE IQLDIA ! ! ********************************************************************** ! - SUBROUTINE BACKTR (N,M,R,NR,X,NX,Y,NY,H) - use accuracy + SUBROUTINE BACKTR(N,M,R,NR,X,NX,Y,NY,H) + use common_accuracy, only : dp IMPLICIT NONE integer :: N,M,NR,NX,NY,i,j,ii,I1,K real(dp) :: R,X,Y,H,D,S @@ -839,7 +841,7 @@ END SUBROUTINE BACKTR ! ********************************************************************** ! SUBROUTINE SORTVC (NM,N,NQ,D,Q,M,IEV,E) - use accuracy + use common_accuracy, only : dp IMPLICIT NONE integer :: NM,M,NQ,IEV,i,j,ii,KK,K,N real(dp) :: D,Q,E,H,S diff --git a/slateratom/lib/globals.f90 b/slateratom/lib/globals.f90 index 957bd82c..196152dc 100644 --- a/slateratom/lib/globals.f90 +++ b/slateratom/lib/globals.f90 @@ -1,5 +1,7 @@ module globals - use accuracy + + use common_accuracy, only : dp + implicit none real(dp) :: conf_r0(0:4) ! confinement radius diff --git a/slateratom/lib/hamiltonian.f90 b/slateratom/lib/hamiltonian.f90 index c07653de..e20fcb27 100644 --- a/slateratom/lib/hamiltonian.f90 +++ b/slateratom/lib/hamiltonian.f90 @@ -1,10 +1,12 @@ module hamiltonian - use accuracy - use constants + + use common_accuracy, only : dp + use common_constants use dft use broyden use utilities use zora_routines + implicit none private diff --git a/slateratom/lib/input.f90 b/slateratom/lib/input.f90 index c13ceaa2..f25af8bb 100644 --- a/slateratom/lib/input.f90 +++ b/slateratom/lib/input.f90 @@ -1,6 +1,8 @@ !!* Read input from stdin module input - use accuracy + + use common_accuracy, only : dp + implicit none private diff --git a/slateratom/lib/integration.f90 b/slateratom/lib/integration.f90 index 5f0b742c..75647b12 100644 --- a/slateratom/lib/integration.f90 +++ b/slateratom/lib/integration.f90 @@ -1,6 +1,7 @@ module integration - use accuracy - use constants + + use common_accuracy, only : dp + use common_constants use utilities implicit none private diff --git a/slateratom/lib/numerical_differentiation.f90 b/slateratom/lib/numerical_differentiation.f90 index 6fb63722..7abec733 100644 --- a/slateratom/lib/numerical_differentiation.f90 +++ b/slateratom/lib/numerical_differentiation.f90 @@ -1,8 +1,10 @@ module numerical_differentiation - use accuracy - use constants + + use common_accuracy, only : dp + use common_constants use utilities use integration + implicit none private diff --git a/slateratom/lib/output.f90 b/slateratom/lib/output.f90 index ccfa2c1f..78ced5b6 100644 --- a/slateratom/lib/output.f90 +++ b/slateratom/lib/output.f90 @@ -1,11 +1,13 @@ module output - use accuracy - use constants + + use common_accuracy, only : dp + use common_constants, only : pi use core_overlap use density use coulomb_potential - use taggedout + use common_taggedout, only : TTaggedwriter, TTaggedwriter_init, writetag use utilities, only : fak + implicit none private @@ -14,7 +16,7 @@ module output public :: write_waves_file_standard, cusp_values, write_energies_tagged public :: write_wave_coeffs_file - character(1), parameter :: orbnames(0:4) = (/ "s", "p", "d", "f", "g" /) + character(1), parameter :: orbnames(0:4) = ["s", "p", "d", "f", "g"] contains @@ -474,9 +476,9 @@ subroutine write_energies_tagged(ekin, enuc, ecoul, exc, econf, etot, zora,& real(dp), intent(in) :: eigvals(:,0:,:), occ(:,0:,:) integer :: fp - type(TaggedWriter) :: twriter + type(TTaggedwriter) :: twriter - call init(twriter) + call TTaggedwriter_init(twriter) fp = 95 open(fp, file="energies.tag", status="replace", action="write") call writetag(twriter, fp, "zora", zora) @@ -504,11 +506,11 @@ subroutine write_wave_coeffs_file(max_l, num_alpha, poly_order, cof, & integer, intent(in) :: qnvalorbs(:,0:) integer :: fp, ii, ll, ncoeff - type(TaggedWriter) :: twriter + type(TTaggedwriter) :: twriter character(20) :: fname real(dp), allocatable :: coeffs(:,:) - call init(twriter) + call TTaggedwriter_init(twriter) fp = 95 do ll = 0, max_l ncoeff = poly_order(ll) * num_alpha(ll) diff --git a/slateratom/lib/total_energy.f90 b/slateratom/lib/total_energy.f90 index ee4e0b43..32b161f6 100644 --- a/slateratom/lib/total_energy.f90 +++ b/slateratom/lib/total_energy.f90 @@ -1,7 +1,9 @@ module totalenergy - use accuracy - use constants + + use common_accuracy, only : dp + use common_constants use dft + implicit none private diff --git a/slateratom/lib/utilities.f90 b/slateratom/lib/utilities.f90 index d16d066f..5cca3703 100644 --- a/slateratom/lib/utilities.f90 +++ b/slateratom/lib/utilities.f90 @@ -1,6 +1,8 @@ module utilities - use accuracy - use constants + + use common_accuracy, only : dp + use common_constants + implicit none private diff --git a/slateratom/lib/zora_routines.f90 b/slateratom/lib/zora_routines.f90 index b6f26f74..a614c38a 100644 --- a/slateratom/lib/zora_routines.f90 +++ b/slateratom/lib/zora_routines.f90 @@ -1,9 +1,10 @@ module zora_routines - use accuracy - use constants + + use common_accuracy, only : dp + use common_constants use coulomb_potential -! use numerical_differentiation use density + implicit none private @@ -130,7 +131,7 @@ subroutine scaled_zora(eigval,max_l,num_alpha,alpha,& zora_ekin=0.0d0 zora_ekin1=0.0d0 zora_ekin2=0.0d0 - tsol2=1.0_dp/sol**2 + tsol2=1.0_dp/cc**2 call zora_t_correction(1,zscale,max_l,num_alpha,alpha,poly_order,& &num_mesh_points,weight,abcissa,vxc,rho,nuc,p,problemsize) @@ -283,7 +284,7 @@ subroutine kappa_to_mesh(num_mesh_points,vtot,kappa,kappa2) real(dp), intent(out) :: kappa(:,:),kappa2(:,:) integer :: ii - real(dp), parameter :: tsol2 =2.0_dp*sol**2 + real(dp), parameter :: tsol2 =2.0_dp*cc**2 do ii=1,num_mesh_points diff --git a/slateratom/prog/main.f90 b/slateratom/prog/main.f90 index 1d8b9648..03caf227 100644 --- a/slateratom/prog/main.f90 +++ b/slateratom/prog/main.f90 @@ -1,5 +1,6 @@ program HFAtom - use accuracy + + use common_accuracy, only : dp use globals use integration use input From 8fa13bf99fc20e0eb66802e530876ee9ec860b85 Mon Sep 17 00:00:00 2001 From: Tammo van der Heide Date: Tue, 23 Nov 2021 12:21:17 +0100 Subject: [PATCH 04/17] Revise sktools codebase --- sktools/bin/collectspinw | 79 ++--- sktools/bin/collectwavecoeffs | 119 ++++---- sktools/bin/skdiff | 94 +++--- sktools/bin/skgen | 189 ++++++------ sktools/bin/skmanip | 8 +- sktools/src/sktools/__init__.py | 2 +- sktools/src/sktools/common.py | 364 ++++++++++++++++++----- sktools/src/sktools/compressions.py | 65 ++-- sktools/src/sktools/hsd/converter.py | 4 +- sktools/src/sktools/hsd/formatter.py | 36 +-- sktools/src/sktools/hsd/parser.py | 104 +++---- sktools/src/sktools/hsd/query.py | 48 +-- sktools/src/sktools/hsd/tree.py | 6 +- sktools/src/sktools/hsd/treebuilder.py | 10 +- sktools/src/sktools/skdef.py | 18 +- sktools/src/sktools/skgen/atom.py | 1 - sktools/src/sktools/skgen/compression.py | 81 +++-- sktools/src/sktools/taggedfile.py | 1 - 18 files changed, 750 insertions(+), 479 deletions(-) diff --git a/sktools/bin/collectspinw b/sktools/bin/collectspinw index 96a90790..295e7c05 100755 --- a/sktools/bin/collectspinw +++ b/sktools/bin/collectspinw @@ -1,8 +1,6 @@ #!/usr/bin/env python3 -''' -Module -''' +'''Collects spin coupling constants.''' import argparse from sktools.skdef import Skdef @@ -11,9 +9,10 @@ import sktools.common as sc USAGE = \ - '''Collects spin coupling constants by iterating over the - elements defined in skdef.hsd. If the atomic calculation has been done already, - it will be reused, otherwised it is done on the fly. + ''' + Collects spin coupling constants by iterating over the elements defined + in skdef.hsd. If the atomic calculation has been done already, it will be + reused, otherwised it is done on the fly. ''' SCRIPTNAME = sc.get_script_name() @@ -21,44 +20,54 @@ SPINW_FILE_NAME = 'spinw.txt' def main(): + '''Main driver routine.''' + args = parseargs() + logger = sc.get_script_logger(args.loglevel, SCRIPTNAME) - logger.info("Collecting spinw constants") - skdef = Skdef.fromfile("skdef.hsd") - searchdirs = [ args.builddir, ] + logger.info('Collecting spinw constants') + + skdef = Skdef.fromfile('skdef.hsd') + searchdirs = [args.builddir] elems = skdef.atomparameters.keys() - fp = open(SPINW_FILE_NAME, "w") - for elem in elems: - calculator = skgen.run_atom( - skdef, elem, args.builddir, searchdirs, args.onecnt_binary) - fp.write(sc.capitalize_elem_name(elem) + ":\n") - results = calculator.get_result() - spinw = results.get_spinws() - ndim = spinw.shape[0] - formstr = "{:13.5f}" * ndim + "\n" - for line in spinw: - fp.write(formstr.format(*line)) - fp.write("\n") - fp.close() + + with open(SPINW_FILE_NAME, 'w') as fp: + + for elem in elems: + calculator = skgen.run_atom(skdef, elem, args.builddir, searchdirs, + args.onecnt_binary) + fp.write(sc.capitalize_elem_name(elem) + ':\n') + results = calculator.get_result() + spinw = results.get_spinws() + ndim = spinw.shape[0] + formstr = '{:13.5f}' * ndim + '\n' + for line in spinw: + fp.write(formstr.format(*line)) + fp.write('\n') + logger.info("File '{}' written.".format(SPINW_FILE_NAME)) def parseargs(): + '''Parses command line arguments and return the parser instance.''' + parser = argparse.ArgumentParser(description=USAGE) - parser.add_argument( - "-b", "--build-dir", default="_build", dest="builddir", - help="build directory (default: _build)") - parser.add_argument( - "-o", "--onecenter-binary", dest="onecnt_binary", default=None, - help="binary to use for the one-center calculations (default: depends " - "on the calculator specified in the input)") - parser.add_argument( - "-l", "--log-level", dest="loglevel", default="info", - choices=[ "debug", "info", "warning", "error" ], - help="Logging level (default: info)") - return parser.parse_args() + msg = 'build directory (default: _build)' + parser.add_argument('-b', '--build-dir', default='_build', dest='builddir', + help=msg) + + msg = 'binary to use for the one-center calculations (default: depends ' + \ + 'on the calculator specified in the input)' + parser.add_argument('-o', '--onecenter-binary', dest='onecnt_binary', + default=None, help=msg) + + msg = 'Logging level (default: info)' + parser.add_argument('-l', '--log-level', dest='loglevel', default='info', + choices=['debug', 'info', 'warning', 'error'], help=msg) + + return parser.parse_args() -if __name__ == "__main__": +if __name__ == '__main__': main() diff --git a/sktools/bin/collectwavecoeffs b/sktools/bin/collectwavecoeffs index 0d4857fb..7de705d0 100755 --- a/sktools/bin/collectwavecoeffs +++ b/sktools/bin/collectwavecoeffs @@ -1,71 +1,84 @@ #!/usr/bin/env python3 -import sys + +'''Collects coefficient information for waveplot.''' + + import os.path -from sktools.common import * + +from sktools.common import ANGMOM_TO_SHELL, writefloats from sktools.taggedfile import TaggedFile -from sktools.skdef import SKDefs +from sktools.skdef import Skdef from sktools.oldskfile import OldSKFile -import argparse -helptxt = """Collects coefficient information for waveplot. It -iterates over the elements defined in skdefs.py and collects the wave -function coefficients and other information necessary for -waveplot. The homonuclear SK-files for those elements must have been -created already. If it is missing, the given element will be ignored. -""" + +USAGE = \ + '''Collects coefficient information for waveplot. It iterates over the + elements defined in skdefs.py and collects the wave function coefficients + and other information necessary for waveplot. The homonuclear SK-files for + those elements must have been created already. If it is missing, the given + element will be ignored. + ''' def writecoeffs(fp, elem, atomconfig, homoskname, wavecompdir): - homosk = OldSKFile.fromfile(homoskname) + '''Writes element-specific input, processed by Waveplot. + + Args: + + fp (file object): file object to write to + elem (str): element name to fetch information for + atomconfig (AtomConfig): represents the configuration of a free atom + homoskname (str): pathname of homonuclear Slater-Koster file + wavecompdir (str): path to calculation of the compressed atom + + ''' + + homosk = OldSKFile.fromfile(homoskname, True) cutoff = homosk.nr * homosk.dr / 2.0 - fp.write("{} {{\n".format(elem)) - fp.write(" AtomicNumber = {:d}\n".format(atomconfig.znuc)) + fp.write('{} {{\n'.format(elem)) + fp.write(' AtomicNumber = {:d}\n'.format(atomconfig.znuc)) for nn, ll in atomconfig.valenceorbs: - coeffsname = "coeffs_{:02d}{:1s}.tag".format(nn, ANGMOM_NAMES[ll]) + coeffsname = 'coeffs_{:02d}{:1s}.tag'.format(nn, ANGMOM_TO_SHELL[ll]) coeffs = TaggedFile.fromfile(os.path.join(wavecompdir, coeffsname), transpose=True) - fp.write(" Orbital {\n") - fp.write(" AngularMomentum = {:d}\n".format(ll)) - fp.write(" Occupation = {:.1f}\n".format(coeffs["occupation"])) - fp.write(" Cutoff = {:5.2f}\n".format(cutoff)) - fp.write(" Exponents {\n") - writefloats(fp, coeffs["exponents"], indent=6, numperline=3, - formstr="{:21.12E}") - fp.write(" }\n") - fp.write(" Coefficients {\n") - writefloats(fp, coeffs["coefficients"], indent=3, numperline=3, - formstr="{:21.12E}") - fp.write(" }\n") - fp.write(" }\n") - fp.write("}\n") - - -def parseargs(): - parser = argparse.ArgumentParser(description=helptxt) - return parser.parse_args() + fp.write(' Orbital {\n') + fp.write(' AngularMomentum = {:d}\n'.format(ll)) + fp.write(' Occupation = {:.1f}\n'.format(coeffs['occupation'])) + fp.write(' Cutoff = {:5.2f}\n'.format(cutoff)) + fp.write(' Exponents {\n') + writefloats(fp, coeffs['exponents'], indent=6, numperline=3, + formstr='{:21.12E}') + fp.write(' }\n') + fp.write(' Coefficients {\n') + writefloats(fp, coeffs['coefficients'], indent=3, numperline=3, + formstr='{:21.12E}') + fp.write(' }\n') + fp.write(' }\n') + fp.write('}\n') def main(): - args = parseargs() - skdefs = SKDefs.fromfile("skdefs.py") + '''Main driver routine.''' + + skdefs = Skdef.fromfile('skdefs.py') atomconfigs = skdefs.atomconfigs elems = atomconfigs.keys() - fp = open("wfc.hsd", "w") - indent = " " * 2 - for elem in elems: - homoskname = "{}-{}.skf".format(elem, elem) - wavecompdir = os.path.join(elem, "wavecomp") - filespresent = (os.path.exists(homoskname) - and os.path.exists(wavecompdir)) - if not filespresent: - print("*** Skipping: ", elem) - continue - - print("*** Processing: ", elem) - atomconfig = atomconfigs[elem] - writecoeffs(fp, elem, atomconfig, homoskname, wavecompdir) - fp.close() - - -if __name__ == "__main__": + + with open('wfc.hsd', 'w') as fp: + + for elem in elems: + homoskname = '{elem}-{elem}.skf'.format(elem=elem) + wavecompdir = os.path.join(elem, 'wavecomp') + filespresent = (os.path.exists(homoskname) + and os.path.exists(wavecompdir)) + if not filespresent: + print('*** Skipping: ', elem) + continue + + print('*** Processing: ', elem) + atomconfig = atomconfigs[elem] + writecoeffs(fp, elem, atomconfig, homoskname, wavecompdir) + + +if __name__ == '__main__': main() diff --git a/sktools/bin/skdiff b/sktools/bin/skdiff index 3caad992..8f57f716 100755 --- a/sktools/bin/skdiff +++ b/sktools/bin/skdiff @@ -1,79 +1,105 @@ #!/usr/bin/env python3 + +''' +Reads two Slater-Koster files and compares the numerical values stored in them. +''' + + import argparse import numpy as np from sktools import PACKAGE_VERSION from sktools.oldskfile import OldSKFile -helptxt = """Reads two sk files and compares the numerical values stored in them.""" + +USAGE = \ + ''' + Reads two SK-files and compares the numerical values stored in them. + ''' + def parseargs(): - """Parse the program arguments. - """ - parser = argparse.ArgumentParser(description=helptxt) - parser.add_argument("--version", action="version", - version="sktools {}".format(PACKAGE_VERSION)) - parser.add_argument("skfile", nargs=2, help="SK files to compare") - parser.add_argument( - "-a", "--atomic", dest="homo", action="store_true", default=False, - help="Compare atomic values as stored in homonuclear sk-files") - parser.add_argument( - "-s", "--skip", dest="nskip", type=int, default=0, - help="Skip a given number of lines") + '''Parse the program arguments.''' + + parser = argparse.ArgumentParser(description=USAGE) + + parser.add_argument('--version', action='version', + version='sktools {}'.format(PACKAGE_VERSION)) + + msg = 'SK-files to compare' + parser.add_argument('skfile', nargs=2, help=msg) + + msg = 'compare atomic values as stored in homonuclear SK-files' + parser.add_argument('-a', '--atomic', dest='homo', action='store_true', + default=False, help=msg) + + msg = 'skip a given number of lines' + parser.add_argument('-s', '--skip', dest='nskip', type=int, default=0, + help=msg) + return parser.parse_args() def compare_atomic_data(sk1, sk2): - """Compares the atomic data stored in two homonuclear SK-file. - """ + '''Compares the atomic data stored in two homonuclear SK-file.''' + onsite_diffs = abs(sk1.onsites - sk2.onsites) maxpos = np.argmax(onsite_diffs) - print("Onsite: {:12.3e} {:5d}".format(onsite_diffs[maxpos], maxpos)) + print('Onsite: {:12.3e} {:5d}'.format(onsite_diffs[maxpos], maxpos)) hubbu_diffs = abs(sk1.hubbardus - sk2.hubbardus) maxpos = np.argmax(hubbu_diffs) - print("Hubbards: {:12.3e} {:5d}".format(hubbu_diffs[maxpos], maxpos)) - print("Hubbard (s): {:12.3e}".format(hubbu_diffs[-1])) + print('Hubbards: {:12.3e} {:5d}'.format(hubbu_diffs[maxpos], maxpos)) + print('Hubbard (s): {:12.3e}'.format(hubbu_diffs[-1])) occ_diffs = abs(sk1.occupations - sk2.occupations) maxpos = np.argmax(occ_diffs) - print("Occupations: {:12.3e} {:5d}".format(occ_diffs[maxpos], maxpos)) + print('Occupations: {:12.3e} {:5d}'.format(occ_diffs[maxpos], maxpos)) def compare_integral_tables(sk1, sk2, nstart): - """Compares integral tables in two sk-files - """ + '''Compares integral tables in two SK-files.''' + if abs(sk1.dr - sk2.dr) > 1e-8: - print("Incompatible grid separation ({:.3f} vs {:.3f}).") + print('Incompatible grid separation ({:.3f} vs {:.3f}).') return + nr = min(sk1.nr, sk2.nr) if nstart > nr: - print("Tables too short.") + print('Tables too short.') return - hamdiff = abs(abs(sk1.hamiltonian[nstart:nr,:]) - - abs(sk2.hamiltonian[nstart:nr,:])) + + hamdiff = abs(abs(sk1.hamiltonian[nstart:nr, :]) + - abs(sk2.hamiltonian[nstart:nr, :])) + maxpos = np.argmax(hamdiff) maxinds = np.unravel_index(maxpos, hamdiff.shape) - print("Hamiltonian: {:12.3e} ({:4d},{:3d})".format( + + print('Hamiltonian: {:12.3e} ({:4d},{:3d})'.format( hamdiff[maxinds], maxinds[0] + nstart, maxinds[1])) - overdiff = abs(abs(sk1.overlap[nstart:nr,:]) - - abs(sk2.overlap[nstart:nr,:])) + + overdiff = abs(abs(sk1.overlap[nstart:nr, :]) + - abs(sk2.overlap[nstart:nr, :])) maxpos = np.argmax(overdiff) maxinds = np.unravel_index(maxpos, overdiff.shape) - print("Overlap: {:12.3e} ({:4d},{:3d})".format( - overdiff[maxinds], maxinds[0] + nstart + 1, maxinds[1] + 1)) + + print('Overlap: {:12.3e} ({:4d},{:3d})'.format( + overdiff[maxinds], maxinds[0] + nstart + 1, maxinds[1] + 1)) def main(): + '''Main driver routine.''' + args = parseargs() + sk1 = OldSKFile.fromfile(args.skfile[0], args.homo) sk2 = OldSKFile.fromfile(args.skfile[1], args.homo) + if args.homo: - print("*** Atomic data:""") + print('*** Atomic data:''') compare_atomic_data(sk1, sk2) print() - print("*** Integral tables:") + print('*** Integral tables:') compare_integral_tables(sk1, sk2, args.nskip) - -if __name__ == "__main__": +if __name__ == '__main__': main() diff --git a/sktools/bin/skgen b/sktools/bin/skgen index 0ff73fb8..4bb48aff 100755 --- a/sktools/bin/skgen +++ b/sktools/bin/skgen @@ -1,15 +1,27 @@ #!/usr/bin/env python3 + +''' +Module to generate homo- and hetero-nuclear Slater-Koster files. +''' + + import sys -if sys.hexversion < 0x03020000: - sys.exit("Program only works with Python 3.2 or greater") import argparse import numpy as np -if np.__version__.startswith("1.6."): - sys.exit("Program only works with Numpy 1.7.x or greater") -from sktools import PACKAGE_VERSION + + import sktools.common as sc -from sktools.skdef import Skdef import sktools.skgen as skgen +from sktools.skdef import Skdef +from sktools import PACKAGE_VERSION + + +if sys.hexversion < 0x03020000: + sys.exit('Program only works with Python 3.2 or greater') + +if np.__version__.startswith('1.6.'): + sys.exit('Program only works with Numpy 1.7.x or greater') + SCRIPTNAME = sc.get_script_name() @@ -19,6 +31,8 @@ logger = None def main(): + '''Main driver routine.''' + parser, subparsers = get_parser_and_subparser_container() setup_parser_main(parser) onecnt_common = get_onecnt_common_parser() @@ -33,57 +47,57 @@ def main(): def run_atom(args): setup_logger(args.loglevel) - logger.info("Subcommand atom started") + logger.info('Subcommand atom started') elements = convert_argument_to_elements(args.element) skdefs = merge_skdefs(args.configfiles) - searchdirs = [ args.builddir, ] + args.includedirs + searchdirs = [args.builddir,] + args.includedirs resultdirs = [] for elem in elements: calculator = skgen.run_atom( skdefs, elem, args.builddir, searchdirs, args.onecnt_binary, args.eigenonly, args.eigenspinonly) resultdirs.append(calculator.get_result_directory()) - logger.info("Subcommand atom finished") - logger.info("Atom results in {}".format(" ".join(resultdirs))) + logger.info('Subcommand atom finished') + logger.info('Atom results in {}'.format(' '.join(resultdirs))) def run_denscomp(args): setup_logger(args.loglevel) - logger.info("Subcommand denscomp started") + logger.info('Subcommand denscomp started') elements = convert_argument_to_elements(args.element) skdefs = merge_skdefs(args.configfiles) - searchdirs = [ args.builddir, ] + args.includedirs + searchdirs = [args.builddir,] + args.includedirs resultdirs = [] for elem in elements: calculator = skgen.run_denscomp( skdefs, elem, args.builddir, searchdirs, args.onecnt_binary) resultdirs.append(calculator.get_result_directory()) - logger.info("Subcommand densecomp finished") - logger.info("Denscomp results in {}".format(" ".join(resultdirs))) + logger.info('Subcommand densecomp finished') + logger.info('Denscomp results in {}'.format(' '.join(resultdirs))) def run_wavecomp(args): setup_logger(args.loglevel) - logger.info("Subcommand wavecomp started") + logger.info('Subcommand wavecomp started') elements = convert_argument_to_elements(args.element) skdefs = merge_skdefs(args.configfiles) - searchdirs = [ args.builddir, ] + args.includedirs + searchdirs = [args.builddir,] + args.includedirs resultdirs = [] for elem in elements: calculator = skgen.run_wavecomp( skdefs, elem, args.builddir, searchdirs, args.onecnt_binary) - dirnames = " ".join(calculator.get_result_directories()) + dirnames = ' '.join(calculator.get_result_directories()) resultdirs.append(dirnames) - logger.info("Subcommand wavecomp finished") - logger.info("Wavecomp results in {}".format(" ".join(resultdirs))) + logger.info('Subcommand wavecomp finished') + logger.info('Wavecomp results in {}'.format(' '.join(resultdirs))) def run_twocnt(args): setup_logger(args.loglevel) - logger.info("Subcommand twocnt started") + logger.info('Subcommand twocnt started') skdefs = merge_skdefs(args.configfiles) builddir = args.builddir - searchdirs = [ builddir, ] + args.includedirs + searchdirs = [builddir,] + args.includedirs resultdirs = [] element_pairs = convert_arguments_to_element_pairs(args.element1, args.element2) @@ -92,16 +106,16 @@ def run_twocnt(args): skdefs, elem1, elem2, builddir, searchdirs, args.onecnt_binary, args.twocnt_binary) resultdirs.append(calculator.get_result_directory()) - logger.info("Subcommand twocnt finished") - logger.info("Twocnt results in {}".format(" ".join(resultdirs))) + logger.info('Subcommand twocnt finished') + logger.info('Twocnt results in {}'.format(' '.join(resultdirs))) def run_sktable(args): setup_logger(args.loglevel) - logger.info("Subcommand sktable started") + logger.info('Subcommand sktable started') skdefs = merge_skdefs(args.configfiles) builddir = args.builddir - searchdirs = [ builddir, ] + args.includedirs + searchdirs = [builddir,] + args.includedirs workdir = args.outdir add_dummy_rep = args.dummyrep skfiles_written = [] @@ -111,118 +125,118 @@ def run_sktable(args): skfiles_written += skgen.run_sktable( skdefs, elem1, elem2, builddir, searchdirs, args.onecnt_binary, args.twocnt_binary, workdir, add_dummy_rep) - logger.info("Directory with assembled SK-file(s): {}".format(workdir)) - logger.info("SK-file(s) written: {}".format(" ".join(skfiles_written))) + logger.info('Directory with assembled SK-file(s): {}'.format(workdir)) + logger.info('SK-file(s) written: {}'.format(' '.join(skfiles_written))) def get_parser_and_subparser_container(): parser = argparse.ArgumentParser( - description="General tool for generating Slater-Koster tables.") - subparsers = parser.add_subparsers(title="available subcommands", - help="") + description='General tool for generating Slater-Koster tables.') + subparsers = parser.add_subparsers(title='available subcommands', + help='') return parser, subparsers def get_onecnt_common_parser(): - """Common settings for all one-center calculations.""" + '''Common settings for all one-center calculations.''' onecnt_common = argparse.ArgumentParser(add_help=False) onecnt_common.add_argument( - "element", help="element to process: either one element (e.g. N) or a " - "comma separated list of element names *without* spaces in between " - "(e.g. N,C,H)") + 'element', help='element to process: either one element (e.g. N) or a ' + 'comma separated list of element names *without* spaces in between ' + '(e.g. N,C,H)') return onecnt_common def get_twocnt_common_parser(): twocnt_common = argparse.ArgumentParser(add_help=False) twocnt_common.add_argument( - "element1", help="first element of the element pair to process: " - "either one element (e.g. N) or a comma separated list of element " - "names *without* spaces in between (e.g. N,C,H)") + 'element1', help='first element of the element pair to process: ' + 'either one element (e.g. N) or a comma separated list of element ' + 'names *without* spaces in between (e.g. N,C,H)') twocnt_common.add_argument( - "element2", help="second element of the element pair to process: " - "either one element (e.g. N) or a comma separated list of element " - "names *without* spaces in between (e.g. N,C,H)") + 'element2', help='second element of the element pair to process: ' + 'either one element (e.g. N) or a comma separated list of element ' + 'names *without* spaces in between (e.g. N,C,H)') return twocnt_common def setup_parser_main(parser): - parser.add_argument("--version", action="version", - version="sktools {}".format(PACKAGE_VERSION)) + parser.add_argument('--version', action='version', + version='sktools {}'.format(PACKAGE_VERSION)) parser.add_argument( - "-I", "--include-dir", action="append", default=[], - dest="includedirs", - help="directory to include in the search for calculation " - "(default: build directory only)") + '-I', '--include-dir', action='append', default=[], + dest='includedirs', + help='directory to include in the search for calculation ' + '(default: build directory only)') parser.add_argument( - "-c", "--config-file", action="append", dest="configfiles", - default=[ "skdef.hsd", ], - help="config file(s) to be parsed (default: ./skdef.hsd)" + '-c', '--config-file', action='append', dest='configfiles', + default=['skdef.hsd',], + help='config file(s) to be parsed (default: ./skdef.hsd)' ) parser.add_argument( - "-b", "--build-dir", default="_build", dest="builddir", - help="build directory (default: _build)") + '-b', '--build-dir', default='_build', dest='builddir', + help='build directory (default: _build)') parser.add_argument( - "-o", "--onecenter-binary", dest="onecnt_binary", default=None, - help="binary to use for the one-center calculations (default: depends " - "on the calculator specified in the input)") + '-o', '--onecenter-binary', dest='onecnt_binary', default=None, + help='binary to use for the one-center calculations (default: depends ' + 'on the calculator specified in the input)') parser.add_argument( - "-t", "--twocenter-binary", dest="twocnt_binary", default=None, - help="binary to use for the two-center calculationrs (default: depends " - "on the calculator speciefied in the input)") + '-t', '--twocenter-binary', dest='twocnt_binary', default=None, + help='binary to use for the two-center calculationrs (default: depends ' + 'on the calculator speciefied in the input)') parser.add_argument( - "-l", "--log-level", dest="loglevel", default="info", - choices=[ "debug", "info", "warning", "error" ], - help="Logging level (default: info)") + '-l', '--log-level', dest='loglevel', default='info', + choices=['debug', 'info', 'warning', 'error'], + help='Logging level (default: info)') def setup_parser_atom(subparsers, onecnt_common, target_function): parser_atom = subparsers.add_parser( - "atom", parents=[onecnt_common], - help="calculates the free atom to get eigenlevels, hubbard values, spin" - " couplings, etc.") + 'atom', parents=[onecnt_common], + help='calculates the free atom to get eigenlevels, hubbard values, spin' + ' couplings, etc.') parser_atom.add_argument( - "-e", "--eigenlevels-only", dest="eigenonly", action="store_true", - default=False, help="calculates only eigenlevels of the spin " - "unpolarized atom but no derivatives.") + '-e', '--eigenlevels-only', dest='eigenonly', action='store_true', + default=False, help='calculates only eigenlevels of the spin ' + 'unpolarized atom but no derivatives.') parser_atom.add_argument( - "-s", "--spin-polarized", dest="eigenspinonly", action="store_true", - default=False, help="calculates only the eigenlevels of the spin " - "polarized atom but no derivatives") + '-s', '--spin-polarized', dest='eigenspinonly', action='store_true', + default=False, help='calculates only the eigenlevels of the spin ' + 'polarized atom but no derivatives') parser_atom.set_defaults(func=target_function) def setup_parser_denscomp(subparsers, onecnt_common, target_function): parser_denscomp = subparsers.add_parser( - "denscomp", parents=[ onecnt_common ], - help="calculates density compression") + 'denscomp', parents=[onecnt_common], + help='calculates density compression') parser_denscomp.set_defaults(func=target_function) def setup_parser_wavecomp(subparsers, onecnt_common, target_function): parser_wavecomp = subparsers.add_parser( - "wavecomp", parents=[ onecnt_common ], - help="calculates wave function compression") + 'wavecomp', parents=[onecnt_common], + help='calculates wave function compression') parser_wavecomp.set_defaults(func=target_function) def setup_parser_twocnt(subparsers, twocnt_common, target_function): parser_twocnt = subparsers.add_parser( - "twocnt", parents=[ twocnt_common ], - help="calculates two center integrals") + 'twocnt', parents=[twocnt_common], + help='calculates two center integrals') parser_twocnt.set_defaults(func=target_function) def setup_parser_sktable(subparsers, twocnt_common, target_function): parser_sktable = subparsers.add_parser( - "sktable", parents=[ twocnt_common ], - help="creates an sktable for a given element pair") + 'sktable', parents=[twocnt_common], + help='creates an sktable for a given element pair') parser_sktable.add_argument( - "-d", "--dummy-repulsive", action="store_true", dest="dummyrep", - default=False, help="add dummy repulsive spline to the sk tables") + '-d', '--dummy-repulsive', action='store_true', dest='dummyrep', + default=False, help='add dummy repulsive spline to the sk tables') parser_sktable.add_argument( - "-o", "--output-dir", dest="outdir", default=".", - help="directory where the skfiles should be written to (default: .)") + '-o', '--output-dir', dest='outdir', default='.', + help='directory where the skfiles should be written to (default: .)') parser_sktable.set_defaults(func=target_function) @@ -237,7 +251,7 @@ def setup_logger(loglevel): def merge_skdefs(filenames): - """Returns a merged skdefs object using all specified skdef files.""" + '''Returns a merged skdefs object using all specified skdef files.''' skdef = Skdef.fromfile(filenames[0]) for filename in filenames[1:]: @@ -247,7 +261,7 @@ def merge_skdefs(filenames): def convert_argument_to_elements(argument): - return argument.split(",") + return argument.split(',') def convert_arguments_to_element_pairs(argument1, argument2): @@ -260,15 +274,14 @@ def convert_arguments_to_element_pairs(argument1, argument2): for elem2 in elements2: elem2low = elem2.lower() already_processed = ((elem1low, elem2low) in processed - or (elem2low, elem1low) in processed) + or (elem2low, elem1low) in processed) if not already_processed: - element_pairs.append(( elem1, elem2 )) - processed.add(( elem1low, elem2low )) + element_pairs.append((elem1, elem2)) + processed.add((elem1low, elem2low)) return element_pairs - -if __name__ == "__main__": +if __name__ == '__main__': try: main() except sc.SkgenException as ex: diff --git a/sktools/bin/skmanip b/sktools/bin/skmanip index e5aa3af7..eba0784d 100755 --- a/sktools/bin/skmanip +++ b/sktools/bin/skmanip @@ -1,4 +1,10 @@ #!/usr/bin/env python3 + +''' + +''' + + import sys import argparse import re @@ -110,4 +116,4 @@ if __name__ == "__main__": sc.check_version() main() except sc.SkgenException as ex: - sc.fatalerror(str(ex)) \ No newline at end of file + sc.fatalerror(str(ex)) diff --git a/sktools/src/sktools/__init__.py b/sktools/src/sktools/__init__.py index 05aefabd..3d362066 100644 --- a/sktools/src/sktools/__init__.py +++ b/sktools/src/sktools/__init__.py @@ -1 +1 @@ -PACKAGE_VERSION = "0.4" +PACKAGE_VERSION = '0.4' diff --git a/sktools/src/sktools/common.py b/sktools/src/sktools/common.py index a9d6ac57..b98f4e5e 100644 --- a/sktools/src/sktools/common.py +++ b/sktools/src/sktools/common.py @@ -1,3 +1,6 @@ +'''Common functionality used by the project.''' + + import sys import re import os.path @@ -11,42 +14,42 @@ import sktools.hsd.converter as conv -logger = logging.getLogger("common") +LOGGER = logging.getLogger('common') # Maximal angular momentum MAX_ANGMOM = 4 # Translate between angular momentum and shell name -ANGMOM_TO_SHELL = [ "s", "p", "d", "f", "g" ] +ANGMOM_TO_SHELL = ['s', 'p', 'd', 'f', 'g'] # Translate between shell name and angular momentum -SHELL_TO_ANGMOM = { "s": 0, "p": 1, "d": 2, "f": 3, "g": 4 } +SHELL_TO_ANGMOM = {'s': 0, 'p': 1, 'd': 2, 'f': 3, 'g': 4} # Name of the spin channels -SPIN_NAMES = [ "u", "d" ] +SPIN_NAMES = ['u', 'd'] # Max. principal quantum number MAX_PRINCIPAL_QN = 7 RELATIVISTICS_NONE = 0 RELATIVISTICS_ZORA = 1 -RELATIVISTICS_TYPES = { "none": RELATIVISTICS_NONE, - "zora": RELATIVISTICS_ZORA } +RELATIVISTICS_TYPES = {'none': RELATIVISTICS_NONE, + 'zora': RELATIVISTICS_ZORA} XC_FUNCTIONAL_LDA = 0 XC_FUNCTIONAL_PBE = 1 -XC_FUNCTIONAL_TYPES = { "lda": XC_FUNCTIONAL_LDA, - "pbe": XC_FUNCTIONAL_PBE } +XC_FUNCTIONAL_TYPES = {'lda': XC_FUNCTIONAL_LDA, + 'pbe': XC_FUNCTIONAL_PBE} SUPERPOSITION_POTENTIAL = 0 SUPERPOSITION_DENSITY = 1 -SUPERPOSITION_TYPES = { "potential": SUPERPOSITION_POTENTIAL, - "density": SUPERPOSITION_DENSITY } +SUPERPOSITION_TYPES = {'potential': SUPERPOSITION_POTENTIAL, + 'density': SUPERPOSITION_DENSITY} -WAVEFUNC_FILE_NAME_FORMAT = "wave_{:02d}{:s}.dat" -POTENTIAL_FILE_NAME = "pot.dat" -DENSITY_FILE_NAME = "dens.dat" +WAVEFUNC_FILE_NAME_FORMAT = 'wave_{:02d}{:s}.dat' +POTENTIAL_FILE_NAME = 'pot.dat' +DENSITY_FILE_NAME = 'dens.dat' # Tolerance for float numbers in user input @@ -54,49 +57,91 @@ class SkgenException(Exception): - pass + '''Custom exception of the skgen script.''' def openfile(fobj, mode): - """Opens a file.""" + '''Opens a file or passes a file object. + + Args: + + fobj (file object): file object + mode (str): mode to open file in + + Returns: + + fp (file object): file object + isfname (bool): true, if file object got opened from file name + + ''' + isfname = isinstance(fobj, str) + if isfname: fp = open(fobj, mode) else: fp = fobj - return fp, isfname + + return fp, isfname def writefloats(fp, nums, indent=0, indentstr=None, numperline=4, - formstr="{:23.15E}"): + formstr='{:23.15E}'): + '''Writes (nested) data array to formatted file. + + Args: + + fp (file object): file object + nums (ndarray): data + indent (int): number of space indentations while writing data + indentstr (str): if none, indentation string build from indent + numperline (int): number of values to write per line + formstr (str): string formatter + + ''' + if indentstr is None: - indentstr = " " * indent - lineform = indentstr + formstr * numperline + "\n" + indentstr = ' ' * indent + + lineform = indentstr + formstr * numperline + '\n' nums1d = nums.flat nnumber = len(nums1d) nline = nnumber // numperline + for ii in range(nline): - fp.write(lineform.format( - *nums1d[ii * numperline:(ii + 1) * numperline])) + fp.write( + lineform.format(*nums1d[ii * numperline:(ii + 1) * numperline])) + res = nnumber % numperline if res: - lineform = indentstr + formstr * res + "\n" + lineform = indentstr + formstr * res + '\n' fp.write(lineform.format(*nums1d[nnumber - res:nnumber])) # Fortran float pattern with possibility for reccurance PAT_FORTRAN_FLOAT = re.compile( - r"^(?:(?P[0-9]+)\*)?(?P[+-]?\d*\.?\d*(?:[eE][+-]?\d+)?)$") -PAT_FORTRAN_SEPARATOR = re.compile(r"[,]?\s+") + r'^(?:(?P[0-9]+)\*)?(?P[+-]?\d*\.?\d*(?:[eE][+-]?\d+)?)$') +PAT_FORTRAN_SEPARATOR = re.compile(r'[,]?\s+') + + +def split_fortran_fields(sep, maxsplit=0): + ''''Splits a line containing Fortran (numeric) fields. + + Args: + + sep (str): separator to use when splitting the string + maxsplit (int): maximum number of splits allowed + + ''' + + return [field for field in + PAT_FORTRAN_SEPARATOR.split(sep, maxsplit=maxsplit) + if len(field) > 1] -def split_fortran_fields(txt, maxsplit=0): - """"Splits a line containing Fortran (numeric) fields.""" - return [ field - for field in PAT_FORTRAN_SEPARATOR.split(txt, maxsplit=maxsplit) - if len(field) > 1 ] def convert_fortran_floats(txt): - """Converts floats in fortran notation to intrinsic floats""" + '''Converts floats in fortran notation to intrinsic floats.''' + result = [] words = split_fortran_fields(txt) for word in words: @@ -104,22 +149,22 @@ def convert_fortran_floats(txt): if not match: result.append(None) continue - occ = match.group("occurance") + occ = match.group('occurance') if occ is not None: occ = int(occ) else: occ = 1 - val = float(match.group("value")) - result += [ val, ] * occ + val = float(match.group('value')) + result += [val,] * occ return result # Shell name pattern -PAT_SHELLNAME = re.compile(r"^(?P[0-9])(?P[spdfg])$") +PAT_SHELLNAME = re.compile(r'^(?P[0-9])(?P[spdfg])$') def shell_name_to_ind(txt): - """Converts a named shell (e.g. '1s') into (n, l) tuple (e.g. (1, 0)). + '''Converts a named shell (e.g. '1s') into (n, l) tuple (e.g. (1, 0)). Parameters ---------- @@ -137,20 +182,39 @@ def shell_name_to_ind(txt): ------ ValueError If conversion was not successfull. - """ + + ''' + match = PAT_SHELLNAME.match(txt) if not match: raise ValueError("Invalid shell name '{}'".format(txt)) - return int(match.group("n")), SHELL_TO_ANGMOM[match.group("shell")] + + return int(match.group('n')), SHELL_TO_ANGMOM[match.group('shell')] def shell_ind_to_name(nn, ll): - return "{:d}{}".format(nn, ANGMOM_TO_SHELL[ll]) + '''Converts the shell index, i.e. angular momentum, to the shell string. + + Args: + + nn (int): principal quantum number, i.e. 1, 2, 3, ... + ll (int): angular momentum quantum number, i.e. ll = 0, ..., nn - 1 + + Returns: + + shell string + + ''' + + return '{:d}{}'.format(nn, ANGMOM_TO_SHELL[ll]) class FileFromStringOrHandler: + '''Class that handles file I/O based on a handler or filename.''' def __init__(self, fname_or_handler, mode): + '''Initializes a FileFromStringOrHandler object.''' + if isinstance(fname_or_handler, str): self._fp = open(fname_or_handler, mode) self._tobeclosed = True @@ -159,49 +223,55 @@ def __init__(self, fname_or_handler, mode): self._tobeclosed = False def __enter__(self): + '''Overload __enter__ function.''' return self def __exit__(self, exc_type, exc_val, exc_tb): + '''Overload __exit__ function.''' if self._tobeclosed: self._fp.close() def write(self, *args, **kwargs): + '''Overload write function.''' return self._fp.write(*args, **kwargs) def writelines(self, *args, **kwargs): + '''Overload writelines function.''' return self._fp.writelines(*args, **kwargs) def read(self, *args, **kwargs): + '''Overload read function.''' return self._fp.read(*args, **kwargs) def readline(self, *args, **kwargs): + '''Overload readline function.''' return self._fp.readline(*args, **kwargs) def readlines(self, *args, **kwargs): + '''Overload readlines function.''' return self._fp.readlines(*args, **kwargs) - class ClassDict: - """Dictionary like object accessible in class notation. - """ + '''Dictionary like object accessible in class notation.''' def __init__(self, initdata=None): + '''Initializes a ClassDict object.''' + self._dict = {} if initdata is not None: self._dict.update(initdata) def __setattr__(self, key, value): - if key.startswith("_"): + if key.startswith('_'): super().__setattr__(key, value) else: self[key] = value def __getattr__(self, item): - if item.startswith("_"): + if item.startswith('_'): return super().__getattribute__(item) - else: - return self[item] + return self[item] def __contains__(self, item): return item in self._dict @@ -214,7 +284,7 @@ def __getitem__(self, item): return self._dict[item] except KeyError: pass - msg = "{} instance has no key/attribute '{}'".format( + msg = '{} instance has no key/attribute "{}"'.format( self.__class__.__name__, item) raise KeyError(msg) @@ -227,53 +297,97 @@ def __len__(self): def __eq__(self, other): if isinstance(other, ClassDict): return self._dict == other._dict - else: - return self._dict == other + return self._dict == other def update(self, other): + '''Adds other iterable to the dictionary.''' self._dict.update(other._dict) + def get(self, key, default=None): + '''Returns the value of the item with the specified key.''' return self._dict.get(key, default) + def keys(self): + '''Returns view that contains the keys of the dictionary.''' return self._dict.keys() - def fatalerror(msg, errorcode=-1): - """Issue error message and exit.""" - logger.critical(msg) + '''Issue error message and exit. + + Args: + + msg (str): error message + errorcode (int): error code to raise + + ''' + + LOGGER.critical(msg) sys.exit(errorcode) -def getshellvalues(node, query): - """Returns dictionary with the values assigned to individual shells.""" +def get_shellvalues(node, query): + '''Returns dictionary with the values assigned to individual shells. + + Args: + + node (Element): parent node + query (HSDQuery): queries an HSD-tree + + Returns: + + values (dict): dictionary with the values assigned to individual shells + + ''' + values = {} + for child in node: + try: shell = shell_name_to_ind(child.tag) except ValueError: raise hsd.HSDInvalidTagException( msg="Invalid shell name '{}'".format(child.tag), node=child) - value = query.getvalue(child, ".", conv.float0) + + value = query.getvalue(child, '.', conv.float0) values[shell] = value + return values def get_shellvalues_list(node, query, converter): + '''Returns a list of converted shell values. + + Args: + + node (Element): parent node + query (HSDQuery): queries an HSD-tree + converter (converter object): object with methods fromhsd() and tohsd() + which can convert between the hsd element and the desired type + + Returns: + + values (list): list of values with their type depending on the converter + + ''' + values = [] - for ll, shellname in enumerate(ANGMOM_TO_SHELL): + + for shellname in ANGMOM_TO_SHELL: shellnode = query.findchild(node, shellname, optional=True) if shellnode is None: break - value = query.getvalue(shellnode, ".", converter) + value = query.getvalue(shellnode, '.', converter) values.append(value) + return values def hsd_node_factory(classtype, classes, node, query): - """Creates an object depending on the node and a class dictionary. + '''Creates an object depending on the node and a class dictionary. Parameters ---------- @@ -293,18 +407,20 @@ def hsd_node_factory(classtype, classes, node, query): node : Element or None Returns the element created using the hsd input in the node or None if the node passed was None. - """ + ''' + if node is None: return None myclass = classes.get(node.tag) if myclass is None: - raise hsd.HSDInvalidTagException("Unknown {} '{}'".format(classtype, - node.tag)) + raise hsd.HSDInvalidTagException( + "Unknown {} '{}'".format(classtype, node.tag)) + return myclass.fromhsd(node, query) def store_as_shelf(fname, shelfdict=None, **kwargs): - """Stores the given keyword arguments in a shelf. + '''Stores the given keyword arguments in a shelf. Parameters ---------- @@ -314,8 +430,9 @@ def store_as_shelf(fname, shelfdict=None, **kwargs): Dictionary with values to be stored in the shelf file. **kwargs : arbitrary, optional Keyword value pairs to be stored in the shelf file. - """ - db = shelve.open(fname, "n") + ''' + + db = shelve.open(fname, 'n') if shelfdict is not None: for key, value in shelfdict.items(): db[key] = value @@ -325,20 +442,37 @@ def store_as_shelf(fname, shelfdict=None, **kwargs): def retrive_from_shelf(fname): - db = shelve.open(fname, "r") + '''Open dictionary from shelf.''' + + db = shelve.open(fname, 'r') resdict = dict(db) db.close() + return resdict def create_unique_workdir(workroot, subdirprefix): + '''Create uniquely named directory. + + Args: + + workroot (str): root directory where to create temporary directory + subdirprefix (str): file name will begin with this prefix + + Returns: + + workdir (str): created temporary directory + + ''' + workdir = tempfile.mkdtemp(prefix=subdirprefix, dir=workroot) - logger.debug("Created working directory %s", workdir) + LOGGER.debug('Created working directory %s', workdir) + return workdir def create_workdir(workdir, reuse_existing=False): - """Creates a working directory. + '''Creates a working directory. Parameters ---------- @@ -347,18 +481,19 @@ def create_workdir(workdir, reuse_existing=False): be deleted, unless reuse_existing is set to True. resuse_existing : bool, optional Reuse if working directory already exists. - """ + ''' + if os.path.exists(workdir): if reuse_existing: return - logger.debug("Removing existing working directory %s", workdir) + LOGGER.debug('Removing existing working directory %s', workdir) shutil.rmtree(workdir) os.makedirs(workdir) - logger.debug("Created working directory %s", workdir) + LOGGER.debug('Created working directory %s', workdir) def find_dir_with_matching_shelf(search_dirs, shelf_file, **kwargs): - """Returns the directory containing a shelve with given content. + '''Returns the directory containing a shelve with given content. Paramters --------- @@ -374,16 +509,20 @@ def find_dir_with_matching_shelf(search_dirs, shelf_file, **kwargs): directory : str The directory, where a shelve file containing at least the given content exist. If no such directory was found, None is returned. - """ + ''' + for directory in search_dirs: if is_shelf_file_matching(os.path.join(directory, shelf_file), kwargs): return directory + return None def is_shelf_file_matching(shelf_file, mydict): + '''Returns true, if the dictionary in shelf file matches reference.''' + try: - db = shelve.open(shelf_file, "r") + db = shelve.open(shelf_file, 'r') except dbm.error: return False match = True @@ -395,42 +534,74 @@ def is_shelf_file_matching(shelf_file, mydict): def get_dirs_with_matching_shelf(search_dirs, shelf_file, **kwargs): + '''Searches multiple directories for given shelf and returns those with + matching entries.''' + matching_dirs = [] for directory in search_dirs: shelf_path = os.path.join(directory, shelf_file) if is_shelf_file_matching(shelf_path, kwargs): matching_dirs.append(directory) + return matching_dirs def shelf_exists(shelf_name): + '''Infers whether given dictionary-like object exists in shelve. + + Args: + + shelf_name (dict): dictionary-like object + + Returns: + + result (bool): true, if dictionary-like object exists in shelve + + ''' + try: - db = shelve.open(shelf_name, "r") + db = shelve.open(shelf_name, 'r') except dbm.error: result = False else: db.close() result = True + return result def capitalize_elem_name(elem): + '''Converts element name into a capitalized one. + + Args: + + elem (str): element string to convert + + Returns: + + proper, capitalized element name + + ''' + return elem[0].upper() + elem[1:].lower() class ScriptLogFormatter(logging.Formatter): + '''Defines the general log formatting.''' log_formats = { - logging.CRITICAL: "!!! [{logrecord.name}] {logrecord.message}", - logging.ERROR: "!!! [{logrecord.name}] {logrecord.message}", - logging.WARNING: "! [{logrecord.name}] {logrecord.message}", - logging.INFO: "[{logrecord.name}] {logrecord.message}", - logging.DEBUG: "[{logrecord.name}] {logrecord.message}" + logging.CRITICAL: '!!! [{logrecord.name}] {logrecord.message}', + logging.ERROR: '!!! [{logrecord.name}] {logrecord.message}', + logging.WARNING: '! [{logrecord.name}] {logrecord.message}', + logging.INFO: '[{logrecord.name}] {logrecord.message}', + logging.DEBUG: '[{logrecord.name}] {logrecord.message}' } - default_log_format = "{logrecord.levelno}: {logrecord.message}" + default_log_format = '{logrecord.levelno}: {logrecord.message}' + def __init__(self): - super().__init__("{message}", style="{") + super().__init__('{message}', style='{') + def format(self, logrecord): # Make sure, message attribute of logrecord is generated @@ -442,6 +613,18 @@ def format(self, logrecord): def log_path(path): + '''Generate path shown in logging messages. + + Args: + + path (str): path to build message string from + + Returns: + + pathname (str): modified pathname of logging message + + ''' + cwd = os.path.curdir pathname_abs = os.path.abspath(path) pathname_rel = os.path.relpath(path, cwd) @@ -449,20 +632,37 @@ def log_path(path): pathname = pathname_abs else: pathname = pathname_rel - return "(" + pathname + ")" + pathname = '(' + pathname + ')' + + return pathname def get_script_logger(loglevel, scriptname): + '''Generate script logger with proper loglevel. + + Args: + + loglevel (str): logging level, i.e. debug, info, warning, error + scriptname (str): name of the current script + + Returns: + + logger (logger): script logger + + ''' + loghandler = logging.StreamHandler() myformatter = ScriptLogFormatter() loghandler.setFormatter(myformatter) logging.root.addHandler(loghandler) numeric_level = getattr(logging, loglevel.upper(), None) logging.root.setLevel(numeric_level) - logger = logging.getLogger(scriptname) + logger = logging.getLogger(name=scriptname) + return logger def get_script_name(): + '''Returns the name of the invoked script.''' return os.path.basename(sys.argv[0]) diff --git a/sktools/src/sktools/compressions.py b/sktools/src/sktools/compressions.py index 20f16bc5..81ac3774 100644 --- a/sktools/src/sktools/compressions.py +++ b/sktools/src/sktools/compressions.py @@ -1,4 +1,6 @@ -"""Contains various compression types.""" +'''Contains various compression types.''' + + import sktools.hsd as hsd import sktools.hsd.converter as conv import sktools.common as sc @@ -10,7 +12,7 @@ class PowerCompression(sc.ClassDict): - """Compression by a power function (r/r0)^n. + '''Compression by a power function (r/r0)^n. Attributes ---------- @@ -18,37 +20,40 @@ class PowerCompression(sc.ClassDict): Power of the compression function (n). radius : float Radius of the compression (r0) - """ + ''' @classmethod def fromhsd(cls, root, query): - """Creates instance from a HSD-node and with given query object.""" + '''Creates instance from a HSD-node and with given query object.''' - power, child = query.getvalue(root, "power", conv.float0, + power, child = query.getvalue(root, 'power', conv.float0, returnchild=True) if power <= 0.0: raise hsd.HSDInvalidTagValueException( - msg="Invalid compression power {:f}".format(power), node=child) - radius, child = query.getvalue(root, "radius", conv.float0, + msg='Invalid compression power {:f}'.format(power), node=child) + radius, child = query.getvalue(root, 'radius', conv.float0, returnchild=True) if radius <= 0.0: raise hsd.HSDInvalidTagValueException( - msg="Invalid compression radius {:f}".format(radius), + msg='Invalid compression radius {:f}'.format(radius), node=child) myself = cls() myself.power = power myself.radius = radius + return myself def tohsd(self, root, query, parentname=None): + '''''' + if parentname is None: mynode = root else: - mynode = query.setchild(root, "PowerCompression") - query.setchildvalue(mynode, "power", conv.float0, self.power) - query.setchildvalue(mynode, "radius", conv.float0, self.radius) + mynode = query.setchild(root, 'PowerCompression') + query.setchildvalue(mynode, 'power', conv.float0, self.power) + query.setchildvalue(mynode, 'radius', conv.float0, self.radius) def __eq__(self, other): @@ -57,9 +62,9 @@ def __eq__(self, other): return power_ok and radius_ok -# Registered compressions with corresponing hsd name as key +# Registered compressions with corresponding hsd name as key COMPRESSIONS = { - "powercompression": PowerCompression, + 'powercompression': PowerCompression, } @@ -69,17 +74,17 @@ def __eq__(self, other): class SingleAtomCompressions(sc.ClassDict): - """Compression container for cases where all compressed wavefunctions are + '''Compression container for cases where all compressed wavefunctions are determined from one single atomic calculation. Attributes ---------- 0,1,2.. : compression object Compression type for the given object. - """ + ''' def getatomcompressions(self, atomconfig): - """Returns compressions for one or more atomic calculations. + '''Returns compressions for one or more atomic calculations. Parameters ---------- @@ -97,15 +102,15 @@ def getatomcompressions(self, atomconfig): tuples containing principal quantum number and angular momentum of the valenceshells, for which the wave function should be taken from that compressed calculation. - """ + ''' compressions = [] for ll in range(atomconfig.maxang + 1): if ll not in self: - msg = "Missing wave compression for shell {:s}".format( + msg = 'Missing wave compression for shell {:s}'.format( sc.ANGMOM_TO_SHELL[ll]) raise sc.SkgenException(msg) compressions.append(self[ll]) - atomcompressions = [ ( compressions, atomconfig.valenceshells )] + atomcompressions = [(compressions, atomconfig.valenceshells)] return atomcompressions @@ -117,8 +122,8 @@ def fromhsd(cls, root, query): if child is None: break compr = sc.hsd_node_factory( - "wavefunction compression", COMPRESSIONS, - query.getvaluenode(child, "."), query) + 'wavefunction compression', COMPRESSIONS, + query.getvaluenode(child, '.'), query) myself[ll] = compr return myself @@ -126,7 +131,7 @@ def fromhsd(cls, root, query): class MultipleAtomCompressions(sc.ClassDict): def getatomcompressions(self, atomconfig): - """Returns compressions for one or more atomic calculations. + '''Returns compressions for one or more atomic calculations. Parameters ---------- @@ -144,15 +149,15 @@ def getatomcompressions(self, atomconfig): tuples containing principal quantum number and angular momentum of the valenceshells, for which the wave function should be taken from that compressed calculation. - """ + ''' atomcompressions = [] for nn, ll in atomconfig.valenceshells: if (nn, ll) not in self: - msg = "Missing compression for shell {:d}{:s}".format( + msg = 'Missing compression for shell {:d}{:s}'.format( nn, sc.ANGMOM_TO_SHELL[ll]) raise sc.SkgenException(msg) - comprs = [ self[(nn, ll)], ] * (atomconfig.maxang + 1) - atomcompressions.append(( comprs, [ (nn, ll), ])) + comprs = [self[(nn, ll)],] * (atomconfig.maxang + 1) + atomcompressions.append((comprs, [(nn, ll), ])) return atomcompressions @@ -167,14 +172,14 @@ def fromhsd(cls, root, query): raise hsd.HSDInvalidTagException( "Invalid shell name '{}'".format(shellnode.tag), shellnode) wavecompr = sc.hsd_node_factory( - "wavefunction compression", COMPRESSIONS, - query.getvaluenode(shellnode, "."), query) + 'wavefunction compression', COMPRESSIONS, + query.getvaluenode(shellnode, '.'), query) myself[(nn, ll)] = wavecompr return myself # Registered compression containers with corresponing hsd name as key COMPRESSION_CONTAINERS = { - "singleatomcompressions": SingleAtomCompressions, - "multipleatomcompressions": MultipleAtomCompressions, + 'singleatomcompressions': SingleAtomCompressions, + 'multipleatomcompressions': MultipleAtomCompressions, } diff --git a/sktools/src/sktools/hsd/converter.py b/sktools/src/sktools/hsd/converter.py index 87f643c1..75d1dd90 100644 --- a/sktools/src/sktools/hsd/converter.py +++ b/sktools/src/sktools/hsd/converter.py @@ -12,7 +12,7 @@ def fromhsd(txt): def tohsd(value): return str(value) -#: Converts an +#: Converts an int0 = _HSDConvInt0 @@ -78,7 +78,7 @@ def fromhsd(txt): @staticmethod def tohsd(values): - return " ".join(values) + return " ".join(values) str1 = _HSDConvStr1 diff --git a/sktools/src/sktools/hsd/formatter.py b/sktools/src/sktools/hsd/formatter.py index 67537d8a..4cdfceb7 100644 --- a/sktools/src/sktools/hsd/formatter.py +++ b/sktools/src/sktools/hsd/formatter.py @@ -8,10 +8,10 @@ class HSDFormatter: """Event controlled formatter producing HSD output.""" - + def __init__(self, indentstring=" ", closecomments=False, defattrib=None): """Initializes HSDFormatter instance. - + Args: indentstring: String used for indenting (default: " "). closecomments: Whether comments after tag closing should indicate @@ -46,7 +46,7 @@ def set_output(self, output): def start_tag(self, tagname, options, hsdoptions): """Starts an HSD tag. - + Args: tagname: Name of the tag to be started. options: Dictionary of the tag options. @@ -54,7 +54,7 @@ def start_tag(self, tagname, options, hsdoptions): tagname = hsdoptions.get(hsd.HSDATTR_TAG, tagname) equalsign = hsdoptions.get(hsd.HSDATTR_EQUAL, False) # opens with '='? if options: - if (self._defattrib and len(options) == 1 + if (self._defattrib and len(options) == 1 and self._defattrib in options): optstr = " [" + options[self._defattrib] + "]" else: @@ -77,7 +77,7 @@ def start_tag(self, tagname, options, hsdoptions): def close_tag(self, tagname): """Closes an HSD tag. - + Args: tagname: Name of the tag to be closed. """ @@ -93,10 +93,10 @@ def close_tag(self, tagname): self.output.write(", " + tagname) del self._equalsigns[-1] self._last2, self._last = self._last, 2 - + def text(self, text): """Adds text between tag opening and closing. - + Args: text: Text to be added. """ @@ -104,13 +104,13 @@ def text(self, text): self.output.write("\n") self.output.write(text) self._last2, self._last = self._last, 3 - + def _increaseindentation(self): """Increases indentation level and adjusts indentation string.""" self._indentlist.append(self._curindent) if not self._equalsigns[-1]: self._curindent += self._indent - + def _decreaseindentation(self): """Decreases indentation level and adjusts indentation string.""" self._curindent = self._indentlist.pop() @@ -118,36 +118,36 @@ def _decreaseindentation(self): class HSDStreamFormatter: """Reads a HSD feed and writes it on the fly formatted into a stream.""" - + def __init__(self, parser, formatter): """Intializes HSDFeedPrinter instance. - + Args: parser: Event controled parser to be used. - formatter: Formatter to be used. + formatter: Formatter to be used. """ self._parser = parser self._formatter = formatter self._parser.start_handler = self._formatter.start_tag self._parser.close_handler = self._formatter.close_tag self._parser.text_handler = self._formatter.text - + def feed(self, fileobj): """Feeds the printer with content. - + The contant in fileobj is passed to the parser, and output is generated depending on the events. - + Args: fileobj: File with HSD-content. """ self._parser.feed(fileobj) - -if __name__ == "__main__": + +if __name__ == "__main__": import io from sktools.hsd.parser import HSDParser - + fp = io.StringIO(""" Geometry = GenFormat { 2 S diff --git a/sktools/src/sktools/hsd/parser.py b/sktools/src/sktools/hsd/parser.py index 66dcb5f0..b47b7651 100644 --- a/sktools/src/sktools/hsd/parser.py +++ b/sktools/src/sktools/hsd/parser.py @@ -19,11 +19,11 @@ class HSDParser: """Event based parser for the HSD format. - + The methods `start_handler()`, `close_handler()`, `text_handler()` and `error_handler()` should be overridden by the actual application. """ - + def __init__(self, defattrib="default"): """Initializes the parser. @@ -35,7 +35,7 @@ def __init__(self, defattrib="default"): self._checkstr = GENERAL_SPECIALS # special characters to look for self._oldcheckstr = "" # buffer fo checkstr self._currenttags = [] # info about opened tags - self._buffer = [] # buffering plain text between lines + self._buffer = [] # buffering plain text between lines self._options = OrderedDict() # options for current tag self._hsdoptions = OrderedDict() # hsd-options for current tag self._key = "" # current option name @@ -46,10 +46,10 @@ def __init__(self, defattrib="default"): self._flag_haschild = False self._oldbefore = "" - + def feed(self, fileobj): """Feeds the parser with data. - + Args: fileobj: File like object or name of a file containing the data. """ @@ -64,7 +64,7 @@ def feed(self, fileobj): self._currline += 1 if isfilename: fp.close() - + # Check for errors if self._currenttags: line0 = self._currenttags[-1][1] @@ -79,51 +79,51 @@ def feed(self, fileobj): elif ("".join(self._buffer)).strip(): self._error(ORPHAN_TEXT_ERROR, (line0, self._currline)) - + def start_handler(self, tagname, options, hsdoptions): """Handler which is called when a tag is opened. - + It should be overriden in the application to handle the event in a customized way. - + Args: tagname: Name of the tag which had been opened. options: Dictionary of the options (attributes) of the tag. hsdoptions: Dictionary of the options created during the processing - in the hsd-parser. + in the hsd-parser. """ pass - + def close_handler(self, tagname): """Handler which is called when a tag is closed. - + It should be overriden in the application to handle the event in a customized way. - + Args: tagname: Name of the tag which had been closed. - """ + """ pass - + def text_handler(self, text): """Handler which is called with the text found inside a tag. - + It should be overriden in the application to handle the event in a customized way. - + Args: text: Text in the current tag. """ pass - + def error_handler(self, error_code, file, lines): """Handler which is called if an error was detected during parsing. - + The default implementation throws a HSDException or a descendant of it. - + Args: error_code: Code for signalizing the type of the error. file: Current file name (empty string if not known). @@ -133,18 +133,18 @@ def error_handler(self, error_code, file, lines): "Parsing error ({}) between lines {} - {} in file '{}'.".format( error_code, lines[0] + 1, lines[1] + 1, file)) raise hsd.HSDParserError(error_msg) - - + + def interrupt_handler_hsd(self, command): """Handles hsd type interrupt. - + The base class implements following handling: Command is interpreted as a file name (quotes eventually removed). A parser is opened with the same handlers as the current one, and the given file is feeded in it. - + Args: command: Unstripped string as specified in the HSD input after - the interrupt sign. + the interrupt sign. """ fname = hsd.unquote(command.strip()) parser = HSDParser(defattrib=self._defattrib) @@ -153,18 +153,18 @@ def interrupt_handler_hsd(self, command): parser.text_handler = self.text_handler parser.feed(fname) - + def interrupt_handler_txt(self, command): """Handles text type interrupt. - + The base class implements following handling: Command is interpreted as a file name (quotes eventually removed). The file is opened and its content is read (without parsing) and added as text. - + Args: command: Unstripped string as specified in the HSD input after the interrupt sign. - + Returns: Unparsed text to be added to the HSD input. """ @@ -174,31 +174,31 @@ def interrupt_handler_txt(self, command): fp.close() return txt - + def _parse(self, line): """Parses a given line.""" - + while True: sign, before, after = _splitbycharset(line, self._checkstr) - # End of line + # End of line if not sign: if self._flag_quote: self._buffer.append(before) elif self._flag_equalsign: self._text("".join(self._buffer) + before.strip()) self._closetag() - self._flag_equalsign = False + self._flag_equalsign = False elif not self._flag_option: self._buffer.append(before) elif before.strip(): self._error(SYNTAX_ERROR, (self._currline, self._currline)) break - + # Special character is escaped elif before.endswith("\\") and not before.endswith("\\\\"): self._buffer.append(before + sign) - + # Equal sign outside option specification elif sign == "=" and not self._flag_option: # Ignore if followed by "{" (DFTB+ compatibility) @@ -209,12 +209,12 @@ def _parse(self, line): self._hsdoptions[hsd.HSDATTR_EQUAL] = True self._starttag(before, False) self._flag_equalsign = True - + # Equal sign inside option specification elif sign == "=": self._key = before.strip() self._buffer = [] - + # Opening tag by curly brace elif sign == "{" and not self._flag_option: self._flag_haschild = True @@ -231,18 +231,18 @@ def _parse(self, line): self._flag_equalsign = False self._closetag() self._closetag() - + # Closing tag by semicolon elif sign == ";" and self._flag_equalsign and not self._flag_option: self._flag_equalsign = False self._text(before) self._closetag() - + # Comment line elif sign == "#": self._buffer.append(before) after = "" - + # Opening option specification elif sign == "[" and not self._flag_option: if "".join(self._buffer).strip(): @@ -253,7 +253,7 @@ def _parse(self, line): self._key = "" self._currenttags.append(("[", self._currline, None)) self._checkstr = OPTION_SPECIALS - + # Closing option specification elif sign == "]" and self._flag_option: value = "".join(self._buffer) + before @@ -263,7 +263,7 @@ def _parse(self, line): self._buffer = [] self._currenttags.pop() self._checkstr = GENERAL_SPECIALS - + # Quoting strings elif sign == "'" or sign == '"': if self._flag_quote: @@ -277,15 +277,15 @@ def _parse(self, line): self._flag_quote = True self._buffer.append(sign) self._currenttags.append(('"', self._currline, None)) - + # Closing attribute specification elif sign == "," and self._flag_option: value = "".join(self._buffer) + before key = self._key.lower() if self._key else self._defattrib self._options[key] = value.strip() - + # Interrupt - elif (sign == "<" and not self._flag_option + elif (sign == "<" and not self._flag_option and not self._flag_equalsign): txtint = after.startswith("<<") hsdint = after.startswith(" Date: Sat, 4 Dec 2021 01:41:31 +0000 Subject: [PATCH 05/17] Missing line ending added --- .gitignore | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index 19540097..75f25bd0 100644 --- a/.gitignore +++ b/.gitignore @@ -5,4 +5,4 @@ *.pyc __pycache__ *build/ -*_build/ \ No newline at end of file +*_build/ From 690ad1269a8d41ce24a5b7f120e195c58281e84b Mon Sep 17 00:00:00 2001 From: Ziyang HU Date: Sun, 5 Dec 2021 10:46:57 +0800 Subject: [PATCH 06/17] Changed to LibXC 5 interface --- .gitignore | 2 +- AUTHORS.rst | 2 ++ README.rst | 2 +- slateratom/lib/dft.f90 | 19 +++++++++++++------ 4 files changed, 17 insertions(+), 8 deletions(-) diff --git a/.gitignore b/.gitignore index 19540097..75f25bd0 100644 --- a/.gitignore +++ b/.gitignore @@ -5,4 +5,4 @@ *.pyc __pycache__ *build/ -*_build/ \ No newline at end of file +*_build/ diff --git a/AUTHORS.rst b/AUTHORS.rst index 163d6315..1602e6df 100644 --- a/AUTHORS.rst +++ b/AUTHORS.rst @@ -9,6 +9,8 @@ contributed to this package : * Ben Hourahine (University of Strathclyde, UK) +* Ziyang Hu (Hong Kong Quantum AI Lab Limited, HKU) + * Christof Köhler (University of Bremen) * Thomas Niehaus (University of Lyon, France) diff --git a/README.rst b/README.rst index 9b2dc99b..14b08532 100644 --- a/README.rst +++ b/README.rst @@ -23,7 +23,7 @@ Prerequisites * Python3 -* LibXC library with f90 interface (tested with version 4.3.4, version 5.x does +* LibXC library with f90 interface (tested with version 5.1.6, version 4.x does not work due to inteface changes in LibXC) diff --git a/slateratom/lib/dft.f90 b/slateratom/lib/dft.f90 index 84f925ab..daeb9840 100644 --- a/slateratom/lib/dft.f90 +++ b/slateratom/lib/dft.f90 @@ -65,8 +65,11 @@ subroutine density_grid(p,max_l,num_alpha,poly_order,alpha,num_mesh_points,& integer, intent(in) :: xcnr real(dp), intent(out) :: rho(:,:),drho(:,:),ddrho(:,:),vxc(:,:),exc(:) real(dp) :: rhotot,rhodiff,drhotot,ddrhotot,drhodiff,ddrhodiff - integer :: ii,jj,kk,ll,mm,nn,oo - type(xc_f90_pointer_t) :: xcfunc_x, xcfunc_c, xcinfo + integer :: ii,jj,kk,ll,mm,oo + integer(c_size_t) :: nn + !type(xc_f90_pointer_t) :: xcfunc_x, xcfunc_c, xcinfo + type(xc_f90_func_t) :: xcfunc_x, xcfunc_c + type(xc_f90_func_info_t) :: xcinfo real(dp), allocatable :: tmprho(:,:), ex(:), ec(:), vx(:,:), vc(:,:) real(dp), allocatable :: tmpsigma(:,:), vxsigma(:,:), vcsigma(:,:) real(dp), allocatable :: tmpv(:), tmpv2(:) @@ -76,11 +79,15 @@ subroutine density_grid(p,max_l,num_alpha,poly_order,alpha,num_mesh_points,& if (xcnr==0) return if (xcnr == 2) then - call xc_f90_func_init(xcfunc_x, xcinfo, XC_LDA_X, XC_POLARIZED) - call xc_f90_func_init(xcfunc_c, xcinfo, XC_LDA_C_PW, XC_POLARIZED) + call xc_f90_func_init(xcfunc_x, XC_LDA_X, XC_POLARIZED) + xcinfo = xc_f90_func_get_info(xcfunc_x) + call xc_f90_func_init(xcfunc_c, XC_LDA_C_PW, XC_POLARIZED) + xcinfo = xc_f90_func_get_info(xcfunc_x) elseif (xcnr == 3) then - call xc_f90_func_init(xcfunc_x, xcinfo, XC_GGA_X_PBE, XC_POLARIZED) - call xc_f90_func_init(xcfunc_c, xcinfo, XC_GGA_C_PBE, XC_POLARIZED) + call xc_f90_func_init(xcfunc_x, XC_GGA_X_PBE, XC_POLARIZED) + xcinfo = xc_f90_func_get_info(xcfunc_x) + call xc_f90_func_init(xcfunc_c, XC_GGA_C_PBE, XC_POLARIZED) + xcinfo = xc_f90_func_get_info(xcfunc_x) end if do ii=1,num_mesh_points From cfaebc4e90643faad9e8c6d9f13e7881a3693564 Mon Sep 17 00:00:00 2001 From: Ziyang HU Date: Sun, 5 Dec 2021 11:12:57 +0800 Subject: [PATCH 07/17] Intel compiler added to compile example --- README.rst | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/README.rst b/README.rst index 14b08532..434bd5c8 100644 --- a/README.rst +++ b/README.rst @@ -32,11 +32,15 @@ Building the code Follow the usual CMake build workflow: -* Configure the project, specify your compiler (e.g. ``gfortran``), the install +* Configure the project, specify your compiler (e.g. ``gfortran``, ``ifort``, etc), the install location (e.g. ``$HOME/opt/skprogs``) and the build directory (e.g. ``_build``):: - FC=gfortran cmake -DCMAKE_INSTALL_PREFIX=$HOME/opt/skprogs -B _build . + FC=gfortran cmake -DCMAKE_INSTALL_PREFIX=$HOME/opt/skprogs -DCMAKE_Fortran_FLAGS=-fopenmp -B _build . + + or:: + + FC=ifort cmake -DCMAKE_INSTALL_PREFIX=$HOME/opt/skprogs -DCMAKE_Fortran_FLAGS=-qopenmp -B _build . If libXC is installed in a non-standard location, you may need to specify either the ``CMAKE_PREFIX_PATH`` environment variable (if libXC was built with @@ -47,8 +51,14 @@ Follow the usual CMake build workflow: PKG_CONFIG_PATH=FOLDER_WITH_LIBXC_PC_FILES FC=gfortran cmake [...] + or:: + + CMAKE_PREFIX_PATH=YOUR_LIBXC_INSTALL_FOLDER FC=ifort cmake [...] + + PKG_CONFIG_PATH=FOLDER_WITH_LIBXC_PC_FILES FC=ifort cmake [...] + -* If the configuration was successful, buid the code :: +* If the configuration was successful, build the code :: cmake --build _build -- -j From 50131de6a70c9ba0423c685348ba0c7eaed02a1d Mon Sep 17 00:00:00 2001 From: Ziyang HU Date: Sun, 5 Dec 2021 13:24:06 +0800 Subject: [PATCH 08/17] Change type conversion from float/dfloat to real(,dp) --- slateratom/lib/core_overlap.f90 | 4 +-- slateratom/lib/coulomb_hfex.f90 | 6 ++-- slateratom/lib/coulomb_potential.f90 | 4 +-- slateratom/lib/density.f90 | 54 ++++++++++++++-------------- slateratom/lib/dft.f90 | 4 +-- slateratom/lib/hamiltonian.f90 | 4 +-- slateratom/lib/integration.f90 | 22 ++++++------ slateratom/lib/output.f90 | 4 +-- slateratom/lib/total_energy.f90 | 2 +- slateratom/lib/zora_routines.f90 | 12 +++---- 10 files changed, 58 insertions(+), 58 deletions(-) diff --git a/slateratom/lib/core_overlap.f90 b/slateratom/lib/core_overlap.f90 index 22923ed6..ae484a03 100644 --- a/slateratom/lib/core_overlap.f90 +++ b/slateratom/lib/core_overlap.f90 @@ -167,7 +167,7 @@ end subroutine nuclear ! oo=oo+1 ! nlq=mm+ii ! - ! normalization=float(2**(nlp+nlq+1))/& + ! normalization=real(2**(nlp+nlq+1),dp)/& ! sqrt(v(alpha(ii,jj),2*nlp)*v(alpha(ii,kk),2*nlq)) ! ! part1=exp_int(alpha2,nlp+nlq-1,r0)-exp_int(alpha2,nlp+nlq-1,0.0d0) @@ -387,7 +387,7 @@ function w(x,i,j) ! W_{ij}(x) integer, intent(in) :: i,j real(dp) :: w - w=2.0d0*float((j-i-1))/x + w=2.0d0*real((j-i-1),dp)/x return end function w diff --git a/slateratom/lib/coulomb_hfex.f90 b/slateratom/lib/coulomb_hfex.f90 index 04631eec..36d64272 100644 --- a/slateratom/lib/coulomb_hfex.f90 +++ b/slateratom/lib/coulomb_hfex.f90 @@ -85,7 +85,7 @@ subroutine coulomb(j,max_l,num_alpha,alpha,poly_order,u,s) ! do ii=0,max_l ! do jj=0,max_l ! j(ii,:,:,jj,:,:)=j(ii,:,:,jj,:,:)/& - ! &((2.0d0*float(ii)+1.0d0)*(2.0d0*float(jj)+1.0d0)) + ! &((2.0d0*real(ii,dp)+1.0d0)*(2.0d0*real(jj,dp)+1.0d0)) ! end do ! end do @@ -222,7 +222,7 @@ subroutine hfex(k,max_l,num_alpha,alpha,poly_order,problemsize) ! do ii=0,max_l ! do jj=0,max_l ! k(ii,:,:,jj,:,:)=k(ii,:,:,jj,:,:)/& - ! &((2.0d0*float(ii)+1.0d0)*(2.0d0*float(jj)+1.0d0)) + ! &((2.0d0*real(ii,dp)+1.0d0)*(2.0d0*real(jj,dp)+1.0d0)) ! end do ! end do @@ -304,7 +304,7 @@ function almn(lambda,mu,nu) real(dp) :: almn almn=a(lambda+mu-nu)*a(lambda-mu+nu)*a(mu-lambda+nu)/& - &(float(lambda+mu+nu+1)*a(lambda+mu+nu)) + &(real(lambda+mu+nu+1,dp)*a(lambda+mu+nu)) end function almn diff --git a/slateratom/lib/coulomb_potential.f90 b/slateratom/lib/coulomb_potential.f90 index 13aa5d73..5f183884 100644 --- a/slateratom/lib/coulomb_potential.f90 +++ b/slateratom/lib/coulomb_potential.f90 @@ -71,9 +71,9 @@ subroutine cou_pot(p,max_l,num_alpha,poly_order,alpha,problemsize,& ! add normalization of basis functions ! watch out for 2**(nlp+nlq+1) needed because variable integration ranges - help1(:,ii,ll,oo)=help1(:,ii,ll,oo)*float(2**(nlp+nlq+1))/& + help1(:,ii,ll,oo)=help1(:,ii,ll,oo)*real(2**(nlp+nlq+1),dp)/& &sqrt(v(alpha(ii,jj),2*nlp)*v(alpha(ii,mm),2*nlq)) - help2(:,ii,ll,oo)=help2(:,ii,ll,oo)*float(2**(nlp+nlq+1))/& + help2(:,ii,ll,oo)=help2(:,ii,ll,oo)*real(2**(nlp+nlq+1),dp)/& &sqrt(v(alpha(ii,jj),2*nlp)*v(alpha(ii,mm),2*nlq)) end do diff --git a/slateratom/lib/density.f90 b/slateratom/lib/density.f90 index 5a662524..89ef944c 100644 --- a/slateratom/lib/density.f90 +++ b/slateratom/lib/density.f90 @@ -315,10 +315,10 @@ function basis_1st(alpha,poly_order,l,r) if ((r==0.0d0).and.((poly_order+l-1)==0)) then basis_1st=normalization*(-alpha*exp(-alpha*r)) else if ((r==0.0d0).and.((poly_order+l-2)==0)) then - basis_1st=normalization*(float(poly_order+l-1)*& + basis_1st=normalization*(real(poly_order+l-1,dp)*& &exp(-alpha*r)-alpha*r**(poly_order+l-1)*exp(-alpha*r)) else - basis_1st=normalization*(float(poly_order+l-1)*r**(poly_order+l-2)*& + basis_1st=normalization*(real(poly_order+l-1,dp)*r**(poly_order+l-2)*& &exp(-alpha*r)-alpha*r**(poly_order+l-1)*exp(-alpha*r)) end if @@ -339,16 +339,16 @@ function basis_2nd(alpha,poly_order,l,r) ! catch 0^0 if ((r==0.0d0).and.((poly_order+l-3)==0)) then - basis_2nd=normalization*(float(poly_order+l-1)*float(poly_order+l-2)*& + basis_2nd=normalization*(real(poly_order+l-1,dp)*real(poly_order+l-2,dp)*& &exp(-alpha*r)) else if ((r==0.0d0).and.((poly_order+l-2)==0)) then - basis_2nd=normalization*(-2.0d0*alpha*float(poly_order+l-1)*& + basis_2nd=normalization*(-2.0d0*alpha*real(poly_order+l-1,dp)*& &exp(-alpha*r)) else if ((r==0.0d0).and.((poly_order+l-1)==0)) then basis_2nd=normalization*(alpha**2*exp(-alpha*r)) else - basis_2nd=normalization*(float(poly_order+l-1)*float(poly_order+l-2)*& - &r**(poly_order+l-3)*exp(-alpha*r)-2.0d0*alpha*float(poly_order+l-1)*& + basis_2nd=normalization*(real(poly_order+l-1,dp)*real(poly_order+l-2,dp)*& + &r**(poly_order+l-3)*exp(-alpha*r)-2.0d0*alpha*real(poly_order+l-1,dp)*& &r**(poly_order+l-2)*exp(-alpha*r)+alpha**2*r**(poly_order+l-1)*& &exp(-alpha*r)) end if @@ -419,10 +419,10 @@ function basis_times_basis_1st(alpha,poly1,beta,poly2,l,r) &(-beta)*exp(ab*r) else if ((r==0.0d0).and.((m+n-3)==0)) then basis_times_basis_1st=normalization1*normalization2*& - &(float(n-1))*exp(ab*r) + &(real(n-1,dp))*exp(ab*r) else basis_times_basis_1st=normalization1*normalization2*& - &(float(n-1)*r**(m+n-3)-beta*r**(n+m-2))*exp(ab*r) + &(real(n-1,dp)*r**(m+n-3)-beta*r**(n+m-2))*exp(ab*r) end if if (abs(basis_times_basis_1st)<1.0d-20) basis_times_basis_1st=0.0d0 @@ -452,8 +452,8 @@ function basis_times_basis_2nd(alpha,poly1,beta,poly2,l,r) ! WARNING: without summing negative and positive contributions independently ! zora becomes completely unstable ! - positive=float((n-1)*(n-2))*r**(m+n-4)+beta**2*r**(m+n-2) - negative=float(2*(n-1))*beta*r**(n+m-3) + positive=real((n-1)*(n-2),dp)*r**(m+n-4)+beta**2*r**(m+n-2) + negative=real(2*(n-1),dp)*beta*r**(n+m-3) basis_times_basis_2nd=normalization1*normalization2*& &(positive-negative)*exp(ab*r) @@ -488,16 +488,16 @@ function basis_1st_times_basis_1st(alpha,poly1,beta,poly2,l,r) if ((r==0.0d0).and.((m+n-2)==0)) then positive=alpha*beta else if ((r==0.0d0).and.((m+n-4)==0)) then - positive=float((m-1)*(n-1)) + positive=real((m-1)*(n-1),dp) else - positive=float((m-1)*(n-1))*r**(m+n-4)+& + positive=real((m-1)*(n-1),dp)*r**(m+n-4)+& &alpha*beta*r**(m+n-2) end if if ((r==0.0d0).and.((m+n-3)==0)) then - negative=(alpha*float(n-1)+beta*float(m-1)) + negative=(alpha*real(n-1,dp)+beta*real(m-1,dp)) else - negative=(alpha*float(n-1)+beta*float(m-1))*r**(m+n-3) + negative=(alpha*real(n-1,dp)+beta*real(m-1,dp))*r**(m+n-3) end if basis_1st_times_basis_1st=normalization1*normalization2*& @@ -528,15 +528,15 @@ function basis_2nd_times_basis_2nd(alpha,poly1,beta,poly2,l,r) ! WARNING: without summing negative and positive contributions independently ! zora becomes completely unstable ! - positive=float((m-1)*(m-2)*(n-1)*(n-2))*r**(n+m-6)+& - &r**(m+n-4)*(beta**2*float((m-1)*(m-2))+alpha**2*float((n-1)*(n-2))+& - &alpha*beta*float(4*(m-1)*(n-1)))+& + positive=real((m-1)*(m-2)*(n-1)*(n-2),dp)*r**(n+m-6)+& + &r**(m+n-4)*(beta**2*real((m-1)*(m-2),dp)+alpha**2*real((n-1)*(n-2),dp)+& + &alpha*beta*real(4*(m-1)*(n-1),dp))+& &alpha**2*beta**2*r**(m+n-2) - negative=r**(m+n-5)*(beta*float(2*(n-1)*(m-1)*(m-2))+& - &alpha*float(2*(m-1)*(n-1)*(n-2)))+& - &r**(m+n-3)*(alpha*beta**2*float(2*(m-1))+& - &beta*alpha**2*float(2*(n-1))) + negative=r**(m+n-5)*(beta*real(2*(n-1)*(m-1)*(m-2),dp)+& + &alpha*real(2*(m-1)*(n-1)*(n-2),dp))+& + &r**(m+n-3)*(alpha*beta**2*real(2*(m-1),dp)+& + &beta*alpha**2*real(2*(n-1),dp)) basis_2nd_times_basis_2nd=normalization1*normalization2*& &(positive-negative)*exp(ab*r) @@ -596,7 +596,7 @@ function basis_times_basis_1st_times_r2(alpha,poly1,beta,poly2,l,r) ! WARNING: without summing negative and positive contributions independently ! zora becomes completely unstable ! basis_times_basis_1st_times_r2=normalization1*normalization2*& - &(float(n-1)*r**(m+n-1)-beta*r**(n+m))*exp(ab*r) + &(real(n-1,dp)*r**(m+n-1)-beta*r**(n+m))*exp(ab*r) if (abs(basis_times_basis_1st_times_r2)<1.0d-20) & &basis_times_basis_1st_times_r2=0.0d0 @@ -626,8 +626,8 @@ function basis_times_basis_2nd_times_r2(alpha,poly1,beta,poly2,l,r) ! WARNING: without summing negative and positive contributions independently ! zora becomes completely unstable ! - positive=float((n-1)*(n-2))*r**(m+n-2)+beta**2*r**(m+n) - negative=float(2*(n-1))*beta*r**(n+m-1) + positive=real((n-1)*(n-2),dp)*r**(m+n-2)+beta**2*r**(m+n) + negative=real(2*(n-1),dp)*beta*r**(n+m-1) basis_times_basis_2nd_times_r2=normalization1*normalization2*& &(positive-negative)*exp(ab*r) @@ -661,7 +661,7 @@ function basis_times_basis_1st_times_r(alpha,poly1,beta,poly2,l,r) ! WARNING: without summing negative and positive contributions independently ! zora becomes completely unstable ! basis_times_basis_1st_times_r=normalization1*normalization2*& - &(float(n-1)*r**(m+n-2)-beta*r**(n+m-1))*exp(ab*r) + &(real(n-1,dp)*r**(m+n-2)-beta*r**(n+m-1))*exp(ab*r) if (abs(basis_times_basis_1st_times_r)<1.0d-20) & &basis_times_basis_1st_times_r=0.0d0 @@ -689,9 +689,9 @@ function basis_1st_times_basis_1st_times_r2(alpha,poly1,beta,poly2,l,r) ! WARNING: without summing negative and positive contributions independently ! zora becomes completely unstable ! - positive=float((m-1)*(n-1))*r**(m+n-2)+& + positive=real((m-1)*(n-1),dp)*r**(m+n-2)+& &alpha*beta*r**(m+n) - negative=(alpha*float(n-1)+beta*float(m-1))*r**(m+n-1) + negative=(alpha*real(n-1,dp)+beta*real(m-1,dp))*r**(m+n-1) basis_1st_times_basis_1st_times_r2=normalization1*normalization2*& &(positive-negative)*exp(ab*r) diff --git a/slateratom/lib/dft.f90 b/slateratom/lib/dft.f90 index daeb9840..8719d8a6 100644 --- a/slateratom/lib/dft.f90 +++ b/slateratom/lib/dft.f90 @@ -33,14 +33,14 @@ subroutine dft_start_pot(abcissa,num_mesh_points,nuc,vxc) real(dp) :: b,t,x,rtx integer :: ii - b= (0.69395656d0/float(nuc))**(1.0d0/3.0d0) + b= (0.69395656d0/real(nuc,dp))**(1.0d0/3.0d0) do ii=1,num_mesh_points x= abcissa(ii)/b rtx= sqrt(x) - t= float(nuc)/(1.0d0+rtx*(0.02747d0-x*(0.1486d0-0.007298d0*x))& + t= real(nuc,dp)/(1.0d0+rtx*(0.02747d0-x*(0.1486d0-0.007298d0*x))& &+x*(1.243d0+x*(0.2302d0+0.006944d0*x))); if (t < 1.0d0) t= 1.0d0 diff --git a/slateratom/lib/hamiltonian.f90 b/slateratom/lib/hamiltonian.f90 index e20fcb27..865921e3 100644 --- a/slateratom/lib/hamiltonian.f90 +++ b/slateratom/lib/hamiltonian.f90 @@ -65,8 +65,8 @@ subroutine build_fock(iter,t,u,nuc,vconf,j,k,p,max_l,num_alpha,poly_order,& ! build mixer input - pot_new(1,:,:,:)=-float(nuc)*u(:,:,:)+j_matrix(:,:,:)-k_matrix(1,:,:,:) - pot_new(2,:,:,:)=-float(nuc)*u(:,:,:)+j_matrix(:,:,:)-k_matrix(2,:,:,:) + pot_new(1,:,:,:)=-real(nuc,dp)*u(:,:,:)+j_matrix(:,:,:)-k_matrix(1,:,:,:) + pot_new(2,:,:,:)=-real(nuc,dp)*u(:,:,:)+j_matrix(:,:,:)-k_matrix(2,:,:,:) ! mixer diff --git a/slateratom/lib/integration.f90 b/slateratom/lib/integration.f90 index 75647b12..45a51e5b 100644 --- a/slateratom/lib/integration.f90 +++ b/slateratom/lib/integration.f90 @@ -34,7 +34,7 @@ subroutine gauss_chebyshev_becke_mesh(N,nuc,w,r, dzdr, d2zdr2, dz) allocate(x(N)) allocate(fak(N)) ! - temp=pi/float(N+1) + temp=pi/real(N+1,dp) dz = temp ! do ii=1,N @@ -52,7 +52,7 @@ subroutine gauss_chebyshev_becke_mesh(N,nuc,w,r, dzdr, d2zdr2, dz) &/ (4.0_dp * bragg(nuc)**2 * (-1.0_dp + cosz) * sinz) ! r**2 times first derivative of x -> r mapping function - w(ii)=temp*(sin(float(ii)*temp)) + w(ii)=temp*(sin(real(ii,dp)*temp)) ! fak(ii)=2.0_dp*r(ii)**2*bragg(nuc)/(1.0_dp-x(ii))**2 fak(ii)=2.0_dp*bragg(nuc)/(1.0_dp-x(ii))**2 @@ -79,12 +79,12 @@ subroutine get_abcissas(N,nuc,r,step) allocate(x(N)) - step=pi/float(N+1) + step=pi/real(N+1,dp) do ii=1,N ! NOTE prefactor - x(ii)=(-1.0_dp)*cos(step*float(ii)) ! gauss-chebyshev abcissas + x(ii)=(-1.0_dp)*cos(step*real(ii,dp)) ! gauss-chebyshev abcissas r(ii)=(1.0_dp+x(ii))/(1.0_dp-x(ii))*bragg(nuc) end do @@ -103,12 +103,12 @@ subroutine get_abcissas_z_1st(N,nuc,dr,step) integer, intent(out) :: step ! generator step size integer :: ii - step=pi/float(N+1) + step=pi/real(N+1,dp) do ii=1,N - dr(ii)=2.0d0*bragg(nuc)*pi*sin(step*float(ii))/& - &(1.0d0+2.0d0*cos(step*float(ii))+cos(step*float(ii))**2) + dr(ii)=2.0d0*bragg(nuc)*pi*sin(step*real(ii,dp))/& + &(1.0d0+2.0d0*cos(step*real(ii,dp))+cos(step*real(ii,dp))**2) end do @@ -124,12 +124,12 @@ subroutine get_abcissas_z_2nd(N,nuc,ddr,step) integer, intent(out) :: step ! generator step size integer :: ii - step=pi/float(N+1) + step=pi/real(N+1,dp) do ii=1,N - ddr(ii)=(-2.0d0*bragg(nuc)*pi**2)*(cos(step*float(ii))-2.0d0)/& - &(1.0d0+2.0d0*cos(step*float(ii))+cos(step*float(ii))**2) + ddr(ii)=(-2.0d0*bragg(nuc)*pi**2)*(cos(step*real(ii,dp))-2.0d0)/& + &(1.0d0+2.0d0*cos(step*real(ii,dp))+cos(step*real(ii,dp))**2) end do @@ -240,7 +240,7 @@ function exp_int(alpha,power,r) exp_int=1.0d0/alpha*exp(alpha*r) do ii=1,power - exp_int=1.0d0/alpha*r**ii*exp(alpha*r)-float(ii)/alpha*exp_int + exp_int=1.0d0/alpha*r**ii*exp(alpha*r)-real(ii,dp)/alpha*exp_int end do end function exp_int diff --git a/slateratom/lib/output.f90 b/slateratom/lib/output.f90 index 78ced5b6..f0cb7a2d 100644 --- a/slateratom/lib/output.f90 +++ b/slateratom/lib/output.f90 @@ -276,13 +276,13 @@ subroutine write_potentials_file_standard(num_mesh_points,abcissa,weight,& do ii=1,num_mesh_points write(95,'(6ES21.12E3)') abcissa(ii), weight(ii), & - &float(-nuc) / abcissa(ii), cpot(ii), vxc(ii,1), vxc(ii,2) + &real(-nuc,dp) / abcissa(ii), cpot(ii), vxc(ii,1), vxc(ii,2) end do close(95) do ii=1,num_mesh_points ecou=ecou+weight(ii)*rhotot(ii)*cpot(ii)*abcissa(ii)**2 - enuc=enuc-weight(ii)*rhotot(ii)*float(nuc)*abcissa(ii) + enuc=enuc-weight(ii)*rhotot(ii)*real(nuc,dp)*abcissa(ii) vxcint(1)=vxcint(1)+weight(ii)*rho(ii,1)*vxc(ii,1)*abcissa(ii)**2 vxcint(2)=vxcint(2)+weight(ii)*rho(ii,2)*vxc(ii,2)*abcissa(ii)**2 end do diff --git a/slateratom/lib/total_energy.f90 b/slateratom/lib/total_energy.f90 index 32b161f6..3481f97c 100644 --- a/slateratom/lib/total_energy.f90 +++ b/slateratom/lib/total_energy.f90 @@ -229,7 +229,7 @@ subroutine core_hamiltonian_energies(t,u,vconf,p_total,max_l,num_alpha,& do mm=1,poly_order(ii) tt=tt+1 kinetic=kinetic+t(ii,ss,tt)*p_total(ii,ss,tt) - nuclear=nuclear-float(nuc)*u(ii,ss,tt)*p_total(ii,ss,tt) + nuclear=nuclear-real(nuc,dp)*u(ii,ss,tt)*p_total(ii,ss,tt) confinement=confinement+vconf(ii,ss,tt)*p_total(ii,ss,tt) end do end do diff --git a/slateratom/lib/zora_routines.f90 b/slateratom/lib/zora_routines.f90 index a614c38a..3033bfbf 100644 --- a/slateratom/lib/zora_routines.f90 +++ b/slateratom/lib/zora_routines.f90 @@ -62,13 +62,13 @@ subroutine zora_t_correction(mode,t,max_l,num_alpha,alpha,poly_order,& &kappa(1,:),alpha(ii,jj),ll,alpha(ii,kk),& &mm,ii)+kinetic_part_2(num_mesh_points,weight,abcissa,& &kappa(1,:),alpha(ii,jj),ll,alpha(ii,kk),& - &mm,ii)*dfloat(ii*(ii+1)) + &mm,ii)*real(ii*(ii+1),dp) t(2,ii,nn,oo)=kinetic_part_1(num_mesh_points,weight,abcissa,& &kappa(2,:),alpha(ii,jj),ll,alpha(ii,kk),& &mm,ii)+kinetic_part_2(num_mesh_points,weight,abcissa,& &kappa(2,:),alpha(ii,jj),ll,alpha(ii,kk),& - &mm,ii)*dfloat(ii*(ii+1)) + &mm,ii)*real(ii*(ii+1),dp) end if @@ -82,13 +82,13 @@ subroutine zora_t_correction(mode,t,max_l,num_alpha,alpha,poly_order,& &kappa2(1,:),alpha(ii,jj),ll,alpha(ii,kk),& &mm,ii)+kinetic_part_2(num_mesh_points,weight,abcissa,& &kappa2(1,:),alpha(ii,jj),ll,alpha(ii,kk),& - &mm,ii)*dfloat(ii*(ii+1)) + &mm,ii)*real(ii*(ii+1),dp) t(2,ii,nn,oo)=kinetic_part_1(num_mesh_points,weight,abcissa,& &kappa2(2,:),alpha(ii,jj),ll,alpha(ii,kk),& &mm,ii)+kinetic_part_2(num_mesh_points,weight,abcissa,& &kappa2(2,:),alpha(ii,jj),ll,alpha(ii,kk),& - &mm,ii)*dfloat(ii*(ii+1)) + &mm,ii)*real(ii*(ii+1),dp) end if @@ -325,8 +325,8 @@ subroutine potential_to_mesh(num_mesh_points,abcissa,& do ii=1,num_mesh_points - vtot(1,ii)=-float(nuc)/abcissa(ii)+cpot(ii)+vxc(ii,1) - vtot(2,ii)=-float(nuc)/abcissa(ii)+cpot(ii)+vxc(ii,2) + vtot(1,ii)=-real(nuc,dp)/abcissa(ii)+cpot(ii)+vxc(ii,1) + vtot(2,ii)=-real(nuc,dp)/abcissa(ii)+cpot(ii)+vxc(ii,2) end do From d86146c1ee6139cf908dd6da63276daa5af9feb7 Mon Sep 17 00:00:00 2001 From: Young WU <43809414+tsihyoung@users.noreply.github.com> Date: Sun, 5 Dec 2021 18:13:53 +0800 Subject: [PATCH 09/17] Update slateratom/lib/dft.f90 Co-authored-by: Sebastian Ehlert <28669218+awvwgk@users.noreply.github.com> --- slateratom/lib/dft.f90 | 1 - 1 file changed, 1 deletion(-) diff --git a/slateratom/lib/dft.f90 b/slateratom/lib/dft.f90 index daeb9840..61cfc452 100644 --- a/slateratom/lib/dft.f90 +++ b/slateratom/lib/dft.f90 @@ -67,7 +67,6 @@ subroutine density_grid(p,max_l,num_alpha,poly_order,alpha,num_mesh_points,& real(dp) :: rhotot,rhodiff,drhotot,ddrhotot,drhodiff,ddrhodiff integer :: ii,jj,kk,ll,mm,oo integer(c_size_t) :: nn - !type(xc_f90_pointer_t) :: xcfunc_x, xcfunc_c, xcinfo type(xc_f90_func_t) :: xcfunc_x, xcfunc_c type(xc_f90_func_info_t) :: xcinfo real(dp), allocatable :: tmprho(:,:), ex(:), ec(:), vx(:,:), vc(:,:) From 40fed7cead079677e454c1eb96d5dbb83cd84729 Mon Sep 17 00:00:00 2001 From: Ben Hourahine Date: Sun, 5 Dec 2021 11:41:38 +0000 Subject: [PATCH 10/17] Small re-wording --- README.rst | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/README.rst b/README.rst index 9b2dc99b..4f565972 100644 --- a/README.rst +++ b/README.rst @@ -2,8 +2,8 @@ SkProgs ******* -Package containing a few programs enabling to generate Slater-Koster files for -the DFTB-method. +Package containing a few programs that are useful in generating Slater-Koster +files for the DFTB-method. **NOTE**: This packages comes with minimal documentation and with a currently rather fragile user interface. It is considered to be neither stable nor From 2666694db33751a0470d31d09eaf70aeb6e41b85 Mon Sep 17 00:00:00 2001 From: Ben Hourahine Date: Tue, 7 Dec 2021 10:31:15 +0000 Subject: [PATCH 11/17] Update issue templates --- .github/ISSUE_TEMPLATE/bug_report.md | 27 +++++++++++++++++++++++ .github/ISSUE_TEMPLATE/feature_request.md | 23 +++++++++++++++++++ 2 files changed, 50 insertions(+) create mode 100644 .github/ISSUE_TEMPLATE/bug_report.md create mode 100644 .github/ISSUE_TEMPLATE/feature_request.md diff --git a/.github/ISSUE_TEMPLATE/bug_report.md b/.github/ISSUE_TEMPLATE/bug_report.md new file mode 100644 index 00000000..34197e11 --- /dev/null +++ b/.github/ISSUE_TEMPLATE/bug_report.md @@ -0,0 +1,27 @@ +--- +name: Bug report +about: Create a report to help us improve skprogs +title: '' +labels: '' +assignees: '' + +--- + +**Describe the bug** + + +**To Reproduce** + + +**Expected behaviour** + + +**Additional context** + diff --git a/.github/ISSUE_TEMPLATE/feature_request.md b/.github/ISSUE_TEMPLATE/feature_request.md new file mode 100644 index 00000000..4683bee8 --- /dev/null +++ b/.github/ISSUE_TEMPLATE/feature_request.md @@ -0,0 +1,23 @@ +--- +name: Feature request +about: Suggest an idea for the skprogs project +title: '' +labels: '' +assignees: '' + +--- + +**What is your suggested feature? Please describe.** + + +**Is your feature request related to a problem? Please describe.** + + +**Describe the solution you'd like** + + +**Describe alternatives you've considered** + + +**Additional context** + From 744d104ee139bbdd8c6c9d69506e769a25a31a81 Mon Sep 17 00:00:00 2001 From: Tammo van der Heide Date: Fri, 10 Dec 2021 17:41:36 +0100 Subject: [PATCH 12/17] Establish consistent formatting of two-center code --- AUTHORS.rst | 2 + common/lib/accuracy.F90 | 4 +- common/lib/fifo_real1.F90 | 3 +- common/lib/fifo_real2.F90 | 3 +- common/lib/taggedout.F90 | 2 +- sktwocnt/lib/bisection.f90 | 35 ++-- sktwocnt/lib/coordtrans.f90 | 20 +-- sktwocnt/lib/dftbxc.f90 | 260 ++++++++++++++-------------- sktwocnt/lib/gridgenerator.f90 | 65 ++++--- sktwocnt/lib/gridorbital.f90 | 114 ++++++------ sktwocnt/lib/interpolation.f90 | 35 ++-- sktwocnt/lib/partition.f90 | 7 +- sktwocnt/lib/quadrature.f90 | 41 ++--- sktwocnt/lib/sphericalharmonics.f90 | 141 +++++++-------- sktwocnt/lib/twocnt.f90 | 204 ++++++++++------------ sktwocnt/prog/cmdargs.f90 | 7 +- sktwocnt/prog/input.f90 | 163 ++++++++--------- sktwocnt/prog/main.f90 | 7 +- sktwocnt/prog/output.f90 | 13 +- 19 files changed, 524 insertions(+), 602 deletions(-) diff --git a/AUTHORS.rst b/AUTHORS.rst index 1602e6df..100af573 100644 --- a/AUTHORS.rst +++ b/AUTHORS.rst @@ -7,6 +7,8 @@ contributed to this package : * Bálint Aradi (University of Bremen) +* Tammo van der Heide (University of Bremen) + * Ben Hourahine (University of Strathclyde, UK) * Ziyang Hu (Hong Kong Quantum AI Lab Limited, HKU) diff --git a/common/lib/accuracy.F90 b/common/lib/accuracy.F90 index 2faa4e67..e20221ac 100644 --- a/common/lib/accuracy.F90 +++ b/common/lib/accuracy.F90 @@ -3,13 +3,15 @@ !! Not all routines use the string length specifications to set their character string lengths. module common_accuracy + use, intrinsic :: iso_fortran_env, only : real64 + implicit none private public :: dp, cp, sc, mc, lc !> precision of the real data type - integer, parameter :: dp = 8 + integer, parameter :: dp = real64 !> precision of the complex data type integer, parameter :: cp = dp diff --git a/common/lib/fifo_real1.F90 b/common/lib/fifo_real1.F90 index 6a9dd793..31e20446 100644 --- a/common/lib/fifo_real1.F90 +++ b/common/lib/fifo_real1.F90 @@ -1,6 +1,7 @@ !> Implements fifo for rank 1 real (double precision) arrays. module common_fifo_real1 + use common_accuracy, only : dp use common_fifobase, only : TFiFoBase, size implicit none @@ -8,8 +9,6 @@ module common_fifo_real1 public :: TFiFoReal1 - integer, parameter :: dp = kind(1.0d0) - !> Extended data type. type :: TMyData diff --git a/common/lib/fifo_real2.F90 b/common/lib/fifo_real2.F90 index 728173aa..9ac61131 100644 --- a/common/lib/fifo_real2.F90 +++ b/common/lib/fifo_real2.F90 @@ -1,6 +1,7 @@ !> Implements fifo for rank 2 real (double precision) arrays. module common_fifo_real2 + use common_accuracy, only : dp use common_fifobase, only : TFiFoBase, size implicit none @@ -8,8 +9,6 @@ module common_fifo_real2 public :: TFiFoReal2 - integer, parameter :: dp = kind(1.0d0) - !> Extended data type. type :: TMyData diff --git a/common/lib/taggedout.F90 b/common/lib/taggedout.F90 index 46a19d9c..5a79d6af 100644 --- a/common/lib/taggedout.F90 +++ b/common/lib/taggedout.F90 @@ -89,7 +89,7 @@ subroutine TTaggedwriter_init(this) nfield = 1 end if - write (this%formInt, "('(', I2.2, 'I', I2.2, ')')") nfield, nchar + write(this%formInt, "('(', I2.2, 'I', I2.2, ')')") nfield, nchar write(this%formLogical, "('(40L2)')") diff --git a/sktwocnt/lib/bisection.f90 b/sktwocnt/lib/bisection.f90 index 6e24f0a9..3062cd8b 100644 --- a/sktwocnt/lib/bisection.f90 +++ b/sktwocnt/lib/bisection.f90 @@ -1,7 +1,7 @@ !> Contains routines to locate a value in an array using bisection. module bisection - use common_accuracy, only : dp + use common_accuracy, only: dp implicit none private @@ -13,7 +13,7 @@ module bisection module procedure bisect_real module procedure bisect_int end interface bisect - + contains !> Real case for bisection search to to find a point in an array xx(:) @@ -23,15 +23,15 @@ module bisection !! \param x0 Value to locate ind for. !! \param ind Located element such that xx(ind) < x < xx(ind). pure subroutine bisect_real(xx, x0, ind, tol) - real(dp), intent(in) :: xx(:), x0 - integer, intent(out) :: ind + real(dp), intent(in) :: xx(:), x0 + integer, intent(out) :: ind real(dp), intent(in), optional :: tol - - integer :: nn - integer :: ilower, iupper, icurr + + integer :: nn + integer :: ilower, iupper, icurr real(dp) :: rTol ! real tolerance - logical :: ascending - + logical :: ascending + nn = size(xx) if (nn == 0) then ind = 0 @@ -43,8 +43,8 @@ pure subroutine bisect_real(xx, x0, ind, tol) else rTol = epsilon(0.0_dp) end if - - if (x0 < xx(1) - rTol) then + + if (x0 < xx(1) - rTol) then ind = 0 else if (abs(x0 - xx(1)) <= rTol) then ind = 1 @@ -53,7 +53,7 @@ pure subroutine bisect_real(xx, x0, ind, tol) else if (x0 > xx(nn) + rTol) then ind = nn else - ascending = (xx(nn) >= xx(1)) + ascending = (xx(nn) >= xx(1)) ilower = 0 icurr = nn + 1 do while ((icurr - ilower) > 1) @@ -66,9 +66,8 @@ pure subroutine bisect_real(xx, x0, ind, tol) end do ind = ilower end if - - end subroutine bisect_real + end subroutine bisect_real !> Integer case for bisection search to to find a point in an array xx(:) !! between xx(1) and xx(size(xx)) such that element indexed ind is less than @@ -93,16 +92,16 @@ pure subroutine bisect_int(xx, x0, ind) ind = 0 else if (x0 == xx(1)) then ind = 1 - else if(x0 == xx(nn)) then - ind = nn -1 - else if(x0 > xx(nn)) then + else if (x0 == xx(nn)) then + ind = nn - 1 + else if (x0 > xx(nn)) then ind = nn else ilower = 0 icurr = nn + 1 do while ((icurr - ilower) > 1) iupper = (icurr + ilower) / 2 - if((xx(nn) >= xx(1)) .eqv. (x0 >= xx(iupper)))then + if ((xx(nn) >= xx(1)) .eqv. (x0 >= xx(iupper))) then ilower = iupper else icurr = iupper diff --git a/sktwocnt/lib/coordtrans.f90 b/sktwocnt/lib/coordtrans.f90 index cd87cd1c..c99394b3 100644 --- a/sktwocnt/lib/coordtrans.f90 +++ b/sktwocnt/lib/coordtrans.f90 @@ -1,6 +1,6 @@ module coordtrans - use common_accuracy, only : dp + use common_accuracy, only: dp use common_constants implicit none @@ -18,7 +18,7 @@ subroutine coordtrans_becke(c11, spheric, jacobi) real(dp), intent(out) :: spheric(:) real(dp), intent(out) :: jacobi - real(dp), parameter :: rm = 1.5_dp; + real(dp), parameter :: rm = 1.5_dp; real(dp) :: rtmp1, rtmp2 !assert(size(c11) == 3) @@ -33,7 +33,6 @@ subroutine coordtrans_becke(c11, spheric, jacobi) end subroutine coordtrans_becke - !> Transforms a 2 dimensional vector with coordinates in [-1,1] onto spherical !! coordinates (r, theta), using the Becke algorithm. !! \param crd11 2d coordinate vector, each coordinate in [-1,1]. @@ -45,7 +44,7 @@ subroutine coordtrans_becke_12(c11, spheric, jacobi) real(dp), intent(out) :: spheric(:) real(dp), intent(out) :: jacobi - real(dp), parameter :: rm = 1.5_dp; + real(dp), parameter :: rm = 1.5_dp; real(dp) :: rtmp1, rtmp2 !assert(size(c11) == 2) @@ -59,7 +58,6 @@ subroutine coordtrans_becke_12(c11, spheric, jacobi) end subroutine coordtrans_becke_12 - !> Transforms a 2 dimensional vector with coordinates in [-1,1] onto spherical !! coordinates (theta, phi), using the Becke algorithm. !! \param crd11 2d coordinate vector, each coordinate in [-1,1]. @@ -79,7 +77,6 @@ subroutine coordtrans_becke_23(c11, spheric, jacobi) jacobi = pi end subroutine coordtrans_becke_23 - !> Transforms a 3 dimensional vector with coordinates in [-1,1] onto spherical !! coordinates, using the Ahlrichs algorithm. @@ -93,7 +90,7 @@ subroutine coordtrans_ahlrichs1(c11, spheric, jacobi) real(dp), intent(out) :: jacobi real(dp), parameter :: zeta = 1.20_dp - real(dp) :: rr + real(dp) :: rr !assert(size(c11) == 3) !assert(size(spheric) == 3) @@ -106,8 +103,6 @@ subroutine coordtrans_ahlrichs1(c11, spheric, jacobi) end subroutine coordtrans_ahlrichs1 - - !> Transforms a 3 dimensional vector with coordinates in [-1,1] onto spherical !! coordinates, using the Ahlrichs algorithm. !! \param c11 3d coordinate vector, each coordinate in [-1,1]. @@ -120,7 +115,7 @@ subroutine coordtrans_ahlrichs1_2d(c11, spheric, jacobi) real(dp), intent(out) :: jacobi real(dp), parameter :: zeta = 1.20_dp - real(dp) :: rr + real(dp) :: rr !assert(size(c11) == 3) !assert(size(spheric) == 3) @@ -133,7 +128,6 @@ subroutine coordtrans_ahlrichs1_2d(c11, spheric, jacobi) end subroutine coordtrans_ahlrichs1_2d - !> Transforms a 3 dimensional vector with coordinates in [-1,1] onto spherical !! coordinates, using the Ahlrichs algorithm. !! \param c11 3d coordinate vector, each coordinate in [-1,1]. @@ -164,8 +158,6 @@ subroutine coordtrans_ahlrichs2(c11, spheric, jacobi) end subroutine coordtrans_ahlrichs2 - - !> Transforms a 3 dimensional vector with coordinates in [-1,1] onto spherical !! coordinates, using the Ahlrichs algorithm. !! \param c11 3d coordinate vector, each coordinate in [-1,1]. @@ -196,8 +188,6 @@ subroutine coordtrans_ahlrichs2_2d(c11, spheric, jacobi) end subroutine coordtrans_ahlrichs2_2d - - subroutine coordtrans_identity(c11, ctarget, jacobi) real(dp), intent(in) :: c11(:) real(dp), intent(out) :: ctarget(:) diff --git a/sktwocnt/lib/dftbxc.f90 b/sktwocnt/lib/dftbxc.f90 index 84f5bfa7..87fd02bc 100644 --- a/sktwocnt/lib/dftbxc.f90 +++ b/sktwocnt/lib/dftbxc.f90 @@ -1,7 +1,7 @@ module dftxc use, intrinsic :: ieee_arithmetic - use common_accuracy, only : dp + use common_accuracy, only: dp use common_constants implicit none @@ -40,10 +40,8 @@ subroutine getxcpot_ldapw91(rho4pi, xcpot) end do deallocate(rs, rho) - - end subroutine getxcpot_ldapw91 - + end subroutine getxcpot_ldapw91 subroutine getxcpot_ggapbe(rho4pi, absgr4pi, laplace4pi, gr_grabsgr4pi, xcpot) real(dp), intent(in) :: rho4pi(:) @@ -71,7 +69,7 @@ subroutine getxcpot_ggapbe(rho4pi, absgr4pi, laplace4pi, gr_grabsgr4pi, xcpot) rs = (3.0_dp / rho4pi)**(1.0_dp / 3.0_dp) zeta = 0.0_dp gg = 1.0_dp - alpha = (4.0_dp/(9.0_dp * pi))**(1.0_dp/3.0_dp) + alpha = (4.0_dp / (9.0_dp * pi))**(1.0_dp / 3.0_dp) ! Factors for the correlation routine fac = sqrt(pi / 4.0_dp * alpha * rs) / (2.0_dp * gg) tt = absgr * fac @@ -92,11 +90,11 @@ subroutine getxcpot_ggapbe(rho4pi, absgr4pi, laplace4pi, gr_grabsgr4pi, xcpot) &ec, vcup, vcdn) call exchange_pbe(rho(ii), ss(ii), u2(ii), v2(ii), 1, ex, vx) if (ieee_is_nan(vcup)) then - print *, "VCUP NAN", ii, rs(ii), tt(ii), uu(ii), vv(ii) - print *, ":", absgr(ii), gr_grabsgr(ii), laplace(ii) + print*,"VCUP NAN", ii, rs(ii), tt(ii), uu(ii), vv(ii) + print*,":", absgr(ii), gr_grabsgr(ii), laplace(ii) stop elseif (ieee_is_nan(vx)) then - print *, "VX NAN", ii + print*,"VX NAN", ii stop end if xcpot(ii) = vcup + vx @@ -105,12 +103,10 @@ subroutine getxcpot_ggapbe(rho4pi, absgr4pi, laplace4pi, gr_grabsgr4pi, xcpot) deallocate(rho, absgr, laplace, gr_grabsgr) deallocate(rs, fac, tt, uu, vv) - - end subroutine getxcpot_ggapbe + end subroutine getxcpot_ggapbe - - SUBROUTINE CORRELATION_PBE(RS,ZET,T,UU,VV,WW,igga,ec,vc1,vc2) + SUBROUTINE CORRELATION_PBE(RS, ZET, T, UU, VV, WW, igga, ec, vc1, vc2) ! ! APART FROM COSMETICS THIS IS IN FACT BURKEs FORTRAN REFERENCE IMPLEMENTATION @@ -118,7 +114,7 @@ SUBROUTINE CORRELATION_PBE(RS,ZET,T,UU,VV,WW,igga,ec,vc1,vc2) ! This is the PBE and PW-LDA Correlation routine. - IMPLICIT REAL(8) (A-H,O-Z) + IMPLICIT REAL(8) (A - H, O - Z) !---------------------------------------------------------------------- ! INPUT: RS=SEITZ RADIUS=(3/4pi rho)^(1/3) ! : ZET=RELATIVE SPIN POLARIZATION = (rhoup-rhodn)/rho @@ -136,7 +132,7 @@ SUBROUTINE CORRELATION_PBE(RS,ZET,T,UU,VV,WW,igga,ec,vc1,vc2) ! : dvcdn=nonlocal correction to vcdn !---------------------------------------------------------------------- ! References: - ! [a] J.P.~Perdew, K.~Burke, and M.~Ernzerhof, + ! [a] J.P.~Perdew, K.~Burke, and M.~Ernzerhof, ! {\sl Generalized gradient approximation made simple}, sub. ! to Phys. Rev.Lett. May 1996. ! [b] J. P. Perdew, K. Burke, and Y. Wang, {\sl Real-space cutoff @@ -146,18 +142,18 @@ SUBROUTINE CORRELATION_PBE(RS,ZET,T,UU,VV,WW,igga,ec,vc1,vc2) !---------------------------------------------------------------------- ! bet=coefficient in gradient expansion for correlation, [a](4). integer :: igga - parameter(thrd=1.d0/3.d0,thrdm=-thrd,thrd2=2.d0*thrd) - parameter(GAM=0.5198420997897463295344212145565d0) - parameter(thrd4=4.d0*thrd, fzz=8.d0/(9.d0*GAM)) - parameter(gamma=0.03109069086965489503494086371273d0) - parameter(bet=0.06672455060314922d0,delt=bet/gamma) - dimension u(6),p(6),s(6) - data u/ 0.03109070D0, 0.2137000D0, 7.5957000D0,& - & 3.58760000D0, 1.6382000D0, 0.4929400D0/ - data p/ 0.01554535D0, 0.2054800D0,14.1189000D0,& - & 6.19770000D0, 3.3662000D0, 0.6251700D0/ - data s/ 0.01688690D0, 0.1112500D0,10.3570000D0,& - & 3.62310000D0, 0.8802600D0, 0.4967100D0/ + parameter(thrd=1._dp / 3._dp, thrdm=-thrd, thrd2=2._dp * thrd) + parameter(GAM=0.5198420997897463295344212145565_dp) + parameter(thrd4=4._dp * thrd, fzz=8._dp / (9._dp * GAM)) + parameter(gamma=0.03109069086965489503494086371273_dp) + parameter(bet=0.06672455060314922_dp, delt=bet / gamma) + dimension u(6), p(6), s(6) + data u/0.03109070_dp, 0.2137000_dp, 7.5957000_dp,& + & 3.58760000_dp, 1.6382000_dp, 0.4929400_dp/ + data p/0.01554535_dp, 0.2054800_dp, 14.1189000_dp,& + & 6.19770000_dp, 3.3662000_dp, 0.6251700_dp/ + data s/0.01688690_dp, 0.1112500_dp, 10.3570000_dp,& + & 3.62310000_dp, 0.8802600_dp, 0.4967100_dp/ !---------------------------------------------------------------------- ! find LSD energy contributions, using [c](10) . ! EU=unpolarized LSD correlation energy , EURS=dEU/drs @@ -167,123 +163,122 @@ SUBROUTINE CORRELATION_PBE(RS,ZET,T,UU,VV,WW,igga,ec,vc1,vc2) ! construct ecl, using [c](8) . ! - rtrs=dsqrt(rs) - Q0 = -2.D0*u(1)*(1.D0+u(2)*rtrs*rtrs) - Q1 = 2.D0*u(1)*rtrs*(u(3)+rtrs*(u(4)+rtrs*(u(5)+u(6)*rtrs))) - Q2 = DLOG(1.D0+1.D0/Q1) - Q3 = u(1)*(u(3)/rtrs+2.D0*u(4)+rtrs*(3.D0*u(5)+4.D0*u(6)*rtrs)) - EU = Q0*Q2 - EURS = -2.D0*u(1)*u(2)*Q2-Q0*Q3/(Q1*(1.d0+Q1)) - Q0 = -2.D0*p(1)*(1.D0+p(2)*rtrs*rtrs) - Q1 = 2.D0*p(1)*rtrs*(p(3)+rtrs*(p(4)+rtrs*(p(5)+p(6)*rtrs))) - Q2 = DLOG(1.D0+1.D0/Q1) - Q3 = p(1)*(p(3)/rtrs+2.D0*p(4)+rtrs*(3.D0*p(5)+4.D0*p(6)*rtrs)) - EP = Q0*Q2 - EPRS = -2.D0*p(1)*p(2)*Q2-Q0*Q3/(Q1*(1.d0+Q1)) - Q0 = -2.D0*s(1)*(1.D0+s(2)*rtrs*rtrs) - Q1 = 2.D0*s(1)*rtrs*(s(3)+rtrs*(s(4)+rtrs*(s(5)+s(6)*rtrs))) - Q2 = DLOG(1.D0+1.D0/Q1) - Q3 = s(1)*(s(3)/rtrs+2.D0*s(4)+rtrs*(3.D0*s(5)+4.D0*s(6)*rtrs)) - ALFM = Q0*Q2 - ALFRSM = -2.D0*s(1)*s(2)*Q2-Q0*Q3/(Q1*(1.d0+Q1)) + rtrs = dsqrt(rs) + Q0 = -2._dp * u(1) * (1._dp + u(2) * rtrs * rtrs) + Q1 = 2._dp * u(1) * rtrs * (u(3) + rtrs * (u(4) + rtrs * (u(5) + u(6) * rtrs))) + Q2 = DLOG(1._dp + 1._dp / Q1) + Q3 = u(1) * (u(3) / rtrs + 2._dp * u(4) + rtrs * (3._dp * u(5) + 4._dp * u(6) * rtrs)) + EU = Q0 * Q2 + EURS = -2._dp * u(1) * u(2) * Q2 - Q0 * Q3 / (Q1 * (1._dp + Q1)) + Q0 = -2._dp * p(1) * (1._dp + p(2) * rtrs * rtrs) + Q1 = 2._dp * p(1) * rtrs * (p(3) + rtrs * (p(4) + rtrs * (p(5) + p(6) * rtrs))) + Q2 = DLOG(1._dp + 1._dp / Q1) + Q3 = p(1) * (p(3) / rtrs + 2._dp * p(4) + rtrs * (3._dp * p(5) + 4._dp * p(6) * rtrs)) + EP = Q0 * Q2 + EPRS = -2._dp * p(1) * p(2) * Q2 - Q0 * Q3 / (Q1 * (1._dp + Q1)) + Q0 = -2._dp * s(1) * (1._dp + s(2) * rtrs * rtrs) + Q1 = 2._dp * s(1) * rtrs * (s(3) + rtrs * (s(4) + rtrs * (s(5) + s(6) * rtrs))) + Q2 = DLOG(1._dp + 1._dp / Q1) + Q3 = s(1) * (s(3) / rtrs + 2._dp * s(4) + rtrs * (3._dp * s(5) + 4._dp * s(6) * rtrs)) + ALFM = Q0 * Q2 + ALFRSM = -2._dp * s(1) * s(2) * Q2 - Q0 * Q3 / (Q1 * (1._dp + Q1)) Z4 = ZET**4 - F=((1.D0+ZET)**THRD4+(1.D0-ZET)**THRD4-2.D0)/GAM - ECL= EU*(1.D0-F*Z4)+EP*F*Z4-ALFM*F*(1.D0-Z4)/FZZ + F = ((1._dp + ZET)**THRD4 + (1._dp - ZET)**THRD4 - 2._dp) / GAM + ECL = EU * (1._dp - F * Z4) + EP * F * Z4 - ALFM * F * (1._dp - Z4) / FZZ !---------------------------------------------------------------------- ! LSD potential from [c](A1) ! ECRS = dEc/drs , ECZET=dEc/dzeta , FZ = dF/dzeta [c](A2-A4) ! - ECRS = EURS*(1.D0-F*Z4)+EPRS*F*Z4-ALFRSM*F*(1.D0-Z4)/FZZ - FZ = THRD4*((1.D0+ZET)**THRD-(1.D0-ZET)**THRD)/GAM - ECZET = 4.D0*(ZET**3)*F*(EP-EU+ALFM/FZZ)& - & +FZ*(Z4*EP-Z4*EU-(1.D0-Z4)*ALFM/FZZ) - COMM = ECL -RS*ECRS/3.D0-ZET*ECZET + ECRS = EURS * (1._dp - F * Z4) + EPRS * F * Z4 - ALFRSM * F * (1._dp - Z4) / FZZ + FZ = THRD4 * ((1._dp + ZET)**THRD - (1._dp - ZET)**THRD) / GAM + ECZET = 4._dp * (ZET**3) * F * (EP - EU + ALFM / FZZ)& + & + FZ * (Z4 * EP - Z4 * EU - (1._dp - Z4) * ALFM / FZZ) + COMM = ECL - RS * ECRS / 3._dp - ZET * ECZET VCUP = COMM + ECZET VCDN = COMM - ECZET - if(igga.eq.0)then - EC=ECL - VC1=VCUP - VC2=VCDN + if (igga .eq. 0) then + EC = ECL + VC1 = VCUP + VC2 = VCDN return - endif + end if !---------------------------------------------------------------------- ! PBE correlation energy ! G=phi(zeta), given after [a](3) ! DELT=bet/gamma , B=A of [a](8) ! - G=((1.d0+ZET)**thrd2+(1.d0-ZET)**thrd2)/2.d0 + G = ((1._dp + ZET)**thrd2 + (1._dp - ZET)**thrd2) / 2._dp G3 = G**3 - PON=-ECL/(G3*gamma) - B = DELT/(DEXP(PON)-1.D0) - B2 = B*B - T2 = T*T - T4 = T2*T2 - Q4 = 1.D0+B*T2 - Q5 = 1.D0+B*T2+B2*T4 - ECN= G3*(BET/DELT)*DLOG(1.D0+DELT*Q4*T2/Q5) + PON = -ECL / (G3 * gamma) + B = DELT / (DEXP(PON) - 1._dp) + B2 = B * B + T2 = T * T + T4 = T2 * T2 + Q4 = 1._dp + B * T2 + Q5 = 1._dp + B * T2 + B2 * T4 + ECN = G3 * (BET / DELT) * DLOG(1._dp + DELT * Q4 * T2 / Q5) EC = ECL + ECN !---------------------------------------------------------------------- ! ENERGY DONE. NOW THE POTENTIAL, using appendix E of [b]. ! - G4 = G3*G - T6 = T4*T2 - RSTHRD = RS/3.D0 - ! GZ=((1.d0+zet)**thirdm-(1.d0-zet)**thirdm)/3.d0 + G4 = G3 * G + T6 = T4 * T2 + RSTHRD = RS / 3._dp + ! GZ=((1._dp+zet)**thirdm-(1._dp-zet)**thirdm)/3._dp ! ckoe: hack thirdm never gets defined, but 1-1 should be zero anyway - GZ=0.0d0 - FAC = DELT/B+1.D0 - BG = -3.D0*B2*ECL*FAC/(BET*G4) - BEC = B2*FAC/(BET*G3) - Q8 = Q5*Q5+DELT*Q4*Q5*T2 - Q9 = 1.D0+2.D0*B*T2 - hB = -BET*G3*B*T6*(2.D0+B*T2)/Q8 - hRS = -RSTHRD*hB*BEC*ECRS - FACT0 = 2.D0*DELT-6.D0*B - FACT1 = Q5*Q9+Q4*Q9*Q9 - hBT = 2.D0*BET*G3*T4*((Q4*Q5*FACT0-DELT*FACT1)/Q8)/Q8 - hRST = RSTHRD*T2*hBT*BEC*ECRS - hZ = 3.D0*GZ*ecn/G + hB*(BG*GZ+BEC*ECZET) - hT = 2.d0*BET*G3*Q9/Q8 - hZT = 3.D0*GZ*hT/G+hBT*(BG*GZ+BEC*ECZET) - FACT2 = Q4*Q5+B*T2*(Q4*Q9+Q5) - FACT3 = 2.D0*B*Q5*Q9+DELT*FACT2 - hTT = 4.D0*BET*G3*T*(2.D0*B/Q8-(Q9*FACT3/Q8)/Q8) - COMM = ECN+HRS+HRST+T2*HT/6.D0+7.D0*T2*T*HTT/6.D0 - PREF = HZ-GZ*T2*HT/G - FACT5 = GZ*(2.D0*HT+T*HTT)/G - COMM = COMM-PREF*ZET-UU*HTT-VV*HT-WW*(HZT-FACT5) + GZ = 0.0_dp + FAC = DELT / B + 1._dp + BG = -3._dp * B2 * ECL * FAC / (BET * G4) + BEC = B2 * FAC / (BET * G3) + Q8 = Q5 * Q5 + DELT * Q4 * Q5 * T2 + Q9 = 1._dp + 2._dp * B * T2 + hB = -BET * G3 * B * T6 * (2._dp + B * T2) / Q8 + hRS = -RSTHRD * hB * BEC * ECRS + FACT0 = 2._dp * DELT - 6._dp * B + FACT1 = Q5 * Q9 + Q4 * Q9 * Q9 + hBT = 2._dp * BET * G3 * T4 * ((Q4 * Q5 * FACT0 - DELT * FACT1) / Q8) / Q8 + hRST = RSTHRD * T2 * hBT * BEC * ECRS + hZ = 3._dp * GZ * ecn / G + hB * (BG * GZ + BEC * ECZET) + hT = 2._dp * BET * G3 * Q9 / Q8 + hZT = 3._dp * GZ * hT / G + hBT * (BG * GZ + BEC * ECZET) + FACT2 = Q4 * Q5 + B * T2 * (Q4 * Q9 + Q5) + FACT3 = 2._dp * B * Q5 * Q9 + DELT * FACT2 + hTT = 4._dp * BET * G3 * T * (2._dp * B / Q8 - (Q9 * FACT3 / Q8) / Q8) + COMM = ECN + HRS + HRST + T2 * HT / 6._dp + 7._dp * T2 * T * HTT / 6._dp + PREF = HZ - GZ * T2 * HT / G + FACT5 = GZ * (2._dp * HT + T * HTT) / G + COMM = COMM - PREF * ZET - UU * HTT - VV * HT - WW * (HZT - FACT5) DVCUP = COMM + PREF DVCDN = COMM - PREF - VC1 = VCUP + DVCUP + VC1 = VCUP + DVCUP VC2 = VCDN + DVCDN - ! print*,'c igga is',dvcup + ! print*,'c igga is',dvcup RETURN END subroutine CORRELATION_PBE - - subroutine exchange_pbe(rho,s,u,t,igga,EX,VX) + subroutine exchange_pbe(rho, s, u, t, igga, EX, VX) ! APART FROM COSMETICS THIS IS IN FACT BURKEs FORTRAN REFERENCE IMPLEMENTATION ! This is the PBE and PW-LDA Exchange routine. - implicit integer(4) (i-n) - implicit real(8) (a-h,o-z) + implicit integer(4) (i - n) + implicit real(8) (a - h, o - z) - parameter(thrd=1.d0/3.d0,thrd4=4.d0/3.d0) - parameter(pi=3.14159265358979323846264338327950d0) - parameter(ax=-0.738558766382022405884230032680836d0) + parameter(thrd=1._dp / 3._dp, thrd4=4._dp / 3._dp) + parameter(pi=3.14159265358979323846264338327950_dp) + parameter(ax=-0.738558766382022405884230032680836_dp) - parameter(um=0.21951d0,uk=0.8040d0,ul=um/uk) + parameter(um=0.21951_dp, uk=0.8040_dp, ul=um / uk) - parameter(ap=1.647127d0,bp=0.980118d0,cp=0.017399d0) - parameter(aq=1.523671d0,bq=0.367229d0,cq=0.011282d0) - parameter(ah=0.19645d0,bh=7.7956d0) - parameter(ahp=0.27430d0,bhp=0.15084d0,ahq=0.004d0) - parameter(a1=0.19645d0,a2=0.27430d0,a3=0.15084d0,a4=100.d0) - parameter(a=7.79560d0,b1=0.004d0,eps=1.d-15) + parameter(ap=1.647127_dp, bp=0.980118_dp, cp=0.017399_dp) + parameter(aq=1.523671_dp, bq=0.367229_dp, cq=0.011282_dp) + parameter(ah=0.19645_dp, bh=7.7956_dp) + parameter(ahp=0.27430_dp, bhp=0.15084_dp, ahq=0.004_dp) + parameter(a1=0.19645_dp, a2=0.27430_dp, a3=0.15084_dp, a4=100._dp) + parameter(a=7.79560_dp, b1=0.004_dp, eps=1.d-15) !---------------------------------------------------------------------- !---------------------------------------------------------------------- @@ -294,7 +289,7 @@ subroutine exchange_pbe(rho,s,u,t,igga,EX,VX) ! INPUT U: (GRAD rho)*GRAD(ABS(GRAD rho))/(rho**2 * (2*KF)**3) ! INPUT V: (LAPLACIAN rho)/(rho*(2*KF)**2) (for U,V, see PW86(24)) ! input igga: (=0=>don't put in gradient corrections, just LDA) - ! OUTPUT: EXCHANGE ENERGY PER ELECTRON (LOCAL: EXL, NONLOCAL: EXN, + ! OUTPUT: EXCHANGE ENERGY PER ELECTRON (LOCAL: EXL, NONLOCAL: EXN, ! TOTAL: EX) AND POTENTIAL (VX) !---------------------------------------------------------------------- ! References: @@ -304,47 +299,46 @@ subroutine exchange_pbe(rho,s,u,t,igga,EX,VX) !---------------------------------------------------------------------- ! Formulas: e_x[unif]=ax*rho^(4/3) [LDA] ! ax = -0.75*(3/pi)^(1/3) - ! e_x[PBE]=e_x[unif]*FxPBE(s) - ! FxPBE(s)=1+uk-uk/(1+ul*s*s) [a](13) - ! uk, ul defined after [a](13) + ! e_x[PBE]=e_x[unif]*FxPBE(s) + ! FxPBE(s)=1+uk-uk/(1+ul*s*s) [a](13) + ! uk, ul defined after [a](13) !---------------------------------------------------------------------- !---------------------------------------------------------------------- ! construct LDA exchange energy density - exunif = ax*rho**thrd - if((igga.eq.0).or.(s.lt.eps))then - EXL=exunif - EXN=0.d0 - EX=EXL+EXN - VX= exunif*thrd4 + exunif = ax * rho**thrd + if ((igga .eq. 0) .or. (s .lt. eps)) then + EXL = exunif + EXN = 0._dp + EX = EXL + EXN + VX = exunif * thrd4 return - endif + end if !---------------------------------------------------------------------- ! construct GGA enhancement factor ! find first and second derivatives of f and: - ! fs=(1/s)*df/ds and fss=dfs/ds = (d2f/ds2 - (1/s)*df/ds)/s + ! fs=(1/s)*df/ds and fss=dfs/ds = (d2f/ds2 - (1/s)*df/ds)/s ! ! PBE enhancement factors checked against NRLMOL ! - if(igga.eq.1)then - p0 =1.d0+ul*s**2 - f =1.d0+uk-uk/p0 - fs =2.d0*uk*ul/p0**2 - fss=-4.d0*ul*s*fs/p0 - endif + if (igga .eq. 1) then + p0 = 1._dp + ul * s**2 + f = 1._dp + uk - uk / p0 + fs = 2._dp * uk * ul / p0**2 + fss = -4._dp * ul * s * fs / p0 + end if ! - EXL= exunif - EXN= exunif*(f-1.0d0) - EX = EXL+EXN + EXL = exunif + EXN = exunif * (f - 1.0_dp) + EX = EXL + EXN !---------------------------------------------------------------------- - ! energy done. calculate potential from [b](24) + ! energy done. calculate potential from [b](24) ! - VX = exunif*(thrd4*f-(u-thrd4*s**3)*fss-t*fs ) - ! print*,'e igga is',igga,vx,xunif*thrd4 - + VX = exunif * (thrd4 * f - (u - thrd4 * s**3) * fss - t * fs) + ! print*,'e igga is',igga,vx,xunif*thrd4 RETURN END subroutine exchange_pbe diff --git a/sktwocnt/lib/gridgenerator.f90 b/sktwocnt/lib/gridgenerator.f90 index f5910a2d..c2634700 100644 --- a/sktwocnt/lib/gridgenerator.f90 +++ b/sktwocnt/lib/gridgenerator.f90 @@ -1,6 +1,6 @@ module gridgenerator - use common_accuracy, only : dp + use common_accuracy, only: dp use quadratures implicit none @@ -11,59 +11,58 @@ subroutine gengrid1_12(quads, coordtrans, grid, weights) type(quadrature), intent(in) :: quads(2) interface subroutine coordtrans(oldc, newc, jacobi) - use common_accuracy, only : dp + use common_accuracy, only: dp real(dp), intent(in) :: oldc(:) real(dp), intent(out) :: newc(:) real(dp), intent(out) :: jacobi end subroutine coordtrans end interface - real(dp), allocatable, intent(out) :: grid(:,:) + real(dp), allocatable, intent(out) :: grid(:, :) real(dp), allocatable, intent(out) :: weights(:) integer :: n1, n2, nn integer :: ind, i1, i2 real(dp) :: coord(2), coordreal(2), jacobi - n1 = size(quads(1)%xx) - n2 = size(quads(2)%xx) + n1 = size(quads(1) % xx) + n2 = size(quads(2) % xx) nn = n1 * n2 allocate(grid(nn, 2)) allocate(weights(nn)) ind = 1 do i2 = 1, n2 - coord(2) = quads(2)%xx(i2) + coord(2) = quads(2) % xx(i2) do i1 = 1, n1 - coord(1) = quads(1)%xx(i1) + coord(1) = quads(1) % xx(i1) call coordtrans(coord, coordreal, jacobi) grid(ind, 1) = coordreal(1) grid(ind, 2) = coordreal(2) - weights(ind) = quads(1)%ww(i1) * quads(2)%ww(i2) * jacobi + weights(ind) = quads(1) % ww(i1) * quads(2) % ww(i2) * jacobi ind = ind + 1 end do end do - - end subroutine gengrid1_12 + end subroutine gengrid1_12 subroutine gengrid2_12(quads, coordtrans, partition, partparams, dist,& & grid1, grid2, dots, weights) type(quadrature), intent(in) :: quads(2) interface subroutine coordtrans(oldc, newc, jacobi) - use common_accuracy, only : dp + use common_accuracy, only: dp real(dp), intent(in) :: oldc(:) real(dp), intent(out) :: newc(:) real(dp), intent(out) :: jacobi end subroutine coordtrans function partition(r1, r2, dist, params) - use common_accuracy, only : dp + use common_accuracy, only: dp real(dp), intent(in) :: r1, r2, dist, params(:) real(dp) :: partition end function partition end interface real(dp), intent(in) :: partparams(:) real(dp), intent(in) :: dist - real(dp), allocatable, intent(out) :: grid1(:,:), grid2(:,:) + real(dp), allocatable, intent(out) :: grid1(:, :), grid2(:, :) real(dp), allocatable, intent(out) :: dots(:), weights(:) integer :: n1, n2, nn @@ -71,18 +70,18 @@ end function partition real(dp) :: coord(2), coordreal(2) real(dp) :: r1, theta1, r2a, r2b, theta2a, theta2b, rtmpa, rtmpb, jacobi - n1 = size(quads(1)%xx) - n2 = size(quads(2)%xx) + n1 = size(quads(1) % xx) + n2 = size(quads(2) % xx) nn = n1 * n2 - allocate(grid1(2*nn, 2)) - allocate(grid2(2*nn, 2)) - allocate(dots(2*nn)) - allocate(weights(2*nn)) + allocate(grid1(2 * nn, 2)) + allocate(grid2(2 * nn, 2)) + allocate(dots(2 * nn)) + allocate(weights(2 * nn)) ind = 1 do i2 = 1, n2 - coord(2) = quads(2)%xx(i2) + coord(2) = quads(2) % xx(i2) do i1 = 1, n1 - coord(1) = quads(1)%xx(i1) + coord(1) = quads(1) % xx(i1) call coordtrans(coord, coordreal, jacobi) r1 = coordreal(1) theta1 = coordreal(2) @@ -100,25 +99,25 @@ end function partition rtmpb = max(rtmpb, -1.0_dp) theta2a = acos(rtmpa) theta2b = acos(rtmpb) - + grid1(ind, 1) = r1 grid1(ind, 2) = theta1 - grid1(ind+nn, 1) = r2b - grid1(ind+nn, 2) = theta2b + grid1(ind + nn, 1) = r2b + grid1(ind + nn, 2) = theta2b grid2(ind, 1) = r2a grid2(ind, 2) = theta2a - grid2(ind+nn, 1) = r1 - grid2(ind+nn, 2) = theta1 + grid2(ind + nn, 1) = r1 + grid2(ind + nn, 2) = theta1 dots(ind) = cos(theta1 - theta2a) - dots(ind+nn) = cos(theta2b - theta1) - - rtmpa = quads(1)%ww(i1) * quads(2)%ww(i2) * jacobi - weights(ind) = rtmpa * partition(r1, r2a, dist, partparams) - weights(ind+nn) = rtmpa * partition(r1, r2b, -dist, partparams) + dots(ind + nn) = cos(theta2b - theta1) + + rtmpa = quads(1) % ww(i1) * quads(2) % ww(i2) * jacobi + weights(ind) = rtmpa * partition(r1, r2a, dist, partparams) + weights(ind + nn) = rtmpa * partition(r1, r2b, -dist, partparams) ind = ind + 1 end do end do - + end subroutine gengrid2_12 - + end module gridgenerator diff --git a/sktwocnt/lib/gridorbital.f90 b/sktwocnt/lib/gridorbital.f90 index ec811d58..d6505d22 100644 --- a/sktwocnt/lib/gridorbital.f90 +++ b/sktwocnt/lib/gridorbital.f90 @@ -1,7 +1,7 @@ !> Implements a grid-type orbital. module gridorbital - use common_accuracy, only : dp + use common_accuracy, only: dp use common_constants use bisection use interpolation @@ -34,7 +34,7 @@ module gridorbital interface init module procedure gridorb_init module procedure gridorb2_init - end interface + end interface interface destruct module procedure gridorb_destruct @@ -72,26 +72,24 @@ subroutine gridorb_init(self, rvals, fvals) !assert(size(values, dim=1) == 2) !assert(size(values, dim=2) > 0) - self%ngrid = size(rvals) - allocate(self%rvalues(self%ngrid)) - allocate(self%fvalues(self%ngrid)) - self%rvalues = rvals(:) - self%fvalues = fvals(:) - + self % ngrid = size(rvals) + allocate(self % rvalues(self % ngrid)) + allocate(self % fvalues(self % ngrid)) + self % rvalues = rvals(:) + self % fvalues = fvals(:) + end subroutine gridorb_init - !> Destructs the instance. !! \param self instance. subroutine gridorb_destruct(self) type(gridorb), intent(inout) :: self - - deallocate(self%rvalues) - deallocate(self%fvalues) - + + deallocate(self % rvalues) + deallocate(self % fvalues) + end subroutine gridorb_destruct - !> Delivers the value of the orbital !! \param self instance. !! \param rr radius at which to calculate the value. @@ -106,39 +104,37 @@ elemental function gridorb_getvalue(self, rr) result(rad) ! sanity check !if (self%ngrid < ninter + 1) then - ! write (*,*) "not enough points in the orbital grid!" + ! write(*,*) "not enough points in the orbital grid!" ! stop !end if ! Find position of the point - call bisect(self%rvalues, rr, ind, 1e-10_dp) - rmax = self%rvalues(self%ngrid) + distfudge - if (rr >= rmax) then + call bisect(self % rvalues, rr, ind, 1e-10_dp) + rmax = self % rvalues(self % ngrid) + distfudge + if (rr >= rmax) then ! outside of the region -> 0 rad = 0.0_dp - elseif (ind < self%ngrid) then + elseif (ind < self % ngrid) then ! before last gridpoint - iend = min(self%ngrid, ind + nrightinter) + iend = min(self % ngrid, ind + nrightinter) iend = max(iend, ninter) istart = iend - ninter + 1 - rad = polyinter(self%rvalues(istart:iend), self%fvalues(istart:iend), rr) + rad = polyinter(self % rvalues(istart:iend), self % fvalues(istart:iend), rr) else - iend = self%ngrid + iend = self % ngrid istart = iend - ninter + 1 ! calculate 1st und 2nd derivatives at the end - f1 = self%fvalues(iend) - f0 = polyinter(self%rvalues(istart:iend), self%fvalues(istart:iend), & - &self%rvalues(iend) - deltar) - f2 = polyinter(self%rvalues(istart:iend), self%fvalues(istart:iend), & - &self%rvalues(iend) + deltar) + f1 = self % fvalues(iend) + f0 = polyinter(self % rvalues(istart:iend), self % fvalues(istart:iend), & + &self % rvalues(iend) - deltar) + f2 = polyinter(self % rvalues(istart:iend), self % fvalues(istart:iend), & + &self % rvalues(iend) + deltar) f1p = (f2 - f0) / (2.0_dp * deltar) f1pp = (f2 + f0 - 2.0_dp * f1) / deltar**2 rad = poly5zero(f1, f1p, f1pp, rr - rmax, -1.0_dp * distfudge) end if - - end function gridorb_getvalue - + end function gridorb_getvalue !> Initializes the grid orbital. !! \param self initialised instance on exit. @@ -155,32 +151,30 @@ subroutine gridorb2_init(self, rvals, fvals) !assert(size(values, dim=2) > 0) call init(orb, rvals, fvals) - self%ngrid = npoint - allocate(self%rvalues(self%ngrid)) - allocate(self%fvalues(self%ngrid)) - self%delta = pi / real(self%ngrid + 1, dp) - do ii = 1, self%ngrid - xx = cos(self%delta * real(ii, dp)) + self % ngrid = npoint + allocate(self % rvalues(self % ngrid)) + allocate(self % fvalues(self % ngrid)) + self % delta = pi / real(self % ngrid + 1, dp) + do ii = 1, self % ngrid + xx = cos(self % delta * real(ii, dp)) rr = (1.0_dp - xx) / (1.0_dp + xx) - self%rvalues(ii) = rr - self%fvalues(ii) = getvalue(orb, rr) + self % rvalues(ii) = rr + self % fvalues(ii) = getvalue(orb, rr) end do - self%rcut = self%rvalues(self%ngrid) + distfudge + self % rcut = self % rvalues(self % ngrid) + distfudge call destruct(orb) - + end subroutine gridorb2_init - !> Destructs the instance. !! \param self instance. subroutine gridorb2_destruct(self) type(gridorb2), intent(inout) :: self - - deallocate(self%fvalues) - + + deallocate(self % fvalues) + end subroutine gridorb2_destruct - !> Delivers the value of the orbital !! \param self instance. !! \param rr radius at which to calculate the value. @@ -194,40 +188,38 @@ elemental function gridorb2_getvalue(self, rr) result(rad) real(dp) :: rmax, f0, f1, f2, f1p, f1pp real(dp) :: xx - if (rr > self%rcut) then + if (rr > self % rcut) then rad = 0.0_dp end if xx = (1.0_dp - rr) / (1.0_dp + rr) - ind = floor(acos(xx) / self%delta) - if (ind < self%ngrid) then - iend = min(self%ngrid, ind + nrightinter2) + ind = floor(acos(xx) / self % delta) + if (ind < self % ngrid) then + iend = min(self % ngrid, ind + nrightinter2) iend = max(iend, ninter2) istart = iend - ninter2 + 1 - rad = polyinter(self%rvalues(istart:iend), self%fvalues(istart:iend), rr) + rad = polyinter(self % rvalues(istart:iend), self % fvalues(istart:iend), rr) else - iend = self%ngrid + iend = self % ngrid istart = iend - ninter2 + 1 ! calculate 1st und 2nd derivatives at the end - f1 = self%fvalues(iend) - f0 = polyinter(self%rvalues(istart:iend), self%fvalues(istart:iend), & - &self%rvalues(iend) - deltar) - f2 = polyinter(self%rvalues(istart:iend), self%fvalues(istart:iend), & - &self%rvalues(iend) + deltar) + f1 = self % fvalues(iend) + f0 = polyinter(self % rvalues(istart:iend), self % fvalues(istart:iend), & + &self % rvalues(iend) - deltar) + f2 = polyinter(self % rvalues(istart:iend), self % fvalues(istart:iend), & + &self % rvalues(iend) + deltar) f1p = (f2 - f0) / (2.0_dp * deltar) f1pp = (f2 + f0 - 2.0_dp * f1) / deltar**2 rad = poly5zero(f1, f1p, f1pp, rr - rmax, -1.0_dp * distfudge) end if - - end function gridorb2_getvalue + end function gridorb2_getvalue subroutine gridorb2_rescale(self, fac) type(gridorb2), intent(inout) :: self real(dp), intent(in) :: fac - self%fvalues = self%fvalues * fac - - end subroutine gridorb2_rescale + self % fvalues = self % fvalues * fac + end subroutine gridorb2_rescale end module gridorbital diff --git a/sktwocnt/lib/interpolation.f90 b/sktwocnt/lib/interpolation.f90 index b6942602..d57ad4a7 100644 --- a/sktwocnt/lib/interpolation.f90 +++ b/sktwocnt/lib/interpolation.f90 @@ -1,17 +1,15 @@ !!* Contains routines for interpolation and extrapolation module interpolation - use common_accuracy, only : dp + use common_accuracy, only: dp implicit none private public :: poly5zero, spline3_free, polyinter - contains - !! Returns the value of a polynomial of 5th degree at x. !! \param y0 Value of the polynom at x = dx. !! \param y0p Value of the 1st derivative at x = dx. @@ -35,16 +33,14 @@ pure function poly5zero(y0, y0p, y0pp, xx, dx) result(yy) dx1 = y0p * dx dx2 = y0pp * dx * dx - dd = 10.0_dp * y0 - 4.0_dp * dx1 + 0.5_dp * dx2 + dd = 10.0_dp * y0 - 4.0_dp * dx1 + 0.5_dp * dx2 ee = -15.0_dp * y0 + 7.0_dp * dx1 - 1.0_dp * dx2 - ff = 6.0_dp * y0 - 3.0_dp * dx1 + 0.5_dp * dx2 + ff = 6.0_dp * y0 - 3.0_dp * dx1 + 0.5_dp * dx2 xr = xx / dx - yy = ((ff*xr + ee)*xr + dd)*xr*xr*xr + yy = ((ff * xr + ee) * xr + dd) * xr * xr * xr end function poly5zero - - !! Returns the value of a free spline at a certain point. !! \param y0 Function value at x = 0. !! \param y0p First derivative at x = 0. @@ -60,7 +56,7 @@ end function poly5zero !! x = 0 and its value agrees with the provided value at x = dx. !! \note If you want the value for a derivative, you have to query them !! both. - pure subroutine spline3_free(y0, y0p, y0pp, dx, ydx, xx, yy, yp, ypp) + pure subroutine spline3_free(y0, y0p, y0pp, dx, ydx, xx, yy, yp, ypp) real(dp), intent(in) :: y0 real(dp), intent(in) :: y0p real(dp), intent(in) :: y0pp @@ -79,18 +75,16 @@ pure subroutine spline3_free(y0, y0p, y0pp, dx, ydx, xx, yy, yp, ypp) bb = y0p cc = 0.5_dp * y0pp dx1 = 1.0_dp / dx - dd = (((ydx - y0)*dx1 - y0p)*dx1 - 0.5_dp*y0pp)*dx1 + dd = (((ydx - y0) * dx1 - y0p) * dx1 - 0.5_dp * y0pp) * dx1 if (present(yy)) then - yy = ((dd*xx + cc)*xx + bb)*xx + aa + yy = ((dd * xx + cc) * xx + bb) * xx + aa end if if (present(yp)) then - yp = (3.0_dp*dd*xx + 2.0_dp*cc)*xx + bb + yp = (3.0_dp * dd * xx + 2.0_dp * cc) * xx + bb ypp = 6.0_dp * dd * xx + 2.0_dp * cc end if - - end subroutine spline3_free - + end subroutine spline3_free !! Polynomial interpolation through given points !! \param xa x-coordinates of the fit points @@ -130,14 +124,14 @@ pure function polyinter(xp, yp, xx) result(yy) icl = icl - 1 do mm = 1, nn - 1 do ii = 1, nn - mm - rtmp = xp(ii) - xp(ii+mm) + rtmp = xp(ii) - xp(ii + mm) !if (abs(rtmp) < epsilon(1.0_dp)) then - !write (*,*) "Polint failed" - !stop + !write(*,*) "Polint failed" + !stop !end if - rtmp = (cc(ii+1) - dd(ii)) / rtmp + rtmp = (cc(ii + 1) - dd(ii)) / rtmp cc(ii) = (xp(ii) - xx) * rtmp - dd(ii) = (xp(ii+mm) - xx) * rtmp + dd(ii) = (xp(ii + mm) - xx) * rtmp end do if (2 * icl < nn - mm) then dyy = cc(icl + 1) @@ -149,6 +143,5 @@ pure function polyinter(xp, yp, xx) result(yy) end do end function polyinter - end module interpolation diff --git a/sktwocnt/lib/partition.f90 b/sktwocnt/lib/partition.f90 index fe1e8192..d518e1aa 100644 --- a/sktwocnt/lib/partition.f90 +++ b/sktwocnt/lib/partition.f90 @@ -1,14 +1,13 @@ !> Conains space partioning functions. module partition - use common_accuracy, only : dp + use common_accuracy, only: dp implicit none private public :: partition_becke, partition_becke_hetero, beckepar - contains !> Becke partition function for 2 centers. @@ -32,7 +31,6 @@ function partition_becke(r1, r2, dist, partparams) result(res) end function partition_becke - !> Becke partition function for 2 heteronuclear centers. !! \param r1 Distance from 1st center. !! \param r2 Distance from 2nd center. @@ -57,7 +55,6 @@ function partition_becke_hetero(r1, r2, dist, partparams) result(res) end function partition_becke_hetero - !> Delivers parameter aij in the becke partition scheme for given atomic !! radii. !! \param r1 Radius of the first atom. @@ -77,5 +74,5 @@ function beckepar(r1, r2) result(res) end if end function beckepar - + end module partition diff --git a/sktwocnt/lib/quadrature.f90 b/sktwocnt/lib/quadrature.f90 index 657e4f9c..75618514 100644 --- a/sktwocnt/lib/quadrature.f90 +++ b/sktwocnt/lib/quadrature.f90 @@ -1,6 +1,6 @@ module quadratures - use common_accuracy, only : dp + use common_accuracy, only: dp use common_constants implicit none @@ -25,8 +25,8 @@ subroutine gauss_legendre_quadrature(nn, quad) integer :: mm, ii, jj real(dp) :: zz, z1, pp, p1, p2, p3, rj - allocate(quad%xx(nn)) - allocate(quad%ww(nn)) + allocate(quad % xx(nn)) + allocate(quad % ww(nn)) mm = (nn + 1) / 2 do ii = 1, mm zz = cos(pi * (real(ii, dp) - 0.25_dp) / (real(nn, dp) + 0.5_dp)) @@ -46,20 +46,19 @@ subroutine gauss_legendre_quadrature(nn, quad) exit end if end do - quad%xx(ii) = -zz - quad%xx(nn + 1 - ii) = zz - quad%ww(ii) = 2.0_dp / ((1.0_dp - zz * zz) * pp * pp) - quad%ww(nn + 1 - ii) = quad%ww(ii) + quad % xx(ii) = -zz + quad % xx(nn + 1 - ii) = zz + quad % ww(ii) = 2.0_dp / ((1.0_dp - zz * zz) * pp * pp) + quad % ww(nn + 1 - ii) = quad % ww(ii) end do - - end subroutine gauss_legendre_quadrature + end subroutine gauss_legendre_quadrature !> Gauss-Chebishev quadrature for integration in the interval [-1,1]. !! !! Integration of functions with Gauss-Chebishev quadrature of second kind. !! The weights already contain 1/sqrt(1-x^2) so that it can be directly - !! used to integrate a function on [-1,1]. + !! used to integrate a function on [-1,1]. !! See also: J. M. Pérez-Jordá et al., J. Chem. Phys. 100 6520 (1994). !! !! \param nn Number of points for the quadrature @@ -71,21 +70,20 @@ subroutine gauss_chebyshev_quadrature(nn, quad) integer :: ii real(dp) :: rtmp - allocate(quad%xx(nn)) - allocate(quad%ww(nn)) + allocate(quad % xx(nn)) + allocate(quad % ww(nn)) !do ii = 1, nn ! quad%xx(ii) = cos(pi * (real(ii, dp) - 0.5_dp) / real(nn, dp)) !end do !quad%ww = pi / real(nn, dp) do ii = 1, nn rtmp = real(ii, dp) * pi / real(nn + 1, dp) - quad%xx(ii) = cos(rtmp) - quad%ww(ii) = sin(rtmp) + quad % xx(ii) = cos(rtmp) + quad % ww(ii) = sin(rtmp) end do - quad%ww = quad%ww * pi / real(nn + 1, dp) - - end subroutine gauss_chebyshev_quadrature + quad % ww = quad % ww * pi / real(nn + 1, dp) + end subroutine gauss_chebyshev_quadrature !> Trapezoidal quadrature for integration in the interval [-1,1]. !! \param nn Number of points for the quadrature @@ -98,15 +96,14 @@ subroutine trapezoidal_quadrature(nn, quad) integer :: ii real(dp) :: fac - allocate(quad%xx(nn)) - allocate(quad%ww(nn)) + allocate(quad % xx(nn)) + allocate(quad % ww(nn)) fac = 2.0_dp / real(nn, dp) do ii = 1, nn - quad%xx(ii) = -1.0_dp + fac * real(ii - 1, dp) + quad % xx(ii) = -1.0_dp + fac * real(ii - 1, dp) end do - quad%ww = fac + quad % ww = fac end subroutine trapezoidal_quadrature - end module quadratures diff --git a/sktwocnt/lib/sphericalharmonics.f90 b/sktwocnt/lib/sphericalharmonics.f90 index 8025d76a..9776ce21 100644 --- a/sktwocnt/lib/sphericalharmonics.f90 +++ b/sktwocnt/lib/sphericalharmonics.f90 @@ -1,7 +1,7 @@ !> Spherical harmonics. module sphericalharmonics - use common_accuracy, only : dp + use common_accuracy, only: dp implicit none private @@ -40,11 +40,10 @@ subroutine realtess_init(self, ll, mm) type(realtess), intent(inout) :: self integer, intent(in) :: ll, mm - self%ll = ll - self%mm = mm - - end subroutine realtess_init + self % ll = ll + self % mm = mm + end subroutine realtess_init !> Destroys the instance. !! \param self instance. @@ -52,10 +51,9 @@ subroutine realtess_destruct(self) type(realtess), intent(inout) :: self continue - + end subroutine realtess_destruct - !> returns the value of the tessereal function. !! \param self instance. !! \param theta spherical coordinate theta. @@ -65,22 +63,18 @@ elemental function realtess_getvalue(self, theta, phi) result(ang) real(dp), intent(in) :: theta, phi real(dp) :: ang - ang = calc_realtess(self%ll, self%mm, theta, phi) - - end function realtess_getvalue + ang = calc_realtess(self % ll, self % mm, theta, phi) + end function realtess_getvalue elemental function realtess_getvalue_1d(self, theta) result(ang) type(realtess), intent(in) :: self real(dp), intent(in) :: theta real(dp) :: ang - ang = calc_realtess_1d(self%ll, self%mm, theta) - - end function realtess_getvalue_1d - - + ang = calc_realtess_1d(self % ll, self % mm, theta) + end function realtess_getvalue_1d !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!! private functions @@ -92,66 +86,65 @@ end function realtess_getvalue_1d !! \param theta spherical coordinate theta. !! \param phi spherical coordinate phi. !! \return value of the real tesseral harmonics. - elemental function calc_realtess(ll, mm, theta, phi) result (rty) + elemental function calc_realtess(ll, mm, theta, phi) result(rty) integer, intent(in) :: ll integer, intent(in) :: mm real(dp), intent(in) :: theta, phi real(dp) :: rty - + !assert(ll >= 0 .and. ll <= 3) !assert(abs(mm) <= ll) - + select case (ll) - case(0) + case (0) rty = 0.2820947917738782_dp - case(1) - select case(mm) - case(-1) + case (1) + select case (mm) + case (-1) rty = 0.4886025119029198_dp * sin(theta) * sin(phi) - case(0) + case (0) rty = 0.4886025119029198_dp * cos(theta) - case(1) + case (1) rty = 0.4886025119029198_dp * sin(theta) * cos(phi) end select - case(2) - select case(mm) - case(-2) + case (2) + select case (mm) + case (-2) rty = 0.5462742152960395_dp * sin(theta)**2 * sin(2.0_dp * phi) - case(-1) + case (-1) rty = 1.092548430592079_dp * sin(theta) * cos(theta) * sin(phi) - case(0) + case (0) rty = 0.9461746957575600_dp * cos(theta)**2 - 0.3153915652525200_dp - case(1) + case (1) rty = 1.092548430592079_dp * sin(theta) * cos(theta) * cos(phi) - case(2) + case (2) rty = 0.5462742152960395_dp * sin(theta)**2 * cos(2.0_dp * phi) end select - case(3) + case (3) select case (mm) - case(-3) + case (-3) rty = 0.5900435899266435_dp * sin(theta)**3 * sin(3.0_dp * phi) - case(-2) + case (-2) rty = 1.445305721320277_dp * sin(theta)**2 * cos(theta) & - &* sin(2.0_dp * phi) - case(-1) + &* sin(2.0_dp * phi) + case (-1) rty = 0.4570457994644658_dp * sin(theta) & - &* (5.0_dp * cos(theta)**2 - 1.0_dp) * sin(phi) - case(0) + &* (5.0_dp * cos(theta)**2 - 1.0_dp) * sin(phi) + case (0) rty = 0.3731763325901155_dp * cos(theta) & - &* (5.0_dp * cos(theta)**2 - 3.0_dp) - case(1) + &* (5.0_dp * cos(theta)**2 - 3.0_dp) + case (1) rty = 0.4570457994644658_dp * sin(theta) & - &* (5.0_dp * cos(theta)**2 - 1.0_dp) * cos(phi) - case(2) + &* (5.0_dp * cos(theta)**2 - 1.0_dp) * cos(phi) + case (2) rty = 1.445305721320277_dp * sin(theta)**2 * cos(theta) & - &* cos(2.0_dp * phi) - case(3) + &* cos(2.0_dp * phi) + case (3) rty = 0.5900435899266435_dp * sin(theta)**3 * cos(3.0_dp * phi) end select end select - - end function calc_realtess + end function calc_realtess !> Real tessereal spherical harmonics up to f. !! \param ll angular momentum (l). @@ -159,62 +152,62 @@ end function calc_realtess !! \param theta spherical coordinate theta. !! \param phi spherical coordinate phi. !! \return value of the real tesseral harmonics. - elemental function calc_realtess_1d(ll, mm, theta) result (rty) + elemental function calc_realtess_1d(ll, mm, theta) result(rty) integer, intent(in) :: ll integer, intent(in) :: mm real(dp), intent(in) :: theta real(dp) :: rty - + !assert(ll >= 0 .and. ll <= 3) !assert(abs(mm) <= ll) - + select case (ll) - case(0) + case (0) rty = 0.2820947917738782_dp - case(1) - select case(mm) - case(-1) + case (1) + select case (mm) + case (-1) rty = 0.4886025119029198_dp * sin(theta) - case(0) + case (0) rty = 0.4886025119029198_dp * cos(theta) - case(1) + case (1) rty = 0.4886025119029198_dp * sin(theta) end select - case(2) - select case(mm) - case(-2) + case (2) + select case (mm) + case (-2) rty = 0.5462742152960395_dp * sin(theta)**2 - case(-1) + case (-1) rty = 1.092548430592079_dp * sin(theta) * cos(theta) - case(0) + case (0) rty = 0.9461746957575600_dp * cos(theta)**2 - 0.3153915652525200_dp - case(1) + case (1) rty = 1.092548430592079_dp * sin(theta) * cos(theta) - case(2) + case (2) rty = 0.5462742152960395_dp * sin(theta)**2 end select - case(3) + case (3) select case (mm) - case(-3) + case (-3) rty = 0.5900435899266435_dp * sin(theta)**3 - case(-2) + case (-2) rty = 1.445305721320277_dp * sin(theta)**2 * cos(theta) - case(-1) + case (-1) rty = 0.4570457994644658_dp * sin(theta) & - &* (5.0_dp * cos(theta)**2 - 1.0_dp) - case(0) + &* (5.0_dp * cos(theta)**2 - 1.0_dp) + case (0) rty = 0.3731763325901155_dp * cos(theta) & - &* (5.0_dp * cos(theta)**2 - 3.0_dp) - case(1) + &* (5.0_dp * cos(theta)**2 - 3.0_dp) + case (1) rty = 0.4570457994644658_dp * sin(theta) & - &* (5.0_dp * cos(theta)**2 - 1.0_dp) - case(2) + &* (5.0_dp * cos(theta)**2 - 1.0_dp) + case (2) rty = 1.445305721320277_dp * sin(theta)**2 * cos(theta) - case(3) + case (3) rty = 0.5900435899266435_dp * sin(theta)**3 end select end select - + end function calc_realtess_1d end module sphericalharmonics diff --git a/sktwocnt/lib/twocnt.f90 b/sktwocnt/lib/twocnt.f90 index 2d5ff785..c331f7ff 100644 --- a/sktwocnt/lib/twocnt.f90 +++ b/sktwocnt/lib/twocnt.f90 @@ -2,7 +2,7 @@ module twocnt use omp_lib - use common_accuracy, only : dp + use common_accuracy, only: dp use common_constants use quadratures use coordtrans @@ -23,7 +23,7 @@ module twocnt type atomdata integer :: nbasis integer, allocatable :: angmoms(:) - type(gridorb2), allocatable :: rad(:), drad(:), ddrad(:) + type(gridorb2), allocatable :: rad(:), drad(:), ddrad(:) type(gridorb2) :: pot, rho, drho, ddrho end type atomdata @@ -37,121 +37,118 @@ module twocnt type(atomdata) :: atom1, atom2 end type twocnt_in - !> Type for mapping integrals. type integmap !> Nr. of all nonzero twocenter integrals between orbitals of two atoms. integer :: ninteg !> Indicates for every integral the integrands: - !! + !! !! o type(1,ii): index of orbital on first atom for integral ii. !! o type(2,ii): index of orbital on second atom for integral ii !! o type(3,ii): interaction type for integral ii: (0 - sigma, 1 - pi, ...) - integer, allocatable :: type(:,:) + integer, allocatable :: type(:, :) !> Indicates which integral corresponds to a given (i1, i2, mm) combination, !! where i1 and i2 are the orbital indices on the two atoms and mm the !! interaction type. If the integral vanishes, the corresponding elemet is 0. - integer, allocatable :: index(:,:,:) + integer, allocatable :: index(:, :, :) contains procedure :: init => integmap_init end type integmap - contains subroutine get_twocenter_integrals(inp, imap, skham, skover) type(twocnt_in), target, intent(in) :: inp type(integmap), intent(out) :: imap - real(dp), allocatable, intent(out) :: skham(:,:), skover(:,:) + real(dp), allocatable, intent(out) :: skham(:, :), skover(:, :) type(quadrature) :: quads(2) type(atomdata), pointer :: atom1, atom2 type(TFiFoReal2) :: hamfifo, overfifo - real(dp), allocatable :: grid1(:,:), grid2(:,:) + real(dp), allocatable :: grid1(:, :), grid2(:, :) real(dp), allocatable :: dots(:), weights(:) real(dp), allocatable :: denserr(:) - real(dp), allocatable :: skhambuffer(:,:), skoverbuffer(:,:) + real(dp), allocatable :: skhambuffer(:, :), skoverbuffer(:, :) real(dp) :: beckepars(1) real(dp) :: dist, maxdist, denserrmax, maxabs integer :: ir, nbatch, nbatchline logical :: converged, dynlen - call gauss_legendre_quadrature(inp%ninteg1, quads(1)) - call gauss_legendre_quadrature(inp%ninteg2, quads(2)) + call gauss_legendre_quadrature(inp % ninteg1, quads(1)) + call gauss_legendre_quadrature(inp % ninteg2, quads(2)) - atom1 => inp%atom1 - if (inp%hetero) then - atom2 => inp%atom2 + atom1 => inp % atom1 + if (inp % hetero) then + atom2 => inp % atom2 else - atom2 => inp%atom1 + atom2 => inp % atom1 end if - call imap%init(atom1, atom2) + call imap % init(atom1, atom2) ! Calculate lines for 1 Bohr in one batch. dist = 0.0_dp - dynlen = (inp%maxdist > 0.0_dp) + dynlen = (inp % maxdist > 0.0_dp) if (dynlen) then - nbatchline = ceiling(1.0_dp / inp%dr) - maxdist = inp%maxdist + real(nbatchline, dp) * inp%dr + nbatchline = ceiling(1.0_dp / inp % dr) + maxdist = inp % maxdist + real(nbatchline, dp) * inp % dr else - maxdist = abs(inp%maxdist) - nbatchline = ceiling((maxdist - inp%r0) / inp%dr) + maxdist = abs(inp % maxdist) + nbatchline = ceiling((maxdist - inp % r0) / inp % dr) end if nbatch = 0 denserrmax = 0.0_dp allocate(denserr(nbatchline)) do - allocate(skhambuffer(imap%ninteg, nbatchline)) - allocate(skoverbuffer(imap%ninteg, nbatchline)) + allocate(skhambuffer(imap % ninteg, nbatchline)) + allocate(skoverbuffer(imap % ninteg, nbatchline)) write(*, "(A,I0,A,F6.3,A,F6.3)") "Calculating ", nbatchline,& - & " lines: r0 = ", inp%r0 + inp%dr * real(nbatch * nbatchline, dp),& - & " dr = ", inp%dr + & " lines: r0 = ", inp % r0 + inp % dr * real(nbatch * nbatchline, dp),& + & " dr = ", inp % dr do ir = 1, nbatchline - dist = inp%r0 + inp%dr * real(nbatch * nbatchline + ir - 1, dp) + dist = inp % r0 + inp % dr * real(nbatch * nbatchline + ir - 1, dp) call gengrid2_12(quads, coordtrans_becke_12, partition_becke,& & beckepars, dist, grid1, grid2, dots, weights) call getskintegrals(atom1, atom2, grid1, grid2, dots, weights,& - &inp%density, inp%ixc, imap, skhambuffer(:,ir), skoverbuffer(:,ir),& + &inp % density, inp % ixc, imap, skhambuffer(:, ir), skoverbuffer(:, ir),& & denserr(ir)) end do denserrmax = max(denserrmax, maxval(denserr)) maxabs = max(maxval(abs(skhambuffer)), maxval(abs(skoverbuffer))) if (dynlen) then - converged = (maxabs < inp%epsilon) + converged = (maxabs < inp % epsilon) ! If new batch gave no contributions above tolerance: omit it and exit if (converged .or. dist > maxdist) then exit end if nbatch = nbatch + 1 - call hamfifo%push_alloc(skhambuffer) - call overfifo%push_alloc(skoverbuffer) + call hamfifo % push_alloc(skhambuffer) + call overfifo % push_alloc(skoverbuffer) else converged = .true. - call hamfifo%push_alloc(skhambuffer) - call overfifo%push_alloc(skoverbuffer) + call hamfifo % push_alloc(skhambuffer) + call overfifo % push_alloc(skoverbuffer) exit end if end do if (.not. converged) then - write(*, "(A,F6.2,A,ES10.3)") "Warning, maximal distance ", inp%maxdist,& + write(*, "(A,F6.2,A,ES10.3)") "Warning, maximal distance ", inp % maxdist,& & " reached! Max integral value:", maxabs end if write(*, "(A,ES10.3)") "Maximal integration error:", denserrmax - call hamfifo%popall_concat(skham) - call overfifo%popall_concat(skover) + call hamfifo % popall_concat(skham) + call overfifo % popall_concat(skover) end subroutine get_twocenter_integrals - !> Calculate SK-integrals. subroutine getskintegrals(atom1, atom2, grid1, grid2, dots, weights,& & densitysuper, ixc, imap, skham, skover, denserr) type(atomdata), intent(in) :: atom1, atom2 - real(dp), intent(in), target :: grid1(:,:), grid2(:,:), dots(:), weights(:) + real(dp), intent(in), target :: grid1(:, :), grid2(:, :), dots(:), weights(:) logical, intent(in) :: densitysuper integer, intent(in) :: ixc type(integmap), intent(in) :: imap @@ -159,57 +156,57 @@ subroutine getskintegrals(atom1, atom2, grid1, grid2, dots, weights,& type(realtess) :: tes1, tes2 real(dp), pointer :: r1(:), r2(:), theta1(:), theta2(:) - real(dp), allocatable :: radval1(:,:) - real(dp), allocatable :: radval2(:,:), radval2p(:,:), radval2pp(:,:) + real(dp), allocatable :: radval1(:, :) + real(dp), allocatable :: radval2(:, :), radval2p(:, :), radval2pp(:, :) real(dp), allocatable :: potval(:), densval(:) real(dp), allocatable :: densval1p(:), densval1pp(:) real(dp), allocatable :: densval2p(:), densval2pp(:) real(dp), allocatable :: spherval1(:), spherval2(:) real(dp), allocatable :: absgr(:), laplace(:), gr_grabsgr(:) - + real(dp) :: integ1, integ2, dens, prefac integer :: ngrid integer :: ii, i1, i2, l1, l2, mm - r1 => grid1(:,1) - theta1 => grid1(:,2) - r2 => grid2(:,1) - theta2 => grid2(:,2) + r1 => grid1(:, 1) + theta1 => grid1(:, 2) + r2 => grid2(:, 1) + theta2 => grid2(:, 2) ngrid = size(r1) - allocate(radval1(ngrid, atom1%nbasis)) - allocate(radval2(ngrid, atom2%nbasis)) - allocate(radval2p(ngrid, atom2%nbasis)) - allocate(radval2pp(ngrid, atom2%nbasis)) + allocate(radval1(ngrid, atom1 % nbasis)) + allocate(radval2(ngrid, atom2 % nbasis)) + allocate(radval2p(ngrid, atom2 % nbasis)) + allocate(radval2pp(ngrid, atom2 % nbasis)) allocate(spherval1(ngrid)) allocate(spherval2(ngrid)) do ii = 1, size(radval1, dim=2) - radval1(:,ii) = getvalue(atom1%rad(ii), r1) + radval1(:, ii) = getvalue(atom1 % rad(ii), r1) end do do ii = 1, size(radval2, dim=2) - radval2(:,ii) = getvalue(atom2%rad(ii), r2) - radval2p(:,ii) = getvalue(atom2%drad(ii), r2) - radval2pp(:,ii) = getvalue(atom2%ddrad(ii), r2) + radval2(:, ii) = getvalue(atom2 % rad(ii), r2) + radval2p(:, ii) = getvalue(atom2 % drad(ii), r2) + radval2pp(:, ii) = getvalue(atom2 % ddrad(ii), r2) end do allocate(potval(ngrid)) ifPotSup: if (.not. densitysuper) then - potval = getvalue(atom1%pot, r1) + getvalue(atom2%pot, r2) + potval = getvalue(atom1 % pot, r1) + getvalue(atom2 % pot, r2) else allocate(densval(ngrid)) - densval = getvalue(atom1%rho, r1) + getvalue(atom2%rho, r2) - select case(ixc) - case(1) + densval = getvalue(atom1 % rho, r1) + getvalue(atom2 % rho, r2) + select case (ixc) + case (1) call getxcpot_ldapw91(densval, potval) - case(2) + case (2) allocate(densval1p(ngrid)) allocate(densval1pp(ngrid)) allocate(densval2p(ngrid)) allocate(densval2pp(ngrid)) - densval1p = getvalue(atom1%drho, r1) - densval1pp = getvalue(atom1%ddrho, r1) - densval2p = getvalue(atom2%drho, r2) - densval2pp = getvalue(atom2%ddrho, r2) + densval1p = getvalue(atom1 % drho, r1) + densval1pp = getvalue(atom1 % ddrho, r1) + densval2p = getvalue(atom2 % drho, r2) + densval2pp = getvalue(atom2 % ddrho, r2) allocate(absgr(ngrid)) allocate(laplace(ngrid)) allocate(gr_grabsgr(ngrid)) @@ -223,26 +220,26 @@ subroutine getskintegrals(atom1, atom2, grid1, grid2, dots, weights,& stop end select ! Add nuclear and coulomb potential - potval = potval + getvalue(atom1%pot, r1) + getvalue(atom2%pot, r2) + potval = potval + getvalue(atom1 % pot, r1) + getvalue(atom2 % pot, r2) end if ifPotSup denserr = 0.0_dp - do ii = 1, imap%ninteg - i1 = imap%type(1, ii) - l1 = atom1%angmoms(i1) - i2 = imap%type(2, ii) - l2 = atom2%angmoms(i2) - mm = imap%type(3, ii) - 1 + do ii = 1, imap % ninteg + i1 = imap % type(1, ii) + l1 = atom1 % angmoms(i1) + i2 = imap % type(2, ii) + l2 = atom2 % angmoms(i2) + mm = imap % type(3, ii) - 1 call init(tes1, l1, mm) call init(tes2, l2, mm) spherval1 = getvalue_1d(tes1, theta1) spherval2 = getvalue_1d(tes2, theta2) - integ1 = gethamiltonian(radval1(:,i1), radval2(:,i2), & - &radval2p(:,i2), radval2pp(:,i2), r2, l2, spherval1, & + integ1 = gethamiltonian(radval1(:, i1), radval2(:, i2), & + &radval2p(:, i2), radval2pp(:, i2), r2, l2, spherval1, & &spherval2, potval, weights) - integ2 = getoverlap(radval1(:,i1), radval2(:,i2), spherval1, & + integ2 = getoverlap(radval1(:, i1), radval2(:, i2), spherval1, & &spherval2, weights) - dens = getdensity(radval1(:,i1), radval2(:,i2), spherval1, & + dens = getdensity(radval1(:, i1), radval2(:, i2), spherval1, & &spherval2, weights) if (mm == 0) then prefac = 2.0_dp * pi @@ -257,28 +254,21 @@ subroutine getskintegrals(atom1, atom2, grid1, grid2, dots, weights,& end subroutine getskintegrals - - - - - function getoverlap(rad1, rad2, spher1, spher2, weights) result(res) real(dp), intent(in) :: rad1(:), rad2(:), spher1(:), spher2(:), weights(:) real(dp) :: res res = sum(rad1 * rad2 * spher1 * spher2 * weights) - - end function getoverlap + end function getoverlap function getdensity(rad1, rad2, spher1, spher2, weights) result(res) real(dp), intent(in) :: rad1(:), rad2(:), spher1(:), spher2(:), weights(:) real(dp) :: res res = sum(((rad1 * spher1)**2 + (rad2 * spher2)**2) * weights) - - end function getdensity + end function getdensity function gethamiltonian(rad1, rad2, rad2p, rad2pp, r2, l2, spher1, spher2, & &pot, weights) result(res) @@ -286,17 +276,15 @@ function gethamiltonian(rad1, rad2, rad2p, rad2pp, r2, l2, spher1, spher2, & integer, intent(in) :: l2 real(dp), intent(in) :: spher1(:), spher2(:), pot(:), weights(:) real(dp) :: res - + res = sum((rad1 * spher1) & &* (-0.5_dp * rad2pp & &- rad2p / r2 & &+ 0.5_dp * l2 * (l2 + 1) * rad2 / r2**2& &+ pot * rad2) & &* spher2 * weights) - - end function gethamiltonian - + end function gethamiltonian subroutine getderivs(drho1, d2rho1, drho2, d2rho2, r1, r2, dots, & &absgr, laplace, gr_grabsgr) @@ -314,16 +302,15 @@ subroutine getderivs(drho1, d2rho1, drho2, d2rho2, r1, r2, dots, & absgr = sqrt(drho1 * f1 + drho2 * f2) laplace = d2rho1 + d2rho2 + 2.0_dp * (drho1 / r1 + drho2 / r2) where (absgr > epsilon(1.0_dp)) - gr_grabsgr = (d2rho1 * f1 * f1 + d2rho2 * f2 * f2 & - &+(1.0_dp - dots**2) * drho1 * drho2 * (drho2 / r1 + drho1 / r2)) & + gr_grabsgr = (d2rho1 * f1 * f1 + d2rho2 * f2 * f2 & + &+ (1.0_dp - dots**2) * drho1 * drho2 * (drho2 / r1 + drho1 / r2)) & &/ absgr elsewhere gr_grabsgr = 0.0_dp end where - + end subroutine getderivs - !> Initializes the twocenter integration map based on the basis on two atoms. !! \param self Instance. !! \param atom1 Properties of atom1. @@ -333,38 +320,37 @@ subroutine integmap_init(self, atom1, atom2) type(atomdata), intent(in) :: atom1, atom2 integer :: mmax, ninteg, ind, i1, l1, i2, l2, mm - - mmax = min(maxval(atom1%angmoms), maxval(atom2%angmoms)) - allocate(self%index(atom1%nbasis, atom2%nbasis, mmax+1)) - self%index = 0 + + mmax = min(maxval(atom1 % angmoms), maxval(atom2 % angmoms)) + allocate(self % index(atom1 % nbasis, atom2 % nbasis, mmax + 1)) + self % index = 0 ninteg = 0 - do i1 = 1, atom1%nbasis - l1 = atom1%angmoms(i1) - do i2 = 1, atom2%nbasis - l2 = atom2%angmoms(i2) + do i1 = 1, atom1 % nbasis + l1 = atom1 % angmoms(i1) + do i2 = 1, atom2 % nbasis + l2 = atom2 % angmoms(i2) do mm = 0, min(l1, l2) - print *, l1, l2, mm + print*,l1, l2, mm ninteg = ninteg + 1 - self%index(i1, i2, mm+1) = ninteg + self % index(i1, i2, mm + 1) = ninteg end do end do end do - self%ninteg = ninteg - allocate(self%type(3, ninteg)) + self % ninteg = ninteg + allocate(self % type(3, ninteg)) ind = 0 - do i1 = 1, atom1%nbasis - l1 = atom1%angmoms(i1) - do i2 = 1, atom2%nbasis - l2 = atom2%angmoms(i2) + do i1 = 1, atom1 % nbasis + l1 = atom1 % angmoms(i1) + do i2 = 1, atom2 % nbasis + l2 = atom2 % angmoms(i2) do mm = 1, min(l1, l2) + 1 ind = ind + 1 - self%type(:, ind) = [ i1, i2, mm ] + self % type(:, ind) = [i1, i2, mm] end do end do end do end subroutine integmap_init - end module twocnt - + diff --git a/sktwocnt/prog/cmdargs.f90 b/sktwocnt/prog/cmdargs.f90 index 32aa64f2..b3eafe3d 100644 --- a/sktwocnt/prog/cmdargs.f90 +++ b/sktwocnt/prog/cmdargs.f90 @@ -4,14 +4,13 @@ module cmdargs character(*), parameter :: programName = 'sktwocnt' character(*), parameter :: programVersion = '0.9' - contains subroutine parse_command_arguments() - + integer :: nArgs, argLen character(:), allocatable :: arg - + nArgs = command_argument_count() if (nArgs > 0) then call get_command_argument(1, length=argLen) @@ -28,5 +27,5 @@ subroutine parse_command_arguments() end if end subroutine parse_command_arguments - + end module cmdargs diff --git a/sktwocnt/prog/input.f90 b/sktwocnt/prog/input.f90 index 89191b82..852c8172 100644 --- a/sktwocnt/prog/input.f90 +++ b/sktwocnt/prog/input.f90 @@ -1,6 +1,6 @@ module input - use common_accuracy, only : dp + use common_accuracy, only: dp use gridorbital use twocnt, only: twocnt_in, atomdata implicit none @@ -25,60 +25,58 @@ subroutine readinput(inp, inputfile) logical :: readradderivs fp = 14 - open(fp, file=inputfile, form="formatted", action="read") + open (fp, file=inputfile, form="formatted", action="read") !! General part iline = 0 call nextline_(fp, iline, line) - read(line, *, iostat=iostat) buffer1, buffer2 + read (line, *, iostat=iostat) buffer1, buffer2 call checkerror_(inputfile, line, iline, iostat) if (buffer1 /= "hetero" .and. buffer1 /= "homo") then call error_("Wrong interaction (must be hetero or homo)", inputfile, & &line, iline) end if - inp%hetero = (buffer1 == "hetero") + inp % hetero = (buffer1 == "hetero") select case (buffer2) - case("potential") - inp%density = .false. - inp%ixc = 0 - case("density_lda") - inp%density = .true. - inp%ixc = 1 - case("density_pbe") - inp%density = .true. - inp%ixc = 2 + case ("potential") + inp % density = .false. + inp % ixc = 0 + case ("density_lda") + inp % density = .true. + inp % ixc = 1 + case ("density_pbe") + inp % density = .true. + inp % ixc = 2 case default call error_("Wrong superposition mode (must be potential, density_lda & &or density_pbe", inputfile, line, iline) end select - + call nextline_(fp, iline, line) - read(line, *, iostat=iostat) inp%r0, inp%dr, inp%epsilon, inp%maxdist + read (line, *, iostat=iostat) inp % r0, inp % dr, inp % epsilon, inp % maxdist call checkerror_(inputfile, line, iline, iostat) call nextline_(fp, iline, line) - read(line, *, iostat=iostat) inp%ninteg1, inp%ninteg2 + read (line, *, iostat=iostat) inp % ninteg1, inp % ninteg2 call checkerror_(inputfile, line, iline, iostat) - if (inp%density) then + if (inp % density) then allocate(potcomps(2)) - potcomps = [ 2, 3 ] + potcomps = [2, 3] else allocate(potcomps(3)) - potcomps = [ 2, 3, 4 ] + potcomps = [2, 3, 4] end if - readradderivs = .not. inp%hetero - call readatom_(inputfile, fp, iline, potcomps, inp%density, readradderivs, & - &inp%atom1) - if (inp%hetero) then - call readatom_(inputfile, fp, iline, potcomps, inp%density, .true., & - &inp%atom2) + readradderivs = .not. inp % hetero + call readatom_(inputfile, fp, iline, potcomps, inp % density, readradderivs, & + &inp % atom1) + if (inp % hetero) then + call readatom_(inputfile, fp, iline, potcomps, inp % density, .true., & + &inp % atom2) end if - - close(fp) - - end subroutine readinput + close (fp) + end subroutine readinput subroutine readatom_(fname, fp, iline, potcomps, density, radderivs, atom) character(*), intent(in) :: fname @@ -89,81 +87,78 @@ subroutine readatom_(fname, fp, iline, potcomps, density, radderivs, atom) type(atomdata), intent(out) :: atom character(maxlen) :: line, buffer - real(dp), allocatable :: data(:,:), potval(:) - real(dp) :: vals(1) + real(dp), allocatable :: data(:, :), potval(:) integer :: ii, iostat, imax - call nextline_(fp, iline, line) - read(line, *, iostat=iostat) atom%nbasis + read (line, *, iostat=iostat) atom % nbasis call checkerror_(fname, line, iline, iostat) - - allocate(atom%angmoms(atom%nbasis)) - allocate(atom%rad(atom%nbasis)) + + allocate(atom % angmoms(atom % nbasis)) + allocate(atom % rad(atom % nbasis)) if (radderivs) then - allocate(atom%drad(atom%nbasis)) - allocate(atom%ddrad(atom%nbasis)) + allocate(atom % drad(atom % nbasis)) + allocate(atom % ddrad(atom % nbasis)) end if - do ii = 1, atom%nbasis + do ii = 1, atom % nbasis call nextline_(fp, iline, line) - read(line, *, iostat=iostat) buffer, atom%angmoms(ii) + read (line, *, iostat=iostat) buffer, atom % angmoms(ii) call checkerror_(fname, line, iline, iostat) if (radderivs) then - call readdata_(buffer, [ 1, 3, 4, 5 ], data) - call init(atom%rad(ii), data(:,1), data(:,2)) - call init(atom%drad(ii), data(:,1), data(:,3)) - call init(atom%ddrad(ii), data(:,1), data(:,4)) + call readdata_(buffer, [1, 3, 4, 5], data) + call init(atom % rad(ii), data(:, 1), data(:, 2)) + call init(atom % drad(ii), data(:, 1), data(:, 3)) + call init(atom % ddrad(ii), data(:, 1), data(:, 4)) else - call readdata_(buffer, [ 1, 3 ], data) - call init(atom%rad(ii), data(:,1), data(:,2)) + call readdata_(buffer, [1, 3], data) + call init(atom % rad(ii), data(:, 1), data(:, 2)) end if ! Check if wave function follows the sign convention ! (positive where abs(r * R(r)) has its maximum) - imax = maxloc(abs(data(:,1) * data(:,2)), dim=1) - if (data(imax,2) < 0.0_dp) then - write(*, "(A,F5.2,A)") "Wave function negative at the maximum of& - & radial probability (r =", data(imax,1), " Bohr)" - write(*, "(A)") "Please change the sign of the wave function (and of& - & its derivatives)!" - write(*, "(A,A,A)") "File: '", trim(buffer), "'" - stop - end if + imax = maxloc(abs(data(:, 1) * data(:, 2)), dim=1) + if (data(imax, 2) < 0.0_dp) then + write(*, "(A,F5.2,A)") "Wave function negative at the maximum of& + & radial probability (r =", data(imax, 1), " Bohr)" + write(*, "(A)") "Please change the sign of the wave function (and of& + & its derivatives)!" + write(*, "(A,A,A)") "File: '", trim(buffer), "'" + stop + end if end do - call checkangmoms_(atom%angmoms) + call checkangmoms_(atom % angmoms) call nextline_(fp, iline, line) read(line, *, iostat=iostat) buffer call checkerror_(fname, line, iline, iostat) - call readdata_(buffer, [ 1, 3, 4, 5 ], data) + call readdata_(buffer, [1, 3, 4, 5], data) allocate(potval(size(data, dim=1))) potval = 0.0_dp do ii = 1, size(potcomps) - potval = potval + data(:,potcomps(ii)) + potval = potval + data(:, potcomps(ii)) end do - call init(atom%pot, data(:,1), potval) - + call init(atom % pot, data(:, 1), potval) + call nextline_(fp, iline, line) read(line, *, iostat=iostat) buffer call checkerror_(fname, line, iline, iostat) if (density) then - call readdata_(buffer, [ 1, 3, 4, 5 ], data) - call init(atom%rho, data(:,1), data(:,2)) - call init(atom%drho, data(:,1), data(:,3)) - call init(atom%ddrho, data(:,1), data(:,4)) + call readdata_(buffer, [1, 3, 4, 5], data) + call init(atom % rho, data(:, 1), data(:, 2)) + call init(atom % drho, data(:, 1), data(:, 3)) + call init(atom % ddrho, data(:, 1), data(:, 4)) else if (trim(line) /= "noread") then - write(*,"(A,I0,A)") "Line ", iline, & + write(*, "(A,I0,A)") "Line ", iline, & &" ignored since density is not needed." end if end if end subroutine readatom_ - - + subroutine readdata_(fname, cols, data) character(*), intent(in) :: fname integer, intent(in) :: cols(:) - real(dp), allocatable, intent(out) :: data(:,:) + real(dp), allocatable, intent(out) :: data(:, :) real(dp), allocatable :: tmp(:) character(maxlen) :: line @@ -172,7 +167,7 @@ subroutine readdata_(fname, cols, data) fp = 12 allocate(tmp(maxval(cols))) iline = 1 - open(fp, file=fname, action="read", form="formatted") + open (fp, file=fname, action="read", form="formatted") call nextline_(fp, iline, line) read(line, *, iostat=iostat) ngrid call checkerror_(fname, line, iline, iostat) @@ -181,14 +176,12 @@ subroutine readdata_(fname, cols, data) call nextline_(fp, iline, line) read(line, *, iostat=iostat) tmp(:) call checkerror_(fname, line, iline, iostat) - data(ii,:) = tmp(cols) + data(ii, :) = tmp(cols) end do - close(fp) + close (fp) deallocate(tmp) - - end subroutine readdata_ - + end subroutine readdata_ subroutine nextline_(fp, iline, line) integer, intent(in) :: fp @@ -205,7 +198,7 @@ subroutine nextline_(fp, iline, line) if (ii == 0) then line = adjustl(buffer) else - line = adjustl(buffer(1:ii-1)) + line = adjustl(buffer(1:ii - 1)) end if if (len_trim(line) > 0) then exit @@ -214,13 +207,9 @@ subroutine nextline_(fp, iline, line) end subroutine nextline_ - - subroutine checkangmoms_(angmoms) integer, intent(in) :: angmoms(:) - integer :: ii - if (maxval(angmoms) > 4) then write(*,*) "Only angular momentum up to 'f' is allowed." stop @@ -228,7 +217,6 @@ subroutine checkangmoms_(angmoms) end subroutine checkangmoms_ - subroutine checkerror_(fname, line, iline, iostat) character(*), intent(in) :: fname, line integer, intent(in) :: iline, iostat @@ -236,21 +224,18 @@ subroutine checkerror_(fname, line, iline, iostat) if (iostat /= 0) then call error_("Bad syntax", fname, line, iline) end if - - end subroutine checkerror_ + end subroutine checkerror_ subroutine error_(txt, fname, line, iline) character(*), intent(in) :: txt, fname, line integer, intent(in) :: iline - write(*,"(A,A)") "!!! Parsing error: ", txt - write(*,"(2X,A,A)") "File: ", trim(fname) - write(*,"(2X,A,I0)") "Line number: ", iline - write(*,"(2X,A,A,A)") "Line: '", trim(line), "'" + write(*, "(A,A)") "!!! Parsing error: ", txt + write(*, "(2X,A,A)") "File: ", trim(fname) + write(*, "(2X,A,I0)") "Line number: ", iline + write(*, "(2X,A,A,A)") "Line: '", trim(line), "'" stop end subroutine error_ - - - + end module input diff --git a/sktwocnt/prog/main.f90 b/sktwocnt/prog/main.f90 index 3f1b3c64..a3f05c3d 100644 --- a/sktwocnt/prog/main.f90 +++ b/sktwocnt/prog/main.f90 @@ -1,6 +1,6 @@ program main - use common_accuracy, only : dp + use common_accuracy, only: dp use input use twocnt use output @@ -9,14 +9,13 @@ program main type(twocnt_in) :: inp type(integmap) :: imap - real(dp), allocatable :: skham(:,:), skover(:,:) + real(dp), allocatable :: skham(:, :), skover(:, :) - call parse_command_arguments() call readinput(inp, "sktwocnt.in") write(*, "(A)") "Input done." call get_twocenter_integrals(inp, imap, skham, skover) write(*, "(A)") "Twocnt done." call write_sktables(skham, skover) - + end program main diff --git a/sktwocnt/prog/output.f90 b/sktwocnt/prog/output.f90 index 59ae7d24..184c1540 100644 --- a/sktwocnt/prog/output.f90 +++ b/sktwocnt/prog/output.f90 @@ -1,7 +1,7 @@ !> Output routines for the sktwocnt code. module output - use common_accuracy, only : dp + use common_accuracy, only: dp implicit none private @@ -11,25 +11,23 @@ module output ! Maximal angular momentum in the old and the extended old SK file. integer, parameter :: LMAX_OLD = 2 integer, parameter :: LMAX_EXTENDED = 3 - contains subroutine write_sktables(skham, skover) - real(dp), intent(in) :: skham(:,:), skover(:,:) + real(dp), intent(in) :: skham(:, :), skover(:, :) call write_sktable_("at1-at2.ham.dat", skham) call write_sktable_("at1-at2.over.dat", skover) end subroutine write_sktables - !> Helper routine writing the SK files. !! \param fname File name. !! \param sktable Slater-Koster type integrals (Hamiltonian or overlap). subroutine write_sktable_(fname, sktable) character(*), intent(in) :: fname - real(dp), intent(in) :: sktable(:,:) + real(dp), intent(in) :: sktable(:, :) integer :: fp, ninteg, nline character(11) :: formstr @@ -39,12 +37,11 @@ subroutine write_sktable_(fname, sktable) nline = size(sktable, dim=2) write(formstr, "(A,I0,A)") "(", ninteg, "ES21.12)" fp = 14 - open(fp, file=fname, status="replace", action="write") + open (fp, file=fname, status="replace", action="write") write(fp, "(I0)") nline write(fp, formstr) sktable close(fp) - + end subroutine write_sktable_ - end module output From 53b01a928f79b1a756f68f427a76a2c927090e94 Mon Sep 17 00:00:00 2001 From: Tammo van der Heide Date: Thu, 30 Dec 2021 15:51:38 +0100 Subject: [PATCH 13/17] Establish consistent formatting of sktwocnt code and docu --- doc/input.txt | 4 +- sktwocnt/lib/CMakeLists.txt | 3 + sktwocnt/lib/bisection.f90 | 96 +++-- sktwocnt/lib/coordtrans.f90 | 225 ++++++---- sktwocnt/lib/dftbxc.f90 | 182 ++++++-- sktwocnt/lib/gridgenerator.f90 | 137 +++--- sktwocnt/lib/gridorbital.f90 | 348 +++++++++------ sktwocnt/lib/interpolation.f90 | 135 +++--- sktwocnt/lib/partition.f90 | 138 ++++-- sktwocnt/lib/quadrature.f90 | 133 +++--- sktwocnt/lib/sphericalharmonics.f90 | 167 +++++--- sktwocnt/lib/twocnt.f90 | 631 ++++++++++++++++++---------- sktwocnt/prog/cmdargs.f90 | 16 +- sktwocnt/prog/input.f90 | 355 ++++++++++------ sktwocnt/prog/main.f90 | 28 +- sktwocnt/prog/output.f90 | 2 +- 16 files changed, 1719 insertions(+), 881 deletions(-) diff --git a/doc/input.txt b/doc/input.txt index 5cce911c..fc85ae48 100644 --- a/doc/input.txt +++ b/doc/input.txt @@ -26,12 +26,12 @@ Line 3: Line 4: num_occ integer :: num_occ, number of occupied shells - + NOTE: This are in fact max_l+1 lines, one for each angular momentum Line 5: num_exp num_poly - integer :: num_exp, number of exponents + integer :: num_exp, number of exponents integer :: number of polynomial coefficients NOTE: This are in fact max_l+1 lines, one for each angular momentum diff --git a/sktwocnt/lib/CMakeLists.txt b/sktwocnt/lib/CMakeLists.txt index 2073ec6c..fd8112cb 100644 --- a/sktwocnt/lib/CMakeLists.txt +++ b/sktwocnt/lib/CMakeLists.txt @@ -14,6 +14,9 @@ add_library(skprogs-sktwocnt ${sources-f90}) target_link_libraries(skprogs-sktwocnt skprogs-common) +# for a potential libxc integration: +# target_link_libraries(skprogs-sktwocnt skprogs-common Libxc::xcf90 Libxc::xc) + set(moddir ${CMAKE_CURRENT_BINARY_DIR}/modfiles) set_target_properties(skprogs-sktwocnt PROPERTIES Fortran_MODULE_DIRECTORY ${moddir}) target_include_directories(skprogs-sktwocnt PUBLIC diff --git a/sktwocnt/lib/bisection.f90 b/sktwocnt/lib/bisection.f90 index 3062cd8b..0a3a2a8e 100644 --- a/sktwocnt/lib/bisection.f90 +++ b/sktwocnt/lib/bisection.f90 @@ -1,36 +1,49 @@ -!> Contains routines to locate a value in an array using bisection. +!> Module that contains routines to locate a value in an array using bisection. module bisection - use common_accuracy, only: dp + use common_accuracy, only : dp implicit none private public :: bisect - !> Bisection driver. + !> Bisection driver that interfaces integer- and real-valued array routines. interface bisect module procedure bisect_real module procedure bisect_int end interface bisect + contains - !> Real case for bisection search to to find a point in an array xx(:) - !! between xx(1) and xx(size(xx)) such that element indexed ind is less than - !! the value x0 queried. - !! \param xx Array of values in monotonic order to search through. - !! \param x0 Value to locate ind for. - !! \param ind Located element such that xx(ind) < x < xx(ind). + !> Real case for bisection search to to find a point in an array xx(:) between xx(1) and + !! xx(size(xx)) such that element indexed ind is less than the value x0 queried. pure subroutine bisect_real(xx, x0, ind, tol) - real(dp), intent(in) :: xx(:), x0 + + !> array of values in monotonic order to search through + real(dp), intent(in) :: xx(:) + + !> value to locate ind for + real(dp), intent(in) :: x0 + + !> located element such that xx(ind) < x0 < xx(ind) integer, intent(out) :: ind + + !> optional, user-specified tolerance for comparisons real(dp), intent(in), optional :: tol + !> length of array to search integer :: nn - integer :: ilower, iupper, icurr - real(dp) :: rTol ! real tolerance - logical :: ascending + + !> lower, upper and current value index + integer :: iLower, iUpper, iCurr + + !> actual tolerance selected + real(dp) :: rTol + + !> true, if xx(:) is in ascending ordering + logical :: tAscending nn = size(xx) if (nn == 0) then @@ -53,34 +66,41 @@ pure subroutine bisect_real(xx, x0, ind, tol) else if (x0 > xx(nn) + rTol) then ind = nn else - ascending = (xx(nn) >= xx(1)) - ilower = 0 - icurr = nn + 1 - do while ((icurr - ilower) > 1) - iupper = (icurr + ilower) / 2 - if (ascending .eqv. (x0 >= xx(iupper) + rTol)) then - ilower = iupper + tAscending = (xx(nn) >= xx(1)) + iLower = 0 + iCurr = nn + 1 + do while ((iCurr - iLower) > 1) + iUpper = (iCurr + iLower) / 2 + if (tAscending .eqv. (x0 >= xx(iUpper) + rTol)) then + iLower = iUpper else - icurr = iupper + iCurr = iUpper end if end do - ind = ilower + ind = iLower end if end subroutine bisect_real - !> Integer case for bisection search to to find a point in an array xx(:) - !! between xx(1) and xx(size(xx)) such that element indexed ind is less than - !! the value x0 queried - !! \param xx Array of values in monotonic order to search through. - !! \param x0 Value to locate ind for. - !! \param ind Located element such that xx(ind) < x < xx(ind). + + !> Integer case for bisection search to to find a point in an array xx(:) between xx(1) and + !! xx(size(xx)) such that element indexed ind is less than the value x0 queried. pure subroutine bisect_int(xx, x0, ind) - integer, intent(in) :: xx(:), x0 + + !> array of values in monotonic order to search through + integer, intent(in) :: xx(:) + + !> value to locate ind for + integer, intent(in) :: x0 + + !> located element such that xx(ind) < x0 < xx(ind) integer, intent(out) :: ind + !> length of array to search integer :: nn - integer :: ilower, iupper, icurr + + !> lower, upper and current value index + integer :: iLower, iUpper, iCurr nn = size(xx) if (nn == 0) then @@ -97,17 +117,17 @@ pure subroutine bisect_int(xx, x0, ind) else if (x0 > xx(nn)) then ind = nn else - ilower = 0 - icurr = nn + 1 - do while ((icurr - ilower) > 1) - iupper = (icurr + ilower) / 2 - if ((xx(nn) >= xx(1)) .eqv. (x0 >= xx(iupper))) then - ilower = iupper + iLower = 0 + iCurr = nn + 1 + do while ((iCurr - iLower) > 1) + iUpper = (iCurr + iLower) / 2 + if ((xx(nn) >= xx(1)) .eqv. (x0 >= xx(iUpper))) then + iLower = iUpper else - icurr = iupper + iCurr = iUpper end if end do - ind = ilower + ind = iLower end if end subroutine bisect_int diff --git a/sktwocnt/lib/coordtrans.f90 b/sktwocnt/lib/coordtrans.f90 index c99394b3..85ad0398 100644 --- a/sktwocnt/lib/coordtrans.f90 +++ b/sktwocnt/lib/coordtrans.f90 @@ -1,54 +1,99 @@ +!> Module that provides several routines related to coordinate transformation. module coordtrans - use common_accuracy, only: dp - use common_constants + use common_accuracy, only : dp + use common_constants, only : pi implicit none + private + + public :: coordtransFunc, coordtrans_becke, coordtrans_becke_12, coordtrans_becke_23,& + & coordtrans_ahlrichs1, coordtrans_ahlrichs1_2d, coordtrans_ahlrichs2,& + & coordtrans_ahlrichs2_2d, coordtrans_identity + + + abstract interface + + !> General interface for (Bekce's) coordinate transformations. + pure subroutine coordtransFunc(oldc, newc, jacobi) + + use common_accuracy, only : dp + + implicit none + + !> old coordinate vector + real(dp), intent(in) :: oldc(:) + + !> new coordinate vector after transformation + real(dp), intent(out) :: newc(:) + + !> Jacobi determinant + real(dp), intent(out) :: jacobi + + end subroutine coordtransFunc + + end interface + contains - !> Transforms a 3 dimensional vector with coordinates in [-1,1] onto spherical - !! coordinates, using the Becke algorithm. - !! \param crd11 3d coordinate vector, each coordinate in [-1,1]. - !! \param spheric Corresponding spherical coordinates. - !! \param jacobi Jacobi determinant. - !! \sa Becke paper. - subroutine coordtrans_becke(c11, spheric, jacobi) + !> Transforms a 3 dimensional vector with coordinates in [-1,1] onto spherical coordinates, using + !! the Becke algorithm, see A. D. Becke, J. Chem. Phys. 88, 2547 (1988) + !! or J. Chem. Phys. 100, 6520 (1994). + pure subroutine coordtrans_becke(c11, spheric, jacobi) + + !> 3d coordinate vector, each coordinate in interval [-1,1] real(dp), intent(in) :: c11(:) + + !> corresponding spherical coordinates real(dp), intent(out) :: spheric(:) + + !> Jacobi determinant real(dp), intent(out) :: jacobi - real(dp), parameter :: rm = 1.5_dp; + !> midpoint of the integration interval, + !! allows adjustment of the radial point distribution to a suitable physical scale + real(dp), parameter :: rm = 1.5_dp + + !> recurring factors real(dp) :: rtmp1, rtmp2 - !assert(size(c11) == 3) - !assert(size(spheric) == 3) + ! assert(size(c11) == 3) + ! assert(size(spheric) == 3) rtmp1 = 1.0_dp + c11(1) rtmp2 = 1.0_dp - c11(1) spheric(1) = rm * (rtmp1 / rtmp2) spheric(2) = acos(c11(2)) spheric(3) = pi * (c11(3) + 1.0_dp) - jacobi = 2.0_dp * rm**3 * rtmp1**2 / rtmp2**4 * pi + jacobi = 2.0_dp * pi * rm**3 * rtmp1**2 / rtmp2**4 end subroutine coordtrans_becke - !> Transforms a 2 dimensional vector with coordinates in [-1,1] onto spherical - !! coordinates (r, theta), using the Becke algorithm. - !! \param crd11 2d coordinate vector, each coordinate in [-1,1]. - !! \param spheric Corresponding spherical coordinates (r, theta) - !! \param jacobi Jacobi determinant. - !! \sa Becke paper. - subroutine coordtrans_becke_12(c11, spheric, jacobi) + + !> Transforms a 2 dimensional vector with coordinates in [-1,1] onto spherical coordinates + !! (r, theta), using the Becke algorithm, see A. D. Becke, J. Chem. Phys. 88, 2547 (1988) + !! or J. Chem. Phys. 100, 6520 (1994). + pure subroutine coordtrans_becke_12(c11, spheric, jacobi) + + !> 2d coordinate vector, each coordinate in interval [-1,1] real(dp), intent(in) :: c11(:) + + !> corresponding spherical coordinates (r, theta) real(dp), intent(out) :: spheric(:) + + !> Jacobi determinant real(dp), intent(out) :: jacobi - real(dp), parameter :: rm = 1.5_dp; + !> midpoint of the integration interval, + !! allows adjustment of the radial point distribution to a suitable physical scale + real(dp), parameter :: rm = 1.5_dp + + !> recurring factors real(dp) :: rtmp1, rtmp2 - !assert(size(c11) == 2) - !assert(size(spheric) == 2) + ! assert(size(c11) == 2) + ! assert(size(spheric) == 2) rtmp1 = 1.0_dp + c11(1) rtmp2 = 1.0_dp - c11(1) @@ -58,19 +103,23 @@ subroutine coordtrans_becke_12(c11, spheric, jacobi) end subroutine coordtrans_becke_12 - !> Transforms a 2 dimensional vector with coordinates in [-1,1] onto spherical - !! coordinates (theta, phi), using the Becke algorithm. - !! \param crd11 2d coordinate vector, each coordinate in [-1,1]. - !! \param spheric Corresponding spherical coordinates (theta, phi). - !! \param jacobi Jacobi determinant. - !! \sa Becke paper. - subroutine coordtrans_becke_23(c11, spheric, jacobi) + + !> Transforms a 2 dimensional vector with coordinates in [-1,1] onto spherical coordinates + !! (theta, phi), using the Becke algorithm, see A. D. Becke, J. Chem. Phys. 88, 2547 (1988) + !! or J. Chem. Phys. 100, 6520 (1994). + pure subroutine coordtrans_becke_23(c11, spheric, jacobi) + + !> 2d coordinate vector, each coordinate in interval [-1,1] real(dp), intent(in) :: c11(:) + + !> corresponding spherical coordinates (theta, phi) real(dp), intent(out) :: spheric(:) + + !> Jacobi determinant real(dp), intent(out) :: jacobi - !assert(size(c11) == 2) - !assert(size(spheric) == 2) + ! assert(size(c11) == 2) + ! assert(size(spheric) == 2) spheric(1) = acos(c11(1)) spheric(2) = pi * (c11(2) + 1.0_dp) @@ -78,22 +127,25 @@ subroutine coordtrans_becke_23(c11, spheric, jacobi) end subroutine coordtrans_becke_23 - !> Transforms a 3 dimensional vector with coordinates in [-1,1] onto spherical - !! coordinates, using the Ahlrichs algorithm. - !! \param c11 3d coordinate vector, each coordinate in [-1,1]. - !! \param spheric Corresponding spherical coordinates. - !! \param jacobi Jacobi determinant. - !! \sa Ahlrichs paper. - subroutine coordtrans_ahlrichs1(c11, spheric, jacobi) + + !> Transforms a 3 dimensional vector with coordinates in [-1,1] onto spherical coordinates, using + !! the Ahlrichs algorithm (cf. Ahlrichs paper). + pure subroutine coordtrans_ahlrichs1(c11, spheric, jacobi) + + !> 3d coordinate vector, each coordinate in interval [-1,1] real(dp), intent(in) :: c11(:) + + !> corresponding spherical coordinates real(dp), intent(out) :: spheric(:) + + !> Jacobi determinant real(dp), intent(out) :: jacobi real(dp), parameter :: zeta = 1.20_dp real(dp) :: rr - !assert(size(c11) == 3) - !assert(size(spheric) == 3) + ! assert(size(c11) == 3) + ! assert(size(spheric) == 3) rr = (zeta / log(2.0_dp)) * log(2.0_dp / (1.0_dp - c11(1))) spheric(1) = rr @@ -103,40 +155,46 @@ subroutine coordtrans_ahlrichs1(c11, spheric, jacobi) end subroutine coordtrans_ahlrichs1 - !> Transforms a 3 dimensional vector with coordinates in [-1,1] onto spherical - !! coordinates, using the Ahlrichs algorithm. - !! \param c11 3d coordinate vector, each coordinate in [-1,1]. - !! \param spheric Corresponding spherical coordinates. - !! \param jacobi Jacobi determinant. - !! \sa Ahlrichs paper. - subroutine coordtrans_ahlrichs1_2d(c11, spheric, jacobi) + + !> Transforms a 3 dimensional vector with coordinates in [-1,1] onto spherical coordinates, using + !! the Ahlrichs algorithm (cf. Ahlrichs paper). + pure subroutine coordtrans_ahlrichs1_2d(c11, spheric, jacobi) + + !> 3d coordinate vector, each coordinate in interval [-1,1] real(dp), intent(in) :: c11(:) + + !> corresponding spherical coordinates real(dp), intent(out) :: spheric(:) + + !> Jacobi determinant real(dp), intent(out) :: jacobi real(dp), parameter :: zeta = 1.20_dp real(dp) :: rr - !assert(size(c11) == 3) - !assert(size(spheric) == 3) + ! assert(size(c11) == 3) + ! assert(size(spheric) == 3) rr = (zeta / log(2.0_dp)) * log(2.0_dp / (1.0_dp - c11(1))) spheric(1) = rr spheric(2) = acos(c11(2)) - !spheric(3) = pi * (c11(3) + 1.0_dp) + ! spheric(3) = pi * (c11(3) + 1.0_dp) jacobi = (zeta / log(2.0_dp)) / (1.0_dp - c11(1)) * rr * rr end subroutine coordtrans_ahlrichs1_2d - !> Transforms a 3 dimensional vector with coordinates in [-1,1] onto spherical - !! coordinates, using the Ahlrichs algorithm. - !! \param c11 3d coordinate vector, each coordinate in [-1,1]. - !! \param spheric Corresponding spherical coordinates. - !! \param jacobi Jacobi determinant. - !! \sa Ahlrichs paper. - subroutine coordtrans_ahlrichs2(c11, spheric, jacobi) + + !> Transforms a 3 dimensional vector with coordinates in [-1,1] onto spherical coordinates, using + !! the Ahlrichs algorithm (cf. Ahlrichs paper). + pure subroutine coordtrans_ahlrichs2(c11, spheric, jacobi) + + !> 3d coordinate vector, each coordinate in interval [-1,1] real(dp), intent(in) :: c11(:) + + !> corresponding spherical coordinates real(dp), intent(out) :: spheric(:) + + !> Jacobi determinant real(dp), intent(out) :: jacobi real(dp), parameter :: zeta = 1.1_dp @@ -146,54 +204,63 @@ subroutine coordtrans_ahlrichs2(c11, spheric, jacobi) !assert(size(c11) == 3) !assert(size(spheric) == 3) - rr = (zeta / log(2.0_dp)) * (1.0_dp + c11(1))**alpha & - &* log(2.0_dp / (1.0_dp - c11(1))) + rr = (zeta / log(2.0_dp)) * (1.0_dp + c11(1))**alpha * log(2.0_dp / (1.0_dp - c11(1))) spheric(1) = rr spheric(2) = acos(c11(2)) spheric(3) = pi * (c11(3) + 1.0_dp) - jacobi = (zeta * (1.0_dp + c11(1))**alpha / log(2.0_dp)) & - &* (alpha * log(2.0_dp / (1.0_dp - c11(1))) / (1.0_dp + c11(1)) & - &+ 1.0_dp / (1.0_dp - c11(1))) * rr * rr * pi + jacobi = (zeta * (1.0_dp + c11(1))**alpha / log(2.0_dp)) * (alpha& + & * log(2.0_dp / (1.0_dp - c11(1))) / (1.0_dp + c11(1)) + 1.0_dp / (1.0_dp - c11(1)))& + & * rr * rr * pi end subroutine coordtrans_ahlrichs2 - !> Transforms a 3 dimensional vector with coordinates in [-1,1] onto spherical - !! coordinates, using the Ahlrichs algorithm. - !! \param c11 3d coordinate vector, each coordinate in [-1,1]. - !! \param spheric Corresponding spherical coordinates. - !! \param jacobi Jacobi determinant. - !! \sa Ahlrichs paper. - subroutine coordtrans_ahlrichs2_2d(c11, spheric, jacobi) + + !> Transforms a 3 dimensional vector with coordinates in [-1,1] onto spherical coordinates, using + !! the Ahlrichs algorithm (cf. Ahlrichs paper). + pure subroutine coordtrans_ahlrichs2_2d(c11, spheric, jacobi) + + !> 3d coordinate vector, each coordinate in interval [-1,1] real(dp), intent(in) :: c11(:) + + !> corresponding spherical coordinates real(dp), intent(out) :: spheric(:) + + !> Jacobi determinant real(dp), intent(out) :: jacobi real(dp), parameter :: zeta = 1.1_dp real(dp), parameter :: alpha = 0.6_dp real(dp) :: rr - !assert(size(c11) == 3) - !assert(size(spheric) == 3) + ! assert(size(c11) == 3) + ! assert(size(spheric) == 3) - rr = (zeta / log(2.0_dp)) * (1.0_dp + c11(1))**alpha & - &* log(2.0_dp / (1.0_dp - c11(1))) + rr = (zeta / log(2.0_dp)) * (1.0_dp + c11(1))**alpha * log(2.0_dp / (1.0_dp - c11(1))) spheric(1) = rr spheric(2) = acos(c11(2)) spheric(3) = pi * (c11(3) + 1.0_dp) - jacobi = (zeta * (1.0_dp + c11(1))**alpha / log(2.0_dp)) & - &* (alpha * log(2.0_dp / (1.0_dp - c11(1))) / (1.0_dp + c11(1)) & - &+ 1.0_dp / (1.0_dp - c11(1))) * rr * rr + jacobi = (zeta * (1.0_dp + c11(1))**alpha / log(2.0_dp))& + & * (alpha * log(2.0_dp / (1.0_dp - c11(1))) / (1.0_dp + c11(1))& + & + 1.0_dp / (1.0_dp - c11(1))) * rr * rr end subroutine coordtrans_ahlrichs2_2d - subroutine coordtrans_identity(c11, ctarget, jacobi) + + !> Identity coordinate transformation. + pure subroutine coordtrans_identity(c11, ctarget, jacobi) + + !> coordinate vector real(dp), intent(in) :: c11(:) + + !> target vector real(dp), intent(out) :: ctarget(:) + + !> Jacobi determinant real(dp), intent(out) :: jacobi - ctarget = c11 + ctarget(:) = c11 jacobi = 1.0_dp end subroutine coordtrans_identity diff --git a/sktwocnt/lib/dftbxc.f90 b/sktwocnt/lib/dftbxc.f90 index 87fd02bc..e6fa1816 100644 --- a/sktwocnt/lib/dftbxc.f90 +++ b/sktwocnt/lib/dftbxc.f90 @@ -1,82 +1,173 @@ +!> Module that provides exchange-correlation DFT routines. module dftxc use, intrinsic :: ieee_arithmetic - use common_accuracy, only: dp - use common_constants + use common_accuracy, only : dp + use common_constants, only : pi + + !! vanderhe: proposed libxc integration + ! use, intrinsic :: iso_c_binding, only : c_size_t + ! use xc_f90_lib_m, only : xc_f90_func_t, xc_f90_func_info_t, xc_f90_func_init,& + ! & xc_f90_func_get_info, xc_f90_lda_vxc, xc_f90_gga_vxc, xc_f90_func_end, XC_LDA_X,& + ! & XC_LDA_C_PW, XC_GGA_X_PBE, XC_GGA_C_PBE, XC_UNPOLARIZED implicit none private public :: getxcpot_ldapw91, getxcpot_ggapbe + !> pre-factor for re-normalization real(dp), parameter :: rec4pi = 1.0_dp / (4.0_dp * pi) + contains + !> Calculates xc-potential based on the LDA-PW91 functional. subroutine getxcpot_ldapw91(rho4pi, xcpot) + + !> density times 4pi on grid real(dp), intent(in) :: rho4pi(:) + + !> resulting xc-potential real(dp), intent(out) :: xcpot(:) - integer :: nn, ii - real(dp), allocatable :: rho(:), rs(:) - real(dp) :: vcup, vcdn, ec, vx, ex + !> density with libxc compatible normalization + real(dp), allocatable :: rho(:) + + !> local Seitz radius, needed for functional evaluation + real(dp), allocatable :: rs(:) + + !> exchange and correlation (up, down) potential of a single grid point + real(dp) :: vx, vcup, vcdn + + !> exchange and correlation energy of a single grid point + real(dp) :: ex, ec + + !> number of density grid points + integer :: nn + + !> auxiliary variable + integer :: ii nn = size(rho4pi) allocate(rs(nn), rho(nn)) - ! Renorm rho (incoming quantity is 4pi normed) + ! renorm rho (incoming quantity is 4pi normed) rho = rho4pi * rec4pi - ! Note: rho is normed to 4pi, therefore 4*pi missing in rs + ! note: rho is normed to 4pi, therefore 4*pi missing in rs rs = (3.0_dp / rho4pi)**(1.0_dp / 3.0_dp) do ii = 1, nn if (rho(ii) < epsilon(1.0_dp)) then xcpot(ii) = 0.0_dp else - call correlation_pbe(rs(ii), 0.0_dp, 0.0_dp, 0.0_dp, 0.0_dp, 0.0_dp, & - &0, ec, vcup, vcdn) + call correlation_pbe(rs(ii), 0.0_dp, 0.0_dp, 0.0_dp, 0.0_dp, 0.0_dp, 0, ec, vcup, vcdn) call exchange_pbe(rho(ii), 0.0_dp, 0.0_dp, 0.0_dp, 0, ex, vx) xcpot(ii) = vcup + vx end if end do - deallocate(rs, rho) + !! vanderhe: proposed libxc integration + !! --> but Hamiltonian matrix elements differ up to 1e-07 a.u. (something is wrong)!? + + ! !> libxc related objects + ! type(xc_f90_func_t) :: xcfunc_x, xcfunc_c + ! type(xc_f90_func_info_t) :: xcinfo + + ! !> density with libxc compatible normalization + ! real(dp), allocatable :: rho(:) + + ! !> exchange and correlation potential on grid + ! real(dp), allocatable :: vx(:), vc(:) + + ! !> number of density grid points + ! integer(c_size_t) :: nn + + ! call xc_f90_func_init(xcfunc_x, XC_LDA_X, XC_UNPOLARIZED) + ! xcinfo = xc_f90_func_get_info(xcfunc_x) + ! call xc_f90_func_init(xcfunc_c, XC_LDA_C_PW, XC_UNPOLARIZED) + ! xcinfo = xc_f90_func_get_info(xcfunc_x) + + ! nn = size(rho4pi) + ! allocate(vx(nn), vc(nn)) + + ! rho = rho4pi * rec4pi + + ! call xc_f90_lda_vxc(xcfunc_x, nn, rho, vx) + ! call xc_f90_lda_vxc(xcfunc_c, nn, rho, vc) + + ! xcpot(:) = vx + vc + + ! call xc_f90_func_end(xcfunc_x) + ! call xc_f90_func_end(xcfunc_c) end subroutine getxcpot_ldapw91 + + !> Calculates xc-potential based on the GGA-PBE functional. subroutine getxcpot_ggapbe(rho4pi, absgr4pi, laplace4pi, gr_grabsgr4pi, xcpot) + + !> density times 4pi on grid real(dp), intent(in) :: rho4pi(:) - real(dp), intent(in) :: absgr4pi(:), laplace4pi(:), gr_grabsgr4pi(:) + + !> absolute gradient of density times 4pi on grid + real(dp), intent(in) :: absgr4pi(:) + + !> laplace operator acting on density times 4pi on grid + real(dp), intent(in) :: laplace4pi(:) + + !> (grad rho4pi) * grad(abs(grad rho4pi)) + real(dp), intent(in) :: gr_grabsgr4pi(:) + + !> resulting xc-potential real(dp), intent(out) :: xcpot(:) - real(dp), allocatable :: rho(:), absgr(:), laplace(:), gr_grabsgr(:) + !> density with libxc compatible normalization + real(dp), allocatable :: rho(:) + + !> absolute gradient of density on grid + real(dp), allocatable :: absgr(:) + + !> laplace operator acting on density on grid + real(dp), allocatable :: laplace(:) + + !> (grad rho) * grad(abs(grad rho)) / rho**2 + !! actually calculated based on rho4pi, but 4pi cancels out + real(dp), allocatable :: gr_grabsgr(:) + + !> number of density grid points + integer :: nn + + !> auxiliary variables real(dp), allocatable :: rs(:), fac(:), tt(:), uu(:), vv(:) real(dp), allocatable :: ss(:), u2(:), v2(:) real(dp) :: alpha, zeta, gg, ww real(dp) :: ec, vcup, vcdn, ex, vx - integer :: nn, ii + integer :: ii nn = size(rho4pi) allocate(rho(nn), absgr(nn), laplace(nn), gr_grabsgr(nn)) allocate(rs(nn), fac(nn), tt(nn), uu(nn), vv(nn), ss(nn), u2(nn), v2(nn)) - ! Renorm rho and derivatives (incoming quantities are 4pi normed) + ! renorm rho and derivatives (incoming quantities are 4pi normed) rho = rho4pi * rec4pi absgr = absgr4pi / rho4pi laplace = laplace4pi / rho4pi gr_grabsgr = gr_grabsgr4pi / rho4pi**2 - ! Note: rho is normed to 4pi, therefore 4*pi missing in rs + ! note: rho is normed to 4pi, therefore 4*pi missing in rs rs = (3.0_dp / rho4pi)**(1.0_dp / 3.0_dp) zeta = 0.0_dp gg = 1.0_dp alpha = (4.0_dp / (9.0_dp * pi))**(1.0_dp / 3.0_dp) - ! Factors for the correlation routine + + ! factors for the correlation routine fac = sqrt(pi / 4.0_dp * alpha * rs) / (2.0_dp * gg) tt = absgr * fac uu = gr_grabsgr * fac**3 vv = laplace * fac**2 ww = 0.0_dp - ! Factors for the exchange routine + + ! factors for the exchange routine fac = alpha * rs / 2.0_dp ss = absgr * fac u2 = gr_grabsgr * fac**3 @@ -86,26 +177,64 @@ subroutine getxcpot_ggapbe(rho4pi, absgr4pi, laplace4pi, gr_grabsgr4pi, xcpot) if (rho(ii) < epsilon(1.0_dp)) then xcpot(ii) = 0.0_dp else - call correlation_pbe(rs(ii), 0.0_dp, tt(ii), uu(ii), vv(ii), ww, 1, & - &ec, vcup, vcdn) + call correlation_pbe(rs(ii), zeta, tt(ii), uu(ii), vv(ii), ww, 1, ec, vcup, vcdn) call exchange_pbe(rho(ii), ss(ii), u2(ii), v2(ii), 1, ex, vx) if (ieee_is_nan(vcup)) then - print*,"VCUP NAN", ii, rs(ii), tt(ii), uu(ii), vv(ii) - print*,":", absgr(ii), gr_grabsgr(ii), laplace(ii) + print *, "VCUP NAN", ii, rs(ii), tt(ii), uu(ii), vv(ii) + print *, ":", absgr(ii), gr_grabsgr(ii), laplace(ii) stop elseif (ieee_is_nan(vx)) then - print*,"VX NAN", ii + print *, "VX NAN", ii stop end if xcpot(ii) = vcup + vx end if end do - deallocate(rho, absgr, laplace, gr_grabsgr) - deallocate(rs, fac, tt, uu, vv) + !! vanderhe: proposed libxc integration + !! --> but Hamiltonian matrix elements differ up to 1e-02 a.u. (something is wrong)!? + + ! !> libxc related objects + ! type(xc_f90_func_t) :: xcfunc_x, xcfunc_c + ! type(xc_f90_func_info_t) :: xcinfo + + ! !> density with libxc compatible normalization + ! real(dp), allocatable :: rho(:) + + ! !> contracted gradients of the density + ! real(dp), allocatable :: sigma(:) + + ! !> exchange and correlation potential on grid + ! real(dp), allocatable :: vx(:), vc(:) + + ! !> first partial derivative of the energy per unit volume in terms of sigma + ! real(dp), allocatable :: vxsigma(:), vcsigma(:) + + ! !> number of density grid points + ! integer(c_size_t) :: nn + + ! nn = size(rho4pi) + ! allocate(vx(nn), vc(nn), vxsigma(nn), vcsigma(nn)) + + ! rho = rho4pi * rec4pi + ! sigma = (absgr4pi * rec4pi)**2 + + ! call xc_f90_func_init(xcfunc_x, XC_GGA_X_PBE, XC_UNPOLARIZED) + ! xcinfo = xc_f90_func_get_info(xcfunc_x) + ! call xc_f90_func_init(xcfunc_c, XC_GGA_C_PBE, XC_UNPOLARIZED) + ! xcinfo = xc_f90_func_get_info(xcfunc_x) + + ! call xc_f90_gga_vxc(xcfunc_x, nn, rho, sigma, vx, vxsigma) + ! call xc_f90_gga_vxc(xcfunc_c, nn, rho, sigma, vc, vcsigma) + + ! xcpot(:) = vx + vc + + ! call xc_f90_func_end(xcfunc_x) + ! call xc_f90_func_end(xcfunc_c) end subroutine getxcpot_ggapbe + SUBROUTINE CORRELATION_PBE(RS, ZET, T, UU, VV, WW, igga, ec, vc1, vc2) ! @@ -253,11 +382,11 @@ SUBROUTINE CORRELATION_PBE(RS, ZET, T, UU, VV, WW, igga, ec, vc1, vc2) DVCDN = COMM - PREF VC1 = VCUP + DVCUP VC2 = VCDN + DVCDN - ! print*,'c igga is',dvcup RETURN END subroutine CORRELATION_PBE + subroutine exchange_pbe(rho, s, u, t, igga, EX, VX) ! APART FROM COSMETICS THIS IS IN FACT BURKEs FORTRAN REFERENCE IMPLEMENTATION @@ -293,7 +422,7 @@ subroutine exchange_pbe(rho, s, u, t, igga, EX, VX) ! TOTAL: EX) AND POTENTIAL (VX) !---------------------------------------------------------------------- ! References: - ! [a]J.P.~Perdew, K.~Burke, and M.~Ernzerhof, submiited to PRL, May96 + ! [a]J.P.~Perdew, K.~Burke, and M.~Ernzerhof, submitted to PRL, May96 ! [b]J.P. Perdew and Y. Wang, Phys. Rev. B {\bf 33}, 8800 (1986); ! {\bf 40}, 3399 (1989) (E). !---------------------------------------------------------------------- @@ -338,7 +467,6 @@ subroutine exchange_pbe(rho, s, u, t, igga, EX, VX) ! energy done. calculate potential from [b](24) ! VX = exunif * (thrd4 * f - (u - thrd4 * s**3) * fss - t * fs) - ! print*,'e igga is',igga,vx,xunif*thrd4 RETURN END subroutine exchange_pbe diff --git a/sktwocnt/lib/gridgenerator.f90 b/sktwocnt/lib/gridgenerator.f90 index c2634700..1f5d36fb 100644 --- a/sktwocnt/lib/gridgenerator.f90 +++ b/sktwocnt/lib/gridgenerator.f90 @@ -1,102 +1,135 @@ +!> Module that provides routines for quadrature grid generation. module gridgenerator - use common_accuracy, only: dp - use quadratures + use common_accuracy, only : dp + use quadratures, only : TQuadrature + use coordtrans, only : coordtransFunc + use partition, only : partitionFunc implicit none + private + + public :: gengrid1_12, gengrid2_12 contains - subroutine gengrid1_12(quads, coordtrans, grid, weights) - type(quadrature), intent(in) :: quads(2) - interface - subroutine coordtrans(oldc, newc, jacobi) - use common_accuracy, only: dp - real(dp), intent(in) :: oldc(:) - real(dp), intent(out) :: newc(:) - real(dp), intent(out) :: jacobi - end subroutine coordtrans - end interface - real(dp), allocatable, intent(out) :: grid(:, :) - real(dp), allocatable, intent(out) :: weights(:) + !> ??? + pure subroutine gengrid1_12(quads, coordtrans, grid, weights) + + !> abscissas and weights for numerical quadrature + type(TQuadrature), intent(in) :: quads(2) + + !> coordinate transformation procedure + procedure(coordtransFunc) :: coordtrans + + !> two-dimensional atom grid, whereas r = grid(:, 1) and theta = grid(:, 2) + real(dp), intent(out), allocatable :: grid(:,:) + + !> + real(dp), intent(out), allocatable :: weights(:) + + !> atomic and total number of quadrature abscissas integer :: n1, n2, nn + + !> auxiliary variables integer :: ind, i1, i2 real(dp) :: coord(2), coordreal(2), jacobi - n1 = size(quads(1) % xx) - n2 = size(quads(2) % xx) + n1 = size(quads(1)%xx) + n2 = size(quads(2)%xx) + nn = n1 * n2 + allocate(grid(nn, 2)) allocate(weights(nn)) + ind = 1 do i2 = 1, n2 - coord(2) = quads(2) % xx(i2) + coord(2) = quads(2)%xx(i2) do i1 = 1, n1 - coord(1) = quads(1) % xx(i1) + coord(1) = quads(1)%xx(i1) call coordtrans(coord, coordreal, jacobi) grid(ind, 1) = coordreal(1) grid(ind, 2) = coordreal(2) - weights(ind) = quads(1) % ww(i1) * quads(2) % ww(i2) * jacobi + weights(ind) = quads(1)%ww(i1) * quads(2)%ww(i2) * jacobi ind = ind + 1 end do end do end subroutine gengrid1_12 - subroutine gengrid2_12(quads, coordtrans, partition, partparams, dist,& - & grid1, grid2, dots, weights) - type(quadrature), intent(in) :: quads(2) - interface - subroutine coordtrans(oldc, newc, jacobi) - use common_accuracy, only: dp - real(dp), intent(in) :: oldc(:) - real(dp), intent(out) :: newc(:) - real(dp), intent(out) :: jacobi - end subroutine coordtrans - function partition(r1, r2, dist, params) - use common_accuracy, only: dp - real(dp), intent(in) :: r1, r2, dist, params(:) - real(dp) :: partition - end function partition - end interface + + !> ??? + pure subroutine gengrid2_12(quads, coordtrans, partition, partparams, dist, grid1, grid2, dots,& + & weights) + + !> abscissas and weights for numerical quadrature + type(TQuadrature), intent(in) :: quads(2) + + !> coordinate transformation procedure + procedure(coordtransFunc) :: coordtrans + + !> partitioning procedure + procedure(partitionFunc) :: partition + + !> arbitrary dummy real array, unused in this routine real(dp), intent(in) :: partparams(:) + + !> distance between centers real(dp), intent(in) :: dist - real(dp), allocatable, intent(out) :: grid1(:, :), grid2(:, :) - real(dp), allocatable, intent(out) :: dots(:), weights(:) + !> two-dimensional atom grids, whereas r = grid(:, 1) and theta = grid(:, 2) + real(dp), intent(out), allocatable :: grid1(:,:), grid2(:,:) + + !> ??? + real(dp), intent(out), allocatable :: dots(:) + + !> integration weights + real(dp), intent(out), allocatable :: weights(:) + + !> atomic and total number of quadrature abscissas integer :: n1, n2, nn + + !> auxiliary variables integer :: ind, i1, i2 real(dp) :: coord(2), coordreal(2) real(dp) :: r1, theta1, r2a, r2b, theta2a, theta2b, rtmpa, rtmpb, jacobi - n1 = size(quads(1) % xx) - n2 = size(quads(2) % xx) + n1 = size(quads(1)%xx) + n2 = size(quads(2)%xx) + nn = n1 * n2 + allocate(grid1(2 * nn, 2)) allocate(grid2(2 * nn, 2)) allocate(dots(2 * nn)) allocate(weights(2 * nn)) + ind = 1 do i2 = 1, n2 - coord(2) = quads(2) % xx(i2) + coord(2) = quads(2)%xx(i2) do i1 = 1, n1 - coord(1) = quads(1) % xx(i1) + coord(1) = quads(1)%xx(i1) call coordtrans(coord, coordreal, jacobi) r1 = coordreal(1) theta1 = coordreal(2) - rtmpa = dist * dist + r1 * r1 + + rtmpa = dist**2 + r1**2 rtmpb = 2.0_dp * r1 * dist * cos(theta1) - r2a = sqrt(rtmpa - rtmpb) ! dist > 0 - r2b = sqrt(rtmpa + rtmpb) ! dist < 0 - rtmpa = -0.5_dp * (dist * dist + r2a * r2a - r1 * r1) / (dist * r2a) - rtmpb = 0.5_dp * (dist * dist + r2b * r2b - r1 * r1) / (dist * r2b) - !! Make sure, we are not sliding out from [-1,1] range for acos + r2a = sqrt(rtmpa - rtmpb) ! dist > 0 + r2b = sqrt(rtmpa + rtmpb) ! dist < 0 + + rtmpa = - 0.5_dp * (dist**2 + r2a**2 - r1**2) / (dist * r2a) + rtmpb = 0.5_dp * (dist**2 + r2b**2 - r1**2) / (dist * r2b) + + ! make sure, we are not sliding out from [-1,1] range for acos rtmpa = min(rtmpa, 1.0_dp) - rtmpa = max(rtmpa, -1.0_dp) + rtmpa = max(rtmpa, - 1.0_dp) rtmpb = min(rtmpb, 1.0_dp) - rtmpb = max(rtmpb, -1.0_dp) + rtmpb = max(rtmpb, - 1.0_dp) + theta2a = acos(rtmpa) theta2b = acos(rtmpb) @@ -104,16 +137,18 @@ end function partition grid1(ind, 2) = theta1 grid1(ind + nn, 1) = r2b grid1(ind + nn, 2) = theta2b + grid2(ind, 1) = r2a grid2(ind, 2) = theta2a grid2(ind + nn, 1) = r1 grid2(ind + nn, 2) = theta1 + dots(ind) = cos(theta1 - theta2a) dots(ind + nn) = cos(theta2b - theta1) - rtmpa = quads(1) % ww(i1) * quads(2) % ww(i2) * jacobi + rtmpa = quads(1)%ww(i1) * quads(2)%ww(i2) * jacobi weights(ind) = rtmpa * partition(r1, r2a, dist, partparams) - weights(ind + nn) = rtmpa * partition(r1, r2b, -dist, partparams) + weights(ind + nn) = rtmpa * partition(r1, r2b, - dist, partparams) ind = ind + 1 end do end do diff --git a/sktwocnt/lib/gridorbital.f90 b/sktwocnt/lib/gridorbital.f90 index d6505d22..777cee86 100644 --- a/sktwocnt/lib/gridorbital.f90 +++ b/sktwocnt/lib/gridorbital.f90 @@ -1,225 +1,297 @@ -!> Implements a grid-type orbital. +!> Module that implements a grid-type orbital. module gridorbital - use common_accuracy, only: dp - use common_constants - use bisection - use interpolation + use common_accuracy, only : dp + use common_constants, only : pi + use bisection, only : bisect + use interpolation, only : polyinter, poly5zero implicit none private - public :: gridorb, gridorb2, init, destruct, getvalue, rescale + public :: TGridorb1, TGridorb1_init, TGridorb2, TGridorb2_init + !> Contains the data of a grid function. - type gridorb - integer :: ngrid + type TGridorb1 + + !> number of grid points + integer :: nGrid + + !> r, f(r) values on grid real(dp), allocatable :: rvalues(:), fvalues(:) - end type gridorb - type gridorb2 - integer :: ngrid + contains + + procedure :: getValue => TGridorb1_getValue + procedure :: destruct => TGridorb1_destruct + + end type TGridorb1 + + + !> Contains the data of a grid function. + type TGridorb2 + + !> number of grid points + integer :: nGrid + + !> r, f(r) values on grid real(dp), allocatable :: rvalues(:), fvalues(:) - real(dp) :: delta, rcut - end type gridorb2 - type gridorb_wrap - type(gridorb), pointer :: ptr => null() - end type gridorb_wrap + !> Gauss-Chebyshev pre-factor + real(dp) :: delta + + !> cutoff radius at which the values f(r) shall vanish + real(dp) :: rcut + + contains + + procedure :: getValue => TGridorb2_getValue + procedure :: rescale => TGridorb2_rescale + procedure :: destruct => TGridorb2_destruct + + end type TGridorb2 - type gridorb2_wrap - type(gridorb2), pointer :: ptr => null() - end type gridorb2_wrap - interface init - module procedure gridorb_init - module procedure gridorb2_init - end interface + !> Wraps around TGridorb1 pointer. + type TGridorb1Wrap + type(TGridorb1), pointer :: ptr => null() + end type TGridorb1Wrap - interface destruct - module procedure gridorb_destruct - module procedure gridorb2_destruct - end interface - interface getvalue - module procedure gridorb_getvalue - module procedure gridorb2_getvalue - end interface + !> Wraps around TGridorb2 pointer. + type TGridorb2Wrap + type(TGridorb2), pointer :: ptr => null() + end type TGridorb2Wrap - interface rescale - module procedure gridorb2_rescale - end interface real(dp), parameter :: distfudge = 1.0_dp + real(dp), parameter :: deltar = 1e-04_dp + integer, parameter :: ninter = 8 integer, parameter :: nrightinter = 4 - real(dp), parameter :: deltar = 1e-4_dp integer, parameter :: npoint = 10000 - !real(dp), parameter :: tol = 1e-12_dp integer, parameter :: ninter2 = 4 integer, parameter :: nrightinter2 = 2 + contains - !> Initializes the grid orbital. - !! \param self initialised instance on exit. - !! \param values r,f(r) values for the grid - subroutine gridorb_init(self, rvals, fvals) - type(gridorb), intent(inout) :: self + !> Initializes a TGridorb1 grid-orbital. + subroutine TGridorb1_init(this, rvals, fvals) + + !> initialised grid-orbital instance on exit + type(TGridorb1), intent(out) :: this + + !> r, f(r) values on grid real(dp), intent(in) :: rvals(:), fvals(:) - !assert(size(values, dim=1) == 2) - !assert(size(values, dim=2) > 0) + ! assert(size(values, dim=1) == 2) + ! assert(size(values, dim=2) > 0) + + this%nGrid = size(rvals) + + this%rvalues = rvals + this%fvalues = fvals + + end subroutine TGridorb1_init - self % ngrid = size(rvals) - allocate(self % rvalues(self % ngrid)) - allocate(self % fvalues(self % ngrid)) - self % rvalues = rvals(:) - self % fvalues = fvals(:) - end subroutine gridorb_init + !> Destructs a TGridorb1 grid-orbital. + subroutine TGridorb1_destruct(this) - !> Destructs the instance. - !! \param self instance. - subroutine gridorb_destruct(self) - type(gridorb), intent(inout) :: self + !> initialised grid-orbital instance to destruct + class(TGridorb1), intent(inout) :: this - deallocate(self % rvalues) - deallocate(self % fvalues) + if (allocated(this%rvalues)) deallocate(this%rvalues) + if (allocated(this%fvalues)) deallocate(this%fvalues) - end subroutine gridorb_destruct + end subroutine TGridorb1_destruct - !> Delivers the value of the orbital - !! \param self instance. - !! \param rr radius at which to calculate the value. - !! \return rad radial part of the orbital at the given distance. - elemental function gridorb_getvalue(self, rr) result(rad) - type(gridorb), intent(in) :: self + + !> Delivers radial part of the orbital at the given distance. + elemental function TGridorb1_getValue(this, rr) result(rad) + + !> grid-orbital instance + class(TGridorb1), intent(in) :: this + + !> radius to calculate the value for real(dp), intent(in) :: rr + + !> radial part of the orbital at the given distance real(dp) :: rad - integer :: ind, istart, iend + !> auxiliary variables + integer :: ind, iStart, iEnd real(dp) :: rmax, f0, f1, f2, f1p, f1pp ! sanity check - !if (self%ngrid < ninter + 1) then - ! write(*,*) "not enough points in the orbital grid!" - ! stop - !end if - - ! Find position of the point - call bisect(self % rvalues, rr, ind, 1e-10_dp) - rmax = self % rvalues(self % ngrid) + distfudge + ! if (this%nGrid < ninter + 1) then + ! write(*,*) "Not enough points in the orbital grid!" + ! stop + ! end if + + ! find position of the point + call bisect(this%rvalues, rr, ind, 1e-10_dp) + rmax = this%rvalues(this%nGrid) + distfudge if (rr >= rmax) then ! outside of the region -> 0 rad = 0.0_dp - elseif (ind < self % ngrid) then + elseif (ind < this%nGrid) then ! before last gridpoint - iend = min(self % ngrid, ind + nrightinter) - iend = max(iend, ninter) - istart = iend - ninter + 1 - rad = polyinter(self % rvalues(istart:iend), self % fvalues(istart:iend), rr) + iEnd = min(this%nGrid, ind + nrightinter) + iEnd = max(iEnd, ninter) + iStart = iEnd - ninter + 1 + + rad = polyinter(this%rvalues(iStart:iEnd), this%fvalues(iStart:iEnd), rr) else - iend = self % ngrid - istart = iend - ninter + 1 + iEnd = this%nGrid + iStart = iEnd - ninter + 1 + ! calculate 1st und 2nd derivatives at the end - f1 = self % fvalues(iend) - f0 = polyinter(self % rvalues(istart:iend), self % fvalues(istart:iend), & - &self % rvalues(iend) - deltar) - f2 = polyinter(self % rvalues(istart:iend), self % fvalues(istart:iend), & - &self % rvalues(iend) + deltar) + f1 = this%fvalues(iEnd) + f0 = polyinter(this%rvalues(iStart:iEnd), this%fvalues(iStart:iEnd),& + & this%rvalues(iEnd) - deltar) + f2 = polyinter(this%rvalues(iStart:iEnd), this%fvalues(iStart:iEnd),& + & this%rvalues(iEnd) + deltar) + + ! 1st order central finite difference --> 1st derivative f1p = (f2 - f0) / (2.0_dp * deltar) + ! 2nd order central finite difference --> 2nd derivative f1pp = (f2 + f0 - 2.0_dp * f1) / deltar**2 - rad = poly5zero(f1, f1p, f1pp, rr - rmax, -1.0_dp * distfudge) + + rad = poly5zero(f1, f1p, f1pp, rr - rmax, - 1.0_dp * distfudge) end if - end function gridorb_getvalue + end function TGridorb1_getValue + + + !> Initializes a TGridorb2 grid-orbital. + subroutine TGridorb2_init(this, rvals, fvals) + + !> initialised grid-orbital instance on exit + type(TGridorb2), intent(out) :: this - !> Initializes the grid orbital. - !! \param self initialised instance on exit. - !! \param values r,f(r) values for the grid - subroutine gridorb2_init(self, rvals, fvals) - type(gridorb2), intent(inout) :: self + !> r, f(r) values on grid real(dp), intent(in) :: rvals(:), fvals(:) - type(gridorb) :: orb + !> grid-orbital instance + type(TGridorb1) :: orb + + !> Gauss-Chebyshev abscissas and inverse Becke radii real(dp) :: xx, rr + + !> auxiliary variable integer :: ii - !assert(size(values, dim=1) == 2) - !assert(size(values, dim=2) > 0) + ! assert(size(values, dim=1) == 2) + ! assert(size(values, dim=2) > 0) + + call TGridorb1_init(orb, rvals, fvals) - call init(orb, rvals, fvals) - self % ngrid = npoint - allocate(self % rvalues(self % ngrid)) - allocate(self % fvalues(self % ngrid)) - self % delta = pi / real(self % ngrid + 1, dp) - do ii = 1, self % ngrid - xx = cos(self % delta * real(ii, dp)) + this%nGrid = npoint + + allocate(this%rvalues(this%nGrid)) + allocate(this%fvalues(this%nGrid)) + + ! Gauss-Chebyshev pre-factor + this%delta = pi / real(this%nGrid + 1, dp) + + do ii = 1, this%nGrid + ! Gauss-Chebyshev abscissas + xx = cos(this%delta * real(ii, dp)) + + ! inverse Becke radius? rr = (1.0_dp - xx) / (1.0_dp + xx) - self % rvalues(ii) = rr - self % fvalues(ii) = getvalue(orb, rr) + this%rvalues(ii) = rr + this%fvalues(ii) = orb%getValue(rr) end do - self % rcut = self % rvalues(self % ngrid) + distfudge - call destruct(orb) - end subroutine gridorb2_init + ! cutoff radius at which the values f(r) shall vanish + this%rcut = this%rvalues(this%nGrid) + distfudge + + call orb%destruct() + + end subroutine TGridorb2_init + - !> Destructs the instance. - !! \param self instance. - subroutine gridorb2_destruct(self) - type(gridorb2), intent(inout) :: self + !> Destructs a TGridorb2 grid-orbital. + subroutine TGridorb2_destruct(this) - deallocate(self % fvalues) + !> initialised grid-orbital instance to destruct + class(TGridorb2), intent(inout) :: this - end subroutine gridorb2_destruct + if (allocated(this%fvalues)) deallocate(this%fvalues) - !> Delivers the value of the orbital - !! \param self instance. - !! \param rr radius at which to calculate the value. - !! \return rad radial part of the orbital at the given distance. - elemental function gridorb2_getvalue(self, rr) result(rad) - type(gridorb2), intent(in) :: self + end subroutine TGridorb2_destruct + + + !> Delivers radial part of the orbital at the given distance. + elemental function TGridorb2_getValue(this, rr) result(rad) + + !> grid-orbital instance + class(TGridorb2), intent(in) :: this + + !> radius to calculate the value for real(dp), intent(in) :: rr + + !> radial part of the orbital at the given distance real(dp) :: rad - integer :: ind, istart, iend + !> auxiliary variables + integer :: ind, iStart, iEnd real(dp) :: rmax, f0, f1, f2, f1p, f1pp real(dp) :: xx - if (rr > self % rcut) then + if (rr > this%rcut) then rad = 0.0_dp end if + + ! abscissa xx = (1.0_dp - rr) / (1.0_dp + rr) - ind = floor(acos(xx) / self % delta) - if (ind < self % ngrid) then - iend = min(self % ngrid, ind + nrightinter2) - iend = max(iend, ninter2) - istart = iend - ninter2 + 1 - rad = polyinter(self % rvalues(istart:iend), self % fvalues(istart:iend), rr) + + ! abscissa index + ind = floor(acos(xx) / this%delta) + + if (ind < this%nGrid) then + iEnd = min(this%nGrid, ind + nrightinter2) + iEnd = max(iEnd, ninter2) + iStart = iEnd - ninter2 + 1 + rad = polyinter(this%rvalues(iStart:iEnd), this%fvalues(iStart:iEnd), rr) else - iend = self % ngrid - istart = iend - ninter2 + 1 + iEnd = this%nGrid + iStart = iEnd - ninter2 + 1 + ! calculate 1st und 2nd derivatives at the end - f1 = self % fvalues(iend) - f0 = polyinter(self % rvalues(istart:iend), self % fvalues(istart:iend), & - &self % rvalues(iend) - deltar) - f2 = polyinter(self % rvalues(istart:iend), self % fvalues(istart:iend), & - &self % rvalues(iend) + deltar) + f1 = this%fvalues(iEnd) + f0 = polyinter(this%rvalues(iStart:iEnd), this%fvalues(iStart:iEnd),& + & this%rvalues(iEnd) - deltar) + f2 = polyinter(this%rvalues(iStart:iEnd), this%fvalues(iStart:iEnd),& + & this%rvalues(iEnd) + deltar) + + ! 1st order central finite difference --> 1st derivative f1p = (f2 - f0) / (2.0_dp * deltar) + ! 2nd order central finite difference --> 2nd derivative f1pp = (f2 + f0 - 2.0_dp * f1) / deltar**2 - rad = poly5zero(f1, f1p, f1pp, rr - rmax, -1.0_dp * distfudge) + + rad = poly5zero(f1, f1p, f1pp, rr - rmax, - 1.0_dp * distfudge) end if - end function gridorb2_getvalue + end function TGridorb2_getValue + + + !> Rescales stored values f(r) of a grid-orbital instance. + subroutine TGridorb2_rescale(this, fac) + + !> grid-orbital instance + class(TGridorb2), intent(inout) :: this - subroutine gridorb2_rescale(self, fac) - type(gridorb2), intent(inout) :: self + !> rescaling factor for f(r) values real(dp), intent(in) :: fac - self % fvalues = self % fvalues * fac + this%fvalues = this%fvalues * fac - end subroutine gridorb2_rescale + end subroutine TGridorb2_rescale end module gridorbital diff --git a/sktwocnt/lib/interpolation.f90 b/sktwocnt/lib/interpolation.f90 index d57ad4a7..7f021992 100644 --- a/sktwocnt/lib/interpolation.f90 +++ b/sktwocnt/lib/interpolation.f90 @@ -1,84 +1,116 @@ -!!* Contains routines for interpolation and extrapolation +!> Module that contains routines for inter- and extrapolation. module interpolation - use common_accuracy, only: dp + use common_accuracy, only : dp implicit none private public :: poly5zero, spline3_free, polyinter + contains - !! Returns the value of a polynomial of 5th degree at x. - !! \param y0 Value of the polynom at x = dx. - !! \param y0p Value of the 1st derivative at x = dx. - !! \param y0pp Value of the 2nd derivative at x = dx. - !! \param xx The point where the polynomial should be calculated - !! \param dx The point, where the polynomials value and first two derivatives - !! should take the provided values. - !! \return Value of the polynomial at xx. - !! \details The polynomial is created with the following boundary conditions: - !! Its value, its 1st and 2nd derivatives are zero at x = 0 and agree - !! with the provided values at x = dx. + !> Returns the value of a polynomial of 5th degree at x. + !! \details The polynomial is created with the following boundary conditions: + !! Its value, its 1st and 2nd derivatives are zero at x = 0 and agree with the provided values + !! at x = dx. pure function poly5zero(y0, y0p, y0pp, xx, dx) result(yy) + + !> value of the polynom at x = dx real(dp), intent(in) :: y0 + + !> value of the 1st derivative at x = dx real(dp), intent(in) :: y0p + + !> value of the 2nd derivative at x = dx real(dp), intent(in) :: y0pp + + !> point where the polynomial should be calculated real(dp), intent(in) :: xx + + !> point, where the polynomials value and first two derivatives should take the provided values real(dp), intent(in) :: dx + + !> value of the polynomial at xx real(dp) :: yy - real(dp) :: dx1, dx2, dd, ee, ff, xr + real(dp) :: dx1, dx2, cc, bb, aa, xr + + ! f(x) = ax^5 + bx^4 + cx^3 + dx^2 + ex + f + ! f(0) = 0, f'(0) = 0, f''(0) = 0 --> d = e = f = 0 dx1 = y0p * dx - dx2 = y0pp * dx * dx - dd = 10.0_dp * y0 - 4.0_dp * dx1 + 0.5_dp * dx2 - ee = -15.0_dp * y0 + 7.0_dp * dx1 - 1.0_dp * dx2 - ff = 6.0_dp * y0 - 3.0_dp * dx1 + 0.5_dp * dx2 + dx2 = y0pp * dx**2 + + ! c * (dx)**3 + cc = 10.0_dp * y0 - 4.0_dp * dx1 + 0.5_dp * dx2 + + ! b * (dx)**4 + bb = - 15.0_dp * y0 + 7.0_dp * dx1 - 1.0_dp * dx2 + + ! a * (dx)**5 + aa = 6.0_dp * y0 - 3.0_dp * dx1 + 0.5_dp * dx2 + xr = xx / dx - yy = ((ff * xr + ee) * xr + dd) * xr * xr * xr + yy = ((aa * xr + bb) * xr + cc) * xr**3 end function poly5zero + !! Returns the value of a free spline at a certain point. - !! \param y0 Function value at x = 0. - !! \param y0p First derivative at x = 0. - !! \param y0pp Second derivative at x = 0. - !! \param dx Second fitting point. - !! \param ydx Function value at dx. - !! \param xx Point to interpolate. - !! \return yy Value of the 3rd order polynomial at xx. - !! \param yp First derivative at xx. - !! \param ypp Second derivative at xx. !! \details The spline is created with the following boundary conditions: !! Its value, 1st and 2nd derivatives agree with the provided values at !! x = 0 and its value agrees with the provided value at x = dx. - !! \note If you want the value for a derivative, you have to query them - !! both. + !! \note If you want the value for a derivative, you have to query them both. pure subroutine spline3_free(y0, y0p, y0pp, dx, ydx, xx, yy, yp, ypp) + + !> function value at x = 0 real(dp), intent(in) :: y0 + + !> first derivative at x = 0 real(dp), intent(in) :: y0p + + !> second derivative at x = 0 real(dp), intent(in) :: y0pp + + !> function value at dx real(dp), intent(in) :: ydx + + !> second fitting point real(dp), intent(in) :: dx + + !> point to interpolate real(dp), intent(in) :: xx + + !> value of the 3rd order polynomial at xx real(dp), intent(out), optional :: yy + + !> first derivative at xx real(dp), intent(out), optional :: yp + + !> second derivative at xx real(dp), intent(out), optional :: ypp - real(dp) :: aa, bb, cc, dd, dx1 + !> spline coefficients + real(dp) :: aa, bb, cc, dd + + !> reciprocal second fitting point + real(dp) :: dx1 - !ASSERT(present(yp) .eqv. present(ypp)) + ! assert(present(yp) .eqv. present(ypp)) + + dx1 = 1.0_dp / dx aa = y0 bb = y0p cc = 0.5_dp * y0pp - dx1 = 1.0_dp / dx dd = (((ydx - y0) * dx1 - y0p) * dx1 - 0.5_dp * y0pp) * dx1 + if (present(yy)) then yy = ((dd * xx + cc) * xx + bb) * xx + aa end if + if (present(yp)) then yp = (3.0_dp * dd * xx + 2.0_dp * cc) * xx + bb ypp = 6.0_dp * dd * xx + 2.0_dp * cc @@ -86,31 +118,38 @@ pure subroutine spline3_free(y0, y0p, y0pp, dx, ydx, xx, yy, yp, ypp) end subroutine spline3_free - !! Polynomial interpolation through given points - !! \param xa x-coordinates of the fit points - !! \param ya y-coordinates of the fit points - !! \param xx The point, where the polynomial should be calculated - !! \return The value of the polynomial - !! \note The algorithm is based on the one in Numerical recipes. + + !> Polynomial interpolation through given points. + !! \note The algorithm is based on the Numerical recipes. pure function polyinter(xp, yp, xx) result(yy) + + !> x-coordinates of the fit points real(dp), intent(in) :: xp(:) + + !> y-coordinates of the fit points real(dp), intent(in) :: yp(:) + + !> point, where the polynomial should be evaluated real(dp), intent(in) :: xx + + !> value of the polynomial real(dp) :: yy + !> number of interpolation abscissas integer :: nn - integer :: icl, ii, mm + !> auxiliary variables + integer :: icl, ii, mm real(dp) :: cc(size(xp)), dd(size(xp)) real(dp) :: dx, dxnew, dyy, rtmp nn = size(xp) - !ASSERT(nn > 1) - !ASSERT(size(yp) == nn) + ! assert(nn > 1) + ! assert(size(yp) == nn) - cc(:) = yp(:) - dd(:) = yp(:) + cc(:) = yp + dd(:) = yp icl = 1 dx = abs(xx - xp(icl)) do ii = 2, nn @@ -125,10 +164,10 @@ pure function polyinter(xp, yp, xx) result(yy) do mm = 1, nn - 1 do ii = 1, nn - mm rtmp = xp(ii) - xp(ii + mm) - !if (abs(rtmp) < epsilon(1.0_dp)) then - !write(*,*) "Polint failed" - !stop - !end if + ! if (abs(rtmp) < epsilon(1.0_dp)) then + ! write(*,*) "Polint failed" + ! stop + ! end if rtmp = (cc(ii + 1) - dd(ii)) / rtmp cc(ii) = (xp(ii) - xx) * rtmp dd(ii) = (xp(ii + mm) - xx) * rtmp diff --git a/sktwocnt/lib/partition.f90 b/sktwocnt/lib/partition.f90 index d518e1aa..e846040c 100644 --- a/sktwocnt/lib/partition.f90 +++ b/sktwocnt/lib/partition.f90 @@ -1,74 +1,148 @@ -!> Conains space partioning functions. +!> Module that provides (Becke's) space partitioning functions. module partition - use common_accuracy, only: dp + use common_accuracy, only : dp implicit none private - public :: partition_becke, partition_becke_hetero, beckepar + public :: partitionFunc + public :: partition_becke_homo, partition_becke_hetero, beckepar + + + abstract interface + + !> General interface of (Becke's) partitioning functions. + pure function partitionFunc(r1, r2, dist, partparams) result(res) + + use common_accuracy, only : dp + + implicit none + + !> distance from 1st center + real(dp), intent(in) :: r1 + + !> distance from 2nd center + real(dp), intent(in) :: r2 + + !> distance between centers + real(dp), intent(in) :: dist + + !> holds partitioning parameters, if required + real(dp), intent(in) :: partparams(:) + + !> resulting value of the partition function, between [0,1] + real(dp) :: res + + end function partitionFunc + + end interface + contains - !> Becke partition function for 2 centers. - !! \param r1 Distance from 1st center. - !! \param r2 Distance from 2nd center. - !! \param dist Distance between centers. - !! \param partparams Arbitrary dummy real array. - !! \return Value of the partition function (between [0,1]) - !! \sa A. D. Becke, J. Chem. Phys. 88, 2547 (1988). - function partition_becke(r1, r2, dist, partparams) result(res) - real(dp), intent(in) :: r1, r2, dist, partparams(:) + !> Becke partition function for 2 homonuclear centers, Voronoi polyhedra bisect internuclear axes, + !! see A. D. Becke, J. Chem. Phys. 88, 2547 (1988). + pure function partition_becke_homo(r1, r2, dist, partparams) result(res) + + !> distance from 1st center + real(dp), intent(in) :: r1 + + !> distance from 2nd center + real(dp), intent(in) :: r2 + + !> distance between centers + real(dp), intent(in) :: dist + + !> arbitrary dummy real array, unused in this routine + real(dp), intent(in) :: partparams(:) + + !> resulting value of the partition function, between [0,1] real(dp) :: res + !> auxiliary variable integer :: ii + ! see A. D. Becke, J. Chem. Phys. 88, 2547 (1988), eqn. 11 res = (r1 - r2) / abs(dist) + + ! see A. D. Becke, J. Chem. Phys. 88, 2547 (1988), eqn. 19/20, choosing k=3 do ii = 1, 3 res = 1.5_dp * res - 0.5 * res**3 end do + + ! see A. D. Becke, J. Chem. Phys. 88, 2547 (1988), eqn. 21 res = 0.5_dp * (1.0_dp - res) - end function partition_becke - - !> Becke partition function for 2 heteronuclear centers. - !! \param r1 Distance from 1st center. - !! \param r2 Distance from 2nd center. - !! \param dist Distance between centers. - !! \param partparams Real array containing the parameter aij in the - !! Becke partitioning scheme. - !! \return Value of the partition function (between [0,1]) - !! \sa A. D. Becke, J. Chem. Phys. 88, 2547 (1988). - function partition_becke_hetero(r1, r2, dist, partparams) result(res) - real(dp), intent(in) :: r1, r2, dist, partparams(:) + end function partition_becke_homo + + + !> Becke partition function for 2 heteronuclear centers, cell boundaries shifted away from + !! internuclear midpoints, see A. D. Becke, J. Chem. Phys. 88, 2547 (1988). + pure function partition_becke_hetero(r1, r2, dist, partparams) result(res) + + !> distance from 1st center + real(dp), intent(in) :: r1 + + !> distance from 2nd center + real(dp), intent(in) :: r2 + + !> distance between centers + real(dp), intent(in) :: dist + + !> real array containing the parameter aij in the Becke partitioning scheme + real(dp), intent(in) :: partparams(:) + + !> resulting value of the partition function, between [0,1] real(dp) :: res - integer :: ii + !> see A. D. Becke, J. Chem. Phys. 88, 2547 (1988), eqn. 11 real(dp) :: mu + !> auxiliary variable + integer :: ii + + ! assert(abs(partparams(1)) <= 0.5_dp) + + ! see A. D. Becke, J. Chem. Phys. 88, 2547 (1988), eqn. 11 mu = (r1 - r2) / abs(dist) + + ! see A. D. Becke, J. Chem. Phys. 88, 2547 (1988), eqn. A2 res = mu + partparams(1) * (1.0_dp - mu**2) + + ! see A. D. Becke, J. Chem. Phys. 88, 2547 (1988), eqn. 19/20, choosing k=3 do ii = 1, 3 res = 1.5_dp * res - 0.5 * res**3 end do + + ! see A. D. Becke, J. Chem. Phys. 88, 2547 (1988), eqn. 21 res = 0.5_dp * (1.0_dp - res) end function partition_becke_hetero - !> Delivers parameter aij in the becke partition scheme for given atomic - !! radii. - !! \param r1 Radius of the first atom. - !! \param r2 Radius of the second atom. - !! \return Value of aij. - function beckepar(r1, r2) result(res) + + !> Delivers parameter aij in the becke partition scheme for given atomic radii, + !! see A. D. Becke, J. Chem. Phys. 88, 2547 (1988). + pure function beckepar(r1, r2) result(res) + + !> Bragg-Slater radius of first and second atom real(dp), intent(in) :: r1, r2 + + !> parameter a_{ij}, see A. D. Becke, J. Chem. Phys. 88, 2547 (1988), eqn. A5 real(dp) :: res - real(dp) :: chi, uu + !> see A. D. Becke, J. Chem. Phys. 88, 2547 (1988), eqn. A4 + real(dp) :: chi + + !> see A. D. Becke, J. Chem. Phys. 88, 2547 (1988), eqn. A6 + real(dp) :: uu chi = sqrt(r1 / r2) + uu = (chi - 1.0_dp) / (chi + 1.0_dp) + res = uu / (uu**2 - 1.0_dp) + if (abs(res) > 0.5_dp) then res = sign(0.5_dp, res) end if diff --git a/sktwocnt/lib/quadrature.f90 b/sktwocnt/lib/quadrature.f90 index 75618514..3cfb6df1 100644 --- a/sktwocnt/lib/quadrature.f90 +++ b/sktwocnt/lib/quadrature.f90 @@ -1,32 +1,56 @@ +!> Module that provides several quadrature related functionalities. module quadratures - use common_accuracy, only: dp - use common_constants + use common_accuracy, only : dp + use common_constants, only : pi implicit none + private - type quadrature + public :: TQuadrature + public :: gauss_legendre_quadrature, gauss_chebyshev_quadrature, trapezoidal_quadrature + + + !> Holds abscissas and weights for numerical quadrature. + type TQuadrature + + !> abscissas real(dp), allocatable :: xx(:) + + !> weights real(dp), allocatable :: ww(:) - end type quadrature + end type TQuadrature + + !> relative quadrature precision real(dp), parameter :: eps = 1e-14_dp + contains - !> Gauss-Legendre quadrature for integration in the interval [-1,1]. - !! \param nn Number of points for the quadrature - !! \param quad Quadrature with abscissas and weights. - !! \sa Numerical Recipes - subroutine gauss_legendre_quadrature(nn, quad) + !> Gauss-Legendre quadrature for integration in the interval [-1,1], + !! see Numerical Recipes or J. M. Pérez-Jordá et al., J. Chem. Phys. 100 6520 (1994). + pure subroutine gauss_legendre_quadrature(nn, quad) + + !> number of points for the quadrature integer, intent(in) :: nn - type(quadrature), intent(out) :: quad - integer :: mm, ii, jj - real(dp) :: zz, z1, pp, p1, p2, p3, rj + !> at exit, holds abscissas and weights for numerical quadrature + type(TQuadrature), intent(out) :: quad + + !> number of roots after symmetry is considered + integer :: mm + + !> initial approximations to the roots + real(dp) :: zz + + !> auxiliary variables + integer :: ii, jj + real(dp) :: z1, pp, p1, p2, p3, rj + + allocate(quad%xx(nn)) + allocate(quad%ww(nn)) - allocate(quad % xx(nn)) - allocate(quad % ww(nn)) mm = (nn + 1) / 2 do ii = 1, mm zz = cos(pi * (real(ii, dp) - 0.25_dp) / (real(nn, dp) + 0.5_dp)) @@ -42,67 +66,74 @@ subroutine gauss_legendre_quadrature(nn, quad) pp = real(nn, dp) * (zz * p1 - p2) / (zz * zz - 1.0_dp) z1 = zz zz = z1 - (p1 / pp) - if (abs(zz - z1) <= eps) then - exit - end if + if (abs(zz - z1) <= eps) exit end do - quad % xx(ii) = -zz - quad % xx(nn + 1 - ii) = zz - quad % ww(ii) = 2.0_dp / ((1.0_dp - zz * zz) * pp * pp) - quad % ww(nn + 1 - ii) = quad % ww(ii) + quad%xx(ii) = - zz + quad%xx(nn + 1 - ii) = zz + quad%ww(ii) = 2.0_dp / ((1.0_dp - zz**2) * pp**2) + quad%ww(nn + 1 - ii) = quad%ww(ii) end do end subroutine gauss_legendre_quadrature + !> Gauss-Chebishev quadrature for integration in the interval [-1,1]. !! - !! Integration of functions with Gauss-Chebishev quadrature of second kind. - !! The weights already contain 1/sqrt(1-x^2) so that it can be directly - !! used to integrate a function on [-1,1]. - !! See also: J. M. Pérez-Jordá et al., J. Chem. Phys. 100 6520 (1994). - !! - !! \param nn Number of points for the quadrature - !! \param quad Quadrature with abscissas and weights. - subroutine gauss_chebyshev_quadrature(nn, quad) + !! Integration of functions with Gauss-Chebishev quadrature of second kind. The weights already + !! contain 1/sqrt(1-x^2) so that it can be directly used to integrate a function on [-1,1], + !! see J. M. Pérez-Jordá et al., J. Chem. Phys. 100 6520 (1994). + pure subroutine gauss_chebyshev_quadrature(nn, quad) + + !> number of points for the quadrature integer, intent(in) :: nn - type(quadrature), intent(out) :: quad - integer :: ii + !> at exit, holds abscissas and weights for numerical quadrature + type(TQuadrature), intent(out) :: quad + + !> recurring argument of trigonometry functions real(dp) :: rtmp - allocate(quad % xx(nn)) - allocate(quad % ww(nn)) - !do ii = 1, nn - ! quad%xx(ii) = cos(pi * (real(ii, dp) - 0.5_dp) / real(nn, dp)) - !end do - !quad%ww = pi / real(nn, dp) + !> auxiliary variable + integer :: ii + + allocate(quad%xx(nn)) + allocate(quad%ww(nn)) + + ! see J. M. Pérez-Jordá et al., J. Chem. Phys. 100 6520 (1994), eqn. 28/29 do ii = 1, nn rtmp = real(ii, dp) * pi / real(nn + 1, dp) - quad % xx(ii) = cos(rtmp) - quad % ww(ii) = sin(rtmp) + quad%xx(ii) = cos(rtmp) + quad%ww(ii) = sin(rtmp) end do - quad % ww = quad % ww * pi / real(nn + 1, dp) + quad%ww(:) = quad%ww * pi / real(nn + 1, dp) end subroutine gauss_chebyshev_quadrature - !> Trapezoidal quadrature for integration in the interval [-1,1]. - !! \param nn Number of points for the quadrature - !! \param quad Quadrature with abscissas and weights. - !! \sa Numerical Recipes - subroutine trapezoidal_quadrature(nn, quad) + + !> Trapezoidal quadrature for integration in the interval [-1,1], + !! see Numerical Recipes. + pure subroutine trapezoidal_quadrature(nn, quad) + + !> number of points for the quadrature integer, intent(in) :: nn - type(quadrature), intent(out) :: quad - integer :: ii + !> at exit, holds abscissas and weights for numerical quadrature + type(TQuadrature), intent(out) :: quad + + !> discretization stepwidth of interval [-1,1] real(dp) :: fac - allocate(quad % xx(nn)) - allocate(quad % ww(nn)) + !> auxiliary variable + integer :: ii + + allocate(quad%xx(nn)) + allocate(quad%ww(nn)) + fac = 2.0_dp / real(nn, dp) do ii = 1, nn - quad % xx(ii) = -1.0_dp + fac * real(ii - 1, dp) + quad%xx(ii) = - 1.0_dp + fac * real(ii - 1, dp) end do - quad % ww = fac + quad%ww(:) = fac end subroutine trapezoidal_quadrature diff --git a/sktwocnt/lib/sphericalharmonics.f90 b/sktwocnt/lib/sphericalharmonics.f90 index 9776ce21..83710f00 100644 --- a/sktwocnt/lib/sphericalharmonics.f90 +++ b/sktwocnt/lib/sphericalharmonics.f90 @@ -1,99 +1,124 @@ -!> Spherical harmonics. +!> Module that provides the functionality for real tesseral spherical harmonics. module sphericalharmonics - use common_accuracy, only: dp + use common_accuracy, only : dp implicit none private - public :: realtess, init, destruct, getvalue, getvalue_1d + public :: TRealTessY, TRealTessY_init - !> Real tessereal shperical. - type realtess - private - integer :: ll, mm - end type realtess - interface init - module procedure realtess_init - end interface + !> Real tesseral spherical harmonics. + type TRealTessY - interface destruct - module procedure realtess_destruct - end interface + !> angular momentum + integer :: ll - interface getvalue - module procedure realtess_getvalue - end interface + !> magnetic quantum number + integer :: mm + + contains + + procedure :: getValue => TRealTessY_getValue + procedure :: getValue_1d => TRealTessY_getValue_1d + procedure :: destruct => TRealTessY_destruct + + end type TRealTessY - interface getvalue_1d - module procedure realtess_getvalue_1d - end interface contains - !> Initialises realtess. - !! \param self instance. - !! \param ll angulam momentum (l) - !! \param mm magnetic quantum number (m) - subroutine realtess_init(self, ll, mm) - type(realtess), intent(inout) :: self - integer, intent(in) :: ll, mm + !> Initialises a TRealTessY object. + subroutine TRealTessY_init(this, ll, mm) + + !> real tesseral spherical harmonics instance + type(TRealTessY), intent(out) :: this + + !> angular momentum (l) + integer, intent(in) :: ll + + !> magnetic quantum number (m) + integer, intent(in) :: mm + + this%ll = ll + this%mm = mm + + end subroutine TRealTessY_init - self % ll = ll - self % mm = mm - end subroutine realtess_init + !> Destroys an initialised instance. + subroutine TRealTessY_destruct(this) - !> Destroys the instance. - !! \param self instance. - subroutine realtess_destruct(self) - type(realtess), intent(inout) :: self + !> real tesseral spherical harmonics instance + class(TRealTessY), intent(inout) :: this continue - end subroutine realtess_destruct + end subroutine TRealTessY_destruct + + + !> Returns value of real tesseral spherical harmonic function. + elemental function TRealTessY_getValue(this, theta, phi) result(ang) + + !> real tesseral spherical harmonics instance + class(TRealTessY), intent(in) :: this + + !> spherical coordinate theta + real(dp), intent(in) :: theta + + !> spherical coordinate phi + real(dp), intent(in) :: phi - !> returns the value of the tessereal function. - !! \param self instance. - !! \param theta spherical coordinate theta. - !! \param phi spherical coordinate phi. - elemental function realtess_getvalue(self, theta, phi) result(ang) - type(realtess), intent(in) :: self - real(dp), intent(in) :: theta, phi + !> value of real tesseral spherical harmonic function real(dp) :: ang - ang = calc_realtess(self % ll, self % mm, theta, phi) + ang = calc_realtessy(this%ll, this%mm, theta, phi) - end function realtess_getvalue + end function TRealTessY_getValue - elemental function realtess_getvalue_1d(self, theta) result(ang) - type(realtess), intent(in) :: self + + !> Returns value of real tesseral spherical harmonic function. + elemental function TRealTessY_getValue_1d(this, theta) result(ang) + + !> real tesseral spherical harmonics instance + class(TRealTessY), intent(in) :: this + + !> spherical coordinate theta real(dp), intent(in) :: theta + + !> value of real tesseral spherical harmonic function real(dp) :: ang - ang = calc_realtess_1d(self % ll, self % mm, theta) + ang = calc_realtessy_1d(this%ll, this%mm, theta) + + end function TRealTessY_getValue_1d - end function realtess_getvalue_1d !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!! private functions !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !> Real tessereal spherical harmonics up to f. - !! \param ll angular momentum (l). - !! \param mm magnetic moment (m) - !! \param theta spherical coordinate theta. - !! \param phi spherical coordinate phi. - !! \return value of the real tesseral harmonics. - elemental function calc_realtess(ll, mm, theta, phi) result(rty) + !> Real tesseral spherical harmonics up to angular momentum f. + elemental function calc_realtessy(ll, mm, theta, phi) result(rty) + + !> angular momentum (l) integer, intent(in) :: ll + + !> magnetic quantum number (m) integer, intent(in) :: mm - real(dp), intent(in) :: theta, phi + + !> spherical coordinate theta + real(dp), intent(in) :: theta + + !> spherical coordinate phi + real(dp), intent(in) :: phi + + !> value of real tesseral spherical harmonic function real(dp) :: rty - !assert(ll >= 0 .and. ll <= 3) - !assert(abs(mm) <= ll) + ! assert(ll >= 0 .and. ll <= 3) + ! assert(abs(mm) <= ll) select case (ll) case (0) @@ -144,22 +169,26 @@ elemental function calc_realtess(ll, mm, theta, phi) result(rty) end select end select - end function calc_realtess + end function calc_realtessy + - !> Real tessereal spherical harmonics up to f. - !! \param ll angular momentum (l). - !! \param mm magnetic moment (m) - !! \param theta spherical coordinate theta. - !! \param phi spherical coordinate phi. - !! \return value of the real tesseral harmonics. - elemental function calc_realtess_1d(ll, mm, theta) result(rty) + !> Real tesseral spherical harmonics up to angular momentum f. + elemental function calc_realtessy_1d(ll, mm, theta) result(rty) + + !> angular momentum (l) integer, intent(in) :: ll + + !> magnetic quantum number (m) integer, intent(in) :: mm + + !> spherical coordinate theta real(dp), intent(in) :: theta + + !> value of real tesseral spherical harmonic function real(dp) :: rty - !assert(ll >= 0 .and. ll <= 3) - !assert(abs(mm) <= ll) + ! assert(ll >= 0 .and. ll <= 3) + ! assert(abs(mm) <= ll) select case (ll) case (0) @@ -208,6 +237,6 @@ elemental function calc_realtess_1d(ll, mm, theta) result(rty) end select end select - end function calc_realtess_1d + end function calc_realtessy_1d end module sphericalharmonics diff --git a/sktwocnt/lib/twocnt.f90 b/sktwocnt/lib/twocnt.f90 index c331f7ff..a7f5fd8a 100644 --- a/sktwocnt/lib/twocnt.f90 +++ b/sktwocnt/lib/twocnt.f90 @@ -1,246 +1,375 @@ -!> Contains the twocenter integrator routines. +!> Module that contains the two-center integrator routines for tabulating Hamiltonian and overlap. module twocnt - use omp_lib - use common_accuracy, only: dp - use common_constants - use quadratures - use coordtrans - use gridorbital - use sphericalharmonics - use gridgenerator - use partition - use dftxc - use common_fifo + use common_accuracy, only : dp + use common_constants, only : pi + use coordtrans, only : coordtrans_becke_12 + use gridorbital, only : TGridorb2 + use sphericalharmonics, only : TRealTessY, TRealTessY_init + use quadratures, only : TQuadrature, gauss_legendre_quadrature + use gridgenerator, only : gengrid2_12 + use partition, only : partition_becke_homo + use dftxc, only : getxcpot_ldapw91, getxcpot_ggapbe + use common_fifo, only : TFiFoReal2 implicit none private - public :: twocnt_in, atomdata, integmap + public :: TTwocntInp, TAtomdata, TIntegMap public :: get_twocenter_integrals - ! Data associated with atoms - type atomdata - integer :: nbasis + + ! Holds properties associated with a single atom. + type TAtomdata + + !> number of basis functions + integer :: nBasis + + !> angular momenta integer, allocatable :: angmoms(:) - type(gridorb2), allocatable :: rad(:), drad(:), ddrad(:) - type(gridorb2) :: pot, rho, drho, ddrho - end type atomdata - - !> Parsed input for twocnt. - type twocnt_in - logical :: hetero - logical :: density + + !> radial grid-orbital portion and 1st/2nd derivative + type(TGridorb2), allocatable :: rad(:), drad(:), ddrad(:) + + !> atomic potential on grid + type(TGridorb2) :: pot + + !> atomic density and 1st/2nd derivative on grid + type(TGridorb2) :: rho, drho, ddrho + + end type TAtomdata + + + !> Holds parsed input for twocnt. + type TTwocntInp + + !> true, if heteronuclear dimer is present + logical :: tHetero + + !> true, if density superposition is requested, otherwise potential superposition is applied + logical :: tDensitySuperpos + + !> xc-functional type (0: potential superposition, 1: LDA-PW91, 2: GGA-PBE) integer :: ixc - real(dp) :: r0, dr, epsilon, maxdist + + !> start grid distance + real(dp) :: r0 + + !> grid separation, i.e. stepwidth + real(dp) :: dr + + !> convergence criteria for Hamiltonian and overlap matrix elements + real(dp) :: epsilon + + !> maximum grid distance + real(dp) :: maxdist + + !> number of integration points integer :: ninteg1, ninteg2 - type(atomdata) :: atom1, atom2 - end type twocnt_in + + !> atomic properties of slateratom code, in the homonuclear case only atom1 is read + type(TAtomdata) :: atom1, atom2 + + end type TTwocntInp + !> Type for mapping integrals. - type integmap - !> Nr. of all nonzero twocenter integrals between orbitals of two atoms. + type TIntegMap + + !> number of all nonzero two-center integrals between orbitals of two atoms integer :: ninteg !> Indicates for every integral the integrands: !! - !! o type(1,ii): index of orbital on first atom for integral ii. - !! o type(2,ii): index of orbital on second atom for integral ii - !! o type(3,ii): interaction type for integral ii: (0 - sigma, 1 - pi, ...) - integer, allocatable :: type(:, :) + !! o type(1, ii): index of orbital on first atom for integral ii + !! o type(2, ii): index of orbital on second atom for integral ii + !! o type(3, ii): interaction type for integral ii: (0 - sigma, 1 - pi, ...) + integer, allocatable :: type(:,:) !> Indicates which integral corresponds to a given (i1, i2, mm) combination, !! where i1 and i2 are the orbital indices on the two atoms and mm the - !! interaction type. If the integral vanishes, the corresponding elemet is 0. - integer, allocatable :: index(:, :, :) - contains - procedure :: init => integmap_init - end type integmap + !! interaction type. If the integral vanishes, the corresponding element is 0. + integer, allocatable :: index(:,:,:) + + end type TIntegMap + contains + !> Calculates Hamiltonian and overlap matrix elements for different dimer distances. subroutine get_twocenter_integrals(inp, imap, skham, skover) - type(twocnt_in), target, intent(in) :: inp - type(integmap), intent(out) :: imap - real(dp), allocatable, intent(out) :: skham(:, :), skover(:, :) - type(quadrature) :: quads(2) + !> parsed twocnt input instance + type(TTwocntInp), intent(in), target :: inp + + !> integral mapping instance + type(TIntegMap), intent(out) :: imap + + !> resulting Hamiltonian and overlap matrices + real(dp), intent(out), allocatable :: skham(:,:), skover(:,:) + + !> abscissas and weight instances for numerical quadrature + type(TQuadrature) :: quads(2) - type(atomdata), pointer :: atom1, atom2 + !> pointer to atomic properties of dimer atoms + type(TAtomdata), pointer :: atom1, atom2 + + !> database that holds Hamiltonian and overlap matrices type(TFiFoReal2) :: hamfifo, overfifo - real(dp), allocatable :: grid1(:, :), grid2(:, :) + + !> integration grids of dimer atoms, holding spherical coordinates (r, theta) + real(dp), allocatable :: grid1(:,:), grid2(:,:) + + !> ??? and integration weights real(dp), allocatable :: dots(:), weights(:) + + !> relative density integration error for all dimer distances of a batch real(dp), allocatable :: denserr(:) - real(dp), allocatable :: skhambuffer(:, :), skoverbuffer(:, :) + + !> buffer holding Hamiltonian and overlap of current distance batch + real(dp), allocatable :: skhambuffer(:,:), skoverbuffer(:,:) + + !> arbitrary dummy real array, unused for homonuclear Becke partitioning real(dp) :: beckepars(1) - real(dp) :: dist, maxdist, denserrmax, maxabs - integer :: ir, nbatch, nbatchline - logical :: converged, dynlen - call gauss_legendre_quadrature(inp % ninteg1, quads(1)) - call gauss_legendre_quadrature(inp % ninteg2, quads(2)) + !> maximal density integration error + real(dp) :: denserrmax + + !> current dimer distance + real(dp) :: dist + + !> maximum absolute Hamiltonian or overlap matrix element + real(dp) :: maxabs + + !> maximum dimer distance + real(dp) :: maxdist + + !> iterates through a batch of dimer distances + integer :: ir + + !> number of batches for which SK-integrals got calculated + integer :: nBatch + + !> number of dimer distances in a single batch + integer :: nBatchline + + !> true, if dimer distances are shall dynamically be extended if convergency isn't reached + logical :: tDynlen - atom1 => inp % atom1 - if (inp % hetero) then - atom2 => inp % atom2 + !> true, if maximum absolute Hamiltonian or overlap matrix element is below given tolerance + logical :: tConverged + + call gauss_legendre_quadrature(inp%ninteg1, quads(1)) + call gauss_legendre_quadrature(inp%ninteg2, quads(2)) + + atom1 => inp%atom1 + if (inp%tHetero) then + atom2 => inp%atom2 else - atom2 => inp % atom1 + atom2 => inp%atom1 end if - call imap % init(atom1, atom2) + call TIntegMap_init(imap, atom1, atom2) - ! Calculate lines for 1 Bohr in one batch. + ! calculate lines for 1 Bohr in one batch. dist = 0.0_dp - dynlen = (inp % maxdist > 0.0_dp) - if (dynlen) then - nbatchline = ceiling(1.0_dp / inp % dr) - maxdist = inp % maxdist + real(nbatchline, dp) * inp % dr + tDynlen = (inp%maxdist > 0.0_dp) + if (tDynlen) then + nBatchline = ceiling(1.0_dp / inp%dr) + maxdist = inp%maxdist + real(nBatchline, dp) * inp%dr else - maxdist = abs(inp % maxdist) - nbatchline = ceiling((maxdist - inp % r0) / inp % dr) + maxdist = abs(inp%maxdist) + nBatchline = ceiling((maxdist - inp%r0) / inp%dr) end if - nbatch = 0 + nBatch = 0 denserrmax = 0.0_dp - allocate(denserr(nbatchline)) + allocate(denserr(nBatchline)) do - allocate(skhambuffer(imap % ninteg, nbatchline)) - allocate(skoverbuffer(imap % ninteg, nbatchline)) - write(*, "(A,I0,A,F6.3,A,F6.3)") "Calculating ", nbatchline,& - & " lines: r0 = ", inp % r0 + inp % dr * real(nbatch * nbatchline, dp),& - & " dr = ", inp % dr - do ir = 1, nbatchline - dist = inp % r0 + inp % dr * real(nbatch * nbatchline + ir - 1, dp) - call gengrid2_12(quads, coordtrans_becke_12, partition_becke,& - & beckepars, dist, grid1, grid2, dots, weights) - call getskintegrals(atom1, atom2, grid1, grid2, dots, weights,& - &inp % density, inp % ixc, imap, skhambuffer(:, ir), skoverbuffer(:, ir),& - & denserr(ir)) + allocate(skhambuffer(imap%ninteg, nBatchline)) + allocate(skoverbuffer(imap%ninteg, nBatchline)) + write(*, "(A,I0,A,F6.3,A,F6.3)") "Calculating ", nBatchline, " lines: r0 = ",& + & inp%r0 + inp%dr * real(nBatch * nBatchline, dp), " dr = ", inp%dr + do ir = 1, nBatchline + dist = inp%r0 + inp%dr * real(nBatch * nBatchline + ir - 1, dp) + call gengrid2_12(quads, coordtrans_becke_12, partition_becke_homo, beckepars, dist, grid1,& + & grid2, dots, weights) + call getskintegrals(atom1, atom2, grid1, grid2, dots, weights, inp%tDensitySuperpos,& + & inp%ixc, imap, skhambuffer(:, ir), skoverbuffer(:, ir), denserr(ir)) end do denserrmax = max(denserrmax, maxval(denserr)) maxabs = max(maxval(abs(skhambuffer)), maxval(abs(skoverbuffer))) - if (dynlen) then - converged = (maxabs < inp % epsilon) - ! If new batch gave no contributions above tolerance: omit it and exit - if (converged .or. dist > maxdist) then - exit - end if - nbatch = nbatch + 1 - call hamfifo % push_alloc(skhambuffer) - call overfifo % push_alloc(skoverbuffer) + if (tDynlen) then + tConverged = (maxabs < inp%epsilon) + ! if new batch gave no contributions above tolerance: omit it and exit + if (tConverged .or. dist > maxdist) exit + nBatch = nBatch + 1 + call hamfifo%push_alloc(skhambuffer) + call overfifo%push_alloc(skoverbuffer) else - converged = .true. - call hamfifo % push_alloc(skhambuffer) - call overfifo % push_alloc(skoverbuffer) + tConverged = .true. + call hamfifo%push_alloc(skhambuffer) + call overfifo%push_alloc(skoverbuffer) exit end if end do - if (.not. converged) then - write(*, "(A,F6.2,A,ES10.3)") "Warning, maximal distance ", inp % maxdist,& + if (.not. tConverged) then + write(*, "(A,F6.2,A,ES10.3)") "Warning, maximal distance ", inp%maxdist,& & " reached! Max integral value:", maxabs end if - write(*, "(A,ES10.3)") "Maximal integration error:", denserrmax + write(*, "(A,ES10.3)") "Maximal integration error: ", denserrmax - call hamfifo % popall_concat(skham) - call overfifo % popall_concat(skover) + ! hand over Hamiltonian and overlap + call hamfifo%popall_concat(skham) + call overfifo%popall_concat(skover) end subroutine get_twocenter_integrals - !> Calculate SK-integrals. - subroutine getskintegrals(atom1, atom2, grid1, grid2, dots, weights,& - & densitysuper, ixc, imap, skham, skover, denserr) - type(atomdata), intent(in) :: atom1, atom2 - real(dp), intent(in), target :: grid1(:, :), grid2(:, :), dots(:), weights(:) - logical, intent(in) :: densitysuper + + !> Calculates SK-integrals. + subroutine getskintegrals(atom1, atom2, grid1, grid2, dots, weights, tDensitySuperpos, ixc, imap,& + & skham, skover, denserr) + + !> atomic property instances of dimer atoms + type(TAtomdata), intent(in) :: atom1, atom2 + + !> integration grids of dimer atoms, holding spherical coordinates (r, theta) + real(dp), intent(in), target :: grid1(:,:), grid2(:,:) + + !> ??? + real(dp), intent(in) :: dots(:) + + !> integration weights + real(dp), intent(in) :: weights(:) + + !> true, if density superposition is requested, otherwise potential superposition is applied + logical, intent(in) :: tDensitySuperpos + + !> xc-functional type (0: potential superposition, 1: LDA-PW91, 2: GGA-PBE) integer, intent(in) :: ixc - type(integmap), intent(in) :: imap - real(dp), intent(out) :: skham(:), skover(:), denserr - type(realtess) :: tes1, tes2 + !> two-center integration mapping instance + type(TIntegMap), intent(in) :: imap + + !> resulting Hamiltonian and overlap matrix + real(dp), intent(out) :: skham(:), skover(:) + + !> relative density integration error + real(dp), intent(out) :: denserr + + !> instance of real tesseral spherical harmonics + type(TRealTessY) :: tes1, tes2 + + !> spherical coordinates (r, theta) of atom 1 and atom 2 on grid real(dp), pointer :: r1(:), r2(:), theta1(:), theta2(:) - real(dp), allocatable :: radval1(:, :) - real(dp), allocatable :: radval2(:, :), radval2p(:, :), radval2pp(:, :) + + !> radial grid-orbital portion for all basis functions of atom 1 + real(dp), allocatable :: radval1(:,:) + + !> radial grid-orbital portion and 1st/2nd derivative for all basis functions of atom 2 + real(dp), allocatable :: radval2(:,:), radval2p(:,:), radval2pp(:,:) + + !> total potential and electron density of two atoms real(dp), allocatable :: potval(:), densval(:) + + !> atomic 1st and 2nd density derivatives of atom 1 real(dp), allocatable :: densval1p(:), densval1pp(:) + + !> atomic 1st and 2nd density derivatives of atom 2 real(dp), allocatable :: densval2p(:), densval2pp(:) + + !> real tesseral spherical harmonic for spherical coordinate (theta) of atom 1 and atom 2 real(dp), allocatable :: spherval1(:), spherval2(:) + + !> higher-level density expressions real(dp), allocatable :: absgr(:), laplace(:), gr_grabsgr(:) + !> temporary storage for Hamiltonian, overlap, density and pre-factors real(dp) :: integ1, integ2, dens, prefac - integer :: ngrid - integer :: ii, i1, i2, l1, l2, mm + + !> number of integration points + integer :: nGrid + + !> orbital indices/angular momenta on the two atoms and interaction type + integer :: i1, i2, l1, l2, mm + + !> auxiliary variable + integer :: ii r1 => grid1(:, 1) theta1 => grid1(:, 2) r2 => grid2(:, 1) theta2 => grid2(:, 2) - ngrid = size(r1) - - allocate(radval1(ngrid, atom1 % nbasis)) - allocate(radval2(ngrid, atom2 % nbasis)) - allocate(radval2p(ngrid, atom2 % nbasis)) - allocate(radval2pp(ngrid, atom2 % nbasis)) - allocate(spherval1(ngrid)) - allocate(spherval2(ngrid)) + nGrid = size(r1) + + allocate(radval1(nGrid, atom1%nbasis)) + allocate(radval2(nGrid, atom2%nbasis)) + allocate(radval2p(nGrid, atom2%nbasis)) + allocate(radval2pp(nGrid, atom2%nbasis)) + allocate(spherval1(nGrid)) + allocate(spherval2(nGrid)) + + ! get radial portions of all basis functions of atom 1 do ii = 1, size(radval1, dim=2) - radval1(:, ii) = getvalue(atom1 % rad(ii), r1) + radval1(:, ii) = atom1%rad(ii)%getValue(r1) end do + + ! get radial portions (and derivatives) of all basis functions of atom 2 do ii = 1, size(radval2, dim=2) - radval2(:, ii) = getvalue(atom2 % rad(ii), r2) - radval2p(:, ii) = getvalue(atom2 % drad(ii), r2) - radval2pp(:, ii) = getvalue(atom2 % ddrad(ii), r2) + radval2(:, ii) = atom2%rad(ii)%getValue(r2) + radval2p(:, ii) = atom2%drad(ii)%getValue(r2) + radval2pp(:, ii) = atom2%ddrad(ii)%getValue(r2) end do - allocate(potval(ngrid)) - ifPotSup: if (.not. densitysuper) then - potval = getvalue(atom1 % pot, r1) + getvalue(atom2 % pot, r2) + allocate(potval(nGrid)) + ifPotSup: if (.not. tDensitySuperpos) then + potval(:) = atom1%pot%getValue(r1) + atom2%pot%getValue(r2) else - allocate(densval(ngrid)) - densval = getvalue(atom1 % rho, r1) + getvalue(atom2 % rho, r2) + allocate(densval(nGrid)) + densval(:) = atom1%rho%getValue(r1) + atom2%rho%getValue(r2) select case (ixc) case (1) + ! LDA-PW91 xc-functional call getxcpot_ldapw91(densval, potval) case (2) - allocate(densval1p(ngrid)) - allocate(densval1pp(ngrid)) - allocate(densval2p(ngrid)) - allocate(densval2pp(ngrid)) - densval1p = getvalue(atom1 % drho, r1) - densval1pp = getvalue(atom1 % ddrho, r1) - densval2p = getvalue(atom2 % drho, r2) - densval2pp = getvalue(atom2 % ddrho, r2) - allocate(absgr(ngrid)) - allocate(laplace(ngrid)) - allocate(gr_grabsgr(ngrid)) - ! Calculate derivatives for combined density - call getderivs(densval1p, densval1pp, densval2p, densval2pp, r1, r2,& - &dots, absgr, laplace, gr_grabsgr) - ! Get XC potential + ! GGA-PBE xc-functional + allocate(densval1p(nGrid)) + allocate(densval1pp(nGrid)) + allocate(densval2p(nGrid)) + allocate(densval2pp(nGrid)) + densval1p(:) = atom1%drho%getValue(r1) + densval1pp(:) = atom1%ddrho%getValue(r1) + densval2p(:) = atom2%drho%getValue(r2) + densval2pp(:) = atom2%ddrho%getValue(r2) + allocate(absgr(nGrid)) + allocate(laplace(nGrid)) + allocate(gr_grabsgr(nGrid)) + ! calculate derivatives for combined density + call getDerivs(densval1p, densval1pp, densval2p, densval2pp, r1, r2, dots, absgr, laplace,& + & gr_grabsgr) + ! get xc-potential call getxcpot_ggapbe(densval, absgr, laplace, gr_grabsgr, potval) case default - write(*,*) "Unknown functional type" + write(*,*) "Unknown functional type!" stop end select - ! Add nuclear and coulomb potential - potval = potval + getvalue(atom1 % pot, r1) + getvalue(atom2 % pot, r2) + ! add nuclear and coulomb potential to obtain the effective potential + potval(:) = potval + atom1%pot%getValue(r1) + atom2%pot%getValue(r2) end if ifPotSup denserr = 0.0_dp - do ii = 1, imap % ninteg - i1 = imap % type(1, ii) - l1 = atom1 % angmoms(i1) - i2 = imap % type(2, ii) - l2 = atom2 % angmoms(i2) - mm = imap % type(3, ii) - 1 - call init(tes1, l1, mm) - call init(tes2, l2, mm) - spherval1 = getvalue_1d(tes1, theta1) - spherval2 = getvalue_1d(tes2, theta2) - integ1 = gethamiltonian(radval1(:, i1), radval2(:, i2), & - &radval2p(:, i2), radval2pp(:, i2), r2, l2, spherval1, & - &spherval2, potval, weights) - integ2 = getoverlap(radval1(:, i1), radval2(:, i2), spherval1, & - &spherval2, weights) - dens = getdensity(radval1(:, i1), radval2(:, i2), spherval1, & - &spherval2, weights) + do ii = 1, imap%ninteg + i1 = imap%type(1, ii) + l1 = atom1%angmoms(i1) + i2 = imap%type(2, ii) + l2 = atom2%angmoms(i2) + mm = imap%type(3, ii) - 1 + call TRealTessY_init(tes1, l1, mm) + call TRealTessY_init(tes2, l2, mm) + spherval1(:) = tes1%getValue_1d(theta1) + spherval2(:) = tes2%getValue_1d(theta2) + integ1 = getHamiltonian(radval1(:, i1), radval2(:, i2), radval2p(:, i2), radval2pp(:, i2),& + & r2, l2, spherval1, spherval2, potval, weights) + integ2 = getOverlap(radval1(:, i1), radval2(:, i2), spherval1, spherval2, weights) + dens = getDensity(radval1(:, i1), radval2(:, i2), spherval1, spherval2, weights) if (mm == 0) then prefac = 2.0_dp * pi else @@ -254,103 +383,179 @@ subroutine getskintegrals(atom1, atom2, grid1, grid2, dots, weights,& end subroutine getskintegrals - function getoverlap(rad1, rad2, spher1, spher2, weights) result(res) - real(dp), intent(in) :: rad1(:), rad2(:), spher1(:), spher2(:), weights(:) + !> Calculates overlap for a fixed orbital and interaction configuration. + pure function getOverlap(rad1, rad2, spher1, spher2, weights) result(res) + + !> radial grid-orbital portion of atom 1 and atom 2 + real(dp), intent(in) :: rad1(:), rad2(:) + + !> real tesseral spherical harmonic for spherical coordinate (theta) of atom 1 and atom 2 + real(dp), intent(in) :: spher1(:), spher2(:) + + !> integration weights + real(dp), intent(in) :: weights(:) + + !> resulting orbital overlap real(dp) :: res res = sum(rad1 * rad2 * spher1 * spher2 * weights) - end function getoverlap + end function getOverlap + + + !> Calculates density for a fixed orbital and interaction configuration. + pure function getDensity(rad1, rad2, spher1, spher2, weights) result(res) + + !> radial grid-orbital portion of atom 1 and atom 2 + real(dp), intent(in) :: rad1(:), rad2(:) - function getdensity(rad1, rad2, spher1, spher2, weights) result(res) - real(dp), intent(in) :: rad1(:), rad2(:), spher1(:), spher2(:), weights(:) + !> real tesseral spherical harmonic for spherical coordinate (theta) of atom 1 and atom 2 + real(dp), intent(in) :: spher1(:), spher2(:) + + !> integration weights + real(dp), intent(in) :: weights(:) + + !> resulting electron density real(dp) :: res res = sum(((rad1 * spher1)**2 + (rad2 * spher2)**2) * weights) end function getdensity - function gethamiltonian(rad1, rad2, rad2p, rad2pp, r2, l2, spher1, spher2, & - &pot, weights) result(res) - real(dp), intent(in) :: rad1(:), rad2(:), rad2p(:), rad2pp(:), r2(:) + + !> Calculates Hamiltonian for a fixed orbital and interaction configuration. + pure function getHamiltonian(rad1, rad2, rad2p, rad2pp, r2, l2, spher1, spher2, pot, weights)& + & result(res) + + !> radial grid-orbital portion of atom 1 and atom 2 + real(dp), intent(in) :: rad1(:), rad2(:) + + !> radial grid-orbital portion's 1st and 2nd derivative of atom 2 + real(dp), intent(in) :: rad2p(:), rad2pp(:) + + !> radial spherical coordinates of atom 2 on grid + real(dp), intent(in) :: r2(:) + + !> angular momentum corresponding to current orbital index of atom 2 integer, intent(in) :: l2 - real(dp), intent(in) :: spher1(:), spher2(:), pot(:), weights(:) + + !> real tesseral spherical harmonic for spherical coordinate (theta) of atom 1 and atom 2 + real(dp), intent(in) :: spher1(:), spher2(:) + + !> effective potential on grid + real(dp), intent(in) :: pot(:) + + !> integration weights + real(dp), intent(in) :: weights(:) + + !> resulting Hamiltonian matrix element real(dp) :: res - res = sum((rad1 * spher1) & - &* (-0.5_dp * rad2pp & - &- rad2p / r2 & - &+ 0.5_dp * l2 * (l2 + 1) * rad2 / r2**2& - &+ pot * rad2) & - &* spher2 * weights) + res = sum((rad1 * spher1)& + & * (- 0.5_dp * rad2pp& + & - rad2p / r2& + & + 0.5_dp * l2 * (l2 + 1) * rad2 / r2**2& + & + pot * rad2)& + & * spher2 * weights) + + end function getHamiltonian + - end function gethamiltonian + !> Calculates higher-level expressions based on the density's 1st and 2nd derivatives. + pure subroutine getDerivs(drho1, d2rho1, drho2, d2rho2, r1, r2, dots, absgr, laplace, gr_grabsgr) - subroutine getderivs(drho1, d2rho1, drho2, d2rho2, r1, r2, dots, & - &absgr, laplace, gr_grabsgr) + !> 1st and 2nd atomic density derivatives on grid real(dp), intent(in) :: drho1(:), d2rho1(:), drho2(:), d2rho2(:) - real(dp), intent(in) :: r1(:), r2(:), dots(:) - real(dp), intent(out) :: absgr(:), laplace(:), gr_grabsgr(:) - integer :: nn + !> radial spherical coordinates of atom 1 and atom 2 on grid + real(dp), intent(in) :: r1(:), r2(:) + + !> ??? + real(dp), intent(in) :: dots(:) + + !> absolute total density gradient + real(dp), intent(out) :: absgr(:) + + !> laplace operator acting on total density + real(dp), intent(out) :: laplace(:) + + !> (grad rho4pi) * grad(abs(grad rho4pi)) + real(dp), intent(out) :: gr_grabsgr(:) + + !> temporary storage real(dp), allocatable :: f1(:), f2(:) + !> number of grid points + integer :: nn + nn = size(drho1) allocate(f1(nn), f2(nn)) - f1 = drho1 + dots * drho2 - f2 = drho2 + dots * drho1 - absgr = sqrt(drho1 * f1 + drho2 * f2) - laplace = d2rho1 + d2rho2 + 2.0_dp * (drho1 / r1 + drho2 / r2) + + f1(:) = drho1 + dots * drho2 + f2(:) = drho2 + dots * drho1 + + absgr(:) = sqrt(drho1 * f1 + drho2 * f2) + laplace(:) = d2rho1 + d2rho2 + 2.0_dp * (drho1 / r1 + drho2 / r2) where (absgr > epsilon(1.0_dp)) - gr_grabsgr = (d2rho1 * f1 * f1 + d2rho2 * f2 * f2 & - &+ (1.0_dp - dots**2) * drho1 * drho2 * (drho2 / r1 + drho1 / r2)) & - &/ absgr + gr_grabsgr = (d2rho1 * f1 * f1 + d2rho2 * f2 * f2& + & + (1.0_dp - dots**2) * drho1 * drho2 * (drho2 / r1 + drho1 / r2))& + & / absgr elsewhere gr_grabsgr = 0.0_dp end where - end subroutine getderivs + end subroutine getDerivs + + + !> Initializes the two-center integration map based on the basis on two atoms. + subroutine TIntegMap_init(this, atom1, atom2) - !> Initializes the twocenter integration map based on the basis on two atoms. - !! \param self Instance. - !! \param atom1 Properties of atom1. - !! \param atom2 Properties of atom2. - subroutine integmap_init(self, atom1, atom2) - class(integmap), intent(out) :: self - type(atomdata), intent(in) :: atom1, atom2 + !> two-center integration mapping instance + type(TIntegMap), intent(out) :: this - integer :: mmax, ninteg, ind, i1, l1, i2, l2, mm + !> atomic property instances of dimer atoms + type(TAtomdata), intent(in) :: atom1, atom2 - mmax = min(maxval(atom1 % angmoms), maxval(atom2 % angmoms)) - allocate(self % index(atom1 % nbasis, atom2 % nbasis, mmax + 1)) - self % index = 0 + !> number of all nonzero two-center integrals between orbitals of two atoms + integer :: ninteg + + !> maximum mutual angular momentum + integer :: mmax + + !> orbital indices/angular momenta on the two atoms and interaction type + integer :: i1, i2, l1, l2, mm + + !> auxiliary variable + integer :: ind + + mmax = min(maxval(atom1%angmoms), maxval(atom2%angmoms)) + allocate(this%index(atom1%nbasis, atom2%nbasis, mmax + 1)) + this%index = 0 ninteg = 0 - do i1 = 1, atom1 % nbasis - l1 = atom1 % angmoms(i1) - do i2 = 1, atom2 % nbasis - l2 = atom2 % angmoms(i2) + do i1 = 1, atom1%nbasis + l1 = atom1%angmoms(i1) + do i2 = 1, atom2%nbasis + l2 = atom2%angmoms(i2) do mm = 0, min(l1, l2) - print*,l1, l2, mm ninteg = ninteg + 1 - self % index(i1, i2, mm + 1) = ninteg + this%index(i1, i2, mm + 1) = ninteg end do end do end do - self % ninteg = ninteg - allocate(self % type(3, ninteg)) + this%ninteg = ninteg + allocate(this%type(3, ninteg)) ind = 0 - do i1 = 1, atom1 % nbasis - l1 = atom1 % angmoms(i1) - do i2 = 1, atom2 % nbasis - l2 = atom2 % angmoms(i2) + do i1 = 1, atom1%nbasis + l1 = atom1%angmoms(i1) + do i2 = 1, atom2%nbasis + l2 = atom2%angmoms(i2) do mm = 1, min(l1, l2) + 1 ind = ind + 1 - self % type(:, ind) = [i1, i2, mm] + this%type(:, ind) = [i1, i2, mm] end do end do end do - end subroutine integmap_init + end subroutine TIntegMap_init end module twocnt - diff --git a/sktwocnt/prog/cmdargs.f90 b/sktwocnt/prog/cmdargs.f90 index b3eafe3d..7b4e9518 100644 --- a/sktwocnt/prog/cmdargs.f90 +++ b/sktwocnt/prog/cmdargs.f90 @@ -1,15 +1,25 @@ +!> Module that handles command line argument parsing. module cmdargs + implicit none + private + + public :: parse_command_arguments + + character(len=*), parameter :: programName = 'sktwocnt' + character(len=*), parameter :: programVersion = '0.9' - character(*), parameter :: programName = 'sktwocnt' - character(*), parameter :: programVersion = '0.9' contains + !> Parses command line arguments or prints program/version information. subroutine parse_command_arguments() + !> number of command line arguments and length buffer integer :: nArgs, argLen - character(:), allocatable :: arg + + !> string representation of a single command line argument + character(len=:), allocatable :: arg nArgs = command_argument_count() if (nArgs > 0) then diff --git a/sktwocnt/prog/input.f90 b/sktwocnt/prog/input.f90 index 852c8172..241c2f45 100644 --- a/sktwocnt/prog/input.f90 +++ b/sktwocnt/prog/input.f90 @@ -1,198 +1,285 @@ +!> Module that handles input parsing of configuration and raw data. module input - use common_accuracy, only: dp - use gridorbital - use twocnt, only: twocnt_in, atomdata + use common_accuracy, only : dp + use gridorbital, only : TGridorb2_init + use twocnt, only : TTwocntInp, TAtomdata + implicit none private - public :: readinput + public :: readInput + !> maximum line length of sktwocnt.in file integer, parameter :: maxlen = 1024 + + !> expected line format when reading sktwocnt.in file character(len=*), parameter :: lineformat = "(A1024)" + + !> comment string character, parameter :: comment = "#" + contains - subroutine readinput(inp, inputfile) - type(twocnt_in), intent(out) :: inp - character(*), intent(in) :: inputfile + !> Reads and extracts relevant information from 'sktwocnt.in' file. + subroutine readInput(inp, fname) + + !> instance of parsed input for twocnt + type(TTwocntInp), intent(out) :: inp + + !> filename + character(len=*), intent(in) :: fname + + !> file identifier + integer :: fp + + !> current line index + integer :: iLine - integer :: fp, iline - character(maxlen) :: line, buffer1, buffer2 - integer :: iostat + !> character buffer + character(len=maxlen) :: line, buffer1, buffer2 + + !> error status + integer :: iErr + + !> potential data columns, summed up in order to receive the total atomic potential integer, allocatable :: potcomps(:) - logical :: readradderivs + + !> true, if radial grid-orbital 1st/2nd derivative shall be read + logical :: tReadRadDerivs fp = 14 - open (fp, file=inputfile, form="formatted", action="read") - !! General part - iline = 0 - call nextline_(fp, iline, line) - read (line, *, iostat=iostat) buffer1, buffer2 - call checkerror_(inputfile, line, iline, iostat) + open(fp, file=fname, form="formatted", action="read") + ! general part + iLine = 0 + call nextline_(fp, iLine, line) + read(line, *, iostat=iErr) buffer1, buffer2 + call checkerror_(fname, line, iLine, iErr) if (buffer1 /= "hetero" .and. buffer1 /= "homo") then - call error_("Wrong interaction (must be hetero or homo)", inputfile, & - &line, iline) + call error_("Wrong interaction (must be hetero or homo)", fname, line, iLine) end if - inp % hetero = (buffer1 == "hetero") + inp%tHetero = (buffer1 == "hetero") select case (buffer2) case ("potential") - inp % density = .false. - inp % ixc = 0 + inp%tDensitySuperpos = .false. + inp%ixc = 0 case ("density_lda") - inp % density = .true. - inp % ixc = 1 + inp%tDensitySuperpos = .true. + inp%ixc = 1 case ("density_pbe") - inp % density = .true. - inp % ixc = 2 + inp%tDensitySuperpos = .true. + inp%ixc = 2 case default - call error_("Wrong superposition mode (must be potential, density_lda & - &or density_pbe", inputfile, line, iline) + call error_("Wrong superposition mode (must be potential, density_lda or density_pbe", fname,& + & line, iLine) end select - call nextline_(fp, iline, line) - read (line, *, iostat=iostat) inp % r0, inp % dr, inp % epsilon, inp % maxdist - call checkerror_(inputfile, line, iline, iostat) + call nextline_(fp, iLine, line) + read(line, *, iostat=iErr) inp%r0, inp%dr, inp%epsilon, inp%maxdist + call checkerror_(fname, line, iLine, iErr) - call nextline_(fp, iline, line) - read (line, *, iostat=iostat) inp % ninteg1, inp % ninteg2 - call checkerror_(inputfile, line, iline, iostat) + call nextline_(fp, iLine, line) + read(line, *, iostat=iErr) inp%ninteg1, inp%ninteg2 + call checkerror_(fname, line, iLine, iErr) - if (inp % density) then + if (inp%tDensitySuperpos) then allocate(potcomps(2)) potcomps = [2, 3] else allocate(potcomps(3)) potcomps = [2, 3, 4] end if - readradderivs = .not. inp % hetero - call readatom_(inputfile, fp, iline, potcomps, inp % density, readradderivs, & - &inp % atom1) - if (inp % hetero) then - call readatom_(inputfile, fp, iline, potcomps, inp % density, .true., & - &inp % atom2) + tReadRadDerivs = .not. inp%tHetero + call readatom_(fname, fp, iLine, potcomps, inp%tDensitySuperpos, tReadRadDerivs, inp%atom1) + if (inp%tHetero) then + call readatom_(fname, fp, iLine, potcomps, inp%tDensitySuperpos, .true., inp%atom2) end if - close (fp) + close(fp) + + end subroutine readInput - end subroutine readinput - subroutine readatom_(fname, fp, iline, potcomps, density, radderivs, atom) - character(*), intent(in) :: fname + !> Fills TAtomdata instance based on slateratom's output. + subroutine readatom_(fname, fp, iLine, potcomps, tDensitySuperpos, tReadRadDerivs, atom) + + !> filename + character(len=*), intent(in) :: fname + + !> file identifier integer, intent(in) :: fp - integer, intent(inout) :: iline + + !> current line index + integer, intent(inout) :: iLine + + !> potential data columns, summed up in order to receive the total atomic potential integer, intent(in) :: potcomps(:) - logical, intent(in) :: density, radderivs - type(atomdata), intent(out) :: atom + !> true, if density superposition is requested, otherwise potential superposition is applied + logical, intent(in) :: tDensitySuperpos + + !> true, if radial grid-orbital 1st/2nd derivative shall be read + logical, intent(in) :: tReadRadDerivs + + !> atomic properties instance + type(TAtomdata), intent(out) :: atom + + !> character buffer character(maxlen) :: line, buffer - real(dp), allocatable :: data(:, :), potval(:) - integer :: ii, iostat, imax - - call nextline_(fp, iline, line) - read (line, *, iostat=iostat) atom % nbasis - call checkerror_(fname, line, iline, iostat) - - allocate(atom % angmoms(atom % nbasis)) - allocate(atom % rad(atom % nbasis)) - if (radderivs) then - allocate(atom % drad(atom % nbasis)) - allocate(atom % ddrad(atom % nbasis)) + + !> temporarily stores atomic wavefunction and potential + real(dp), allocatable :: data(:,:), potval(:) + + !> error status + integer :: iErr + + !> auxiliary variables + integer :: ii, imax + + call nextline_(fp, iLine, line) + read(line, *, iostat=iErr) atom%nBasis + call checkerror_(fname, line, iLine, iErr) + + allocate(atom%angmoms(atom%nBasis)) + allocate(atom%rad(atom%nBasis)) + if (tReadRadDerivs) then + allocate(atom%drad(atom%nBasis)) + allocate(atom%ddrad(atom%nBasis)) end if - do ii = 1, atom % nbasis - call nextline_(fp, iline, line) - read (line, *, iostat=iostat) buffer, atom % angmoms(ii) - call checkerror_(fname, line, iline, iostat) - if (radderivs) then + + do ii = 1, atom%nBasis + call nextline_(fp, iLine, line) + read(line, *, iostat=iErr) buffer, atom%angmoms(ii) + call checkerror_(fname, line, iLine, iErr) + if (tReadRadDerivs) then call readdata_(buffer, [1, 3, 4, 5], data) - call init(atom % rad(ii), data(:, 1), data(:, 2)) - call init(atom % drad(ii), data(:, 1), data(:, 3)) - call init(atom % ddrad(ii), data(:, 1), data(:, 4)) + call TGridorb2_init(atom%rad(ii), data(:, 1), data(:, 2)) + call TGridorb2_init(atom%drad(ii), data(:, 1), data(:, 3)) + call TGridorb2_init(atom%ddrad(ii), data(:, 1), data(:, 4)) else call readdata_(buffer, [1, 3], data) - call init(atom % rad(ii), data(:, 1), data(:, 2)) + call TGridorb2_init(atom%rad(ii), data(:, 1), data(:, 2)) end if - ! Check if wave function follows the sign convention + ! check if wave function follows the sign convention ! (positive where abs(r * R(r)) has its maximum) imax = maxloc(abs(data(:, 1) * data(:, 2)), dim=1) if (data(imax, 2) < 0.0_dp) then - write(*, "(A,F5.2,A)") "Wave function negative at the maximum of& - & radial probability (r =", data(imax, 1), " Bohr)" - write(*, "(A)") "Please change the sign of the wave function (and of& - & its derivatives)!" + write(*, "(A,F5.2,A)") "Wave function negative at the maximum of radial probability& + & (r =", data(imax, 1), " Bohr)" + write(*, "(A)") "Please change the sign of the wave function (and of its derivatives)!" write(*, "(A,A,A)") "File: '", trim(buffer), "'" stop end if end do - call checkangmoms_(atom % angmoms) - call nextline_(fp, iline, line) - read(line, *, iostat=iostat) buffer - call checkerror_(fname, line, iline, iostat) + call checkangmoms_(atom%angmoms) + + call nextline_(fp, iLine, line) + read(line, *, iostat=iErr) buffer + call checkerror_(fname, line, iLine, iErr) call readdata_(buffer, [1, 3, 4, 5], data) allocate(potval(size(data, dim=1))) - potval = 0.0_dp + potval(:) = 0.0_dp do ii = 1, size(potcomps) - potval = potval + data(:, potcomps(ii)) + potval(:) = potval + data(:, potcomps(ii)) end do - call init(atom % pot, data(:, 1), potval) + call TGridorb2_init(atom%pot, data(:, 1), potval) - call nextline_(fp, iline, line) - read(line, *, iostat=iostat) buffer - call checkerror_(fname, line, iline, iostat) - if (density) then + call nextline_(fp, iLine, line) + read(line, *, iostat=iErr) buffer + call checkerror_(fname, line, iLine, iErr) + if (tDensitySuperpos) then call readdata_(buffer, [1, 3, 4, 5], data) - call init(atom % rho, data(:, 1), data(:, 2)) - call init(atom % drho, data(:, 1), data(:, 3)) - call init(atom % ddrho, data(:, 1), data(:, 4)) + call TGridorb2_init(atom%rho, data(:, 1), data(:, 2)) + call TGridorb2_init(atom%drho, data(:, 1), data(:, 3)) + call TGridorb2_init(atom%ddrho, data(:, 1), data(:, 4)) else if (trim(line) /= "noread") then - write(*, "(A,I0,A)") "Line ", iline, & - &" ignored since density is not needed." + write(*, "(A,I0,A)") "Line ", iLine, " ignored since density is not needed." end if end if end subroutine readatom_ + + !> Reads desired colums of a data file. subroutine readdata_(fname, cols, data) - character(*), intent(in) :: fname + + !> filename + character(len=*), intent(in) :: fname + + !> desired columns to read from file integer, intent(in) :: cols(:) - real(dp), allocatable, intent(out) :: data(:, :) + !> obtained data on grid with nGrid entries + real(dp), intent(out), allocatable :: data(:,:) + + !> temporarily stores all columns of a single line in file real(dp), allocatable :: tmp(:) + + !> character buffer for current line of file character(maxlen) :: line - integer :: ngrid, ii, fp, iline, iostat + + !> number of grid points stored in file + integer :: nGrid + + !> error status + integer :: iErr + + !> current line + integer :: iLine + + !> file identifier + integer :: fp + + !> auxiliary variable + integer :: ii fp = 12 + iLine = 1 + allocate(tmp(maxval(cols))) - iline = 1 - open (fp, file=fname, action="read", form="formatted") - call nextline_(fp, iline, line) - read(line, *, iostat=iostat) ngrid - call checkerror_(fname, line, iline, iostat) - allocate(data(ngrid, size(cols))) - do ii = 1, ngrid - call nextline_(fp, iline, line) - read(line, *, iostat=iostat) tmp(:) - call checkerror_(fname, line, iline, iostat) + + open(fp, file=fname, action="read", form="formatted") + + call nextline_(fp, iLine, line) + read(line, *, iostat=iErr) nGrid + call checkerror_(fname, line, iLine, iErr) + + allocate(data(nGrid, size(cols))) + do ii = 1, nGrid + call nextline_(fp, iLine, line) + read(line, *, iostat=iErr) tmp(:) + call checkerror_(fname, line, iLine, iErr) data(ii, :) = tmp(cols) end do - close (fp) - deallocate(tmp) + + close(fp) end subroutine readdata_ - subroutine nextline_(fp, iline, line) + + !> Iterates through lines of a file, while respecting an user-def. comment string and empty lines. + subroutine nextline_(fp, iLine, line) + + !> file identifier integer, intent(in) :: fp - integer, intent(inout) :: iline + + !> current line of the file + integer, intent(inout) :: iLine + + !> line buffer character(maxlen), intent(out) :: line + !> position of comment string in line if present, otherwise zero integer :: ii + + !> temporarily stores an entire line character(maxlen) :: buffer do while (.true.) - iline = iline + 1 + iLine = iLine + 1 read(fp, lineformat) buffer ii = index(buffer, comment) if (ii == 0) then @@ -200,14 +287,16 @@ subroutine nextline_(fp, iline, line) else line = adjustl(buffer(1:ii - 1)) end if - if (len_trim(line) > 0) then - exit - end if + if (len_trim(line) > 0) exit end do end subroutine nextline_ + + !> Checks range of angular momenta w.r.t. program compatibility. subroutine checkangmoms_(angmoms) + + !> angular momenta integer, intent(in) :: angmoms(:) if (maxval(angmoms) > 4) then @@ -217,25 +306,51 @@ subroutine checkangmoms_(angmoms) end subroutine checkangmoms_ - subroutine checkerror_(fname, line, iline, iostat) - character(*), intent(in) :: fname, line - integer, intent(in) :: iline, iostat - if (iostat /= 0) then - call error_("Bad syntax", fname, line, iline) + !> Error handling. + subroutine checkerror_(fname, line, iLine, iErr) + + !> filename + character(len=*), intent(in) :: fname + + !> content of current line + character(len=*), intent(in) :: line + + !> current line of parsed file + integer, intent(in) :: iLine + + !> error status + integer, intent(in) :: iErr + + if (iErr /= 0) then + call error_("Bad syntax", fname, line, iLine) end if end subroutine checkerror_ - subroutine error_(txt, fname, line, iline) - character(*), intent(in) :: txt, fname, line - integer, intent(in) :: iline + + !> Throws error message. + subroutine error_(txt, fname, line, iLine) + + !> user-specified error message + character(len=*), intent(in) :: txt + + !> filename + character(len=*), intent(in) :: fname + + !> content of erroneous line + character(len=*), intent(in) :: line + + !> index of erroneous line + integer, intent(in) :: iLine write(*, "(A,A)") "!!! Parsing error: ", txt write(*, "(2X,A,A)") "File: ", trim(fname) - write(*, "(2X,A,I0)") "Line number: ", iline + write(*, "(2X,A,I0)") "Line number: ", iLine write(*, "(2X,A,A,A)") "Line: '", trim(line), "'" + stop + end subroutine error_ end module input diff --git a/sktwocnt/prog/main.f90 b/sktwocnt/prog/main.f90 index a3f05c3d..182c423d 100644 --- a/sktwocnt/prog/main.f90 +++ b/sktwocnt/prog/main.f90 @@ -1,21 +1,31 @@ +!> Program to calculate two-center integrals of Slater-Koster tables. program main - use common_accuracy, only: dp - use input - use twocnt - use output - use cmdargs + use common_accuracy, only : dp + use input, only : readInput + use twocnt, only : TTwocntInp, TIntegMap, get_twocenter_integrals + use output, only : write_sktables + use cmdargs, only : parse_command_arguments + implicit none - type(twocnt_in) :: inp - type(integmap) :: imap - real(dp), allocatable :: skham(:, :), skover(:, :) + !> representation of parsed input for sktwocnt. + type(TTwocntInp) :: inp + + !> specifies type for mapping integrals. + type(TIntegMap) :: imap + + !> resulting Hamiltonian and overlap matrices + real(dp), allocatable :: skham(:,:), skover(:,:) call parse_command_arguments() - call readinput(inp, "sktwocnt.in") + + call readInput(inp, "sktwocnt.in") write(*, "(A)") "Input done." + call get_twocenter_integrals(inp, imap, skham, skover) write(*, "(A)") "Twocnt done." + call write_sktables(skham, skover) end program main diff --git a/sktwocnt/prog/output.f90 b/sktwocnt/prog/output.f90 index 184c1540..bde38f7d 100644 --- a/sktwocnt/prog/output.f90 +++ b/sktwocnt/prog/output.f90 @@ -1,7 +1,7 @@ !> Output routines for the sktwocnt code. module output - use common_accuracy, only: dp + use common_accuracy, only : dp implicit none private From 94bb8cee8db0cc6619f4f6cf83127f3a131653fe Mon Sep 17 00:00:00 2001 From: Tammo van der Heide Date: Mon, 3 Jan 2022 13:18:29 +0100 Subject: [PATCH 14/17] Remove docmarkers for vars not part of function signature --- sktwocnt/lib/bisection.f90 | 12 ++--- sktwocnt/lib/coordtrans.f90 | 8 +-- sktwocnt/lib/dftbxc.f90 | 44 ++++++++-------- sktwocnt/lib/gridgenerator.f90 | 10 ++-- sktwocnt/lib/gridorbital.f90 | 14 +++--- sktwocnt/lib/interpolation.f90 | 12 ++--- sktwocnt/lib/partition.f90 | 18 +++---- sktwocnt/lib/quadrature.f90 | 14 +++--- sktwocnt/lib/sphericalharmonics.f90 | 8 +-- sktwocnt/lib/twocnt.f90 | 78 ++++++++++++++--------------- sktwocnt/prog/cmdargs.f90 | 4 +- sktwocnt/prog/input.f90 | 38 +++++++------- sktwocnt/prog/output.f90 | 36 +++++++++---- 13 files changed, 157 insertions(+), 139 deletions(-) diff --git a/sktwocnt/lib/bisection.f90 b/sktwocnt/lib/bisection.f90 index 0a3a2a8e..fdca5033 100644 --- a/sktwocnt/lib/bisection.f90 +++ b/sktwocnt/lib/bisection.f90 @@ -33,16 +33,16 @@ pure subroutine bisect_real(xx, x0, ind, tol) !> optional, user-specified tolerance for comparisons real(dp), intent(in), optional :: tol - !> length of array to search + !! length of array to search integer :: nn - !> lower, upper and current value index + !! lower, upper and current value index integer :: iLower, iUpper, iCurr - !> actual tolerance selected + !! actual tolerance selected real(dp) :: rTol - !> true, if xx(:) is in ascending ordering + !! true, if xx(:) is in ascending ordering logical :: tAscending nn = size(xx) @@ -96,10 +96,10 @@ pure subroutine bisect_int(xx, x0, ind) !> located element such that xx(ind) < x0 < xx(ind) integer, intent(out) :: ind - !> length of array to search + !! length of array to search integer :: nn - !> lower, upper and current value index + !! lower, upper and current value index integer :: iLower, iUpper, iCurr nn = size(xx) diff --git a/sktwocnt/lib/coordtrans.f90 b/sktwocnt/lib/coordtrans.f90 index 85ad0398..365bfab7 100644 --- a/sktwocnt/lib/coordtrans.f90 +++ b/sktwocnt/lib/coordtrans.f90 @@ -51,11 +51,11 @@ pure subroutine coordtrans_becke(c11, spheric, jacobi) !> Jacobi determinant real(dp), intent(out) :: jacobi - !> midpoint of the integration interval, + !! midpoint of the integration interval, !! allows adjustment of the radial point distribution to a suitable physical scale real(dp), parameter :: rm = 1.5_dp - !> recurring factors + !! recurring factors real(dp) :: rtmp1, rtmp2 ! assert(size(c11) == 3) @@ -85,11 +85,11 @@ pure subroutine coordtrans_becke_12(c11, spheric, jacobi) !> Jacobi determinant real(dp), intent(out) :: jacobi - !> midpoint of the integration interval, + !! midpoint of the integration interval, !! allows adjustment of the radial point distribution to a suitable physical scale real(dp), parameter :: rm = 1.5_dp - !> recurring factors + !! recurring factors real(dp) :: rtmp1, rtmp2 ! assert(size(c11) == 2) diff --git a/sktwocnt/lib/dftbxc.f90 b/sktwocnt/lib/dftbxc.f90 index e6fa1816..45d0c3f6 100644 --- a/sktwocnt/lib/dftbxc.f90 +++ b/sktwocnt/lib/dftbxc.f90 @@ -31,22 +31,22 @@ subroutine getxcpot_ldapw91(rho4pi, xcpot) !> resulting xc-potential real(dp), intent(out) :: xcpot(:) - !> density with libxc compatible normalization + !! density with libxc compatible normalization real(dp), allocatable :: rho(:) - !> local Seitz radius, needed for functional evaluation + !! local Seitz radius, needed for functional evaluation real(dp), allocatable :: rs(:) - !> exchange and correlation (up, down) potential of a single grid point + !! exchange and correlation (up, down) potential of a single grid point real(dp) :: vx, vcup, vcdn - !> exchange and correlation energy of a single grid point + !! exchange and correlation energy of a single grid point real(dp) :: ex, ec - !> number of density grid points + !! number of density grid points integer :: nn - !> auxiliary variable + !! auxiliary variable integer :: ii nn = size(rho4pi) @@ -69,17 +69,17 @@ subroutine getxcpot_ldapw91(rho4pi, xcpot) !! vanderhe: proposed libxc integration !! --> but Hamiltonian matrix elements differ up to 1e-07 a.u. (something is wrong)!? - ! !> libxc related objects + ! !! libxc related objects ! type(xc_f90_func_t) :: xcfunc_x, xcfunc_c ! type(xc_f90_func_info_t) :: xcinfo - ! !> density with libxc compatible normalization + ! !! density with libxc compatible normalization ! real(dp), allocatable :: rho(:) - ! !> exchange and correlation potential on grid + ! !! exchange and correlation potential on grid ! real(dp), allocatable :: vx(:), vc(:) - ! !> number of density grid points + ! !! number of density grid points ! integer(c_size_t) :: nn ! call xc_f90_func_init(xcfunc_x, XC_LDA_X, XC_UNPOLARIZED) @@ -121,23 +121,23 @@ subroutine getxcpot_ggapbe(rho4pi, absgr4pi, laplace4pi, gr_grabsgr4pi, xcpot) !> resulting xc-potential real(dp), intent(out) :: xcpot(:) - !> density with libxc compatible normalization + !! density with libxc compatible normalization real(dp), allocatable :: rho(:) - !> absolute gradient of density on grid + !! absolute gradient of density on grid real(dp), allocatable :: absgr(:) - !> laplace operator acting on density on grid + !! laplace operator acting on density on grid real(dp), allocatable :: laplace(:) - !> (grad rho) * grad(abs(grad rho)) / rho**2 + !! (grad rho) * grad(abs(grad rho)) / rho**2 !! actually calculated based on rho4pi, but 4pi cancels out real(dp), allocatable :: gr_grabsgr(:) - !> number of density grid points + !! number of density grid points integer :: nn - !> auxiliary variables + !! auxiliary variables real(dp), allocatable :: rs(:), fac(:), tt(:), uu(:), vv(:) real(dp), allocatable :: ss(:), u2(:), v2(:) real(dp) :: alpha, zeta, gg, ww @@ -194,23 +194,23 @@ subroutine getxcpot_ggapbe(rho4pi, absgr4pi, laplace4pi, gr_grabsgr4pi, xcpot) !! vanderhe: proposed libxc integration !! --> but Hamiltonian matrix elements differ up to 1e-02 a.u. (something is wrong)!? - ! !> libxc related objects + ! !! libxc related objects ! type(xc_f90_func_t) :: xcfunc_x, xcfunc_c ! type(xc_f90_func_info_t) :: xcinfo - ! !> density with libxc compatible normalization + ! !! density with libxc compatible normalization ! real(dp), allocatable :: rho(:) - ! !> contracted gradients of the density + ! !! contracted gradients of the density ! real(dp), allocatable :: sigma(:) - ! !> exchange and correlation potential on grid + ! !! exchange and correlation potential on grid ! real(dp), allocatable :: vx(:), vc(:) - ! !> first partial derivative of the energy per unit volume in terms of sigma + ! !! first partial derivative of the energy per unit volume in terms of sigma ! real(dp), allocatable :: vxsigma(:), vcsigma(:) - ! !> number of density grid points + ! !! number of density grid points ! integer(c_size_t) :: nn ! nn = size(rho4pi) diff --git a/sktwocnt/lib/gridgenerator.f90 b/sktwocnt/lib/gridgenerator.f90 index 1f5d36fb..9a54981f 100644 --- a/sktwocnt/lib/gridgenerator.f90 +++ b/sktwocnt/lib/gridgenerator.f90 @@ -26,13 +26,13 @@ pure subroutine gengrid1_12(quads, coordtrans, grid, weights) !> two-dimensional atom grid, whereas r = grid(:, 1) and theta = grid(:, 2) real(dp), intent(out), allocatable :: grid(:,:) - !> + !> integration weights real(dp), intent(out), allocatable :: weights(:) - !> atomic and total number of quadrature abscissas + !! atomic and total number of quadrature abscissas integer :: n1, n2, nn - !> auxiliary variables + !! auxiliary variables integer :: ind, i1, i2 real(dp) :: coord(2), coordreal(2), jacobi @@ -88,10 +88,10 @@ pure subroutine gengrid2_12(quads, coordtrans, partition, partparams, dist, grid !> integration weights real(dp), intent(out), allocatable :: weights(:) - !> atomic and total number of quadrature abscissas + !! atomic and total number of quadrature abscissas integer :: n1, n2, nn - !> auxiliary variables + !! auxiliary variables integer :: ind, i1, i2 real(dp) :: coord(2), coordreal(2) real(dp) :: r1, theta1, r2a, r2b, theta2a, theta2b, rtmpa, rtmpb, jacobi diff --git a/sktwocnt/lib/gridorbital.f90 b/sktwocnt/lib/gridorbital.f90 index 777cee86..9c3ecb4b 100644 --- a/sktwocnt/lib/gridorbital.f90 +++ b/sktwocnt/lib/gridorbital.f90 @@ -119,10 +119,10 @@ elemental function TGridorb1_getValue(this, rr) result(rad) !> radius to calculate the value for real(dp), intent(in) :: rr - !> radial part of the orbital at the given distance + !! radial part of the orbital at the given distance real(dp) :: rad - !> auxiliary variables + !! auxiliary variables integer :: ind, iStart, iEnd real(dp) :: rmax, f0, f1, f2, f1p, f1pp @@ -176,13 +176,13 @@ subroutine TGridorb2_init(this, rvals, fvals) !> r, f(r) values on grid real(dp), intent(in) :: rvals(:), fvals(:) - !> grid-orbital instance + !! grid-orbital instance type(TGridorb1) :: orb - !> Gauss-Chebyshev abscissas and inverse Becke radii + !! Gauss-Chebyshev abscissas and inverse Becke radii real(dp) :: xx, rr - !> auxiliary variable + !! auxiliary variable integer :: ii ! assert(size(values, dim=1) == 2) @@ -236,10 +236,10 @@ elemental function TGridorb2_getValue(this, rr) result(rad) !> radius to calculate the value for real(dp), intent(in) :: rr - !> radial part of the orbital at the given distance + !! radial part of the orbital at the given distance real(dp) :: rad - !> auxiliary variables + !! auxiliary variables integer :: ind, iStart, iEnd real(dp) :: rmax, f0, f1, f2, f1p, f1pp real(dp) :: xx diff --git a/sktwocnt/lib/interpolation.f90 b/sktwocnt/lib/interpolation.f90 index 7f021992..d20bb154 100644 --- a/sktwocnt/lib/interpolation.f90 +++ b/sktwocnt/lib/interpolation.f90 @@ -32,7 +32,7 @@ pure function poly5zero(y0, y0p, y0pp, xx, dx) result(yy) !> point, where the polynomials value and first two derivatives should take the provided values real(dp), intent(in) :: dx - !> value of the polynomial at xx + !! value of the polynomial at xx real(dp) :: yy real(dp) :: dx1, dx2, cc, bb, aa, xr @@ -92,10 +92,10 @@ pure subroutine spline3_free(y0, y0p, y0pp, dx, ydx, xx, yy, yp, ypp) !> second derivative at xx real(dp), intent(out), optional :: ypp - !> spline coefficients + !! spline coefficients real(dp) :: aa, bb, cc, dd - !> reciprocal second fitting point + !! reciprocal second fitting point real(dp) :: dx1 ! assert(present(yp) .eqv. present(ypp)) @@ -132,13 +132,13 @@ pure function polyinter(xp, yp, xx) result(yy) !> point, where the polynomial should be evaluated real(dp), intent(in) :: xx - !> value of the polynomial + !! value of the polynomial real(dp) :: yy - !> number of interpolation abscissas + !! number of interpolation abscissas integer :: nn - !> auxiliary variables + !! auxiliary variables integer :: icl, ii, mm real(dp) :: cc(size(xp)), dd(size(xp)) real(dp) :: dx, dxnew, dyy, rtmp diff --git a/sktwocnt/lib/partition.f90 b/sktwocnt/lib/partition.f90 index e846040c..5467566d 100644 --- a/sktwocnt/lib/partition.f90 +++ b/sktwocnt/lib/partition.f90 @@ -31,7 +31,7 @@ pure function partitionFunc(r1, r2, dist, partparams) result(res) !> holds partitioning parameters, if required real(dp), intent(in) :: partparams(:) - !> resulting value of the partition function, between [0,1] + !! resulting value of the partition function, between [0,1] real(dp) :: res end function partitionFunc @@ -57,10 +57,10 @@ pure function partition_becke_homo(r1, r2, dist, partparams) result(res) !> arbitrary dummy real array, unused in this routine real(dp), intent(in) :: partparams(:) - !> resulting value of the partition function, between [0,1] + !! resulting value of the partition function, between [0,1] real(dp) :: res - !> auxiliary variable + !! auxiliary variable integer :: ii ! see A. D. Becke, J. Chem. Phys. 88, 2547 (1988), eqn. 11 @@ -93,13 +93,13 @@ pure function partition_becke_hetero(r1, r2, dist, partparams) result(res) !> real array containing the parameter aij in the Becke partitioning scheme real(dp), intent(in) :: partparams(:) - !> resulting value of the partition function, between [0,1] + !! resulting value of the partition function, between [0,1] real(dp) :: res - !> see A. D. Becke, J. Chem. Phys. 88, 2547 (1988), eqn. 11 + !! see A. D. Becke, J. Chem. Phys. 88, 2547 (1988), eqn. 11 real(dp) :: mu - !> auxiliary variable + !! auxiliary variable integer :: ii ! assert(abs(partparams(1)) <= 0.5_dp) @@ -128,13 +128,13 @@ pure function beckepar(r1, r2) result(res) !> Bragg-Slater radius of first and second atom real(dp), intent(in) :: r1, r2 - !> parameter a_{ij}, see A. D. Becke, J. Chem. Phys. 88, 2547 (1988), eqn. A5 + !! parameter a_{ij}, see A. D. Becke, J. Chem. Phys. 88, 2547 (1988), eqn. A5 real(dp) :: res - !> see A. D. Becke, J. Chem. Phys. 88, 2547 (1988), eqn. A4 + !! see A. D. Becke, J. Chem. Phys. 88, 2547 (1988), eqn. A4 real(dp) :: chi - !> see A. D. Becke, J. Chem. Phys. 88, 2547 (1988), eqn. A6 + !! see A. D. Becke, J. Chem. Phys. 88, 2547 (1988), eqn. A6 real(dp) :: uu chi = sqrt(r1 / r2) diff --git a/sktwocnt/lib/quadrature.f90 b/sktwocnt/lib/quadrature.f90 index 3cfb6df1..0ba07791 100644 --- a/sktwocnt/lib/quadrature.f90 +++ b/sktwocnt/lib/quadrature.f90 @@ -38,13 +38,13 @@ pure subroutine gauss_legendre_quadrature(nn, quad) !> at exit, holds abscissas and weights for numerical quadrature type(TQuadrature), intent(out) :: quad - !> number of roots after symmetry is considered + !! number of roots after symmetry is considered integer :: mm - !> initial approximations to the roots + !! initial approximations to the roots real(dp) :: zz - !> auxiliary variables + !! auxiliary variables integer :: ii, jj real(dp) :: z1, pp, p1, p2, p3, rj @@ -90,10 +90,10 @@ pure subroutine gauss_chebyshev_quadrature(nn, quad) !> at exit, holds abscissas and weights for numerical quadrature type(TQuadrature), intent(out) :: quad - !> recurring argument of trigonometry functions + !! recurring argument of trigonometry functions real(dp) :: rtmp - !> auxiliary variable + !! auxiliary variable integer :: ii allocate(quad%xx(nn)) @@ -120,10 +120,10 @@ pure subroutine trapezoidal_quadrature(nn, quad) !> at exit, holds abscissas and weights for numerical quadrature type(TQuadrature), intent(out) :: quad - !> discretization stepwidth of interval [-1,1] + !! discretization stepwidth of interval [-1,1] real(dp) :: fac - !> auxiliary variable + !! auxiliary variable integer :: ii allocate(quad%xx(nn)) diff --git a/sktwocnt/lib/sphericalharmonics.f90 b/sktwocnt/lib/sphericalharmonics.f90 index 83710f00..24f20c6a 100644 --- a/sktwocnt/lib/sphericalharmonics.f90 +++ b/sktwocnt/lib/sphericalharmonics.f90 @@ -70,7 +70,7 @@ elemental function TRealTessY_getValue(this, theta, phi) result(ang) !> spherical coordinate phi real(dp), intent(in) :: phi - !> value of real tesseral spherical harmonic function + !! value of real tesseral spherical harmonic function real(dp) :: ang ang = calc_realtessy(this%ll, this%mm, theta, phi) @@ -87,7 +87,7 @@ elemental function TRealTessY_getValue_1d(this, theta) result(ang) !> spherical coordinate theta real(dp), intent(in) :: theta - !> value of real tesseral spherical harmonic function + !! value of real tesseral spherical harmonic function real(dp) :: ang ang = calc_realtessy_1d(this%ll, this%mm, theta) @@ -114,7 +114,7 @@ elemental function calc_realtessy(ll, mm, theta, phi) result(rty) !> spherical coordinate phi real(dp), intent(in) :: phi - !> value of real tesseral spherical harmonic function + !! value of real tesseral spherical harmonic function real(dp) :: rty ! assert(ll >= 0 .and. ll <= 3) @@ -184,7 +184,7 @@ elemental function calc_realtessy_1d(ll, mm, theta) result(rty) !> spherical coordinate theta real(dp), intent(in) :: theta - !> value of real tesseral spherical harmonic function + !! value of real tesseral spherical harmonic function real(dp) :: rty ! assert(ll >= 0 .and. ll <= 3) diff --git a/sktwocnt/lib/twocnt.f90 b/sktwocnt/lib/twocnt.f90 index a7f5fd8a..47f777ac 100644 --- a/sktwocnt/lib/twocnt.f90 +++ b/sktwocnt/lib/twocnt.f90 @@ -108,55 +108,55 @@ subroutine get_twocenter_integrals(inp, imap, skham, skover) !> resulting Hamiltonian and overlap matrices real(dp), intent(out), allocatable :: skham(:,:), skover(:,:) - !> abscissas and weight instances for numerical quadrature + !! abscissas and weight instances for numerical quadrature type(TQuadrature) :: quads(2) - !> pointer to atomic properties of dimer atoms + !! pointer to atomic properties of dimer atoms type(TAtomdata), pointer :: atom1, atom2 - !> database that holds Hamiltonian and overlap matrices + !! database that holds Hamiltonian and overlap matrices type(TFiFoReal2) :: hamfifo, overfifo - !> integration grids of dimer atoms, holding spherical coordinates (r, theta) + !! integration grids of dimer atoms, holding spherical coordinates (r, theta) real(dp), allocatable :: grid1(:,:), grid2(:,:) - !> ??? and integration weights + !! ??? and integration weights real(dp), allocatable :: dots(:), weights(:) - !> relative density integration error for all dimer distances of a batch + !! relative density integration error for all dimer distances of a batch real(dp), allocatable :: denserr(:) - !> buffer holding Hamiltonian and overlap of current distance batch + !! buffer holding Hamiltonian and overlap of current distance batch real(dp), allocatable :: skhambuffer(:,:), skoverbuffer(:,:) - !> arbitrary dummy real array, unused for homonuclear Becke partitioning + !! arbitrary dummy real array, unused for homonuclear Becke partitioning real(dp) :: beckepars(1) - !> maximal density integration error + !! maximal density integration error real(dp) :: denserrmax - !> current dimer distance + !! current dimer distance real(dp) :: dist - !> maximum absolute Hamiltonian or overlap matrix element + !! maximum absolute Hamiltonian or overlap matrix element real(dp) :: maxabs - !> maximum dimer distance + !! maximum dimer distance real(dp) :: maxdist - !> iterates through a batch of dimer distances + !! iterates through a batch of dimer distances integer :: ir - !> number of batches for which SK-integrals got calculated + !! number of batches for which SK-integrals got calculated integer :: nBatch - !> number of dimer distances in a single batch + !! number of dimer distances in a single batch integer :: nBatchline - !> true, if dimer distances are shall dynamically be extended if convergency isn't reached + !! true, if dimer distances are shall dynamically be extended if convergency isn't reached logical :: tDynlen - !> true, if maximum absolute Hamiltonian or overlap matrix element is below given tolerance + !! true, if maximum absolute Hamiltonian or overlap matrix element is below given tolerance logical :: tConverged call gauss_legendre_quadrature(inp%ninteg1, quads(1)) @@ -255,43 +255,43 @@ subroutine getskintegrals(atom1, atom2, grid1, grid2, dots, weights, tDensitySup !> relative density integration error real(dp), intent(out) :: denserr - !> instance of real tesseral spherical harmonics + !! instance of real tesseral spherical harmonics type(TRealTessY) :: tes1, tes2 - !> spherical coordinates (r, theta) of atom 1 and atom 2 on grid + !! spherical coordinates (r, theta) of atom 1 and atom 2 on grid real(dp), pointer :: r1(:), r2(:), theta1(:), theta2(:) - !> radial grid-orbital portion for all basis functions of atom 1 + !! radial grid-orbital portion for all basis functions of atom 1 real(dp), allocatable :: radval1(:,:) - !> radial grid-orbital portion and 1st/2nd derivative for all basis functions of atom 2 + !! radial grid-orbital portion and 1st/2nd derivative for all basis functions of atom 2 real(dp), allocatable :: radval2(:,:), radval2p(:,:), radval2pp(:,:) - !> total potential and electron density of two atoms + !! total potential and electron density of two atoms real(dp), allocatable :: potval(:), densval(:) - !> atomic 1st and 2nd density derivatives of atom 1 + !! atomic 1st and 2nd density derivatives of atom 1 real(dp), allocatable :: densval1p(:), densval1pp(:) - !> atomic 1st and 2nd density derivatives of atom 2 + !! atomic 1st and 2nd density derivatives of atom 2 real(dp), allocatable :: densval2p(:), densval2pp(:) - !> real tesseral spherical harmonic for spherical coordinate (theta) of atom 1 and atom 2 + !! real tesseral spherical harmonic for spherical coordinate (theta) of atom 1 and atom 2 real(dp), allocatable :: spherval1(:), spherval2(:) - !> higher-level density expressions + !! higher-level density expressions real(dp), allocatable :: absgr(:), laplace(:), gr_grabsgr(:) - !> temporary storage for Hamiltonian, overlap, density and pre-factors + !! temporary storage for Hamiltonian, overlap, density and pre-factors real(dp) :: integ1, integ2, dens, prefac - !> number of integration points + !! number of integration points integer :: nGrid - !> orbital indices/angular momenta on the two atoms and interaction type + !! orbital indices/angular momenta on the two atoms and interaction type integer :: i1, i2, l1, l2, mm - !> auxiliary variable + !! auxiliary variable integer :: ii r1 => grid1(:, 1) @@ -395,7 +395,7 @@ pure function getOverlap(rad1, rad2, spher1, spher2, weights) result(res) !> integration weights real(dp), intent(in) :: weights(:) - !> resulting orbital overlap + !! resulting orbital overlap real(dp) :: res res = sum(rad1 * rad2 * spher1 * spher2 * weights) @@ -415,7 +415,7 @@ pure function getDensity(rad1, rad2, spher1, spher2, weights) result(res) !> integration weights real(dp), intent(in) :: weights(:) - !> resulting electron density + !! resulting electron density real(dp) :: res res = sum(((rad1 * spher1)**2 + (rad2 * spher2)**2) * weights) @@ -448,7 +448,7 @@ pure function getHamiltonian(rad1, rad2, rad2p, rad2pp, r2, l2, spher1, spher2, !> integration weights real(dp), intent(in) :: weights(:) - !> resulting Hamiltonian matrix element + !! resulting Hamiltonian matrix element real(dp) :: res res = sum((rad1 * spher1)& @@ -482,10 +482,10 @@ pure subroutine getDerivs(drho1, d2rho1, drho2, d2rho2, r1, r2, dots, absgr, lap !> (grad rho4pi) * grad(abs(grad rho4pi)) real(dp), intent(out) :: gr_grabsgr(:) - !> temporary storage + !! temporary storage real(dp), allocatable :: f1(:), f2(:) - !> number of grid points + !! number of grid points integer :: nn nn = size(drho1) @@ -516,16 +516,16 @@ subroutine TIntegMap_init(this, atom1, atom2) !> atomic property instances of dimer atoms type(TAtomdata), intent(in) :: atom1, atom2 - !> number of all nonzero two-center integrals between orbitals of two atoms + !! number of all nonzero two-center integrals between orbitals of two atoms integer :: ninteg - !> maximum mutual angular momentum + !! maximum mutual angular momentum integer :: mmax - !> orbital indices/angular momenta on the two atoms and interaction type + !! orbital indices/angular momenta on the two atoms and interaction type integer :: i1, i2, l1, l2, mm - !> auxiliary variable + !! auxiliary variable integer :: ind mmax = min(maxval(atom1%angmoms), maxval(atom2%angmoms)) diff --git a/sktwocnt/prog/cmdargs.f90 b/sktwocnt/prog/cmdargs.f90 index 7b4e9518..1240f250 100644 --- a/sktwocnt/prog/cmdargs.f90 +++ b/sktwocnt/prog/cmdargs.f90 @@ -15,10 +15,10 @@ module cmdargs !> Parses command line arguments or prints program/version information. subroutine parse_command_arguments() - !> number of command line arguments and length buffer + !! number of command line arguments and length buffer integer :: nArgs, argLen - !> string representation of a single command line argument + !! string representation of a single command line argument character(len=:), allocatable :: arg nArgs = command_argument_count() diff --git a/sktwocnt/prog/input.f90 b/sktwocnt/prog/input.f90 index 241c2f45..efd80546 100644 --- a/sktwocnt/prog/input.f90 +++ b/sktwocnt/prog/input.f90 @@ -31,22 +31,22 @@ subroutine readInput(inp, fname) !> filename character(len=*), intent(in) :: fname - !> file identifier + !! file identifier integer :: fp - !> current line index + !! current line index integer :: iLine - !> character buffer + !! character buffer character(len=maxlen) :: line, buffer1, buffer2 - !> error status + !! error status integer :: iErr - !> potential data columns, summed up in order to receive the total atomic potential + !! potential data columns, summed up in order to receive the total atomic potential integer, allocatable :: potcomps(:) - !> true, if radial grid-orbital 1st/2nd derivative shall be read + !! true, if radial grid-orbital 1st/2nd derivative shall be read logical :: tReadRadDerivs fp = 14 @@ -125,16 +125,16 @@ subroutine readatom_(fname, fp, iLine, potcomps, tDensitySuperpos, tReadRadDeriv !> atomic properties instance type(TAtomdata), intent(out) :: atom - !> character buffer + !! character buffer character(maxlen) :: line, buffer - !> temporarily stores atomic wavefunction and potential + !! temporarily stores atomic wavefunction and potential real(dp), allocatable :: data(:,:), potval(:) - !> error status + !! error status integer :: iErr - !> auxiliary variables + !! auxiliary variables integer :: ii, imax call nextline_(fp, iLine, line) @@ -215,25 +215,25 @@ subroutine readdata_(fname, cols, data) !> obtained data on grid with nGrid entries real(dp), intent(out), allocatable :: data(:,:) - !> temporarily stores all columns of a single line in file + !! temporarily stores all columns of a single line in file real(dp), allocatable :: tmp(:) - !> character buffer for current line of file + !! character buffer for current line of file character(maxlen) :: line - !> number of grid points stored in file + !! number of grid points stored in file integer :: nGrid - !> error status + !! error status integer :: iErr - !> current line + !! current line integer :: iLine - !> file identifier + !! file identifier integer :: fp - !> auxiliary variable + !! auxiliary variable integer :: ii fp = 12 @@ -272,10 +272,10 @@ subroutine nextline_(fp, iLine, line) !> line buffer character(maxlen), intent(out) :: line - !> position of comment string in line if present, otherwise zero + !! position of comment string in line if present, otherwise zero integer :: ii - !> temporarily stores an entire line + !! temporarily stores an entire line character(maxlen) :: buffer do while (.true.) diff --git a/sktwocnt/prog/output.f90 b/sktwocnt/prog/output.f90 index bde38f7d..4a951046 100644 --- a/sktwocnt/prog/output.f90 +++ b/sktwocnt/prog/output.f90 @@ -8,36 +8,54 @@ module output public :: write_sktables - ! Maximal angular momentum in the old and the extended old SK file. + !> maximal angular momentum in the old and the extended old SK file integer, parameter :: LMAX_OLD = 2 + + !> maximal angular momentum in the old and the extended old SK file integer, parameter :: LMAX_EXTENDED = 3 + contains + !> Writes tabulated Hamiltonian and overlap matrix to file. subroutine write_sktables(skham, skover) - real(dp), intent(in) :: skham(:, :), skover(:, :) + + !> Hamiltonian and overlap matrix + real(dp), intent(in) :: skham(:,:), skover(:,:) call write_sktable_("at1-at2.ham.dat", skham) call write_sktable_("at1-at2.over.dat", skover) end subroutine write_sktables + !> Helper routine writing the SK files. - !! \param fname File name. - !! \param sktable Slater-Koster type integrals (Hamiltonian or overlap). subroutine write_sktable_(fname, sktable) - character(*), intent(in) :: fname - real(dp), intent(in) :: sktable(:, :) - integer :: fp, ninteg, nline - character(11) :: formstr + !> file name + character(len=*), intent(in) :: fname + + !> Slater-Koster type integrals (Hamiltonian or overlap) + real(dp), intent(in) :: sktable(:,:) + + !! file identifier + integer :: fp + + !! number of all nonzero two-center integrals + integer :: ninteg + + !! number of dimer distances, i.e. lines of written file + integer :: nline + + !! formatting string + character(len=11) :: formstr ninteg = size(sktable, dim=1) print *, "NINTEG:", ninteg nline = size(sktable, dim=2) write(formstr, "(A,I0,A)") "(", ninteg, "ES21.12)" fp = 14 - open (fp, file=fname, status="replace", action="write") + open(fp, file=fname, status="replace", action="write") write(fp, "(I0)") nline write(fp, formstr) sktable close(fp) From a00eabb51ab147439f4e0697533857b3f7efd661 Mon Sep 17 00:00:00 2001 From: Tammo van der Heide Date: Fri, 7 Jan 2022 18:00:20 +0100 Subject: [PATCH 15/17] Account for feedback of reviewers --- sktwocnt/lib/coordtrans.f90 | 6 +++--- sktwocnt/lib/gridgenerator.f90 | 12 ++++++------ 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/sktwocnt/lib/coordtrans.f90 b/sktwocnt/lib/coordtrans.f90 index 365bfab7..525a6c33 100644 --- a/sktwocnt/lib/coordtrans.f90 +++ b/sktwocnt/lib/coordtrans.f90 @@ -209,9 +209,9 @@ pure subroutine coordtrans_ahlrichs2(c11, spheric, jacobi) spheric(2) = acos(c11(2)) spheric(3) = pi * (c11(3) + 1.0_dp) - jacobi = (zeta * (1.0_dp + c11(1))**alpha / log(2.0_dp)) * (alpha& - & * log(2.0_dp / (1.0_dp - c11(1))) / (1.0_dp + c11(1)) + 1.0_dp / (1.0_dp - c11(1)))& - & * rr * rr * pi + jacobi = (zeta * (1.0_dp + c11(1))**alpha / log(2.0_dp))& + & * (alpha * log(2.0_dp / (1.0_dp - c11(1))) / (1.0_dp + c11(1)) + 1.0_dp& + & / (1.0_dp - c11(1))) * rr * rr * pi end subroutine coordtrans_ahlrichs2 diff --git a/sktwocnt/lib/gridgenerator.f90 b/sktwocnt/lib/gridgenerator.f90 index 9a54981f..ebbe4bd7 100644 --- a/sktwocnt/lib/gridgenerator.f90 +++ b/sktwocnt/lib/gridgenerator.f90 @@ -14,7 +14,7 @@ module gridgenerator contains - !> ??? + !> Generates a 1D (radial) grid around two centers. pure subroutine gengrid1_12(quads, coordtrans, grid, weights) !> abscissas and weights for numerical quadrature @@ -60,7 +60,7 @@ pure subroutine gengrid1_12(quads, coordtrans, grid, weights) end subroutine gengrid1_12 - !> ??? + !> Generates a 2D (radial and azimuthal) grid around two centers. pure subroutine gengrid2_12(quads, coordtrans, partition, partparams, dist, grid1, grid2, dots,& & weights) @@ -121,14 +121,14 @@ pure subroutine gengrid2_12(quads, coordtrans, partition, partparams, dist, grid r2a = sqrt(rtmpa - rtmpb) ! dist > 0 r2b = sqrt(rtmpa + rtmpb) ! dist < 0 - rtmpa = - 0.5_dp * (dist**2 + r2a**2 - r1**2) / (dist * r2a) + rtmpa = -0.5_dp * (dist**2 + r2a**2 - r1**2) / (dist * r2a) rtmpb = 0.5_dp * (dist**2 + r2b**2 - r1**2) / (dist * r2b) ! make sure, we are not sliding out from [-1,1] range for acos rtmpa = min(rtmpa, 1.0_dp) - rtmpa = max(rtmpa, - 1.0_dp) + rtmpa = max(rtmpa, -1.0_dp) rtmpb = min(rtmpb, 1.0_dp) - rtmpb = max(rtmpb, - 1.0_dp) + rtmpb = max(rtmpb, -1.0_dp) theta2a = acos(rtmpa) theta2b = acos(rtmpb) @@ -148,7 +148,7 @@ pure subroutine gengrid2_12(quads, coordtrans, partition, partparams, dist, grid rtmpa = quads(1)%ww(i1) * quads(2)%ww(i2) * jacobi weights(ind) = rtmpa * partition(r1, r2a, dist, partparams) - weights(ind + nn) = rtmpa * partition(r1, r2b, - dist, partparams) + weights(ind + nn) = rtmpa * partition(r1, r2b, -dist, partparams) ind = ind + 1 end do end do From 6d8d37b7909fc6d68def9e1233622e6e02673a46 Mon Sep 17 00:00:00 2001 From: Ziyang HU Date: Sat, 8 Jan 2022 11:28:55 +0800 Subject: [PATCH 16/17] roll back to libxc 4 --- README.rst | 18 +++--------------- slateratom/lib/dft.f90 | 16 +++++----------- 2 files changed, 8 insertions(+), 26 deletions(-) diff --git a/README.rst b/README.rst index 434bd5c8..e21d7df9 100644 --- a/README.rst +++ b/README.rst @@ -23,7 +23,7 @@ Prerequisites * Python3 -* LibXC library with f90 interface (tested with version 5.1.6, version 4.x does +* LibXC library with f90 interface (tested with version 4.3.4, version 5.x does not work due to inteface changes in LibXC) @@ -32,15 +32,11 @@ Building the code Follow the usual CMake build workflow: -* Configure the project, specify your compiler (e.g. ``gfortran``, ``ifort``, etc), the install +* Configure the project, specify your compiler (e.g. ``gfortran``), the install location (e.g. ``$HOME/opt/skprogs``) and the build directory (e.g. ``_build``):: - FC=gfortran cmake -DCMAKE_INSTALL_PREFIX=$HOME/opt/skprogs -DCMAKE_Fortran_FLAGS=-fopenmp -B _build . - - or:: - - FC=ifort cmake -DCMAKE_INSTALL_PREFIX=$HOME/opt/skprogs -DCMAKE_Fortran_FLAGS=-qopenmp -B _build . + FC=gfortran cmake -DCMAKE_INSTALL_PREFIX=$HOME/opt/skprogs -B _build . If libXC is installed in a non-standard location, you may need to specify either the ``CMAKE_PREFIX_PATH`` environment variable (if libXC was built with @@ -51,18 +47,10 @@ Follow the usual CMake build workflow: PKG_CONFIG_PATH=FOLDER_WITH_LIBXC_PC_FILES FC=gfortran cmake [...] - or:: - - CMAKE_PREFIX_PATH=YOUR_LIBXC_INSTALL_FOLDER FC=ifort cmake [...] - - PKG_CONFIG_PATH=FOLDER_WITH_LIBXC_PC_FILES FC=ifort cmake [...] - - * If the configuration was successful, build the code :: cmake --build _build -- -j - * If the build was successful, install the code :: cmake --install _build diff --git a/slateratom/lib/dft.f90 b/slateratom/lib/dft.f90 index 8719d8a6..03190ac9 100644 --- a/slateratom/lib/dft.f90 +++ b/slateratom/lib/dft.f90 @@ -67,9 +67,7 @@ subroutine density_grid(p,max_l,num_alpha,poly_order,alpha,num_mesh_points,& real(dp) :: rhotot,rhodiff,drhotot,ddrhotot,drhodiff,ddrhodiff integer :: ii,jj,kk,ll,mm,oo integer(c_size_t) :: nn - !type(xc_f90_pointer_t) :: xcfunc_x, xcfunc_c, xcinfo - type(xc_f90_func_t) :: xcfunc_x, xcfunc_c - type(xc_f90_func_info_t) :: xcinfo + type(xc_f90_pointer_t) :: xcfunc_x, xcfunc_c, xcinfo real(dp), allocatable :: tmprho(:,:), ex(:), ec(:), vx(:,:), vc(:,:) real(dp), allocatable :: tmpsigma(:,:), vxsigma(:,:), vcsigma(:,:) real(dp), allocatable :: tmpv(:), tmpv2(:) @@ -79,15 +77,11 @@ subroutine density_grid(p,max_l,num_alpha,poly_order,alpha,num_mesh_points,& if (xcnr==0) return if (xcnr == 2) then - call xc_f90_func_init(xcfunc_x, XC_LDA_X, XC_POLARIZED) - xcinfo = xc_f90_func_get_info(xcfunc_x) - call xc_f90_func_init(xcfunc_c, XC_LDA_C_PW, XC_POLARIZED) - xcinfo = xc_f90_func_get_info(xcfunc_x) + call xc_f90_func_init(xcfunc_x, xcinfo, XC_LDA_X, XC_POLARIZED) + call xc_f90_func_init(xcfunc_c, xcinfo, XC_LDA_C_PW, XC_POLARIZED) elseif (xcnr == 3) then - call xc_f90_func_init(xcfunc_x, XC_GGA_X_PBE, XC_POLARIZED) - xcinfo = xc_f90_func_get_info(xcfunc_x) - call xc_f90_func_init(xcfunc_c, XC_GGA_C_PBE, XC_POLARIZED) - xcinfo = xc_f90_func_get_info(xcfunc_x) + call xc_f90_func_init(xcfunc_x, xcinfo, XC_GGA_X_PBE, XC_POLARIZED) + call xc_f90_func_init(xcfunc_c, xcinfo, XC_GGA_C_PBE, XC_POLARIZED) end if do ii=1,num_mesh_points From 6b801d4182f2aae7c7d7ced9b30ebc89653ecee2 Mon Sep 17 00:00:00 2001 From: Tammo van der Heide Date: Wed, 2 Feb 2022 12:44:24 +0100 Subject: [PATCH 17/17] Revise installation process --- .gitignore | 5 ++++ CMakeLists.txt | 2 +- sktools/pyproject.toml | 3 +++ sktools/setup.cfg | 31 ++++++++++++++++++++++++ sktools/setup.py | 42 ++++++++++----------------------- sktools/src/sktools/__init__.py | 2 +- slateratom/prog/cmdargs.f90 | 2 +- 7 files changed, 55 insertions(+), 32 deletions(-) create mode 100644 sktools/pyproject.toml create mode 100644 sktools/setup.cfg diff --git a/.gitignore b/.gitignore index 75f25bd0..d1a19546 100644 --- a/.gitignore +++ b/.gitignore @@ -2,7 +2,12 @@ *.o *.mod *.a +*.bak +*.sav *.pyc __pycache__ *build/ *_build/ +_gitmsg.saved.txt +*.egg-info +dist diff --git a/CMakeLists.txt b/CMakeLists.txt index 4f089310..cd25337c 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -1,6 +1,6 @@ cmake_minimum_required(VERSION 3.16) -project(SkProgs VERSION 0.1 LANGUAGES Fortran) +project(SkProgs VERSION 22.1 LANGUAGES Fortran) include(GNUInstallDirs) diff --git a/sktools/pyproject.toml b/sktools/pyproject.toml new file mode 100644 index 00000000..2a03af9c --- /dev/null +++ b/sktools/pyproject.toml @@ -0,0 +1,3 @@ +[build-system] +requires = ['setuptools', 'wheel', 'numpy'] +build-backend = 'setuptools.build_meta' \ No newline at end of file diff --git a/sktools/setup.cfg b/sktools/setup.cfg new file mode 100644 index 00000000..e6dbaa61 --- /dev/null +++ b/sktools/setup.cfg @@ -0,0 +1,31 @@ +[metadata] +name = sktools +version = 22.1 +author = DFTB+ developers +url = http://www.dftbplus.org +description = Tools to Generate Electronic SK-parameters +long_description = file: README.rst +long_description_content_type = text/x-rst +license = LGPL-3.0-or-later +license_files = + ../COPYING + ../COPYING.LESSER +platform = any + +[options] +include_package_data = True +package_dir = + = src +packages = + sktools + sktools.hsd + sktools.calculators + sktools.skgen +scripts = + bin/collectspinw + bin/collectwavecoeffs + bin/skdiff + bin/skgen +install_requires = + numpy +python_requires = >=3.2 diff --git a/sktools/setup.py b/sktools/setup.py index b0c36428..7c3378a0 100644 --- a/sktools/setup.py +++ b/sktools/setup.py @@ -1,31 +1,15 @@ #!/usr/bin/env python3 -from distutils.core import setup -setup( - name="sktools", - version='20.2', - description="Tools to create SK-parameters", - author="DFTB+ developers", - url="http://www.dftbplus.org", - platforms="platform independent", - package_dir={"": "src"}, - packages=["sktools", "sktools.hsd", "sktools.calculators", "sktools.skgen"], - scripts=[ - "bin/skgen", - ], - classifiers=[ - "Programming Language :: Python", - "Environment :: Console", - "Intended Audience :: Science/Research", - "License :: OSI Approved :: BSD License", - "Operating System :: OS Independent", - "Topic :: Scientific/Engineering", - ], - long_description=""" -Processing and converting data related to the DFTB+ package ------------------------------------------------------------ -A few scripts which should make the life of DFTB+ users easier, by providing -functions to process and convert various DFTB+ data formats. -""", - requires=[ "numpy" ] -) +''' +Legacy setup.py file that gathers its +configuration from setup.cfg and pyproject.toml +''' + +try: + from setuptools import setup +except ImportError: + from distutils.core import setup + + +if __name__ == '__main__': + setup() diff --git a/sktools/src/sktools/__init__.py b/sktools/src/sktools/__init__.py index 3d362066..8903e09f 100644 --- a/sktools/src/sktools/__init__.py +++ b/sktools/src/sktools/__init__.py @@ -1 +1 @@ -PACKAGE_VERSION = '0.4' +PACKAGE_VERSION = '22.1' diff --git a/slateratom/prog/cmdargs.f90 b/slateratom/prog/cmdargs.f90 index b1510c21..0907d440 100644 --- a/slateratom/prog/cmdargs.f90 +++ b/slateratom/prog/cmdargs.f90 @@ -2,7 +2,7 @@ module cmdargs implicit none character(*), parameter :: programName = 'slateratom' - character(*), parameter :: programVersion = '0.9' + character(*), parameter :: programVersion = '22.1' contains