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**
+
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 00000000..d1a19546
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,13 @@
+*~
+*.o
+*.mod
+*.a
+*.bak
+*.sav
+*.pyc
+__pycache__
+*build/
+*_build/
+_gitmsg.saved.txt
+*.egg-info
+dist
diff --git a/AUTHORS.rst b/AUTHORS.rst
new file mode 100644
index 00000000..100af573
--- /dev/null
+++ b/AUTHORS.rst
@@ -0,0 +1,18 @@
+*******
+Authors
+*******
+
+The following people (in alphabetic order by their family names) have
+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)
+
+* 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..cd25337c
--- /dev/null
+++ b/CMakeLists.txt
@@ -0,0 +1,59 @@
+cmake_minimum_required(VERSION 3.16)
+
+project(SkProgs VERSION 22.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..acc801a5 100644
--- a/README.rst
+++ b/README.rst
@@ -1 +1,96 @@
-Package containing tools for creating DFTB parameterizations
+*******
+SkProgs
+*******
+
+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
+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, build the code ::
+
+ cmake --build _build -- -j
+
+* If the build was successful, install the code ::
+
+ 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
+=======
+
+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..16577963
--- /dev/null
+++ b/common/lib/CMakeLists.txt
@@ -0,0 +1,20 @@
+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()
diff --git a/common/lib/accuracy.F90 b/common/lib/accuracy.F90
new file mode 100644
index 00000000..e20221ac
--- /dev/null
+++ b/common/lib/accuracy.F90
@@ -0,0 +1,29 @@
+!> 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
+
+ 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 = real64
+
+ !> 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/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/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_real1.F90 b/common/lib/fifo_real1.F90
new file mode 100644
index 00000000..31e20446
--- /dev/null
+++ b/common/lib/fifo_real1.F90
@@ -0,0 +1,297 @@
+!> 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
+ private
+
+ public :: TFiFoReal1
+
+
+ !> Extended data type.
+ type :: TMyData
+
+ real(dp), allocatable :: data(:)
+
+ end type TMyData
+
+
+ !> Extended fifo.
+ type, extends(TFiFoBase) :: TFiFoReal1
+
+ contains
+
+ 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 => TFiFoReal1_datatofile
+ procedure :: datafromfile => TFiFoReal1_datafromfile
+
+ end type TFiFoReal1
+
+
+contains
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!! TFIFOREAL1 Routines
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !> Makes a copy of item and stores it in the collection.
+ !! \param this Instance.
+ !! \param item Item to store.
+ subroutine TFiFoReal1_push(this, item)
+
+ class(TFiFoReal1), intent(inout) :: this
+
+ real(dp), intent(in) :: item(:)
+
+ class(*), pointer :: wrapper
+
+ allocate(TMyData :: wrapper)
+ select type(wrapper)
+ type is (TMyData)
+ wrapper%data = item
+ end select
+ call this%pushptr(wrapper)
+
+ end subroutine TFiFoReal1_push
+
+
+ !> Retrieves the next item (fifo) and removes it from the collection.
+ !! \param this Instance.
+ !! \param item Item storing the result.
+ subroutine TFiFoReal1_pop(this, item)
+
+ class(TFiFoReal1), intent(inout) :: this
+
+ real(dp), intent(out) :: item(:)
+
+ class(*), pointer :: wrapper
+
+ call this%popptr(wrapper)
+ select type (wrapper)
+ type is (TMyData)
+ item(:) = wrapper%data
+ end select
+ deallocate(wrapper)
+
+ end subroutine TFiFoReal1_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 this Instance.
+ !! \param item Item storing the result.
+ subroutine TFiFoReal1_get(this, item)
+
+ class(TFiFoReal1), intent(inout) :: this
+
+ real(dp), intent(out) :: item(:)
+
+ class(*), pointer :: wrapper
+
+ call this%getptr(wrapper)
+ select type (wrapper)
+ type is (TMyData)
+ item(:) = wrapper%data
+ end select
+
+ end subroutine TFiFoReal1_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 this Instance.
+ !! \param item Item to store. Deallocated on return.
+ subroutine TFiFoReal1_push_alloc(this, item)
+
+ class(TFiFoReal1), intent(inout) :: this
+
+ real(dp), allocatable, intent(inout) :: item(:)
+
+ class(*), pointer :: wrapper
+
+ allocate(TMyData :: wrapper)
+ select type (wrapper)
+ type is (TMyData)
+ call move_alloc(item, wrapper%data)
+ end select
+ call this%pushptr(wrapper)
+
+ end subroutine TFiFoReal1_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 this Instance.
+ !! \param item Item storing the result.
+ subroutine TFiFoReal1_pop_alloc(this, item)
+
+ class(TFiFoReal1), intent(inout) :: this
+
+ real(dp), allocatable, intent(out) :: item(:)
+
+ class(*), pointer :: wrapper
+
+ call this%popptr(wrapper)
+ select type (wrapper)
+ type is (TMyData)
+ call move_alloc(wrapper%data, item)
+ end select
+ deallocate(wrapper)
+
+ end subroutine TFiFoReal1_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 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 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 this%getptr(wrapper)
+ select type (wrapper)
+ type is (TMyData)
+ itemshape(:) = shape(wrapper%data)
+ end select
+ allocate(items(itemshape(1), size(this)))
+ do ii = 1, size(this)
+ call this%pop(items(:, ii))
+ end do
+
+ end subroutine TFiFoReal1_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 this Instance.
+ !! \param items Array containing the items.
+ 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(this)
+ call this%getptr(wrapper)
+ select type (wrapper)
+ type is (TMyData)
+ total = total + size(wrapper%data)
+ end select
+ end do
+ allocate(items(total))
+ ind = 1
+ do ii = 1, size(this)
+ call this%popptr(wrapper)
+ select type (wrapper)
+ type is (TMyData)
+ nn = size(wrapper%data)
+ items(ind:ind+nn-1) = wrapper%data(:)
+ ind = ind + nn
+ end select
+ deallocate(wrapper)
+ end do
+
+ end subroutine TFiFoReal1_popall_concat
+
+
+ !> Overrides the datatofile method of the base class.
+ !! \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 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 (TMyData)
+ write(fileid, pos=filepos) shape(data%data)
+ write(fileid) data%data
+ end select
+ deallocate(data)
+
+ end subroutine TFiFoReal1_datatofile
+
+
+ !> Overides the datafromfile method of the base class.
+ !! \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 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(TMyData :: data)
+ select type (data)
+ type is (TMyData)
+ read(fileid, pos=filepos) itemshape
+ allocate(data%data(itemshape(1)))
+ read(fileid) data%data
+ end select
+
+ end subroutine TFiFoReal1_datafromfile
+
+
+end module common_fifo_real1
diff --git a/common/lib/fifo_real2.F90 b/common/lib/fifo_real2.F90
new file mode 100644
index 00000000..9ac61131
--- /dev/null
+++ b/common/lib/fifo_real2.F90
@@ -0,0 +1,299 @@
+!> 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
+ private
+
+ public :: TFiFoReal2
+
+
+ !> Extended data type.
+ type :: TMyData
+ real(dp), allocatable :: data(:,:)
+ end type TMyData
+
+
+ !> Extendid fifo.
+ type, extends(TFiFoBase) :: TFiFoReal2
+ contains
+ 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 => TFiFoReal2_datatofile
+ procedure :: datafromfile => TFiFoReal2_datafromfile
+ end type TFiFoReal2
+
+
+contains
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!! TFIFOREAL2 Routines
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !> Makes a copy of item and stores it in the collection.
+ !! \param this Instance.
+ !! \param item Item to store.
+ subroutine TFiFoReal2_push(this, item)
+
+ class(TFiFoReal2), intent(inout) :: this
+
+ real(dp), intent(in) :: item(:,:)
+
+ class(*), pointer :: wrapper
+
+ allocate(TMyData :: wrapper)
+ select type(wrapper)
+ type is (TMyData)
+ wrapper%data = item ! Automatic allocation
+ end select
+ call this%pushptr(wrapper)
+
+ end subroutine TFiFoReal2_push
+
+
+ !> Retrieves the next item (fifo) and removes it from the collection.
+ !! \param this Instance.
+ !! \param item Item storing the result.
+ subroutine TFiFoReal2_pop(this, item)
+
+ class(TFiFoReal2), intent(inout) :: this
+
+ real(dp), intent(out) :: item(:,:)
+
+ class(*), pointer :: wrapper
+
+ call this%popptr(wrapper)
+ select type (wrapper)
+ type is (TMyData)
+ item(:,:) = wrapper%data
+ end select
+ deallocate(wrapper)
+
+ end subroutine TFiFoReal2_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 this Instance.
+ !! \param item Item storing the result.
+ subroutine TFiFoReal2_get(this, item)
+
+ class(TFiFoReal2), intent(inout) :: this
+
+ real(dp), intent(out) :: item(:,:)
+
+ class(*), pointer :: wrapper
+
+ call this%getptr(wrapper)
+ select type (wrapper)
+ type is (TMyData)
+ item(:,:) = wrapper%data
+ end select
+
+ end subroutine TFiFoReal2_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 this Instance.
+ !! \param item Item to store. Deallocated on return.
+ subroutine TFiFoReal2_push_alloc(this, item)
+
+ class(TFiFoReal2), intent(inout) :: this
+
+ real(dp), allocatable, intent(inout) :: item(:,:)
+
+ class(*), pointer :: wrapper
+
+ allocate(TMyData :: wrapper)
+ select type (wrapper)
+ type is (TMyData)
+ call move_alloc(item, wrapper%data)
+ end select
+ call this%pushptr(wrapper)
+
+ end subroutine TFiFoReal2_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 this Instance.
+ !! \param item Item storing the result.
+ subroutine TFiFoReal2_pop_alloc(this, item)
+
+ class(TFiFoReal2), intent(inout) :: this
+
+ real(dp), allocatable, intent(out) :: item(:,:)
+
+ class(*), pointer :: wrapper
+
+ call this%popptr(wrapper)
+ select type (wrapper)
+ type is (TMyData)
+ call move_alloc(wrapper%data, item)
+ end select
+ deallocate(wrapper)
+
+ end subroutine TFiFoReal2_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 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 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 this%getptr(wrapper)
+ select type (wrapper)
+ type is (TMyData)
+ itemshape = shape(wrapper%data)
+ end select
+ allocate(items(itemshape(1), itemshape(2), size(this)))
+ do ii = 1, size(this)
+ call this%pop(items(:,:,ii))
+ end do
+
+ end subroutine TFiFoReal2_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 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 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(this)
+ call this%getptr(wrapper)
+ select type (wrapper)
+ type is (TMyData)
+ 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(this)
+ call this%popptr(wrapper)
+ select type (wrapper)
+ type is (TMyData)
+ nn = size(wrapper%data, dim=2)
+ items(:,ind:ind+nn-1) = wrapper%data
+ ind = ind + nn
+ end select
+ deallocate(wrapper)
+ end do
+
+ end subroutine TFiFoReal2_popall_concat
+
+
+ !> Overides the datatofile method of the base class.
+ !! \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 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 (TMyData)
+ write(fileid, pos=filepos) shape(data%data)
+ write(fileid) data%data
+ end select
+ deallocate(data)
+
+ end subroutine TFiFoReal2_datatofile
+
+
+ !> Overides the datafromfile method of the base class.
+ !! \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 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(TMyData :: data)
+ select type (data)
+ type is (TMyData)
+ read(fileid, pos=filepos) itemshape
+ allocate(data%data(itemshape(1), itemshape(2)))
+ read(fileid) data%data
+ end select
+
+ end subroutine TFiFoReal2_datafromfile
+
+
+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/taggedout.F90 b/common/lib/taggedout.F90
new file mode 100644
index 00000000..5a79d6af
--- /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/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..fc85ae48
--- /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..295e7c05
--- /dev/null
+++ b/sktools/bin/collectspinw
@@ -0,0 +1,73 @@
+#!/usr/bin/env python3
+
+'''Collects spin coupling constants.'''
+
+import argparse
+from sktools.skdef import Skdef
+import sktools.skgen as skgen
+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.
+ '''
+
+SCRIPTNAME = sc.get_script_name()
+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]
+ elems = skdef.atomparameters.keys()
+
+ 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)
+
+ 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__':
+ main()
diff --git a/sktools/bin/collectwavecoeffs b/sktools/bin/collectwavecoeffs
new file mode 100755
index 00000000..7de705d0
--- /dev/null
+++ b/sktools/bin/collectwavecoeffs
@@ -0,0 +1,84 @@
+#!/usr/bin/env python3
+
+'''Collects coefficient information for waveplot.'''
+
+
+import os.path
+
+from sktools.common import ANGMOM_TO_SHELL, writefloats
+from sktools.taggedfile import TaggedFile
+from sktools.skdef import Skdef
+from sktools.oldskfile import OldSKFile
+
+
+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):
+ '''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))
+ for nn, ll in atomconfig.valenceorbs:
+ 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 main():
+ '''Main driver routine.'''
+
+ skdefs = Skdef.fromfile('skdefs.py')
+ atomconfigs = skdefs.atomconfigs
+ elems = atomconfigs.keys()
+
+ 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
new file mode 100755
index 00000000..8f57f716
--- /dev/null
+++ b/sktools/bin/skdiff
@@ -0,0 +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
+
+
+USAGE = \
+ '''
+ Reads two SK-files and compares the numerical values stored in them.
+ '''
+
+
+def parseargs():
+ '''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.'''
+
+ 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():
+ '''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:''')
+ 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..4bb48aff
--- /dev/null
+++ b/sktools/bin/skgen
@@ -0,0 +1,288 @@
+#!/usr/bin/env python3
+
+'''
+Module to generate homo- and hetero-nuclear Slater-Koster files.
+'''
+
+
+import sys
+import argparse
+import numpy as np
+
+
+import sktools.common as sc
+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()
+
+# 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():
+ '''Main driver routine.'''
+
+ 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..eba0784d
--- /dev/null
+++ b/sktools/bin/skmanip
@@ -0,0 +1,119 @@
+#!/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))
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
new file mode 100644
index 00000000..7c3378a0
--- /dev/null
+++ b/sktools/setup.py
@@ -0,0 +1,15 @@
+#!/usr/bin/env python3
+
+'''
+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
new file mode 100644
index 00000000..8903e09f
--- /dev/null
+++ b/sktools/src/sktools/__init__.py
@@ -0,0 +1 @@
+PACKAGE_VERSION = '22.1'
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..b98f4e5e
--- /dev/null
+++ b/sktools/src/sktools/common.py
@@ -0,0 +1,668 @@
+'''Common functionality used by the project.'''
+
+
+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):
+ '''Custom exception of the skgen script.'''
+
+
+def openfile(fobj, mode):
+ '''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
+
+
+def writefloats(fp, nums, indent=0, indentstr=None, numperline=4,
+ 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'
+ 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(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 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):
+ '''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
+ else:
+ self._fp = fname_or_handler
+ 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.'''
+
+ 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('_'):
+ super().__setattr__(key, value)
+ else:
+ self[key] = value
+
+ def __getattr__(self, item):
+ if item.startswith('_'):
+ return super().__getattribute__(item)
+ 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
+ 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.
+
+ Args:
+
+ msg (str): error message
+ errorcode (int): error code to raise
+
+ '''
+
+ LOGGER.critical(msg)
+ sys.exit(errorcode)
+
+
+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)
+ 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 shellname in 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):
+ '''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)
+
+ 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):
+ '''Returns true, if the dictionary in shelf file matches reference.'''
+
+ 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):
+ '''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')
+ 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}'
+ }
+ 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):
+ '''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)
+ if len(pathname_abs) < len(pathname_rel):
+ pathname = pathname_abs
+ else:
+ pathname = pathname_rel
+
+ 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(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
new file mode 100644
index 00000000..81ac3774
--- /dev/null
+++ b/sktools/src/sktools/compressions.py
@@ -0,0 +1,185 @@
+'''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 corresponding 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..75d1dd90
--- /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..4cdfceb7
--- /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..b47b7651
--- /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..36704072
--- /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..318d5161
--- /dev/null
+++ b/sktools/src/sktools/skdef.py
@@ -0,0 +1,529 @@
+"""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
+ atomparameters : 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.get_shellvalues(customonsites_node, query)
+
+ customhubbards_node = query.getchild(root, "customizedhubbards",
+ optional=True)
+ customhubbards = sc.get_shellvalues(customhubbards_node, query)
+
+ customoccupations_node = query.getchild(root, "customizedoccupations",
+ optional=True)
+ customoccupations = sc.get_shellvalues(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..7ac415a1
--- /dev/null
+++ b/sktools/src/sktools/skgen/atom.py
@@ -0,0 +1,415 @@
+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..cb0f7a99
--- /dev/null
+++ b/sktools/src/sktools/skgen/compression.py
@@ -0,0 +1,287 @@
+'''
+Module to carry out wavefunction and density compressions.
+'''
+
+
+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..c74a0356
--- /dev/null
+++ b/sktools/src/sktools/taggedfile.py
@@ -0,0 +1,118 @@
+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..fd8112cb
--- /dev/null
+++ b/sktwocnt/lib/CMakeLists.txt
@@ -0,0 +1,29 @@
+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)
+
+# 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
+ $
+ $)
+
+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..fdca5033
--- /dev/null
+++ b/sktwocnt/lib/bisection.f90
@@ -0,0 +1,135 @@
+!> Module that contains routines to locate a value in an array using bisection.
+module bisection
+
+ use common_accuracy, only : dp
+
+ implicit none
+ private
+
+ public :: bisect
+
+ !> 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.
+ pure subroutine bisect_real(xx, x0, ind, tol)
+
+ !> 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
+
+ !! 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
+ 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
+ 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
+ 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.
+ pure subroutine bisect_int(xx, x0, ind)
+
+ !> 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
+
+ !! lower, upper and current value index
+ 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..525a6c33
--- /dev/null
+++ b/sktwocnt/lib/coordtrans.f90
@@ -0,0 +1,268 @@
+!> Module that provides several routines related to coordinate transformation.
+module coordtrans
+
+ 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, 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
+
+ !! 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)
+
+ 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 * 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, 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
+
+ !! 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)
+
+ 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, 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)
+
+ 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 (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)
+
+ 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 (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)
+
+ 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 (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
+ 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 (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)
+
+ 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
+
+
+ !> 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
+ 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..45d0c3f6
--- /dev/null
+++ b/sktwocnt/lib/dftbxc.f90
@@ -0,0 +1,474 @@
+!> Module that provides exchange-correlation DFT routines.
+module dftxc
+
+ use, intrinsic :: ieee_arithmetic
+ 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(:)
+
+ !! 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)
+ 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
+
+ !! 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(:)
+
+ !> 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(:)
+
+ !! 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 :: 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), 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)
+ stop
+ elseif (ieee_is_nan(vx)) then
+ print *, "VX NAN", ii
+ stop
+ end if
+ xcpot(ii) = vcup + vx
+ end if
+ end do
+
+ !! 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)
+
+ !
+ ! 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._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
+ ! 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._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._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._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
+ return
+ end if
+ !----------------------------------------------------------------------
+ ! PBE correlation energy
+ ! G=phi(zeta), given after [a](3)
+ ! DELT=bet/gamma , B=A of [a](8)
+ !
+ G = ((1._dp + ZET)**thrd2 + (1._dp - ZET)**thrd2) / 2._dp
+ G3 = G**3
+ 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._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.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
+ VC2 = VCDN + DVCDN
+
+ 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._dp / 3._dp, thrd4=4._dp / 3._dp)
+ parameter(pi=3.14159265358979323846264338327950_dp)
+ parameter(ax=-0.738558766382022405884230032680836_dp)
+
+ parameter(um=0.21951_dp, uk=0.8040_dp, ul=um / uk)
+
+ 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)
+
+ !----------------------------------------------------------------------
+ !----------------------------------------------------------------------
+ ! 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, submitted 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._dp
+ EX = EXL + EXN
+ VX = exunif * thrd4
+ return
+ 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
+
+ !
+ ! PBE enhancement factors checked against NRLMOL
+ !
+ 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.0_dp)
+ EX = EXL + EXN
+ !----------------------------------------------------------------------
+ ! energy done. calculate potential from [b](24)
+ !
+ VX = exunif * (thrd4 * f - (u - thrd4 * s**3) * fss - t * fs)
+
+ 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..ebbe4bd7
--- /dev/null
+++ b/sktwocnt/lib/gridgenerator.f90
@@ -0,0 +1,158 @@
+!> Module that provides routines for quadrature grid generation.
+module gridgenerator
+
+ 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
+
+
+ !> Generates a 1D (radial) grid around two centers.
+ 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(:,:)
+
+ !> 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), 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
+
+
+ !> Generates a 2D (radial and azimuthal) grid around two centers.
+ 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
+
+ !> 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)
+
+ 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**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**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)
+ 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..9c3ecb4b
--- /dev/null
+++ b/sktwocnt/lib/gridorbital.f90
@@ -0,0 +1,297 @@
+!> Module that implements a grid-type orbital.
+module gridorbital
+
+ use common_accuracy, only : dp
+ use common_constants, only : pi
+ use bisection, only : bisect
+ use interpolation, only : polyinter, poly5zero
+
+ implicit none
+ private
+
+ public :: TGridorb1, TGridorb1_init, TGridorb2, TGridorb2_init
+
+
+ !> Contains the data of a grid function.
+ type TGridorb1
+
+ !> number of grid points
+ integer :: nGrid
+
+ !> r, f(r) values on grid
+ real(dp), allocatable :: rvalues(:), fvalues(:)
+
+ 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(:)
+
+ !> 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
+
+
+ !> Wraps around TGridorb1 pointer.
+ type TGridorb1Wrap
+ type(TGridorb1), pointer :: ptr => null()
+ end type TGridorb1Wrap
+
+
+ !> Wraps around TGridorb2 pointer.
+ type TGridorb2Wrap
+ type(TGridorb2), pointer :: ptr => null()
+ end type TGridorb2Wrap
+
+
+ real(dp), parameter :: distfudge = 1.0_dp
+ real(dp), parameter :: deltar = 1e-04_dp
+
+ integer, parameter :: ninter = 8
+ integer, parameter :: nrightinter = 4
+
+ integer, parameter :: npoint = 10000
+ integer, parameter :: ninter2 = 4
+ integer, parameter :: nrightinter2 = 2
+
+
+contains
+
+ !> 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)
+
+ this%nGrid = size(rvals)
+
+ this%rvalues = rvals
+ this%fvalues = fvals
+
+ end subroutine TGridorb1_init
+
+
+ !> Destructs a TGridorb1 grid-orbital.
+ subroutine TGridorb1_destruct(this)
+
+ !> initialised grid-orbital instance to destruct
+ class(TGridorb1), intent(inout) :: this
+
+ if (allocated(this%rvalues)) deallocate(this%rvalues)
+ if (allocated(this%fvalues)) deallocate(this%fvalues)
+
+ end subroutine TGridorb1_destruct
+
+
+ !> 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
+
+ !! auxiliary variables
+ integer :: ind, iStart, iEnd
+ real(dp) :: rmax, f0, f1, f2, f1p, f1pp
+
+ ! sanity check
+ ! 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 < this%nGrid) then
+ ! before last gridpoint
+ 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 = this%nGrid
+ iStart = iEnd - ninter + 1
+
+ ! calculate 1st und 2nd derivatives at the end
+ 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)
+ end if
+
+ 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
+
+ !> r, f(r) values on grid
+ real(dp), intent(in) :: rvals(:), fvals(:)
+
+ !! 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)
+
+ call TGridorb1_init(orb, rvals, fvals)
+
+ 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)
+ this%rvalues(ii) = rr
+ this%fvalues(ii) = orb%getValue(rr)
+ end do
+
+ ! 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 a TGridorb2 grid-orbital.
+ subroutine TGridorb2_destruct(this)
+
+ !> initialised grid-orbital instance to destruct
+ class(TGridorb2), intent(inout) :: this
+
+ if (allocated(this%fvalues)) deallocate(this%fvalues)
+
+ 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
+
+ !! auxiliary variables
+ integer :: ind, iStart, iEnd
+ real(dp) :: rmax, f0, f1, f2, f1p, f1pp
+ real(dp) :: xx
+
+ if (rr > this%rcut) then
+ rad = 0.0_dp
+ end if
+
+ ! abscissa
+ xx = (1.0_dp - rr) / (1.0_dp + 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 = this%nGrid
+ iStart = iEnd - ninter2 + 1
+
+ ! calculate 1st und 2nd derivatives at the end
+ 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)
+ end if
+
+ 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
+
+ !> rescaling factor for f(r) values
+ real(dp), intent(in) :: fac
+
+ this%fvalues = this%fvalues * fac
+
+ end subroutine TGridorb2_rescale
+
+end module gridorbital
diff --git a/sktwocnt/lib/interpolation.f90 b/sktwocnt/lib/interpolation.f90
new file mode 100644
index 00000000..d20bb154
--- /dev/null
+++ b/sktwocnt/lib/interpolation.f90
@@ -0,0 +1,186 @@
+!> Module that contains routines for inter- and extrapolation.
+module interpolation
+
+ 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.
+ !! \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, 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**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 = ((aa * xr + bb) * xr + cc) * xr**3
+
+ end function poly5zero
+
+
+ !! Returns the value of a free spline at a certain point.
+ !! \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)
+
+ !> 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
+
+ !! spline coefficients
+ real(dp) :: aa, bb, cc, dd
+
+ !! reciprocal second fitting point
+ real(dp) :: dx1
+
+ ! assert(present(yp) .eqv. present(ypp))
+
+ dx1 = 1.0_dp / dx
+
+ aa = y0
+ bb = y0p
+ cc = 0.5_dp * y0pp
+ 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.
+ !! \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
+
+ !! 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)
+
+ 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..5467566d
--- /dev/null
+++ b/sktwocnt/lib/partition.f90
@@ -0,0 +1,152 @@
+!> Module that provides (Becke's) space partitioning functions.
+module partition
+
+ use common_accuracy, only : dp
+
+ implicit none
+ private
+
+ 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 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_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
+
+ !! 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,
+ !! 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
+
+ !! 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
+
+ end function beckepar
+
+end module partition
diff --git a/sktwocnt/lib/quadrature.f90 b/sktwocnt/lib/quadrature.f90
new file mode 100644
index 00000000..0ba07791
--- /dev/null
+++ b/sktwocnt/lib/quadrature.f90
@@ -0,0 +1,140 @@
+!> Module that provides several quadrature related functionalities.
+module quadratures
+
+ use common_accuracy, only : dp
+ use common_constants, only : pi
+
+ implicit none
+ private
+
+ 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 TQuadrature
+
+ !> relative quadrature precision
+ real(dp), parameter :: eps = 1e-14_dp
+
+
+contains
+
+ !> 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
+
+ !> 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))
+
+ 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) exit
+ end do
+ 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 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
+
+ !> at exit, holds abscissas and weights for numerical quadrature
+ type(TQuadrature), intent(out) :: quad
+
+ !! recurring argument of trigonometry functions
+ real(dp) :: rtmp
+
+ !! 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)
+ 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],
+ !! see Numerical Recipes.
+ pure subroutine trapezoidal_quadrature(nn, quad)
+
+ !> number of points for the quadrature
+ integer, intent(in) :: nn
+
+ !> at exit, holds abscissas and weights for numerical quadrature
+ type(TQuadrature), intent(out) :: quad
+
+ !! discretization stepwidth of interval [-1,1]
+ real(dp) :: fac
+
+ !! 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)
+ 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..24f20c6a
--- /dev/null
+++ b/sktwocnt/lib/sphericalharmonics.f90
@@ -0,0 +1,242 @@
+!> Module that provides the functionality for real tesseral spherical harmonics.
+module sphericalharmonics
+
+ use common_accuracy, only : dp
+
+ implicit none
+ private
+
+ public :: TRealTessY, TRealTessY_init
+
+
+ !> Real tesseral spherical harmonics.
+ type TRealTessY
+
+ !> angular momentum
+ integer :: ll
+
+ !> magnetic quantum number
+ integer :: mm
+
+ contains
+
+ procedure :: getValue => TRealTessY_getValue
+ procedure :: getValue_1d => TRealTessY_getValue_1d
+ procedure :: destruct => TRealTessY_destruct
+
+ end type TRealTessY
+
+
+contains
+
+ !> 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
+
+
+ !> Destroys an initialised instance.
+ subroutine TRealTessY_destruct(this)
+
+ !> real tesseral spherical harmonics instance
+ class(TRealTessY), intent(inout) :: this
+
+ continue
+
+ 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
+
+ !! value of real tesseral spherical harmonic function
+ real(dp) :: ang
+
+ ang = calc_realtessy(this%ll, this%mm, theta, phi)
+
+ end function TRealTessY_getValue
+
+
+ !> 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_realtessy_1d(this%ll, this%mm, theta)
+
+ end function TRealTessY_getValue_1d
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!! private functions
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !> 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
+
+ !> 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)
+
+ 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_realtessy
+
+
+ !> 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)
+
+ 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_realtessy_1d
+
+end module sphericalharmonics
diff --git a/sktwocnt/lib/twocnt.f90 b/sktwocnt/lib/twocnt.f90
new file mode 100644
index 00000000..47f777ac
--- /dev/null
+++ b/sktwocnt/lib/twocnt.f90
@@ -0,0 +1,561 @@
+!> Module that contains the two-center integrator routines for tabulating Hamiltonian and overlap.
+module twocnt
+
+ 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 :: TTwocntInp, TAtomdata, TIntegMap
+ public :: get_twocenter_integrals
+
+
+ ! Holds properties associated with a single atom.
+ type TAtomdata
+
+ !> number of basis functions
+ integer :: nBasis
+
+ !> angular momenta
+ integer, allocatable :: angmoms(:)
+
+ !> 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
+
+ !> 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
+
+ !> 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 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(:,:)
+
+ !> 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 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)
+
+ !> 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)
+
+ !! pointer to atomic properties of dimer atoms
+ type(TAtomdata), pointer :: atom1, atom2
+
+ !! database that holds Hamiltonian and overlap matrices
+ type(TFiFoReal2) :: hamfifo, overfifo
+
+ !! 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(:)
+
+ !! 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)
+
+ !! 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
+
+ !! 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
+ end if
+ call TIntegMap_init(imap, atom1, atom2)
+
+ ! calculate lines for 1 Bohr in one batch.
+ dist = 0.0_dp
+ 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)
+ 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_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 (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
+ tConverged = .true.
+ call hamfifo%push_alloc(skhambuffer)
+ call overfifo%push_alloc(skoverbuffer)
+ exit
+ end if
+ end do
+ 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
+
+ ! hand over Hamiltonian and overlap
+ call hamfifo%popall_concat(skham)
+ call overfifo%popall_concat(skover)
+
+ end subroutine get_twocenter_integrals
+
+
+ !> 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
+
+ !> 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(:)
+
+ !! 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
+
+ !! 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))
+
+ ! get radial portions of all basis functions of atom 1
+ do ii = 1, size(radval1, dim=2)
+ 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) = 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. tDensitySuperpos) then
+ potval(:) = atom1%pot%getValue(r1) + atom2%pot%getValue(r2)
+ else
+ 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)
+ ! 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!"
+ stop
+ end select
+ ! 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 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
+ 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
+
+ !> 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
+
+
+ !> 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(:)
+
+ !> 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
+
+
+ !> 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 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)
+
+ 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)
+
+ !> 1st and 2nd atomic density derivatives on grid
+ real(dp), intent(in) :: drho1(:), d2rho1(:), drho2(:), d2rho2(:)
+
+ !> 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)
+ 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 two-center integration map based on the basis on two atoms.
+ subroutine TIntegMap_init(this, atom1, atom2)
+
+ !> two-center integration mapping instance
+ type(TIntegMap), intent(out) :: this
+
+ !> atomic property instances of dimer atoms
+ type(TAtomdata), intent(in) :: atom1, atom2
+
+ !! 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 mm = 0, min(l1, l2)
+ ninteg = ninteg + 1
+ this%index(i1, i2, mm + 1) = ninteg
+ end do
+ end do
+ end do
+ 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 mm = 1, min(l1, l2) + 1
+ ind = ind + 1
+ this%type(:, ind) = [i1, i2, mm]
+ end do
+ end do
+ end do
+
+ end subroutine TIntegMap_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..1240f250
--- /dev/null
+++ b/sktwocnt/prog/cmdargs.f90
@@ -0,0 +1,41 @@
+!> 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'
+
+
+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
+
+ !! string representation of a single command line argument
+ character(len=:), 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..efd80546
--- /dev/null
+++ b/sktwocnt/prog/input.f90
@@ -0,0 +1,356 @@
+!> Module that handles input parsing of configuration and raw data.
+module input
+
+ use common_accuracy, only : dp
+ use gridorbital, only : TGridorb2_init
+ use twocnt, only : TTwocntInp, TAtomdata
+
+ implicit none
+ private
+
+ 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
+
+ !> 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
+
+ !! 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(:)
+
+ !! true, if radial grid-orbital 1st/2nd derivative shall be read
+ logical :: tReadRadDerivs
+
+ fp = 14
+ 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)", fname, line, iLine)
+ end if
+ inp%tHetero = (buffer1 == "hetero")
+ select case (buffer2)
+ case ("potential")
+ inp%tDensitySuperpos = .false.
+ inp%ixc = 0
+ case ("density_lda")
+ inp%tDensitySuperpos = .true.
+ inp%ixc = 1
+ case ("density_pbe")
+ inp%tDensitySuperpos = .true.
+ inp%ixc = 2
+ case default
+ 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=iErr) inp%r0, inp%dr, inp%epsilon, inp%maxdist
+ call checkerror_(fname, line, iLine, iErr)
+
+ call nextline_(fp, iLine, line)
+ read(line, *, iostat=iErr) inp%ninteg1, inp%ninteg2
+ call checkerror_(fname, line, iLine, iErr)
+
+ if (inp%tDensitySuperpos) then
+ allocate(potcomps(2))
+ potcomps = [2, 3]
+ else
+ allocate(potcomps(3))
+ potcomps = [2, 3, 4]
+ end if
+ 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)
+
+ end subroutine readInput
+
+
+ !> 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
+
+ !> current line index
+ integer, intent(inout) :: iLine
+
+ !> potential data columns, summed up in order to receive the total atomic potential
+ integer, intent(in) :: potcomps(:)
+
+ !> 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
+
+ !! 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=iErr) buffer, atom%angmoms(ii)
+ call checkerror_(fname, line, iLine, iErr)
+ if (tReadRadDerivs) then
+ call readdata_(buffer, [1, 3, 4, 5], data)
+ 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 TGridorb2_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=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
+ do ii = 1, size(potcomps)
+ potval(:) = potval + data(:, potcomps(ii))
+ end do
+ call TGridorb2_init(atom%pot, data(:, 1), potval)
+
+ 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 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."
+ end if
+ end if
+
+ end subroutine readatom_
+
+
+ !> Reads desired colums of a data file.
+ subroutine readdata_(fname, cols, data)
+
+ !> filename
+ character(len=*), intent(in) :: fname
+
+ !> desired columns to read from file
+ integer, intent(in) :: cols(:)
+
+ !> 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
+
+ !! 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)))
+
+ 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)
+
+ end subroutine readdata_
+
+
+ !> 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
+
+ !> 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
+ 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) 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
+ write(*,*) "Only angular momentum up to 'f' is allowed."
+ stop
+ end if
+
+ end subroutine checkangmoms_
+
+
+ !> 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_
+
+
+ !> 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,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..182c423d
--- /dev/null
+++ b/sktwocnt/prog/main.f90
@@ -0,0 +1,31 @@
+!> Program to calculate two-center integrals of Slater-Koster tables.
+program main
+
+ 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
+
+ !> 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")
+ 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..4a951046
--- /dev/null
+++ b/sktwocnt/prog/output.f90
@@ -0,0 +1,65 @@
+!> Output routines for the sktwocnt code.
+module output
+
+ use common_accuracy, only : dp
+
+ implicit none
+ private
+
+ public :: write_sktables
+
+ !> 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)
+
+ !> 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.
+ subroutine write_sktable_(fname, sktable)
+
+ !> 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")
+ 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..edea85b7
--- /dev/null
+++ b/slateratom/lib/broyden.f90
@@ -0,0 +1,481 @@
+module broyden
+
+ use common_accuracy, only : dp
+
+ 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..ae484a03
--- /dev/null
+++ b/slateratom/lib/core_overlap.f90
@@ -0,0 +1,395 @@
+module core_overlap
+
+ use common_accuracy, only : dp
+ use common_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=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)
+ ! 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*real((j-i-1),dp)/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..36d64272
--- /dev/null
+++ b/slateratom/lib/coulomb_hfex.f90
@@ -0,0 +1,311 @@
+module coulomb_hfex
+
+ use common_accuracy, only : dp
+ use common_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*real(ii,dp)+1.0d0)*(2.0d0*real(jj,dp)+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*real(ii,dp)+1.0d0)*(2.0d0*real(jj,dp)+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)/&
+ &(real(lambda+mu+nu+1,dp)*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..5f183884
--- /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 common_accuracy, only : dp
+ 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)*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)*real(2**(nlp+nlq+1),dp)/&
+ &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..89ef944c
--- /dev/null
+++ b/slateratom/lib/density.f90
@@ -0,0 +1,704 @@
+module density
+
+ use common_accuracy, only : dp
+ 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*(real(poly_order+l-1,dp)*&
+ &exp(-alpha*r)-alpha*r**(poly_order+l-1)*exp(-alpha*r))
+ else
+ 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
+
+ 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*(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*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*(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
+
+ 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*&
+ &(real(n-1,dp))*exp(ab*r)
+ else
+ basis_times_basis_1st=normalization1*normalization2*&
+ &(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
+
+ 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=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)
+
+ 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=real((m-1)*(n-1),dp)
+ else
+ 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*real(n-1,dp)+beta*real(m-1,dp))
+ else
+ negative=(alpha*real(n-1,dp)+beta*real(m-1,dp))*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=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*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)
+
+ 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*&
+ &(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
+
+ 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=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)
+
+ 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*&
+ &(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
+
+ 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=real((m-1)*(n-1),dp)*r**(m+n-2)+&
+ &alpha*beta*r**(m+n)
+ 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)
+
+ 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..c44a852a
--- /dev/null
+++ b/slateratom/lib/densitymatrix.f90
@@ -0,0 +1,44 @@
+module densitymatrix
+
+ use common_accuracy, only : dp
+ use common_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..8ad24c75
--- /dev/null
+++ b/slateratom/lib/dft.f90
@@ -0,0 +1,897 @@
+module dft
+
+ use, intrinsic :: iso_c_binding, only : c_size_t
+ use common_accuracy, only : dp
+ use common_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/real(nuc,dp))**(1.0d0/3.0d0)
+
+ do ii=1,num_mesh_points
+
+ x= abcissa(ii)/b
+ rtx= sqrt(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
+
+ 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,oo
+ integer(c_size_t) :: nn
+ 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(:)
+ 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, 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, 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
+
+ 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..7493e0b8
--- /dev/null
+++ b/slateratom/lib/diagonalizations.f90
@@ -0,0 +1,896 @@
+module diagonalizations
+
+ use common_accuracy, only : dp
+
+ 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 common_accuracy, only : dp
+ 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 common_accuracy, only : dp
+ 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 common_accuracy, only : dp
+ 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 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
+! 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 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
+ 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 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
+! 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 common_accuracy, only : dp
+ 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..196152dc
--- /dev/null
+++ b/slateratom/lib/globals.f90
@@ -0,0 +1,126 @@
+module globals
+
+ use common_accuracy, only : dp
+
+ 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..865921e3
--- /dev/null
+++ b/slateratom/lib/hamiltonian.f90
@@ -0,0 +1,271 @@
+module hamiltonian
+
+ use common_accuracy, only : dp
+ use common_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,:,:,:)=-real(nuc,dp)*u(:,:,:)+j_matrix(:,:,:)-k_matrix(1,:,:,:)
+ pot_new(2,:,:,:)=-real(nuc,dp)*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..f25af8bb
--- /dev/null
+++ b/slateratom/lib/input.f90
@@ -0,0 +1,289 @@
+!!* Read input from stdin
+module input
+
+ use common_accuracy, only : dp
+
+ 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..45a51e5b
--- /dev/null
+++ b/slateratom/lib/integration.f90
@@ -0,0 +1,248 @@
+module integration
+
+ use common_accuracy, only : dp
+ use common_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/real(N+1,dp)
+ 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(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
+
+ ! 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/real(N+1,dp)
+
+ do ii=1,N
+
+ ! NOTE prefactor
+ 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
+
+ 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/real(N+1,dp)
+
+ do ii=1,N
+
+ 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
+
+ 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/real(N+1,dp)
+
+ do ii=1,N
+
+ 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
+
+ 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)-real(ii,dp)/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..7abec733
--- /dev/null
+++ b/slateratom/lib/numerical_differentiation.f90
@@ -0,0 +1,164 @@
+module numerical_differentiation
+
+ use common_accuracy, only : dp
+ use common_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), &
+ &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)*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
+
+ 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(TTaggedwriter) :: twriter
+
+ call TTaggedwriter_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(TTaggedwriter) :: twriter
+ character(20) :: fname
+ real(dp), allocatable :: coeffs(:,:)
+
+ call TTaggedwriter_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..3481f97c
--- /dev/null
+++ b/slateratom/lib/total_energy.f90
@@ -0,0 +1,242 @@
+module totalenergy
+
+ use common_accuracy, only : dp
+ use common_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-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
+ 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..5cca3703
--- /dev/null
+++ b/slateratom/lib/utilities.f90
@@ -0,0 +1,157 @@
+module utilities
+
+ use common_accuracy, only : dp
+ use common_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..3033bfbf
--- /dev/null
+++ b/slateratom/lib/zora_routines.f90
@@ -0,0 +1,338 @@
+module zora_routines
+
+ use common_accuracy, only : dp
+ use common_constants
+ use coulomb_potential
+ 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)*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)*real(ii*(ii+1),dp)
+
+ 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)*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)*real(ii*(ii+1),dp)
+
+ 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/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)
+ 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*cc**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)=-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
+
+ 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..0907d440
--- /dev/null
+++ b/slateratom/prog/cmdargs.f90
@@ -0,0 +1,32 @@
+module cmdargs
+ implicit none
+
+ character(*), parameter :: programName = 'slateratom'
+ character(*), parameter :: programVersion = '22.1'
+
+
+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..03caf227
--- /dev/null
+++ b/slateratom/prog/main.f90
@@ -0,0 +1,214 @@
+program HFAtom
+
+ use common_accuracy, only : dp
+ 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()