diff --git a/.readthedocs.yaml b/.readthedocs.yaml
new file mode 100644
index 00000000..f114dbf9
--- /dev/null
+++ b/.readthedocs.yaml
@@ -0,0 +1,32 @@
+# .readthedocs.yaml
+# Read the Docs configuration file
+# See https://docs.readthedocs.io/en/stable/config-file/v2.html for details
+
+# Required
+version: 2
+
+# Set the OS, Python version and other tools you might need
+build:
+ os: ubuntu-22.04
+ tools:
+ python: "3.12"
+ # You can also specify other tool versions:
+ # nodejs: "19"
+ # rust: "1.64"
+ # golang: "1.19"
+
+# Build documentation in the "docs/" directory with Sphinx
+sphinx:
+ configuration: docs/source/conf.py
+
+# Optionally build your docs in additional formats such as PDF and ePub
+# formats:
+# - pdf
+# - epub
+
+# Optional but recommended, declare the Python requirements required
+# to build your documentation
+# See https://docs.readthedocs.io/en/stable/guides/reproducible-builds.html
+python:
+ install:
+ - requirements: docs/requirements.txt
diff --git a/Makefile b/Makefile
index 0be38b3c..d9c9eb47 100644
--- a/Makefile
+++ b/Makefile
@@ -2,4 +2,4 @@ default: build.ninja
bash -c "source quantum_package.rc ; ninja"
build.ninja:
- @bash -c ' echo '' ; echo xxxxxxxxxxxxxxxxxx ; echo "The QP is not configured yet. Please run the ./configure command" ; echo xxxxxxxxxxxxxxxxxx ; echo '' ; ./configure --help' | more
+ @bash -c ' echo '' ; echo xxxxxxxxxxxxxxxxxx ; echo "QP is not configured yet. Please run the ./configure command" ; echo xxxxxxxxxxxxxxxxxx ; echo '' ; ./configure --help' | more
diff --git a/README.md b/README.md
index 5a35f63d..7a9503d7 100644
--- a/README.md
+++ b/README.md
@@ -2,6 +2,9 @@
executables for Quantum Package. Please use ifort as long as you can, and
consider switching to gfortran in the long term.
+---
+
+
# Quantum Package 2.2
diff --git a/bin/qp_convert_output_to_ezfio b/bin/qp_convert_output_to_ezfio
index 1b33f156..6f2d02d0 100755
--- a/bin/qp_convert_output_to_ezfio
+++ b/bin/qp_convert_output_to_ezfio
@@ -227,8 +227,8 @@ def write_ezfio(res, filename):
shell_index += [nshell_tot] * len(b.prim)
shell_num = len(ang_mom)
- assert(shell_index[0] = 1)
- assert(shell_index[-1] = shell_num)
+ assert(shell_index[0] == 1)
+ assert(shell_index[-1] == shell_num)
# ~#~#~#~#~ #
# W r i t e #
diff --git a/bin/qp_plugins b/bin/qp_plugins
index e53b08e9..b1fbeec0 100755
--- a/bin/qp_plugins
+++ b/bin/qp_plugins
@@ -97,7 +97,7 @@ end
def get_repositories():
l_result = [f for f in os.listdir(QP_PLUGINS) \
- if f not in [".gitignore", "local"] ]
+ if f not in [".gitignore", "local", "README.rst"] ]
return sorted(l_result)
diff --git a/bin/qp_set_frozen_core b/bin/qp_set_frozen_core
index f9761144..d2821bd9 100755
--- a/bin/qp_set_frozen_core
+++ b/bin/qp_set_frozen_core
@@ -83,6 +83,7 @@ def main(arguments):
elif charge <= 118: n_frozen += 43
elif arguments["--small"]:
+ for charge in ezfio.nuclei_nucl_charge:
if charge <= 4: pass
elif charge <= 18: n_frozen += 1
elif charge <= 36: n_frozen += 5
diff --git a/configure b/configure
index e211cfd7..41c0123d 100755
--- a/configure
+++ b/configure
@@ -9,7 +9,7 @@ echo "QP_ROOT="$QP_ROOT
unset CC
unset CCXX
-TREXIO_VERSION=2.3.2
+TREXIO_VERSION=2.4.2
# Force GCC instead of ICC for dependencies
export CC=gcc
@@ -219,7 +219,7 @@ EOF
tar -zxf trexio-${VERSION}.tar.gz && rm trexio-${VERSION}.tar.gz
cd trexio-${VERSION}
./configure --prefix=\${QP_ROOT} --without-hdf5 CFLAGS='-g'
- make -j 8 && make -j 8 check && make -j 8 install
+ (make -j 8 || make) && make check && make -j 8 install
tar -zxvf "\${QP_ROOT}"/external/qp2-dependencies/${ARCHITECTURE}/ninja.tar.gz
mv ninja "\${QP_ROOT}"/bin/
EOF
@@ -233,7 +233,7 @@ EOF
tar -zxf trexio-${VERSION}.tar.gz && rm trexio-${VERSION}.tar.gz
cd trexio-${VERSION}
./configure --prefix=\${QP_ROOT} CFLAGS="-g"
- make -j 8 && make -j 8 check && make -j 8 install
+ (make -j 8 || make) && make check && make -j 8 install
EOF
elif [[ ${PACKAGE} = qmckl ]] ; then
@@ -245,7 +245,7 @@ EOF
tar -zxf qmckl-${VERSION}.tar.gz && rm qmckl-${VERSION}.tar.gz
cd qmckl-${VERSION}
./configure --prefix=\${QP_ROOT} --enable-hpc --disable-doc CFLAGS='-g'
- make && make -j 4 check && make install
+ (make -j 8 || make) && make check && make install
EOF
elif [[ ${PACKAGE} = qmckl-intel ]] ; then
@@ -257,7 +257,7 @@ EOF
tar -zxf qmckl-${VERSION}.tar.gz && rm qmckl-${VERSION}.tar.gz
cd qmckl-${VERSION}
./configure --prefix=\${QP_ROOT} --enable-hpc --disable-doc --with-icc --with-ifort CFLAGS='-g'
- make && make -j 4 check && make install
+ (make -j 8 || make) && make check && make install
EOF
diff --git a/docs/ref b/docs/ref
index 58cc4721..49599966 100644
--- a/docs/ref
+++ b/docs/ref
@@ -20,5 +20,5 @@ Then, to reference for "myref" just type :ref:`myref`
or use `IRPF90`_ and define
_IRPF90: http://irpf90.ups-tlse.fr
somewhere
-* References of published results with QP should be added into docs/source/research.bib in bibtex
+* References of published results with QP should be added into docs/source/references.bib in bibtex
format
diff --git a/docs/requirements.txt b/docs/requirements.txt
index b73f3706..135f6044 100644
--- a/docs/requirements.txt
+++ b/docs/requirements.txt
@@ -1,2 +1,2 @@
-sphinxcontrib-bibtex==0.4.0
-sphinx-rtd-theme==0.4.2
+sphinxcontrib-bibtex
+sphinx-rtd-theme
diff --git a/docs/source/appendix/contributors.rst b/docs/source/appendix/contributors.rst
index bf58adc2..74837282 100644
--- a/docs/source/appendix/contributors.rst
+++ b/docs/source/appendix/contributors.rst
@@ -2,13 +2,13 @@
Contributors
============
-The |qp| is maintained by
+The |qp| is maintained by
-Anthony Scemama
+Anthony Scemama
| `Laboratoire de Chimie et Physique Quantiques `_,
| CNRS - Université Paul Sabatier
| Toulouse, France
- | scemama@irsamc.ups-tlse.fr
+ | scemama@irsamc.ups-tlse.fr
Emmanuel Giner
@@ -18,27 +18,27 @@ Emmanuel Giner
| emmanuel.giner@lct.jussieu.fr
-Thomas Applencourt
- | `Argonne Leadership Computing Facility `_
- | Argonne, USA
- | tapplencourt@anl.gov
-
-
-
The following people have contributed to this project (by alphabetical order):
+* Abdallah Ammar
+* Thomas Applencourt
* Roland Assaraf
* Pierrette Barbaresco
* Anouar Benali
* Chandler Bennet
* Michel Caffarel
+* Vijay Gopal Chilkuri
+* Yann Damour
* Grégoire David
+* Amanda Dumi
* Anthony Ferté
-* Madeline Galbraith
+* Madeline Galbraith
* Yann Garniron
* Kevin Gasperich
+* Fabris Kossoski
* Pierre-François Loos
* Jean-Paul Malrieu
+* Antoine Marie
* Barry Moore
* Julien Paquier
* Barthélémy Pradines
@@ -46,9 +46,11 @@ The following people have contributed to this project (by alphabetical order):
* Nicolas Renon
* Lorenzo Tenti
* Julien Toulouse
+* Diata Traoré
* Mikaël Véril
-If you have contributed and don't appear in this list, please modify this file
+If you have contributed and don't appear in this list, please modify the file
+`$QP_ROOT/docs/source/appendix/contributors.rst`
and submit a pull request.
diff --git a/docs/source/appendix/references.rst b/docs/source/appendix/references.rst
new file mode 100644
index 00000000..b277a6ac
--- /dev/null
+++ b/docs/source/appendix/references.rst
@@ -0,0 +1,8 @@
+References
+==========
+
+.. bibliography:: /references.bib
+ :style: unsrt
+ :all:
+
+
diff --git a/docs/source/appendix/research.rst b/docs/source/appendix/research.rst
deleted file mode 100644
index 992cc1eb..00000000
--- a/docs/source/appendix/research.rst
+++ /dev/null
@@ -1,8 +0,0 @@
-Some research made with the |qp|
-================================
-
-.. bibliography:: /research.bib
- :style: unsrt
- :all:
-
-
diff --git a/docs/source/auto_generate.py b/docs/source/auto_generate.py
index d767b922..6b50bce9 100755
--- a/docs/source/auto_generate.py
+++ b/docs/source/auto_generate.py
@@ -29,7 +29,8 @@ def generate_modules(abs_module, entities):
rst += ["", "EZFIO parameters", "----------------", ""]
config_file = configparser.ConfigParser()
with open(EZFIO, 'r') as f:
- config_file.readfp(f)
+# config_file.readfp(f)
+ config_file.read_file(f)
for section in config_file.sections():
doc = config_file.get(section, "doc")
doc = " " + doc.replace("\n", "\n\n ")+"\n"
diff --git a/docs/source/conf.py b/docs/source/conf.py
index 21498968..bafd95fa 100644
--- a/docs/source/conf.py
+++ b/docs/source/conf.py
@@ -70,7 +70,7 @@ master_doc = 'index'
#
# This is also used if you do content translation via gettext catalogs.
# Usually you set "language" from the command line for these cases.
-language = None
+language = "en"
# List of patterns, relative to source directory, that match files and
# directories to ignore when looking for source files.
@@ -208,3 +208,5 @@ epub_exclude_files = ['search.html']
# -- Extension configuration -------------------------------------------------
+bibtex_bibfiles = [ "references.bib" ]
+
diff --git a/docs/source/index.rst b/docs/source/index.rst
index 4231b1f8..273582d4 100644
--- a/docs/source/index.rst
+++ b/docs/source/index.rst
@@ -39,9 +39,10 @@
programmers_guide/programming
programmers_guide/ezfio
programmers_guide/plugins
+ programmers_guide/plugins_tuto_intro
+ programmers_guide/plugins_tuto_I
programmers_guide/new_ks
programmers_guide/index
- programmers_guide/plugins
.. toctree::
@@ -52,5 +53,6 @@
appendix/benchmarks
appendix/license
appendix/contributors
+ appendix/references
diff --git a/docs/source/intro/intro.rst b/docs/source/intro/intro.rst
index aecd072d..6561f11a 100644
--- a/docs/source/intro/intro.rst
+++ b/docs/source/intro/intro.rst
@@ -11,25 +11,25 @@ The |qp|
What it is
==========
-The |qp| is an open-source **programming environment** for quantum chemistry.
-It has been built from the **developper** point of view in order to help
-the design of new quantum chemistry methods,
-especially for `wave function theory `_ (|WFT|).
+The |qp| is an open-source **programming environment** for quantum chemistry.
+It has been built from the **developper** point of view in order to help
+the design of new quantum chemistry methods,
+especially for `wave function theory `_ (|WFT|).
-From the **user** point of view, the |qp| proposes a stand-alone path
-to use optimized selected configuration interaction |sCI| based on the
-|CIPSI| algorithm that can efficiently reach near-full configuration interaction
-|FCI| quality for relatively large systems (see for instance :cite:`Caffarel_2016,Caffarel_2016.2,Loos_2018,Scemama_2018,Dash_2018,Garniron_2017.2,Loos_2018,Garniron_2018,Giner2018Oct`).
-To have a simple example of how to use the |CIPSI| program, go to the `users_guide/quickstart`.
+From the **user** point of view, the |qp| proposes a stand-alone path
+to use optimized selected configuration interaction |sCI| based on the
+|CIPSI| algorithm that can efficiently reach near-full configuration interaction
+|FCI| quality for relatively large systems.
+To have a simple example of how to use the |CIPSI| program, go to the `users_guide/quickstart`.
The main goal is the development of selected configuration interaction |sCI|
methods and multi-reference perturbation theory |MRPT| in the
-determinant-driven paradigm. It also contains the very basics of Kohn-Sham `density functional theory `_ |KS-DFT| and `range-separated hybrids `_ |RSH|.
+determinant-driven paradigm. It also contains the very basics of Kohn-Sham `density functional theory `_ |KS-DFT| and `range-separated hybrids `_ |RSH|.
-The determinant-driven framework allows the programmer to include any arbitrary set of
-determinants in the variational space, and thus gives a complete freedom in the methodological
-development. The basic ingredients of |RSH| together with those of the |WFT| framework available in the |qp| library allows one to easily develop range-separated DFT (|RSDFT|) approaches (see for instance the plugins at ``_).
+The determinant-driven framework allows the programmer to include any arbitrary set of
+determinants in the variational space, and thus gives a complete freedom in the methodological
+development. The basic ingredients of |RSH| together with those of the |WFT| framework available in the |qp| library allows one to easily develop range-separated DFT (|RSDFT|) approaches (see for instance the plugins at ``_).
All the programs are developed with the `IRPF90`_ code generator, which considerably simplifies
the collaborative development, and the development of new features.
@@ -40,20 +40,20 @@ What it is not
==============
The |qp| is *not* a general purpose quantum chemistry program.
-First of all, it is a *library* to develop new theories and algorithms in quantum chemistry.
+First of all, it is a *library* to develop new theories and algorithms in quantum chemistry.
Therefore, beside the use of the programs of the core modules, the users of the |qp| should develop their own programs.
The |qp| has been designed specifically for |sCI|, so all the
algorithms which are programmed are not adapted to run SCF or DFT calculations
on thousands of atoms. Currently, the systems targeted have less than 600
-molecular orbitals. This limit is due to the memory bottleneck induced by the storring of the two-electron integrals (see ``mo_two_e_integrals`` and ``ao_two_e_integrals``).
+molecular orbitals. This limit is due to the memory bottleneck induced by the storring of the two-electron integrals (see ``mo_two_e_integrals`` and ``ao_two_e_integrals``).
The |qp| is *not* a massive production code. For conventional
methods such as Hartree-Fock, CISD or MP2, the users are recommended to use the
existing standard production codes which are designed to make these methods run
fast. Again, the role of the |qp| is to make life simple for the
developer. Once a new method is developed and tested, the developer is encouraged
-to consider re-expressing it with an integral-driven formulation, and to
+to consider re-expressing it with an integral-driven formulation, and to
implement the new method in open-source production codes, such as `NWChem`_
or |GAMESS|.
diff --git a/docs/source/intro/selected.bib b/docs/source/intro/selected.bib
deleted file mode 100644
index 32df8bce..00000000
--- a/docs/source/intro/selected.bib
+++ /dev/null
@@ -1,182 +0,0 @@
-@article{Bytautas_2009,
- doi = {10.1016/j.chemphys.2008.11.021},
- url = {https://doi.org/10.1016%2Fj.chemphys.2008.11.021},
- year = 2009,
- month = {feb},
- publisher = {Elsevier {BV}},
- volume = {356},
- number = {1-3},
- pages = {64--75},
- author = {Laimutis Bytautas and Klaus Ruedenberg},
- title = {A priori identification of configurational deadwood},
- journal = {Chemical Physics}
-}
-
-@article{Anderson_2018,
- doi = {10.1016/j.comptc.2018.08.017},
- url = {https://doi.org/10.1016%2Fj.comptc.2018.08.017},
- year = 2018,
- month = {oct},
- publisher = {Elsevier {BV}},
- volume = {1142},
- pages = {66--77},
- author = {James S.M. Anderson and Farnaz Heidar-Zadeh and Paul W. Ayers},
- title = {Breaking the curse of dimension for the electronic Schrodinger equation with functional analysis},
- journal = {Computational and Theoretical Chemistry}
-}
-
-@article{Bender_1969,
- doi = {10.1103/physrev.183.23},
- url = {http://dx.doi.org/10.1103/PhysRev.183.23},
- year = 1969,
- month = {jul},
- publisher = {American Physical Society ({APS})},
- volume = {183},
- number = {1},
- pages = {23--30},
- author = {Charles F. Bender and Ernest R. Davidson},
- title = {Studies in Configuration Interaction: The First-Row Diatomic Hydrides},
- journal = {Phys. Rev.}
-}
-
-@article{Whitten_1969,
- doi = {10.1063/1.1671985},
- url = {https://doi.org/10.1063%2F1.1671985},
- year = 1969,
- month = {dec},
- publisher = {{AIP} Publishing},
- volume = {51},
- number = {12},
- pages = {5584--5596},
- author = {J. L. Whitten and Melvyn Hackmeyer},
- title = {Configuration Interaction Studies of Ground and Excited States of Polyatomic Molecules. I. The {CI} Formulation and Studies of Formaldehyde},
- journal = {The Journal of Chemical Physics}
-}
-
-@article{Huron_1973,
- doi = {10.1063/1.1679199},
- url = {https://doi.org/10.1063%2F1.1679199},
- year = 1973,
- month = {jun},
- publisher = {{AIP} Publishing},
- volume = {58},
- number = {12},
- pages = {5745--5759},
- author = {B. Huron and J. P. Malrieu and P. Rancurel},
- title = {Iterative perturbation calculations of ground and excited state energies from multiconfigurational zeroth-order wavefunctions},
- journal = {The Journal of Chemical Physics}
-}
-
-@article{Knowles_1984,
- author="Peter J. Knowles and Nicholas C Handy",
- year=1984,
- journal={Chem. Phys. Letters},
- volume=111,
- pages="315--321",
- title="A New Determinant-based Full Configuration Interaction Method"
-}
-
-
-@article{Scemama_2013,
- author = {{Scemama}, A. and {Giner}, E.},
- title = "{An efficient implementation of Slater-Condon rules}",
- journal = {ArXiv [physics.comp-ph]},
- pages = {1311.6244},
- year = 2013,
- month = nov,
- url = {https://arxiv.org/abs/1311.6244}
-}
-
-@article{Sharma_2017,
- doi = {10.1021/acs.jctc.6b01028},
- url = {https://doi.org/10.1021%2Facs.jctc.6b01028},
- year = 2017,
- month = {mar},
- publisher = {American Chemical Society ({ACS})},
- volume = {13},
- number = {4},
- pages = {1595--1604},
- author = {Sandeep Sharma and Adam A. Holmes and Guillaume Jeanmairet and Ali Alavi and C. J. Umrigar},
- title = {Semistochastic Heat-Bath Configuration Interaction Method: Selected Configuration Interaction with Semistochastic Perturbation Theory},
- journal = {Journal of Chemical Theory and Computation}
-}
-
-@article{Holmes_2016,
- doi = {10.1021/acs.jctc.6b00407},
- url = {https://doi.org/10.1021%2Facs.jctc.6b00407},
- year = 2016,
- month = {aug},
- publisher = {American Chemical Society ({ACS})},
- volume = {12},
- number = {8},
- pages = {3674--3680},
- author = {Adam A. Holmes and Norm M. Tubman and C. J. Umrigar},
- title = {Heat-Bath Configuration Interaction: An Efficient Selected Configuration Interaction Algorithm Inspired by Heat-Bath Sampling},
- journal = {Journal of Chemical Theory and Computation}
-}
-@article{Evangelisti_1983,
- doi = {10.1016/0301-0104(83)85011-3},
- url = {https://doi.org/10.1016%2F0301-0104%2883%2985011-3},
- year = 1983,
- month = {feb},
- publisher = {Elsevier {BV}},
- volume = {75},
- number = {1},
- pages = {91--102},
- author = {Stefano Evangelisti and Jean-Pierre Daudey and Jean-Paul Malrieu},
- title = {Convergence of an improved {CIPSI} algorithm},
- journal = {Chemical Physics}
-}
-@article{Booth_2009,
- doi = {10.1063/1.3193710},
- url = {https://doi.org/10.1063%2F1.3193710},
- year = 2009,
- publisher = {{AIP} Publishing},
- volume = {131},
- number = {5},
- pages = {054106},
- author = {George H. Booth and Alex J. W. Thom and Ali Alavi},
- title = {Fermion Monte Carlo without fixed nodes: A game of life, death, and annihilation in Slater determinant space},
- journal = {The Journal of Chemical Physics}
-}
-@article{Booth_2010,
- doi = {10.1063/1.3407895},
- url = {https://doi.org/10.1063%2F1.3407895},
- year = 2010,
- month = {may},
- publisher = {{AIP} Publishing},
- volume = {132},
- number = {17},
- pages = {174104},
- author = {George H. Booth and Ali Alavi},
- title = {Approaching chemical accuracy using full configuration-interaction quantum Monte Carlo: A study of ionization potentials},
- journal = {The Journal of Chemical Physics}
-}
-@article{Cleland_2010,
- doi = {10.1063/1.3302277},
- url = {https://doi.org/10.1063%2F1.3302277},
- year = 2010,
- month = {jan},
- publisher = {{AIP} Publishing},
- volume = {132},
- number = {4},
- pages = {041103},
- author = {Deidre Cleland and George H. Booth and Ali Alavi},
- title = {Communications: Survival of the fittest: Accelerating convergence in full configuration-interaction quantum Monte Carlo},
- journal = {The Journal of Chemical Physics}
-}
-
-@article{Garniron_2017b,
- doi = {10.1063/1.4992127},
- url = {https://doi.org/10.1063%2F1.4992127},
- year = 2017,
- month = {jul},
- publisher = {{AIP} Publishing},
- volume = {147},
- number = {3},
- pages = {034101},
- author = {Yann Garniron and Anthony Scemama and Pierre-Fran{\c{c}}ois Loos and Michel Caffarel},
- title = {Hybrid stochastic-deterministic calculation of the second-order perturbative contribution of multireference perturbation theory},
- journal = {The Journal of Chemical Physics}
-}
-
diff --git a/docs/source/modules/becke_numerical_grid.rst b/docs/source/modules/becke_numerical_grid.rst
index e67c443a..27a95877 100644
--- a/docs/source/modules/becke_numerical_grid.rst
+++ b/docs/source/modules/becke_numerical_grid.rst
@@ -99,6 +99,71 @@ EZFIO parameters
Default: 1.e-20
+.. option:: my_grid_becke
+
+ if True, the number of angular and radial grid points are read from EZFIO
+
+ Default: False
+
+.. option:: my_n_pt_r_grid
+
+ Number of radial grid points given from input
+
+ Default: 300
+
+.. option:: my_n_pt_a_grid
+
+ Number of angular grid points given from input. Warning, this number cannot be any integer. See file list_angular_grid
+
+ Default: 1202
+
+.. option:: n_points_extra_final_grid
+
+ Total number of extra_grid points
+
+
+.. option:: extra_grid_type_sgn
+
+ Type of extra_grid used for the Becke's numerical extra_grid. Can be, by increasing accuracy: [ 0 | 1 | 2 | 3 ]
+
+ Default: 0
+
+.. option:: thresh_extra_grid
+
+ threshold on the weight of a given extra_grid point
+
+ Default: 1.e-20
+
+.. option:: my_extra_grid_becke
+
+ if True, the number of angular and radial extra_grid points are read from EZFIO
+
+ Default: False
+
+.. option:: my_n_pt_r_extra_grid
+
+ Number of radial extra_grid points given from input
+
+ Default: 300
+
+.. option:: my_n_pt_a_extra_grid
+
+ Number of angular extra_grid points given from input. Warning, this number cannot be any integer. See file list_angular_extra_grid
+
+ Default: 1202
+
+.. option:: rad_grid_type
+
+ method used to sample the radial space. Possible choices are [KNOWLES | GILL]
+
+ Default: KNOWLES
+
+.. option:: extra_rad_grid_type
+
+ method used to sample the radial space. Possible choices are [KNOWLES | GILL]
+
+ Default: KNOWLES
+
Providers
---------
@@ -122,6 +187,8 @@ Providers
:columns: 3
* :c:data:`final_weight_at_r`
+ * :c:data:`final_weight_at_r_extra`
+ * :c:data:`grid_points_extra_per_atom`
* :c:data:`grid_points_per_atom`
@@ -156,6 +223,66 @@ Providers
* :c:data:`grid_points_per_atom`
+.. c:var:: angular_quadrature_points_extra
+
+
+ File : :file:`becke_numerical_grid/angular_extra_grid.irp.f`
+
+ .. code:: fortran
+
+ double precision, allocatable :: angular_quadrature_points_extra (n_points_extra_integration_angular,3)
+ double precision, allocatable :: weights_angular_points_extra (n_points_extra_integration_angular)
+
+
+ weights and grid points_extra for the integration on the angular variables on
+ the unit sphere centered on (0,0,0)
+ According to the LEBEDEV scheme
+
+ Needs:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`n_points_extra_radial_grid`
+
+ Needed by:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`final_weight_at_r_extra`
+ * :c:data:`grid_points_extra_per_atom`
+
+
+.. c:var:: dr_radial_extra_integral
+
+
+ File : :file:`becke_numerical_grid/extra_grid.irp.f`
+
+ .. code:: fortran
+
+ double precision, allocatable :: grid_points_extra_radial (n_points_extra_radial_grid)
+ double precision :: dr_radial_extra_integral
+
+
+ points_extra in [0,1] to map the radial integral [0,\infty]
+
+ Needs:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`n_points_extra_radial_grid`
+
+ Needed by:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`final_weight_at_r_extra`
+ * :c:data:`grid_points_extra_per_atom`
+
+
.. c:var:: dr_radial_integral
@@ -223,6 +350,11 @@ Providers
.. hlist::
:columns: 3
+ * :c:data:`ao_abs_int_grid`
+ * :c:data:`ao_overlap_abs_grid`
+ * :c:data:`ao_prod_abs_r`
+ * :c:data:`ao_prod_center`
+ * :c:data:`ao_prod_dist_grid`
* :c:data:`aos_grad_in_r_array`
* :c:data:`aos_in_r_array`
* :c:data:`aos_lapl_in_r_array`
@@ -241,11 +373,60 @@ Providers
* :c:data:`energy_x_pbe`
* :c:data:`energy_x_sr_lda`
* :c:data:`energy_x_sr_pbe`
+ * :c:data:`f_psi_cas_ab`
+ * :c:data:`f_psi_hf_ab`
+ * :c:data:`final_grid_points_transp`
+ * :c:data:`mo_grad_ints`
* :c:data:`mos_in_r_array`
* :c:data:`mos_in_r_array_omp`
+ * :c:data:`mu_average_prov`
+ * :c:data:`mu_grad_rho`
+ * :c:data:`mu_of_r_dft_average`
+ * :c:data:`mu_rsc_of_r`
* :c:data:`one_e_dm_and_grad_alpha_in_r`
+.. c:var:: final_grid_points_extra
+
+
+ File : :file:`becke_numerical_grid/extra_grid_vector.irp.f`
+
+ .. code:: fortran
+
+ double precision, allocatable :: final_grid_points_extra (3,n_points_extra_final_grid)
+ double precision, allocatable :: final_weight_at_r_vector_extra (n_points_extra_final_grid)
+ integer, allocatable :: index_final_points_extra (3,n_points_extra_final_grid)
+ integer, allocatable :: index_final_points_extra_reverse (n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num)
+
+
+ final_grid_points_extra(1:3,j) = (/ x, y, z /) of the jth grid point
+
+ final_weight_at_r_vector_extra(i) = Total weight function of the ith grid point which contains the Lebedev, Voronoi and radial weights contributions
+
+ index_final_points_extra(1:3,i) = gives the angular, radial and atomic indices associated to the ith grid point
+
+ index_final_points_extra_reverse(i,j,k) = index of the grid point having i as angular, j as radial and l as atomic indices
+
+ Needs:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`final_weight_at_r_extra`
+ * :c:data:`grid_points_extra_per_atom`
+ * :c:data:`n_points_extra_final_grid`
+ * :c:data:`n_points_extra_radial_grid`
+ * :c:data:`nucl_num`
+ * :c:data:`thresh_extra_grid`
+
+ Needed by:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`aos_in_r_array_extra`
+
+
.. c:var:: final_grid_points_per_atom
@@ -272,12 +453,28 @@ Providers
* :c:data:`nucl_num`
* :c:data:`thresh_grid`
- Needed by:
+
+
+.. c:var:: final_grid_points_transp
+
+
+ File : :file:`becke_numerical_grid/grid_becke_vector.irp.f`
+
+ .. code:: fortran
+
+ double precision, allocatable :: final_grid_points_transp (n_points_final_grid,3)
+
+
+ Transposed final_grid_points
+
+ Needs:
.. hlist::
:columns: 3
- * :c:data:`aos_in_r_array_per_atom`
+ * :c:data:`final_grid_points`
+ * :c:data:`n_points_final_grid`
+
.. c:var:: final_weight_at_r
@@ -304,6 +501,8 @@ Providers
* :c:data:`m_knowles`
* :c:data:`n_points_radial_grid`
* :c:data:`nucl_num`
+ * :c:data:`r_gill`
+ * :c:data:`rad_grid_type`
* :c:data:`weight_at_r`
Needed by:
@@ -317,6 +516,43 @@ Providers
* :c:data:`n_pts_per_atom`
+.. c:var:: final_weight_at_r_extra
+
+
+ File : :file:`becke_numerical_grid/extra_grid.irp.f`
+
+ .. code:: fortran
+
+ double precision, allocatable :: final_weight_at_r_extra (n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num)
+
+
+ Total weight on each grid point which takes into account all Lebedev, Voronoi and radial weights.
+
+ Needs:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`alpha_knowles`
+ * :c:data:`angular_quadrature_points_extra`
+ * :c:data:`extra_rad_grid_type`
+ * :c:data:`grid_atomic_number`
+ * :c:data:`grid_points_extra_radial`
+ * :c:data:`m_knowles`
+ * :c:data:`n_points_extra_radial_grid`
+ * :c:data:`nucl_num`
+ * :c:data:`r_gill`
+ * :c:data:`weight_at_r_extra`
+
+ Needed by:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`final_grid_points_extra`
+ * :c:data:`n_points_extra_final_grid`
+
+
.. c:var:: final_weight_at_r_vector
@@ -355,6 +591,11 @@ Providers
.. hlist::
:columns: 3
+ * :c:data:`ao_abs_int_grid`
+ * :c:data:`ao_overlap_abs_grid`
+ * :c:data:`ao_prod_abs_r`
+ * :c:data:`ao_prod_center`
+ * :c:data:`ao_prod_dist_grid`
* :c:data:`aos_grad_in_r_array`
* :c:data:`aos_in_r_array`
* :c:data:`aos_lapl_in_r_array`
@@ -373,11 +614,60 @@ Providers
* :c:data:`energy_x_pbe`
* :c:data:`energy_x_sr_lda`
* :c:data:`energy_x_sr_pbe`
+ * :c:data:`f_psi_cas_ab`
+ * :c:data:`f_psi_hf_ab`
+ * :c:data:`final_grid_points_transp`
+ * :c:data:`mo_grad_ints`
* :c:data:`mos_in_r_array`
* :c:data:`mos_in_r_array_omp`
+ * :c:data:`mu_average_prov`
+ * :c:data:`mu_grad_rho`
+ * :c:data:`mu_of_r_dft_average`
+ * :c:data:`mu_rsc_of_r`
* :c:data:`one_e_dm_and_grad_alpha_in_r`
+.. c:var:: final_weight_at_r_vector_extra
+
+
+ File : :file:`becke_numerical_grid/extra_grid_vector.irp.f`
+
+ .. code:: fortran
+
+ double precision, allocatable :: final_grid_points_extra (3,n_points_extra_final_grid)
+ double precision, allocatable :: final_weight_at_r_vector_extra (n_points_extra_final_grid)
+ integer, allocatable :: index_final_points_extra (3,n_points_extra_final_grid)
+ integer, allocatable :: index_final_points_extra_reverse (n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num)
+
+
+ final_grid_points_extra(1:3,j) = (/ x, y, z /) of the jth grid point
+
+ final_weight_at_r_vector_extra(i) = Total weight function of the ith grid point which contains the Lebedev, Voronoi and radial weights contributions
+
+ index_final_points_extra(1:3,i) = gives the angular, radial and atomic indices associated to the ith grid point
+
+ index_final_points_extra_reverse(i,j,k) = index of the grid point having i as angular, j as radial and l as atomic indices
+
+ Needs:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`final_weight_at_r_extra`
+ * :c:data:`grid_points_extra_per_atom`
+ * :c:data:`n_points_extra_final_grid`
+ * :c:data:`n_points_extra_radial_grid`
+ * :c:data:`nucl_num`
+ * :c:data:`thresh_extra_grid`
+
+ Needed by:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`aos_in_r_array_extra`
+
+
.. c:var:: final_weight_at_r_vector_per_atom
@@ -404,12 +694,6 @@ Providers
* :c:data:`nucl_num`
* :c:data:`thresh_grid`
- Needed by:
-
- .. hlist::
- :columns: 3
-
- * :c:data:`aos_in_r_array_per_atom`
.. c:var:: grid_atomic_number
@@ -438,9 +722,77 @@ Providers
:columns: 3
* :c:data:`final_weight_at_r`
+ * :c:data:`final_weight_at_r_extra`
+ * :c:data:`grid_points_extra_per_atom`
* :c:data:`grid_points_per_atom`
+.. c:var:: grid_points_extra_per_atom
+
+
+ File : :file:`becke_numerical_grid/extra_grid.irp.f`
+
+ .. code:: fortran
+
+ double precision, allocatable :: grid_points_extra_per_atom (3,n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num)
+
+
+ x,y,z coordinates of grid points_extra used for integration in 3d space
+
+ Needs:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`alpha_knowles`
+ * :c:data:`angular_quadrature_points_extra`
+ * :c:data:`extra_rad_grid_type`
+ * :c:data:`grid_atomic_number`
+ * :c:data:`grid_points_extra_radial`
+ * :c:data:`m_knowles`
+ * :c:data:`n_points_extra_radial_grid`
+ * :c:data:`nucl_coord`
+ * :c:data:`nucl_num`
+ * :c:data:`r_gill`
+
+ Needed by:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`final_grid_points_extra`
+ * :c:data:`weight_at_r_extra`
+
+
+.. c:var:: grid_points_extra_radial
+
+
+ File : :file:`becke_numerical_grid/extra_grid.irp.f`
+
+ .. code:: fortran
+
+ double precision, allocatable :: grid_points_extra_radial (n_points_extra_radial_grid)
+ double precision :: dr_radial_extra_integral
+
+
+ points_extra in [0,1] to map the radial integral [0,\infty]
+
+ Needs:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`n_points_extra_radial_grid`
+
+ Needed by:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`final_weight_at_r_extra`
+ * :c:data:`grid_points_extra_per_atom`
+
+
.. c:var:: grid_points_per_atom
@@ -466,6 +818,8 @@ Providers
* :c:data:`n_points_radial_grid`
* :c:data:`nucl_coord`
* :c:data:`nucl_num`
+ * :c:data:`r_gill`
+ * :c:data:`rad_grid_type`
Needed by:
@@ -544,6 +898,11 @@ Providers
.. hlist::
:columns: 3
+ * :c:data:`ao_abs_int_grid`
+ * :c:data:`ao_overlap_abs_grid`
+ * :c:data:`ao_prod_abs_r`
+ * :c:data:`ao_prod_center`
+ * :c:data:`ao_prod_dist_grid`
* :c:data:`aos_grad_in_r_array`
* :c:data:`aos_in_r_array`
* :c:data:`aos_lapl_in_r_array`
@@ -562,11 +921,101 @@ Providers
* :c:data:`energy_x_pbe`
* :c:data:`energy_x_sr_lda`
* :c:data:`energy_x_sr_pbe`
+ * :c:data:`f_psi_cas_ab`
+ * :c:data:`f_psi_hf_ab`
+ * :c:data:`final_grid_points_transp`
+ * :c:data:`mo_grad_ints`
* :c:data:`mos_in_r_array`
* :c:data:`mos_in_r_array_omp`
+ * :c:data:`mu_average_prov`
+ * :c:data:`mu_grad_rho`
+ * :c:data:`mu_of_r_dft_average`
+ * :c:data:`mu_rsc_of_r`
* :c:data:`one_e_dm_and_grad_alpha_in_r`
+.. c:var:: index_final_points_extra
+
+
+ File : :file:`becke_numerical_grid/extra_grid_vector.irp.f`
+
+ .. code:: fortran
+
+ double precision, allocatable :: final_grid_points_extra (3,n_points_extra_final_grid)
+ double precision, allocatable :: final_weight_at_r_vector_extra (n_points_extra_final_grid)
+ integer, allocatable :: index_final_points_extra (3,n_points_extra_final_grid)
+ integer, allocatable :: index_final_points_extra_reverse (n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num)
+
+
+ final_grid_points_extra(1:3,j) = (/ x, y, z /) of the jth grid point
+
+ final_weight_at_r_vector_extra(i) = Total weight function of the ith grid point which contains the Lebedev, Voronoi and radial weights contributions
+
+ index_final_points_extra(1:3,i) = gives the angular, radial and atomic indices associated to the ith grid point
+
+ index_final_points_extra_reverse(i,j,k) = index of the grid point having i as angular, j as radial and l as atomic indices
+
+ Needs:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`final_weight_at_r_extra`
+ * :c:data:`grid_points_extra_per_atom`
+ * :c:data:`n_points_extra_final_grid`
+ * :c:data:`n_points_extra_radial_grid`
+ * :c:data:`nucl_num`
+ * :c:data:`thresh_extra_grid`
+
+ Needed by:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`aos_in_r_array_extra`
+
+
+.. c:var:: index_final_points_extra_reverse
+
+
+ File : :file:`becke_numerical_grid/extra_grid_vector.irp.f`
+
+ .. code:: fortran
+
+ double precision, allocatable :: final_grid_points_extra (3,n_points_extra_final_grid)
+ double precision, allocatable :: final_weight_at_r_vector_extra (n_points_extra_final_grid)
+ integer, allocatable :: index_final_points_extra (3,n_points_extra_final_grid)
+ integer, allocatable :: index_final_points_extra_reverse (n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num)
+
+
+ final_grid_points_extra(1:3,j) = (/ x, y, z /) of the jth grid point
+
+ final_weight_at_r_vector_extra(i) = Total weight function of the ith grid point which contains the Lebedev, Voronoi and radial weights contributions
+
+ index_final_points_extra(1:3,i) = gives the angular, radial and atomic indices associated to the ith grid point
+
+ index_final_points_extra_reverse(i,j,k) = index of the grid point having i as angular, j as radial and l as atomic indices
+
+ Needs:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`final_weight_at_r_extra`
+ * :c:data:`grid_points_extra_per_atom`
+ * :c:data:`n_points_extra_final_grid`
+ * :c:data:`n_points_extra_radial_grid`
+ * :c:data:`nucl_num`
+ * :c:data:`thresh_extra_grid`
+
+ Needed by:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`aos_in_r_array_extra`
+
+
.. c:var:: index_final_points_per_atom
@@ -593,12 +1042,6 @@ Providers
* :c:data:`nucl_num`
* :c:data:`thresh_grid`
- Needed by:
-
- .. hlist::
- :columns: 3
-
- * :c:data:`aos_in_r_array_per_atom`
.. c:var:: index_final_points_per_atom_reverse
@@ -627,12 +1070,6 @@ Providers
* :c:data:`nucl_num`
* :c:data:`thresh_grid`
- Needed by:
-
- .. hlist::
- :columns: 3
-
- * :c:data:`aos_in_r_array_per_atom`
.. c:var:: index_final_points_reverse
@@ -673,6 +1110,11 @@ Providers
.. hlist::
:columns: 3
+ * :c:data:`ao_abs_int_grid`
+ * :c:data:`ao_overlap_abs_grid`
+ * :c:data:`ao_prod_abs_r`
+ * :c:data:`ao_prod_center`
+ * :c:data:`ao_prod_dist_grid`
* :c:data:`aos_grad_in_r_array`
* :c:data:`aos_in_r_array`
* :c:data:`aos_lapl_in_r_array`
@@ -691,8 +1133,16 @@ Providers
* :c:data:`energy_x_pbe`
* :c:data:`energy_x_sr_lda`
* :c:data:`energy_x_sr_pbe`
+ * :c:data:`f_psi_cas_ab`
+ * :c:data:`f_psi_hf_ab`
+ * :c:data:`final_grid_points_transp`
+ * :c:data:`mo_grad_ints`
* :c:data:`mos_in_r_array`
* :c:data:`mos_in_r_array_omp`
+ * :c:data:`mu_average_prov`
+ * :c:data:`mu_grad_rho`
+ * :c:data:`mu_of_r_dft_average`
+ * :c:data:`mu_rsc_of_r`
* :c:data:`one_e_dm_and_grad_alpha_in_r`
@@ -714,9 +1164,148 @@ Providers
:columns: 3
* :c:data:`final_weight_at_r`
+ * :c:data:`final_weight_at_r_extra`
+ * :c:data:`grid_points_extra_per_atom`
* :c:data:`grid_points_per_atom`
+.. c:var:: n_points_extra_final_grid
+
+
+ File : :file:`becke_numerical_grid/extra_grid_vector.irp.f`
+
+ .. code:: fortran
+
+ integer :: n_points_extra_final_grid
+
+
+ Number of points_extra which are non zero
+
+ Needs:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`final_weight_at_r_extra`
+ * :c:data:`n_points_extra_radial_grid`
+ * :c:data:`nucl_num`
+ * :c:data:`thresh_extra_grid`
+
+ Needed by:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`aos_in_r_array_extra`
+ * :c:data:`aos_in_r_array_extra_transp`
+ * :c:data:`final_grid_points_extra`
+
+
+.. c:var:: n_points_extra_grid_per_atom
+
+
+ File : :file:`becke_numerical_grid/extra_grid.irp.f`
+
+ .. code:: fortran
+
+ integer :: n_points_extra_grid_per_atom
+
+
+ Number of grid points_extra per atom
+
+ Needs:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`n_points_extra_radial_grid`
+
+
+
+.. c:var:: n_points_extra_integration_angular
+
+
+ File : :file:`becke_numerical_grid/extra_grid.irp.f`
+
+ .. code:: fortran
+
+ integer :: n_points_extra_radial_grid
+ integer :: n_points_extra_integration_angular
+
+
+ n_points_extra_radial_grid = number of radial grid points_extra per atom
+
+ n_points_extra_integration_angular = number of angular grid points_extra per atom
+
+ These numbers are automatically set by setting the grid_type_sgn parameter
+
+ Needs:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`extra_grid_type_sgn`
+ * :c:data:`my_extra_grid_becke`
+ * :c:data:`my_n_pt_a_extra_grid`
+ * :c:data:`my_n_pt_r_extra_grid`
+
+ Needed by:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`angular_quadrature_points_extra`
+ * :c:data:`final_grid_points_extra`
+ * :c:data:`final_weight_at_r_extra`
+ * :c:data:`grid_points_extra_per_atom`
+ * :c:data:`grid_points_extra_radial`
+ * :c:data:`n_points_extra_final_grid`
+ * :c:data:`n_points_extra_grid_per_atom`
+ * :c:data:`weight_at_r_extra`
+
+
+.. c:var:: n_points_extra_radial_grid
+
+
+ File : :file:`becke_numerical_grid/extra_grid.irp.f`
+
+ .. code:: fortran
+
+ integer :: n_points_extra_radial_grid
+ integer :: n_points_extra_integration_angular
+
+
+ n_points_extra_radial_grid = number of radial grid points_extra per atom
+
+ n_points_extra_integration_angular = number of angular grid points_extra per atom
+
+ These numbers are automatically set by setting the grid_type_sgn parameter
+
+ Needs:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`extra_grid_type_sgn`
+ * :c:data:`my_extra_grid_becke`
+ * :c:data:`my_n_pt_a_extra_grid`
+ * :c:data:`my_n_pt_r_extra_grid`
+
+ Needed by:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`angular_quadrature_points_extra`
+ * :c:data:`final_grid_points_extra`
+ * :c:data:`final_weight_at_r_extra`
+ * :c:data:`grid_points_extra_per_atom`
+ * :c:data:`grid_points_extra_radial`
+ * :c:data:`n_points_extra_final_grid`
+ * :c:data:`n_points_extra_grid_per_atom`
+ * :c:data:`weight_at_r_extra`
+
+
.. c:var:: n_points_final_grid
@@ -744,9 +1333,17 @@ Providers
.. hlist::
:columns: 3
+ * :c:data:`act_mos_in_r_array`
* :c:data:`alpha_dens_kin_in_r`
+ * :c:data:`ao_abs_int_grid`
+ * :c:data:`ao_overlap_abs_grid`
+ * :c:data:`ao_prod_abs_r`
+ * :c:data:`ao_prod_center`
+ * :c:data:`ao_prod_dist_grid`
* :c:data:`aos_grad_in_r_array`
* :c:data:`aos_grad_in_r_array_transp`
+ * :c:data:`aos_grad_in_r_array_transp_3`
+ * :c:data:`aos_grad_in_r_array_transp_bis`
* :c:data:`aos_in_r_array`
* :c:data:`aos_in_r_array_transp`
* :c:data:`aos_lapl_in_r_array`
@@ -759,6 +1356,14 @@ Providers
* :c:data:`aos_vxc_alpha_lda_w`
* :c:data:`aos_vxc_alpha_pbe_w`
* :c:data:`aos_vxc_alpha_sr_pbe_w`
+ * :c:data:`basis_mos_in_r_array`
+ * :c:data:`core_density`
+ * :c:data:`core_inact_act_mos_grad_in_r_array`
+ * :c:data:`core_inact_act_mos_in_r_array`
+ * :c:data:`core_inact_act_v_kl_contracted`
+ * :c:data:`core_mos_in_r_array`
+ * :c:data:`effective_alpha_dm`
+ * :c:data:`effective_spin_dm`
* :c:data:`elec_beta_num_grid_becke`
* :c:data:`energy_c_lda`
* :c:data:`energy_c_sr_lda`
@@ -766,14 +1371,39 @@ Providers
* :c:data:`energy_x_pbe`
* :c:data:`energy_x_sr_lda`
* :c:data:`energy_x_sr_pbe`
+ * :c:data:`f_psi_cas_ab`
+ * :c:data:`f_psi_cas_ab_old`
+ * :c:data:`f_psi_hf_ab`
* :c:data:`final_grid_points`
+ * :c:data:`final_grid_points_transp`
+ * :c:data:`full_occ_2_rdm_cntrctd`
+ * :c:data:`full_occ_2_rdm_cntrctd_trans`
+ * :c:data:`full_occ_v_kl_cntrctd`
+ * :c:data:`grad_total_cas_on_top_density`
+ * :c:data:`inact_density`
+ * :c:data:`inact_mos_in_r_array`
* :c:data:`kinetic_density_generalized`
+ * :c:data:`mo_grad_ints`
* :c:data:`mos_grad_in_r_array`
* :c:data:`mos_grad_in_r_array_tranp`
+ * :c:data:`mos_grad_in_r_array_transp_3`
+ * :c:data:`mos_grad_in_r_array_transp_bis`
* :c:data:`mos_in_r_array`
* :c:data:`mos_in_r_array_omp`
* :c:data:`mos_in_r_array_transp`
* :c:data:`mos_lapl_in_r_array`
+ * :c:data:`mos_lapl_in_r_array_tranp`
+ * :c:data:`mu_average_prov`
+ * :c:data:`mu_grad_rho`
+ * :c:data:`mu_of_r_dft`
+ * :c:data:`mu_of_r_dft_average`
+ * :c:data:`mu_of_r_hf`
+ * :c:data:`mu_of_r_prov`
+ * :c:data:`mu_of_r_psi_cas`
+ * :c:data:`mu_rsc_of_r`
+ * :c:data:`one_e_act_density_alpha`
+ * :c:data:`one_e_act_density_beta`
+ * :c:data:`one_e_cas_total_density`
* :c:data:`one_e_dm_and_grad_alpha_in_r`
* :c:data:`pot_grad_x_alpha_ao_pbe`
* :c:data:`pot_grad_x_alpha_ao_sr_pbe`
@@ -789,6 +1419,8 @@ Providers
* :c:data:`potential_x_alpha_ao_sr_lda`
* :c:data:`potential_xc_alpha_ao_lda`
* :c:data:`potential_xc_alpha_ao_sr_lda`
+ * :c:data:`total_cas_on_top_density`
+ * :c:data:`virt_mos_in_r_array`
.. c:var:: n_points_grid_per_atom
@@ -928,7 +1560,6 @@ Providers
.. hlist::
:columns: 3
- * :c:data:`aos_in_r_array_per_atom`
* :c:data:`final_grid_points_per_atom`
@@ -960,10 +1591,31 @@ Providers
.. hlist::
:columns: 3
- * :c:data:`aos_in_r_array_per_atom`
* :c:data:`final_grid_points_per_atom`
+.. c:var:: r_gill
+
+
+ File : :file:`becke_numerical_grid/grid_becke.irp.f`
+
+ .. code:: fortran
+
+ double precision :: r_gill
+
+
+
+ Needed by:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`final_weight_at_r`
+ * :c:data:`final_weight_at_r_extra`
+ * :c:data:`grid_points_extra_per_atom`
+ * :c:data:`grid_points_per_atom`
+
+
.. c:var:: weight_at_r
@@ -1001,6 +1653,43 @@ Providers
* :c:data:`final_weight_at_r`
+.. c:var:: weight_at_r_extra
+
+
+ File : :file:`becke_numerical_grid/extra_grid.irp.f`
+
+ .. code:: fortran
+
+ double precision, allocatable :: weight_at_r_extra (n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num)
+
+
+ Weight function at grid points_extra : w_n(r) according to the equation (22)
+ of Becke original paper (JCP, 88, 1988)
+
+ The "n" discrete variable represents the nucleis which in this array is
+ represented by the last dimension and the points_extra are labelled by the
+ other dimensions.
+
+ Needs:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`grid_points_extra_per_atom`
+ * :c:data:`n_points_extra_radial_grid`
+ * :c:data:`nucl_coord_transp`
+ * :c:data:`nucl_dist_inv`
+ * :c:data:`nucl_num`
+ * :c:data:`slater_bragg_type_inter_distance_ua`
+
+ Needed by:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`final_weight_at_r_extra`
+
+
.. c:var:: weights_angular_points
@@ -1032,6 +1721,37 @@ Providers
* :c:data:`grid_points_per_atom`
+.. c:var:: weights_angular_points_extra
+
+
+ File : :file:`becke_numerical_grid/angular_extra_grid.irp.f`
+
+ .. code:: fortran
+
+ double precision, allocatable :: angular_quadrature_points_extra (n_points_extra_integration_angular,3)
+ double precision, allocatable :: weights_angular_points_extra (n_points_extra_integration_angular)
+
+
+ weights and grid points_extra for the integration on the angular variables on
+ the unit sphere centered on (0,0,0)
+ According to the LEBEDEV scheme
+
+ Needs:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`n_points_extra_radial_grid`
+
+ Needed by:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`final_weight_at_r_extra`
+ * :c:data:`grid_points_extra_per_atom`
+
+
Subroutines / functions
-----------------------
@@ -1043,7 +1763,7 @@ Subroutines / functions
.. code:: fortran
- double precision function cell_function_becke(r,atom_number)
+ double precision function cell_function_becke(r, atom_number)
atom_number :: atom on which the cell function of Becke (1988, JCP,88(4))
@@ -1067,7 +1787,7 @@ Subroutines / functions
.. code:: fortran
- double precision function derivative_knowles_function(alpha,m,x)
+ double precision function derivative_knowles_function(alpha, m, x)
Derivative of the function proposed by Knowles (JCP, 104, 1996) for distributing the radial points
@@ -1118,7 +1838,7 @@ Subroutines / functions
.. code:: fortran
- double precision function knowles_function(alpha,m,x)
+ double precision function knowles_function(alpha, m, x)
Function proposed by Knowles (JCP, 104, 1996) for distributing the radial points :
diff --git a/docs/source/modules/cipsi.rst b/docs/source/modules/cipsi.rst
index 501a91dd..77212469 100644
--- a/docs/source/modules/cipsi.rst
+++ b/docs/source/modules/cipsi.rst
@@ -21,7 +21,7 @@ The :c:func:`run_cipsi` subroutine iteratively:
* If :option:`determinants s2_eig` is |true|, it adds all the necessary
determinants to allow the eigenstates of |H| to be eigenstates of |S^2|
* Diagonalizes |H| in the enlarged internal space
-* Computes the |PT2| contribution to the energy stochastically :cite:`Garniron_2017.2`
+* Computes the |PT2| contribution to the energy stochastically :cite:`Garniron_2017b`
or deterministically, depending on :option:`perturbation do_pt2`
* Extrapolates the variational energy by fitting
:math:`E=E_\text{FCI} - \alpha\, E_\text{PT2}`
diff --git a/docs/source/programmers_guide/plugins_tuto_I.rst b/docs/source/programmers_guide/plugins_tuto_I.rst
new file mode 100644
index 00000000..27864487
--- /dev/null
+++ b/docs/source/programmers_guide/plugins_tuto_I.rst
@@ -0,0 +1 @@
+.. include:: ../../../plugins/local/tuto_plugins/tuto_I/tuto_I.rst
diff --git a/docs/source/programmers_guide/plugins_tuto_intro.rst b/docs/source/programmers_guide/plugins_tuto_intro.rst
new file mode 100644
index 00000000..63482462
--- /dev/null
+++ b/docs/source/programmers_guide/plugins_tuto_intro.rst
@@ -0,0 +1 @@
+.. include:: ../../../plugins/README.rst
diff --git a/docs/source/references.bib b/docs/source/references.bib
new file mode 100644
index 00000000..6580eefa
--- /dev/null
+++ b/docs/source/references.bib
@@ -0,0 +1,847 @@
+
+@article{Ammar_2023,
+ author = {Ammar, Abdallah and Scemama, Anthony and Giner, Emmanuel},
+ title = {{Transcorrelated selected configuration interaction in a bi-orthonormal basis and with a cheap three-body correlation factor}},
+ journal = {J. Chem. Phys.},
+ volume = {159},
+ number = {11},
+ year = {2023},
+ month = sep,
+ issn = {0021-9606},
+ publisher = {AIP Publishing},
+ doi = {10.1063/5.0163831}
+}
+
+@article{Ammar_2023.2,
+ author = {Ammar, Abdallah and Scemama, Anthony and Giner, Emmanuel},
+ title = {{Biorthonormal Orbital Optimization with a Cheap Core-Electron-Free Three-Body Correlation Factor for Quantum Monte Carlo and Transcorrelation}},
+ journal = {J. Chem. Theory Comput.},
+ volume = {19},
+ number = {15},
+ pages = {4883--4896},
+ year = {2023},
+ month = aug,
+ issn = {1549-9618},
+ publisher = {American Chemical Society},
+ doi = {10.1021/acs.jctc.3c00257}
+}
+
+@article{Damour_2023,
+ author = {Damour, Yann and Quintero-Monsebaiz, Ra{\'{u}}l and Caffarel, Michel and Jacquemin, Denis and Kossoski, F{\'{a}}bris and Scemama, Anthony and Loos, Pierre-Fran{\c{c}}ois},
+ title = {{Ground- and Excited-State Dipole Moments and Oscillator Strengths of Full Configuration Interaction Quality}},
+ journal = {J. Chem. Theory Comput.},
+ volume = {19},
+ number = {1},
+ pages = {221--234},
+ year = {2023},
+ month = jan,
+ issn = {1549-9618},
+ publisher = {American Chemical Society},
+ doi = {10.1021/acs.jctc.2c01111}
+}
+
+@article{Ammar_2022,
+ author = {Ammar, Abdallah and Scemama, Anthony and Giner, Emmanuel},
+ title = {{Extension of selected configuration interaction for transcorrelated methods}},
+ journal = {J. Chem. Phys.},
+ volume = {157},
+ number = {13},
+ year = {2022},
+ month = oct,
+ issn = {0021-9606},
+ publisher = {AIP Publishing},
+ doi = {10.1063/5.0115524}
+}
+
+@article{Ammar_2022.2,
+ author = {Ammar, Abdallah and Giner, Emmanuel and Scemama, Anthony},
+ title = {{Optimization of Large Determinant Expansions in Quantum Monte Carlo}},
+ journal = {J. Chem. Theory Comput.},
+ volume = {18},
+ number = {9},
+ pages = {5325--5336},
+ year = {2022},
+ month = sep,
+ issn = {1549-9618},
+ publisher = {American Chemical Society},
+ doi = {10.1021/acs.jctc.2c00556}
+}
+
+@article{Monino_2022,
+ author = {Monino, Enzo and Boggio-Pasqua, Martial and Scemama, Anthony and Jacquemin, Denis and Loos, Pierre-Fran{\c{c}}ois},
+ title = {{Reference Energies for Cyclobutadiene: Automerization and Excited States}},
+ journal = {J. Phys. Chem. A},
+ volume = {126},
+ number = {28},
+ pages = {4664--4679},
+ year = {2022},
+ month = jul,
+ issn = {1089-5639},
+ publisher = {American Chemical Society},
+ doi = {10.1021/acs.jpca.2c02480}
+}
+
+@article{Cuzzocrea_2022,
+ author = {Cuzzocrea, Alice and Moroni, Saverio and Scemama, Anthony and Filippi, Claudia},
+ title = {{Reference Excitation Energies of Increasingly Large Molecules: A QMC Study of Cyanine Dyes}},
+ journal = {J. Chem. Theory Comput.},
+ volume = {18},
+ number = {2},
+ pages = {1089--1095},
+ year = {2022},
+ month = feb,
+ issn = {1549-9618},
+ publisher = {American Chemical Society},
+ doi = {10.1021/acs.jctc.1c01162}
+}
+
+@article{Damour_2021,
+ author = {Damour, Yann and V{\'{e}}ril, Micka{\"{e}}l and Kossoski, F{\'{a}}bris and Caffarel, Michel and Jacquemin, Denis and Scemama, Anthony and Loos, Pierre-Fran{\c{c}}ois},
+ title = {{Accurate full configuration interaction correlation energy estimates for five- and six-membered rings}},
+ journal = {J. Chem. Phys.},
+ volume = {155},
+ number = {13},
+ year = {2021},
+ month = oct,
+ issn = {0021-9606},
+ publisher = {AIP Publishing},
+ doi = {10.1063/5.0065314}
+}
+
+@article{Veril_2021,
+ author = {V{\'{e}}ril, Micka{\"{e}}l and Scemama, Anthony and Caffarel, Michel and Lipparini, Filippo and Boggio-Pasqua, Martial and Jacquemin, Denis and Loos, Pierre-Fran{\c{c}}ois},
+ title = {{QUESTDB: A database of highly accurate excitation energies for the electronic structure community}},
+ journal = {WIREs Comput. Mol. Sci.},
+ volume = {11},
+ number = {5},
+ pages = {e1517},
+ year = {2021},
+ month = sep,
+ issn = {1759-0876},
+ publisher = {John Wiley {\&} Sons, Ltd},
+ doi = {10.1002/wcms.1517}
+}
+
+@article{Kossoski_2021,
+ author = {Kossoski, F{\'{a}}bris and Marie, Antoine and Scemama, Anthony and Caffarel, Michel and Loos, Pierre-Fran{\c{c}}ois},
+ title = {{Excited States from State-Specific Orbital-Optimized Pair Coupled Cluster}},
+ journal = {J. Chem. Theory Comput.},
+ volume = {17},
+ number = {8},
+ pages = {4756--4768},
+ year = {2021},
+ month = aug,
+ issn = {1549-9618},
+ publisher = {American Chemical Society},
+ doi = {10.1021/acs.jctc.1c00348}
+}
+
+@article{Dash_2021,
+ author = {Dash, Monika and Moroni, Saverio and Filippi, Claudia and Scemama, Anthony},
+ title = {{Tailoring CIPSI Expansions for QMC Calculations of Electronic Excitations: The Case Study of Thiophene}},
+ journal = {J. Chem. Theory Comput.},
+ volume = {17},
+ number = {6},
+ pages = {3426--3434},
+ year = {2021},
+ month = jun,
+ issn = {1549-9618},
+ publisher = {American Chemical Society},
+ doi = {10.1021/acs.jctc.1c00212}
+}
+
+@article{Loos_2020,
+ author = {Loos, Pierre-Fran{\c{c}}ois and Lipparini, Filippo and Boggio-Pasqua, Martial and Scemama, Anthony and Jacquemin, Denis},
+ title = {{A Mountaineering Strategy to Excited States: Highly Accurate Energies and Benchmarks for Medium Sized Molecules}},
+ journal = {J. Chem. Theory Comput.},
+ volume = {16},
+ number = {3},
+ pages = {1711--1741},
+ year = {2020},
+ month = mar,
+ issn = {1549-9618},
+ publisher = {American Chemical Society},
+ doi = {10.1021/acs.jctc.9b01216}
+}
+
+@article{Loos_2020.2,
+ author = {Loos, Pierre-Fran{\c{c}}ois and Pradines, Barth{\'{e}}l{\'{e}}my and Scemama, Anthony and Giner, Emmanuel and Toulouse, Julien},
+ title = {{Density-Based Basis-Set Incompleteness Correction for GW Methods}},
+ journal = {J. Chem. Theory Comput.},
+ volume = {16},
+ number = {2},
+ pages = {1018--1028},
+ year = {2020},
+ month = feb,
+ issn = {1549-9618},
+ publisher = {American Chemical Society},
+ doi = {10.1021/acs.jctc.9b01067}
+}
+
+@article{Loos_2020.3,
+ author = {Loos, Pierre-Fran{\c{c}}ois and Scemama, Anthony and Jacquemin, Denis},
+ title = {{The Quest for Highly Accurate Excitation Energies: A Computational Perspective}},
+ journal = {J. Phys. Chem. Lett.},
+ volume = {11},
+ number = {6},
+ pages = {2374--2383},
+ year = {2020},
+ month = mar,
+ publisher = {American Chemical Society},
+ doi = {10.1021/acs.jpclett.0c00014}
+}
+
+@article{Giner_2020,
+ author = {Giner, Emmanuel and Scemama, Anthony and Loos, Pierre-Fran{\c{c}}ois and Toulouse, Julien},
+ title = {{A basis-set error correction based on density-functional theory for strongly correlated molecular systems}},
+ journal = {J. Chem. Phys.},
+ volume = {152},
+ number = {17},
+ year = {2020},
+ month = may,
+ issn = {0021-9606},
+ publisher = {AIP Publishing},
+ doi = {10.1063/5.0002892}
+}
+
+@article{Loos_2020.4,
+ author = {Loos, Pierre-Fran{\c{c}}ois and Scemama, Anthony and Boggio-Pasqua, Martial and Jacquemin, Denis},
+ title = {{Mountaineering Strategy to Excited States: Highly Accurate Energies and Benchmarks for Exotic Molecules and Radicals}},
+ journal = {J. Chem. Theory Comput.},
+ volume = {16},
+ number = {6},
+ pages = {3720--3736},
+ year = {2020},
+ month = jun,
+ issn = {1549-9618},
+ publisher = {American Chemical Society},
+ doi = {10.1021/acs.jctc.0c00227}
+}
+
+@article{Benali_2020,
+ author = {Benali, Anouar and Gasperich, Kevin and Jordan, Kenneth D. and Applencourt, Thomas and Luo, Ye and Bennett, M. Chandler and Krogel, Jaron T. and Shulenburger, Luke and Kent, Paul R. C. and Loos, Pierre-Fran{\c{c}}ois and Scemama, Anthony and Caffarel, Michel},
+ title = {{Toward a systematic improvement of the fixed-node approximation in diffusion Monte Carlo for solids{\textemdash}A case study in diamond}},
+ journal = {J. Chem. Phys.},
+ volume = {153},
+ number = {18},
+ year = {2020},
+ month = nov,
+ issn = {0021-9606},
+ publisher = {AIP Publishing},
+ doi = {10.1063/5.0021036}
+}
+
+@article{Scemama_2020,
+ author = {Scemama, Anthony and Giner, Emmanuel and Benali, Anouar and Loos, Pierre-Fran{\c{c}}ois},
+ title = {{Taming the fixed-node error in diffusion Monte Carlo via range separation}},
+ journal = {J. Chem. Phys.},
+ volume = {153},
+ number = {17},
+ year = {2020},
+ month = nov,
+ issn = {0021-9606},
+ publisher = {AIP Publishing},
+ doi = {10.1063/5.0026324}
+}
+
+@article{Loos_2020.5,
+ author = {Loos, Pierre-Fran{\c{c}}ois and Damour, Yann and Scemama, Anthony},
+ title = {{The performance of CIPSI on the ground state electronic energy of benzene}},
+ journal = {J. Chem. Phys.},
+ volume = {153},
+ number = {17},
+ year = {2020},
+ month = nov,
+ issn = {0021-9606},
+ publisher = {AIP Publishing},
+ doi = {10.1063/5.0027617}
+}
+
+@article{Loos_2019,
+ author = {Loos, Pierre-Fran{\c{c}}ois and Pradines, Barth{\'{e}}l{\'{e}}my and Scemama, Anthony and Toulouse, Julien and Giner, Emmanuel},
+ title = {{A Density-Based Basis-Set Correction for Wave Function Theory}},
+ journal = {J. Phys. Chem. Lett.},
+ volume = {10},
+ number = {11},
+ pages = {2931--2937},
+ year = {2019},
+ month = jun,
+ publisher = {American Chemical Society},
+ doi = {10.1021/acs.jpclett.9b01176}
+}
+
+@article{Dash_2019,
+ author = {Dash, Monika and Feldt, Jonas and Moroni, Saverio and Scemama, Anthony and Filippi, Claudia},
+ title = {{Excited States with Selected Configuration Interaction-Quantum Monte Carlo: Chemically Accurate Excitation Energies and Geometries}},
+ journal = {J. Chem. Theory Comput.},
+ volume = {15},
+ number = {9},
+ pages = {4896--4906},
+ year = {2019},
+ month = sep,
+ issn = {1549-9618},
+ publisher = {American Chemical Society},
+ doi = {10.1021/acs.jctc.9b00476}
+}
+
+@article{Burton2019May,
+ author = {Burton, Hugh G. A. and Thom, Alex J. W.},
+ title = {{A General Approach for Multireference Ground and Excited States using Non-Orthogonal Configuration Interaction}},
+ journal = {arXiv},
+ year = {2019},
+ month = {May},
+ eprint = {1905.02626},
+ url = {https://arxiv.org/abs/1905.02626}
+}
+
+
+@article{Giner_2019,
+ author = {Giner, Emmanuel and Scemama, Anthony and Toulouse, Julien and Loos, Pierre-Fran{\c{c}}ois},
+ title = {{Chemically accurate excitation energies with small basis sets}},
+ journal = {J. Chem. Phys.},
+ volume = {151},
+ number = {14},
+ year = {2019},
+ month = oct,
+ issn = {0021-9606},
+ publisher = {AIP Publishing},
+ doi = {10.1063/1.5122976}
+}
+
+
+
+@article{Garniron_2019,
+ doi = {10.1021/acs.jctc.9b00176},
+ url = {https://doi.org/10.1021%2Facs.jctc.9b00176},
+ year = 2019,
+ month = {may},
+ publisher = {American Chemical Society ({ACS})},
+ author = {Yann Garniron and Thomas Applencourt and Kevin Gasperich and Anouar Benali and Anthony Ferte and Julien Paquier and Bartélémy Pradines and Roland Assaraf and Peter Reinhardt and Julien Toulouse and Pierrette Barbaresco and Nicolas Renon and Gregoire David and Jean-Paul Malrieu and Mickael Veril and Michel Caffarel and Pierre-Francois Loos and Emmanuel Giner and Anthony Scemama},
+ title = {Quantum Package 2.0: An Open-Source Determinant-Driven Suite of Programs},
+ journal = {Journal of Chemical Theory and Computation}
+}
+
+@article{Scemama_2019,
+ doi = {10.1016/j.rechem.2019.100002},
+ url = {https://doi.org/10.1016%2Fj.rechem.2019.100002},
+ year = 2019,
+ month = {may},
+ publisher = {Elsevier {BV}},
+ pages = {100002},
+ author = {Anthony Scemama and Michel Caffarel and Anouar Benali and Denis Jacquemin and Pierre-Fran{\c{c}}ois Loos},
+ title = {Influence of pseudopotentials on excitation energies from selected configuration interaction and diffusion Monte Carlo},
+ journal = {Results in Chemistry}
+}
+
+
+@article{Applencourt2018Dec,
+ author = {Applencourt, Thomas and Gasperich, Kevin and Scemama, Anthony},
+ title = {{Spin adaptation with determinant-based selected configuration interaction}},
+ journal = {arXiv},
+ year = {2018},
+ month = {Dec},
+ eprint = {1812.06902},
+ url = {https://arxiv.org/abs/1812.06902}
+}
+
+@article{Loos2019Mar,
+ author = {Loos, Pierre-Fran\c{c}ois and Boggio-Pasqua, Martial and Scemama, Anthony and Caffarel, Michel and Jacquemin, Denis},
+ title = {{Reference Energies for Double Excitations}},
+ journal = {J. Chem. Theory Comput.},
+ volume = {15},
+ number = {3},
+ pages = {1939--1956},
+ year = {2019},
+ month = {Mar},
+ issn = {1549-9618},
+ publisher = {American Chemical Society},
+ doi = {10.1021/acs.jctc.8b01205}
+}
+
+@article{PinedaFlores2019Feb,
+ author = {Pineda Flores, Sergio and Neuscamman, Eric},
+ title = {{Excited State Specific Multi-Slater Jastrow Wave Functions}},
+ journal = {J. Phys. Chem. A},
+ volume = {123},
+ number = {8},
+ pages = {1487--1497},
+ year = {2019},
+ month = {Feb},
+ issn = {1089-5639},
+ publisher = {American Chemical Society},
+ doi = {10.1021/acs.jpca.8b10671}
+}
+
+@phdthesis{yann_garniron_2019_2558127,
+ author = {Yann Garniron},
+ title = {{Development and parallel implementation of
+ selected configuration interaction methods}},
+ school = {Université de Toulouse},
+ year = 2019,
+ month = feb,
+ doi = {10.5281/zenodo.2558127},
+ url = {https://doi.org/10.5281/zenodo.2558127}
+}
+
+@article{Giner_2018,
+ doi = {10.1063/1.5052714},
+ url = {https://doi.org/10.1063%2F1.5052714},
+ year = 2018,
+ month = {nov},
+ publisher = {{AIP} Publishing},
+ volume = {149},
+ number = {19},
+ pages = {194301},
+ author = {Emmanuel Giner and Barth{\'{e}}lemy Pradines and Anthony Fert{\'{e}} and Roland Assaraf and Andreas Savin and Julien Toulouse},
+ title = {Curing basis-set convergence of wave-function theory using density-functional theory: A systematically improvable approach},
+ journal = {The Journal of Chemical Physics}
+}
+
+
+@article{Giner2018Oct,
+ author = {Giner, Emmanuel and Tew, David and Garniron, Yann and Alavi, Ali},
+ title = {{Interplay between electronic correlation and metal-ligand delocalization in the spectroscopy of transition metal compounds: case study on a series of planar Cu2+complexes.}},
+ journal = {J. Chem. Theory Comput.},
+ year = {2018},
+ month = {Oct},
+ issn = {1549-9618},
+ publisher = {American Chemical Society},
+ doi = {10.1021/acs.jctc.8b00591}
+}
+
+@article{Loos_2018,
+ doi = {10.1021/acs.jctc.8b00406},
+ url = {https://doi.org/10.1021%2Facs.jctc.8b00406},
+ year = 2018,
+ month = {jul},
+ publisher = {American Chemical Society ({ACS})},
+ volume = {14},
+ number = {8},
+ pages = {4360--4379},
+ author = {Pierre-Fran{\c{c}}ois Loos and Anthony Scemama and Aymeric Blondel and Yann Garniron and Michel Caffarel and Denis Jacquemin},
+ title = {A Mountaineering Strategy to Excited States: Highly Accurate Reference Energies and Benchmarks},
+ journal = {Journal of Chemical Theory and Computation}
+}
+@article{Scemama_2018,
+ doi = {10.1021/acs.jctc.7b01250},
+ url = {https://doi.org/10.1021%2Facs.jctc.7b01250},
+ year = 2018,
+ month = {jan},
+ publisher = {American Chemical Society ({ACS})},
+ volume = {14},
+ number = {3},
+ pages = {1395--1402},
+ author = {Anthony Scemama and Yann Garniron and Michel Caffarel and Pierre-Fran{\c{c}}ois Loos},
+ title = {Deterministic Construction of Nodal Surfaces within Quantum Monte Carlo: The Case of {FeS}},
+ journal = {Journal of Chemical Theory and Computation}
+}
+@article{Scemama_2018.2,
+ doi = {10.1063/1.5041327},
+ url = {https://doi.org/10.1063%2F1.5041327},
+ year = 2018,
+ month = {jul},
+ publisher = {{AIP} Publishing},
+ volume = {149},
+ number = {3},
+ pages = {034108},
+ author = {Anthony Scemama and Anouar Benali and Denis Jacquemin and Michel Caffarel and Pierre-Fran{\c{c}}ois Loos},
+ title = {Excitation energies from diffusion Monte Carlo using selected configuration interaction nodes},
+ journal = {The Journal of Chemical Physics}
+}
+@article{Dash_2018,
+ doi = {10.1021/acs.jctc.8b00393},
+ url = {https://doi.org/10.1021%2Facs.jctc.8b00393},
+ year = 2018,
+ month = {jun},
+ publisher = {American Chemical Society ({ACS})},
+ volume = {14},
+ number = {8},
+ pages = {4176--4182},
+ author = {Monika Dash and Saverio Moroni and Anthony Scemama and Claudia Filippi},
+ title = {Perturbatively Selected Configuration-Interaction Wave Functions for Efficient Geometry Optimization in Quantum Monte Carlo},
+ journal = {Journal of Chemical Theory and Computation}
+}
+@article{Garniron_2018,
+ doi = {10.1063/1.5044503},
+ url = {https://doi.org/10.1063%2F1.5044503},
+ year = 2018,
+ month = {aug},
+ publisher = {{AIP} Publishing},
+ volume = {149},
+ number = {6},
+ pages = {064103},
+ author = {Yann Garniron and Anthony Scemama and Emmanuel Giner and Michel Caffarel and Pierre-Fran{\c{c}}ois Loos},
+ title = {Selected configuration interaction dressed by perturbation},
+ journal = {The Journal of Chemical Physics}
+}
+@article{Giner_2017,
+ doi = {10.1063/1.4984616},
+ url = {https://doi.org/10.1063%2F1.4984616},
+ year = 2017,
+ month = {jun},
+ publisher = {{AIP} Publishing},
+ volume = {146},
+ number = {22},
+ pages = {224108},
+ author = {Emmanuel Giner and Celestino Angeli and Yann Garniron and Anthony Scemama and Jean-Paul Malrieu},
+ title = {A Jeziorski-Monkhorst fully uncontracted multi-reference perturbative treatment. I. Principles, second-order versions, and tests on ground state potential energy curves},
+ journal = {The Journal of Chemical Physics}
+}
+@article{Garniron_2017,
+ doi = {10.1063/1.4980034},
+ url = {https://doi.org/10.1063%2F1.4980034},
+ year = 2017,
+ month = {apr},
+ publisher = {{AIP} Publishing},
+ volume = {146},
+ number = {15},
+ pages = {154107},
+ author = {Yann Garniron and Emmanuel Giner and Jean-Paul Malrieu and Anthony Scemama},
+ title = {Alternative definition of excitation amplitudes in multi-reference state-specific coupled cluster},
+ journal = {The Journal of Chemical Physics}
+}
+@article{Garniron_2017.2,
+ doi = {10.1063/1.4992127},
+ url = {https://doi.org/10.1063%2F1.4992127},
+ year = 2017,
+ month = {jul},
+ publisher = {{AIP} Publishing},
+ volume = {147},
+ number = {3},
+ pages = {034101},
+ author = {Yann Garniron and Anthony Scemama and Pierre-Fran{\c{c}}ois Loos and Michel Caffarel},
+ title = {Hybrid stochastic-deterministic calculation of the second-order perturbative contribution of multireference perturbation theory},
+ journal = {The Journal of Chemical Physics}
+}
+@article{Giner_2017.2,
+ doi = {10.1016/j.comptc.2017.03.001},
+ url = {https://doi.org/10.1016%2Fj.comptc.2017.03.001},
+ year = 2017,
+ month = {sep},
+ publisher = {Elsevier {BV}},
+ volume = {1116},
+ pages = {134--140},
+ author = {E. Giner and C. Angeli and A. Scemama and J.-P. Malrieu},
+ title = {Orthogonal Valence Bond Hamiltonians incorporating dynamical correlation effects},
+ journal = {Computational and Theoretical Chemistry}
+}
+
+@article{Giner_2017.3,
+ author = {Giner, Emmanuel and Tenti, Lorenzo and Angeli, Celestino and Ferré, Nicolas},
+ title = {Computation of the Isotropic Hyperfine Coupling Constant: Efficiency and Insights from a New Approach Based on Wave Function Theory},
+ journal = {Journal of Chemical Theory and Computation},
+ volume = {13},
+ number = {2},
+ pages = {475-487},
+ year = {2017},
+ doi = {10.1021/acs.jctc.6b00827},
+ note ={PMID: 28094936},
+ URL = {https://doi.org/10.1021/acs.jctc.6b00827},
+ eprint = {https://doi.org/10.1021/acs.jctc.6b00827}
+}
+
+@article{Giner2016Mar,
+ author = {Giner, Emmanuel and Angeli, Celestino},
+ title = {{Spin density and orbital optimization in open shell systems: A rational and computationally efficient proposal}},
+ journal = {J. Chem. Phys.},
+ volume = {144},
+ number = {10},
+ pages = {104104},
+ year = {2016},
+ month = {Mar},
+ issn = {0021-9606},
+ publisher = {American Institute of Physics},
+ doi = {10.1063/1.4943187}
+}
+@article{Giner_2016,
+ doi = {10.1063/1.4940781},
+ url = {https://doi.org/10.1063%2F1.4940781},
+ year = 2016,
+ month = {feb},
+ publisher = {{AIP} Publishing},
+ volume = {144},
+ number = {6},
+ pages = {064101},
+ author = {E. Giner and G. David and A. Scemama and J. P. Malrieu},
+ title = {A simple approach to the state-specific {MR}-{CC} using the intermediate Hamiltonian formalism},
+ journal = {The Journal of Chemical Physics}
+}
+
+@article{Caffarel_2016,
+ doi = {10.1063/1.4947093},
+ url = {https://doi.org/10.1063%2F1.4947093},
+ year = 2016,
+ month = {apr},
+ publisher = {{AIP} Publishing},
+ volume = {144},
+ number = {15},
+ pages = {151103},
+ author = {Michel Caffarel and Thomas Applencourt and Emmanuel Giner and Anthony Scemama},
+ title = {Communication: Toward an improved control of the fixed-node error in quantum Monte Carlo: The case of the water molecule},
+ journal = {The Journal of Chemical Physics}
+}
+@incollection{Caffarel_2016.2,
+ doi = {10.1021/bk-2016-1234.ch002},
+ url = {https://doi.org/10.1021%2Fbk-2016-1234.ch002},
+ year = 2016,
+ month = {jan},
+ publisher = {American Chemical Society},
+ pages = {15--46},
+ author = {Michel Caffarel and Thomas Applencourt and Emmanuel Giner and Anthony Scemama},
+ title = {Using CIPSI Nodes in Diffusion Monte Carlo},
+ booktitle = {{ACS} Symposium Series}
+}
+@article{Giner_2015,
+ doi = {10.1063/1.4905528},
+ url = {https://doi.org/10.1063%2F1.4905528},
+ year = 2015,
+ month = {jan},
+ publisher = {{AIP} Publishing},
+ volume = {142},
+ number = {4},
+ pages = {044115},
+ author = {Emmanuel Giner and Anthony Scemama and Michel Caffarel},
+ title = {Fixed-node diffusion Monte Carlo potential energy curve of the fluorine molecule F2 using selected configuration interaction trial wavefunctions},
+ journal = {The Journal of Chemical Physics}
+}
+
+@article{Giner2015Sep,
+ author = {Giner, Emmanuel and Angeli, Celestino},
+ title = {{Metal-ligand delocalization and spin density in the CuCl2 and [CuCl4]2{-} molecules: Some insights from wave function theory}},
+ journal = {J. Chem. Phys.},
+ volume = {143},
+ number = {12},
+ pages = {124305},
+ year = {2015},
+ month = {Sep},
+ issn = {0021-9606},
+ publisher = {American Institute of Physics},
+ doi = {10.1063/1.4931639}
+}
+
+@article{Scemama_2014,
+ doi = {10.1063/1.4903985},
+ url = {https://doi.org/10.1063%2F1.4903985},
+ year = 2014,
+ month = {dec},
+ publisher = {{AIP} Publishing},
+ volume = {141},
+ number = {24},
+ pages = {244110},
+ author = {A. Scemama and T. Applencourt and E. Giner and M. Caffarel},
+ title = {Accurate nonrelativistic ground-state energies of 3d transition metal atoms},
+ journal = {The Journal of Chemical Physics}
+}
+@article{Caffarel_2014,
+ doi = {10.1021/ct5004252},
+ url = {https://doi.org/10.1021%2Fct5004252},
+ year = 2014,
+ month = {nov},
+ publisher = {American Chemical Society ({ACS})},
+ volume = {10},
+ number = {12},
+ pages = {5286--5296},
+ author = {Michel Caffarel and Emmanuel Giner and Anthony Scemama and Alejandro Ram{\'{\i}}rez-Sol{\'{\i}}s},
+ title = {Spin Density Distribution in Open-Shell Transition Metal Systems: A Comparative Post-Hartree-Fock, Density Functional Theory, and Quantum Monte Carlo Study of the CuCl2 Molecule},
+ journal = {Journal of Chemical Theory and Computation}
+}
+@article{Giner_2013,
+ doi = {10.1139/cjc-2013-0017},
+ url = {https://doi.org/10.1139%2Fcjc-2013-0017},
+ year = 2013,
+ month = {sep},
+ publisher = {Canadian Science Publishing},
+ volume = {91},
+ number = {9},
+ pages = {879--885},
+ author = {Emmanuel Giner and Anthony Scemama and Michel Caffarel},
+ title = {Using perturbatively selected configuration interaction in quantum Monte Carlo calculations},
+ journal = {Canadian Journal of Chemistry}
+}
+
+@article{Scemama2013Nov,
+ author = {Scemama, Anthony and Giner, Emmanuel},
+ title = {{An efficient implementation of Slater-Condon rules}},
+ journal = {arXiv},
+ year = {2013},
+ month = {Nov},
+ eprint = {1311.6244},
+ url = {https://arxiv.org/abs/1311.6244}
+}
+
+
+
+@article{Bytautas_2009,
+ doi = {10.1016/j.chemphys.2008.11.021},
+ url = {https://doi.org/10.1016%2Fj.chemphys.2008.11.021},
+ year = 2009,
+ month = {feb},
+ publisher = {Elsevier {BV}},
+ volume = {356},
+ number = {1-3},
+ pages = {64--75},
+ author = {Laimutis Bytautas and Klaus Ruedenberg},
+ title = {A priori identification of configurational deadwood},
+ journal = {Chemical Physics}
+}
+
+@article{Anderson_2018,
+ doi = {10.1016/j.comptc.2018.08.017},
+ url = {https://doi.org/10.1016%2Fj.comptc.2018.08.017},
+ year = 2018,
+ month = {oct},
+ publisher = {Elsevier {BV}},
+ volume = {1142},
+ pages = {66--77},
+ author = {James S.M. Anderson and Farnaz Heidar-Zadeh and Paul W. Ayers},
+ title = {Breaking the curse of dimension for the electronic Schrodinger equation with functional analysis},
+ journal = {Computational and Theoretical Chemistry}
+}
+
+@article{Bender_1969,
+ doi = {10.1103/physrev.183.23},
+ url = {http://dx.doi.org/10.1103/PhysRev.183.23},
+ year = 1969,
+ month = {jul},
+ publisher = {American Physical Society ({APS})},
+ volume = {183},
+ number = {1},
+ pages = {23--30},
+ author = {Charles F. Bender and Ernest R. Davidson},
+ title = {Studies in Configuration Interaction: The First-Row Diatomic Hydrides},
+ journal = {Phys. Rev.}
+}
+
+@article{Whitten_1969,
+ doi = {10.1063/1.1671985},
+ url = {https://doi.org/10.1063%2F1.1671985},
+ year = 1969,
+ month = {dec},
+ publisher = {{AIP} Publishing},
+ volume = {51},
+ number = {12},
+ pages = {5584--5596},
+ author = {J. L. Whitten and Melvyn Hackmeyer},
+ title = {Configuration Interaction Studies of Ground and Excited States of Polyatomic Molecules. I. The {CI} Formulation and Studies of Formaldehyde},
+ journal = {The Journal of Chemical Physics}
+}
+
+@article{Huron_1973,
+ doi = {10.1063/1.1679199},
+ url = {https://doi.org/10.1063%2F1.1679199},
+ year = 1973,
+ month = {jun},
+ publisher = {{AIP} Publishing},
+ volume = {58},
+ number = {12},
+ pages = {5745--5759},
+ author = {B. Huron and J. P. Malrieu and P. Rancurel},
+ title = {Iterative perturbation calculations of ground and excited state energies from multiconfigurational zeroth-order wavefunctions},
+ journal = {The Journal of Chemical Physics}
+}
+
+@article{Knowles_1984,
+ author="Peter J. Knowles and Nicholas C Handy",
+ year=1984,
+ journal={Chem. Phys. Letters},
+ volume=111,
+ pages="315--321",
+ title="A New Determinant-based Full Configuration Interaction Method"
+}
+
+
+@article{Sharma_2017,
+ doi = {10.1021/acs.jctc.6b01028},
+ url = {https://doi.org/10.1021%2Facs.jctc.6b01028},
+ year = 2017,
+ month = {mar},
+ publisher = {American Chemical Society ({ACS})},
+ volume = {13},
+ number = {4},
+ pages = {1595--1604},
+ author = {Sandeep Sharma and Adam A. Holmes and Guillaume Jeanmairet and Ali Alavi and C. J. Umrigar},
+ title = {Semistochastic Heat-Bath Configuration Interaction Method: Selected Configuration Interaction with Semistochastic Perturbation Theory},
+ journal = {Journal of Chemical Theory and Computation}
+}
+
+@article{Holmes_2016,
+ doi = {10.1021/acs.jctc.6b00407},
+ url = {https://doi.org/10.1021%2Facs.jctc.6b00407},
+ year = 2016,
+ month = {aug},
+ publisher = {American Chemical Society ({ACS})},
+ volume = {12},
+ number = {8},
+ pages = {3674--3680},
+ author = {Adam A. Holmes and Norm M. Tubman and C. J. Umrigar},
+ title = {Heat-Bath Configuration Interaction: An Efficient Selected Configuration Interaction Algorithm Inspired by Heat-Bath Sampling},
+ journal = {Journal of Chemical Theory and Computation}
+}
+@article{Evangelisti_1983,
+ doi = {10.1016/0301-0104(83)85011-3},
+ url = {https://doi.org/10.1016%2F0301-0104%2883%2985011-3},
+ year = 1983,
+ month = {feb},
+ publisher = {Elsevier {BV}},
+ volume = {75},
+ number = {1},
+ pages = {91--102},
+ author = {Stefano Evangelisti and Jean-Pierre Daudey and Jean-Paul Malrieu},
+ title = {Convergence of an improved {CIPSI} algorithm},
+ journal = {Chemical Physics}
+}
+@article{Booth_2009,
+ doi = {10.1063/1.3193710},
+ url = {https://doi.org/10.1063%2F1.3193710},
+ year = 2009,
+ publisher = {{AIP} Publishing},
+ volume = {131},
+ number = {5},
+ pages = {054106},
+ author = {George H. Booth and Alex J. W. Thom and Ali Alavi},
+ title = {Fermion Monte Carlo without fixed nodes: A game of life, death, and annihilation in Slater determinant space},
+ journal = {The Journal of Chemical Physics}
+}
+@article{Booth_2010,
+ doi = {10.1063/1.3407895},
+ url = {https://doi.org/10.1063%2F1.3407895},
+ year = 2010,
+ month = {may},
+ publisher = {{AIP} Publishing},
+ volume = {132},
+ number = {17},
+ pages = {174104},
+ author = {George H. Booth and Ali Alavi},
+ title = {Approaching chemical accuracy using full configuration-interaction quantum Monte Carlo: A study of ionization potentials},
+ journal = {The Journal of Chemical Physics}
+}
+@article{Cleland_2010,
+ doi = {10.1063/1.3302277},
+ url = {https://doi.org/10.1063%2F1.3302277},
+ year = 2010,
+ month = {jan},
+ publisher = {{AIP} Publishing},
+ volume = {132},
+ number = {4},
+ pages = {041103},
+ author = {Deidre Cleland and George H. Booth and Ali Alavi},
+ title = {Communications: Survival of the fittest: Accelerating convergence in full configuration-interaction quantum Monte Carlo},
+ journal = {The Journal of Chemical Physics}
+}
+
+@article{Garniron_2017b,
+ doi = {10.1063/1.4992127},
+ url = {https://doi.org/10.1063%2F1.4992127},
+ year = 2017,
+ month = {jul},
+ publisher = {{AIP} Publishing},
+ volume = {147},
+ number = {3},
+ pages = {034101},
+ author = {Yann Garniron and Anthony Scemama and Pierre-Fran{\c{c}}ois Loos and Michel Caffarel},
+ title = {Hybrid stochastic-deterministic calculation of the second-order perturbative contribution of multireference perturbation theory},
+ journal = {The Journal of Chemical Physics}
+}
+
+
+
diff --git a/ocaml/Atom.ml b/ocaml/Atom.ml
index d02b20d8..49e788e8 100644
--- a/ocaml/Atom.ml
+++ b/ocaml/Atom.ml
@@ -22,10 +22,15 @@ let of_string ~units s =
}
| [ name; x; y; z ] ->
let e = Element.of_string name in
- { element = e ;
- charge = Element.to_charge e;
- coord = Point3d.of_string ~units (String.concat " " [x; y; z])
- }
+ begin
+ try
+ { element = e ;
+ charge = Element.to_charge e;
+ coord = Point3d.of_string ~units (String.concat " " [x; y; z])
+ }
+ with
+ | err -> (Printf.eprintf "name = \"%s\"\nxyz = (%s,%s,%s)\n%!" name x y z ; raise err)
+ end
| _ -> raise (AtomError s)
diff --git a/ocaml/Molecule.ml b/ocaml/Molecule.ml
index 603244c8..3771b6f9 100644
--- a/ocaml/Molecule.ml
+++ b/ocaml/Molecule.ml
@@ -142,13 +142,21 @@ let of_xyz_string
result
+let regexp_r = Str.regexp {|
|}
+let regexp_t = Str.regexp {| |}
+
let of_xyz_file
?(charge=(Charge.of_int 0)) ?(multiplicity=(Multiplicity.of_int 1))
?(units=Units.Angstrom)
filename =
let lines =
- match Io_ext.input_lines filename with
+ Io_ext.input_lines filename
+ |> List.map (fun s -> Str.global_replace regexp_r "" s)
+ |> List.map (fun s -> Str.global_replace regexp_t " " s)
+ in
+ let lines =
+ match lines with
| natoms :: title :: rest ->
let natoms =
try
@@ -173,6 +181,8 @@ let of_zmt_file
?(units=Units.Angstrom)
filename =
Io_ext.read_all filename
+ |> Str.global_replace regexp_r ""
+ |> Str.global_replace regexp_t " "
|> Zmatrix.of_string
|> Zmatrix.to_xyz_string
|> of_xyz_string ~charge ~multiplicity ~units
diff --git a/ocaml/Point3d.ml b/ocaml/Point3d.ml
index 57b02bfe..4df375e4 100644
--- a/ocaml/Point3d.ml
+++ b/ocaml/Point3d.ml
@@ -24,7 +24,9 @@ let of_string ~units s =
let l = s
|> String_ext.split ~on:' '
|> List.filter (fun x -> x <> "")
- |> list_map float_of_string
+ |> list_map (fun x ->
+ try float_of_string x with
+ | Failure msg -> (Printf.eprintf "Bad string: \"%s\"\n%!" x ; failwith msg) )
|> Array.of_list
in
{ x = l.(0) *. f ;
diff --git a/plugins/README.rst b/plugins/README.rst
new file mode 100644
index 00000000..3dc50873
--- /dev/null
+++ b/plugins/README.rst
@@ -0,0 +1,131 @@
+==============================
+Tutorial for creating a plugin
+==============================
+
+Introduction: what is a plugin, and what tutorial will be about ?
+=================================================================
+
+The |QP| is split into two kinds of routines/global variables (i.e. *providers*):
+ 1) the **core modules** locatedin qp2/src/, which contains all the bulk of a quantum chemistry software (integrals, matrix elements between Slater determinants, linear algebra routines, DFT stuffs etc..)
+ 2) the **plugins** which are external routines/*providers* connected to the qp2/src/ routines/*providers*.
+
+More precisely, a **plugin** of the |QP| is a directory where you can create routines,
+providers and executables that use all the global variables/functions/routines already created
+in the modules of qp2/src or in other plugins.
+
+Instead of giving a theoretical lecture on what is a plugin,
+we will go through a series of examples that allow you to do the following thing:
+
+1) print out **one- and two-electron integrals** on the AO/MO basis, creates two providers which manipulate these objects, print out these providers,
+
+2) browse the **Slater determinants stored** in the |EZFIO| wave function and compute their matrix elements,
+
+3) build the **Hamiltonian matrix** and **diagonalize** it either with **Lapack or Davidson**,
+
+4) print out the **one- and two-electron rdms**,
+
+5) obtain the **AOs** and **MOs** on the **DFT grid**, together with the **density**,
+
+How the tutorial will be done
+-----------------------------
+
+This tuto is as follows:
+
+ 1) you **READ THIS FILE UNTIL THE END** in order to get the big picture and vocabulary,
+
+ 2) you go to the directory :file:`qp2/plugins/tuto_plugins/` and you will find detailed tutorials for each of the 5 examples.
+
+Creating a plugin: the basic
+----------------------------
+
+The first thing to do is to be in the QPSH mode: you execute the qp2/bin/qpsh script that essentially loads all
+the environement variables and allows for the completion of command lines in bash (that is an AMAZING feature :)
+
+Then, you need to known **where** you want to create your plugin, and what is the **name** of the plugin.
+
+.. important::
+
+ The plugins are **NECESSARILY** located in qp2/plugins/, and from there you can create any structures of directories.
+
+
+Ex: If you want to create a plugin named "my_fancy_plugin" in the directory plugins/plugins_test/,
+this goes with the command
+
+.. code:: bash
+
+ qp plugins create -n my_fancy_plugin -r plugins_test/
+
+Then, to create the plugin of your dreams, the two questions you need to answer are the following:
+
+1) What do I **need** to compute what I want, which means what are the **objects** that I need ?
+
+ There are two kind of objects:
+
+ + the *routines/functions*:
+
+ Ex: Linear algebra routines, integration routines etc ...
+
+ + the global variables which are called the *providers*:
+
+ Ex: one-electron integrals, Slater determinants, density matrices etc ...
+
+2) **Where do I find** these objects ?
+
+ The objects (routines/functions/providers) are necessarily created in other *modules/plugins*.
+
+.. seealso::
+
+ The routine :c:func:`lapack_diagd` (which diagonalises a real hermitian matrix) is located in the file
+ :file:`qp2/src/utils/linear_algebra.irp.f`
+ therefore it "belongs" to the module :ref:`module_utils`
+
+ The routine :c:func:`ao_to_mo` (which converts a given matrix A from the AO basis to the MO basis) is located in the file
+ :file:`qp2/src/mo_one_e_ints/ao_to_mo.irp.f`
+ therefore it "belongs" to the module :ref:`module_mo_one_e_ints`
+
+ The provider :c:data:`ao_one_e_integrals` (which is the integrals of one-body part of H on the AO basis) is located in the file
+ :file:`qp2/src/ao_one_e_ints/ao_one_e_ints.irp.f`
+ therefore it belongs to the module :ref:`module_ao_one_e_ints`
+
+ The provider :c:data:`one_e_dm_mo_beta_average` (which is the state average beta density matrix on the MO basis) is located in the file
+ :file:`qp2/src/determinants/density_matrix.irp.f`
+ therefore it belongs to the module :ref:`module_determinants`
+
+To import all the variables that you need, you just need to write the name of the plugins in the :file:`NEED` file .
+
+To import all the variables/routines of the module :ref:`module_utils`, :ref:`module_determinants` and :ref:`module_mo_one_e_ints`, the :file:`NEED` file you will need is simply the following:
+
+.. code:: bash
+
+ cat NEED
+
+ utils
+ determinants
+ mo_one_e_ints
+
+
+.. important::
+
+ There are **many** routines/providers in the core modules of QP.
+
+ Nevertheless, as everything is coded with the |IRPF90|, you can use the following amazing tools: :command:`irpman`
+
+ :command:`irpman` can be used in command line in bash to obtain all the info on a routine or variable !
+
+
+Example: execute the following command line :
+
+.. code:: bash
+
+ irpman ao_one_e_integrals
+
+Then all the information you need on :c:data:`ao_one_e_integrals` will appear on the screen.
+This includes
+
+ - **where** the provider is created, (*i.e.* the actual file where the provider is designed)
+ - the **type** of the provider (*i.e.* a logical, integer etc ...)
+ - the **dimension** if it is an array,
+ - what other *providers* are **needed** to build this provider,
+ - what other *providers* **need** this provider.
+
+
diff --git a/plugins/local/basis_correction/51.basis_c.bats b/plugins/local/basis_correction/51.basis_c.bats
index 914b482b..1e20bae3 100644
--- a/plugins/local/basis_correction/51.basis_c.bats
+++ b/plugins/local/basis_correction/51.basis_c.bats
@@ -37,14 +37,6 @@ function run_sd() {
eq $energy1 $1 $thresh
}
-@test "O2 CAS" {
- qp set_file o2_cas.gms.ezfio
- qp set_mo_class -c "[1-2]" -a "[3-10]" -d "[11-46]"
- run -149.72435425 3.e-4 10000
- qp set_mo_class -c "[1-2]" -a "[3-10]" -v "[11-46]"
- run_md -0.1160222327 1.e-6
-}
-
@test "LiF RHF" {
qp set_file lif.ezfio
diff --git a/plugins/local/bi_ort_ints/no_dressing.irp.f b/plugins/local/bi_ort_ints/no_dressing.irp.f
index bd225274..fd2c6285 100644
--- a/plugins/local/bi_ort_ints/no_dressing.irp.f
+++ b/plugins/local/bi_ort_ints/no_dressing.irp.f
@@ -322,6 +322,12 @@ END_PROVIDER
BEGIN_PROVIDER [double precision, noL_0e]
+ BEGIN_DOC
+ !
+ ! < Phi_left | L | Phi_right >
+ !
+ END_DOC
+
implicit none
integer :: i, j, k, ipoint
double precision :: t0, t1
@@ -330,10 +336,6 @@ BEGIN_PROVIDER [double precision, noL_0e]
double precision, allocatable :: tmp_M(:,:), tmp_S(:), tmp_O(:), tmp_J(:,:)
double precision, allocatable :: tmp_M_priv(:,:), tmp_S_priv(:), tmp_O_priv(:), tmp_J_priv(:,:)
-
- call wall_time(t0)
- print*, " Providing noL_0e ..."
-
if(elec_alpha_num .eq. elec_beta_num) then
allocate(tmp(elec_beta_num))
@@ -708,11 +710,6 @@ BEGIN_PROVIDER [double precision, noL_0e]
endif
- call wall_time(t1)
- print*, " Wall time for noL_0e (min) = ", (t1 - t0)/60.d0
-
- print*, " noL_0e = ", noL_0e
-
END_PROVIDER
! ---
diff --git a/plugins/local/bi_ort_ints/semi_num_ints_mo.irp.f b/plugins/local/bi_ort_ints/semi_num_ints_mo.irp.f
index 51f0cba4..77e4cb9b 100644
--- a/plugins/local/bi_ort_ints/semi_num_ints_mo.irp.f
+++ b/plugins/local/bi_ort_ints/semi_num_ints_mo.irp.f
@@ -107,8 +107,8 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_transp, (ao_num, ao_num, 3,
integer :: i, j, ipoint
double precision :: wall0, wall1
- print *, ' providing int2_grad1_u12_ao_transp ...'
- call wall_time(wall0)
+ !print *, ' providing int2_grad1_u12_ao_transp ...'
+ !call wall_time(wall0)
if(test_cycle_tc) then
@@ -142,15 +142,15 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_transp, (ao_num, ao_num, 3,
endif
- call wall_time(wall1)
- print *, ' wall time for int2_grad1_u12_ao_transp ', wall1 - wall0
- call print_memory_usage()
+ !call wall_time(wall1)
+ !print *, ' wall time for int2_grad1_u12_ao_transp (min) = ', (wall1 - wall0) / 60.d0
+ !call print_memory_usage()
END_PROVIDER
! ---
-BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_transp, (mo_num, mo_num, 3, n_points_final_grid)]
+BEGIN_PROVIDER [double precision, int2_grad1_u12_bimo_transp, (mo_num, mo_num, 3, n_points_final_grid)]
implicit none
integer :: ipoint
@@ -159,7 +159,7 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_transp, (mo_num, mo_num,
PROVIDE mo_l_coef mo_r_coef
PROVIDE int2_grad1_u12_ao_transp
- !print *, ' providing int2_grad1_u12_bimo_transp'
+ !print *, ' providing int2_grad1_u12_bimo_transp ...'
!call wall_time(wall0)
!$OMP PARALLEL &
@@ -167,33 +167,35 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_transp, (mo_num, mo_num,
!$OMP PRIVATE (ipoint) &
!$OMP SHARED (n_points_final_grid,int2_grad1_u12_ao_transp,int2_grad1_u12_bimo_transp)
!$OMP DO SCHEDULE (dynamic)
- do ipoint = 1, n_points_final_grid
- call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp (1,1,1,ipoint), size(int2_grad1_u12_ao_transp , 1) &
- , int2_grad1_u12_bimo_transp(1,1,1,ipoint), size(int2_grad1_u12_bimo_transp, 1) )
- call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp (1,1,2,ipoint), size(int2_grad1_u12_ao_transp , 1) &
- , int2_grad1_u12_bimo_transp(1,1,2,ipoint), size(int2_grad1_u12_bimo_transp, 1) )
- call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp (1,1,3,ipoint), size(int2_grad1_u12_ao_transp , 1) &
- , int2_grad1_u12_bimo_transp(1,1,3,ipoint), size(int2_grad1_u12_bimo_transp, 1) )
- enddo
+ do ipoint = 1, n_points_final_grid
+ call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp (1,1,1,ipoint), size(int2_grad1_u12_ao_transp , 1) &
+ , int2_grad1_u12_bimo_transp(1,1,1,ipoint), size(int2_grad1_u12_bimo_transp, 1) )
+ call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp (1,1,2,ipoint), size(int2_grad1_u12_ao_transp , 1) &
+ , int2_grad1_u12_bimo_transp(1,1,2,ipoint), size(int2_grad1_u12_bimo_transp, 1) )
+ call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp (1,1,3,ipoint), size(int2_grad1_u12_ao_transp , 1) &
+ , int2_grad1_u12_bimo_transp(1,1,3,ipoint), size(int2_grad1_u12_bimo_transp, 1) )
+ enddo
!$OMP END DO
!$OMP END PARALLEL
+ !FREE int2_grad1_u12_ao_transp
+
!call wall_time(wall1)
- !print *, ' Wall time for providing int2_grad1_u12_bimo_transp',wall1 - wall0
+ !print *, ' wall time for int2_grad1_u12_bimo_transp (min) =', (wall1 - wall0) / 60.d0
!call print_memory_usage()
END_PROVIDER
! ---
-BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_t, (n_points_final_grid, 3, mo_num, mo_num)]
+BEGIN_PROVIDER [double precision, int2_grad1_u12_bimo_t, (n_points_final_grid, 3, mo_num, mo_num)]
implicit none
integer :: i, j, ipoint
double precision :: wall0, wall1
!call wall_time(wall0)
- !print *, ' Providing int2_grad1_u12_bimo_t ...'
+ !print *, ' providing int2_grad1_u12_bimo_t ...'
PROVIDE mo_l_coef mo_r_coef
PROVIDE int2_grad1_u12_bimo_transp
@@ -211,17 +213,21 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_t, (n_points_final_grid,
FREE int2_grad1_u12_bimo_transp
!call wall_time(wall1)
- !print *, ' wall time for int2_grad1_u12_bimo_t,', wall1 - wall0
+ !print *, ' wall time for int2_grad1_u12_bimo_t (min) =', (wall1 - wall0) / 60.d0
!call print_memory_usage()
END_PROVIDER
! ---
-BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_t, (n_points_final_grid, 3, ao_num, ao_num)]
+BEGIN_PROVIDER [double precision, int2_grad1_u12_ao_t, (n_points_final_grid, 3, ao_num, ao_num)]
implicit none
- integer :: i, j, ipoint
+ integer :: i, j, ipoint
+ double precision :: wall0, wall1
+
+ !call wall_time(wall0)
+ !print *, ' providing int2_grad1_u12_ao_t ...'
PROVIDE int2_grad1_u12_ao
@@ -235,6 +241,10 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_t, (n_points_final_grid, 3,
enddo
enddo
+ !call wall_time(wall1)
+ !print *, ' wall time for int2_grad1_u12_ao_t (min) =', (wall1 - wall0) / 60.d0
+ !call print_memory_usage()
+
END_PROVIDER
! ---
@@ -275,8 +285,8 @@ BEGIN_PROVIDER [ double precision, x_W_ki_bi_ortho_erf_rk, (n_points_final_grid,
double precision :: xyz
double precision :: wall0, wall1
- print*, ' providing x_W_ki_bi_ortho_erf_rk ...'
- call wall_time(wall0)
+ !print*, ' providing x_W_ki_bi_ortho_erf_rk ...'
+ !call wall_time(wall0)
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
@@ -300,8 +310,8 @@ BEGIN_PROVIDER [ double precision, x_W_ki_bi_ortho_erf_rk, (n_points_final_grid,
! FREE mo_v_ki_bi_ortho_erf_rk_cst_mu_transp
! FREE mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp
- call wall_time(wall1)
- print *, ' time to provide x_W_ki_bi_ortho_erf_rk = ', wall1 - wall0
+ !call wall_time(wall1)
+ !print *, ' time to provide x_W_ki_bi_ortho_erf_rk = ', wall1 - wall0
END_PROVIDER
@@ -323,8 +333,8 @@ BEGIN_PROVIDER [ double precision, x_W_ki_bi_ortho_erf_rk_diag, (n_points_final_
double precision :: xyz
double precision :: wall0, wall1
- print*,'providing x_W_ki_bi_ortho_erf_rk_diag ...'
- call wall_time(wall0)
+ !print*,'providing x_W_ki_bi_ortho_erf_rk_diag ...'
+ !call wall_time(wall0)
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
@@ -343,8 +353,8 @@ BEGIN_PROVIDER [ double precision, x_W_ki_bi_ortho_erf_rk_diag, (n_points_final_
!$OMP END DO
!$OMP END PARALLEL
- call wall_time(wall1)
- print*,'time to provide x_W_ki_bi_ortho_erf_rk_diag = ',wall1 - wall0
+ !call wall_time(wall1)
+ !print*,'time to provide x_W_ki_bi_ortho_erf_rk_diag = ',wall1 - wall0
END_PROVIDER
diff --git a/plugins/local/bi_ort_ints/three_body_ints_bi_ort.irp.f b/plugins/local/bi_ort_ints/three_body_ints_bi_ort.irp.f
index 726e48ba..73e5a611 100644
--- a/plugins/local/bi_ort_ints/three_body_ints_bi_ort.irp.f
+++ b/plugins/local/bi_ort_ints/three_body_ints_bi_ort.irp.f
@@ -123,7 +123,7 @@ subroutine give_integrals_3_body_bi_ort_spin( n, sigma_n, l, sigma_l, k, sigma_k
endif
return
-end subroutine give_integrals_3_body_bi_ort_spin
+end
! ---
@@ -168,7 +168,7 @@ subroutine give_integrals_3_body_bi_ort(n, l, k, m, j, i, integral)
integral = integral + tmp * final_weight_at_r_vector(ipoint)
enddo
-end subroutine give_integrals_3_body_bi_ort
+end
! ---
diff --git a/plugins/local/bi_ort_ints/total_twoe_pot.irp.f b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f
index 5e6a24e9..e27fdb7f 100644
--- a/plugins/local/bi_ort_ints/total_twoe_pot.irp.f
+++ b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f
@@ -16,10 +16,10 @@ double precision function bi_ortho_mo_ints(l, k, j, i)
integer :: m, n, p, q
bi_ortho_mo_ints = 0.d0
- do m = 1, ao_num
- do p = 1, ao_num
- do n = 1, ao_num
- do q = 1, ao_num
+ do p = 1, ao_num
+ do m = 1, ao_num
+ do q = 1, ao_num
+ do n = 1, ao_num
! p1h1p2h2 l1 l2 r1 r2
bi_ortho_mo_ints += ao_two_e_tc_tot(n,q,m,p) * mo_l_coef(m,l) * mo_l_coef(n,k) * mo_r_coef(p,j) * mo_r_coef(q,i)
enddo
@@ -27,7 +27,7 @@ double precision function bi_ortho_mo_ints(l, k, j, i)
enddo
enddo
-end function bi_ortho_mo_ints
+end
! ---
@@ -40,38 +40,106 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num,
END_DOC
implicit none
- integer :: i, j, k, l, m, n, p, q
+ integer :: i, j, k, l, m, n, p, q, s, r
+ double precision :: t1, t2, tt1, tt2
double precision, allocatable :: a1(:,:,:,:), a2(:,:,:,:)
+ double precision, allocatable :: a_jkp(:,:,:), a_kpq(:,:,:), ao_two_e_tc_tot_tmp(:,:,:)
+
+ print *, ' PROVIDING mo_bi_ortho_tc_two_e_chemist ...'
+ call wall_time(t1)
+ call print_memory_usage()
PROVIDE mo_r_coef mo_l_coef
- allocate(a2(ao_num,ao_num,ao_num,mo_num))
+ if(ao_to_mo_tc_n3) then
- call dgemm( 'T', 'N', ao_num*ao_num*ao_num, mo_num, ao_num, 1.d0 &
- , ao_two_e_tc_tot(1,1,1,1), ao_num, mo_l_coef(1,1), ao_num &
- , 0.d0 , a2(1,1,1,1), ao_num*ao_num*ao_num)
+ print*, ' memory scale of TC ao -> mo: O(N3) '
- allocate(a1(ao_num,ao_num,mo_num,mo_num))
+ if(.not.read_tc_integ) then
+ stop 'read_tc_integ needs to be set to true'
+ endif
- call dgemm( 'T', 'N', ao_num*ao_num*mo_num, mo_num, ao_num, 1.d0 &
- , a2(1,1,1,1), ao_num, mo_r_coef(1,1), ao_num &
- , 0.d0, a1(1,1,1,1), ao_num*ao_num*mo_num)
+ allocate(a_jkp(ao_num,ao_num,mo_num))
+ allocate(a_kpq(ao_num,mo_num,mo_num))
+ allocate(ao_two_e_tc_tot_tmp(ao_num,ao_num,ao_num))
- deallocate(a2)
- allocate(a2(ao_num,mo_num,mo_num,mo_num))
+ open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/ao_two_e_tc_tot', action="read")
- call dgemm( 'T', 'N', ao_num*mo_num*mo_num, mo_num, ao_num, 1.d0 &
- , a1(1,1,1,1), ao_num, mo_l_coef(1,1), ao_num &
- , 0.d0, a2(1,1,1,1), ao_num*mo_num*mo_num)
+ call wall_time(tt1)
- deallocate(a1)
+ mo_bi_ortho_tc_two_e_chemist(:,:,:,:) = 0.d0
+ do l = 1, ao_num
+ read(11) ao_two_e_tc_tot_tmp(:,:,:)
- call dgemm( 'T', 'N', mo_num*mo_num*mo_num, mo_num, ao_num, 1.d0 &
- , a2(1,1,1,1), ao_num, mo_r_coef(1,1), ao_num &
- , 0.d0, mo_bi_ortho_tc_two_e_chemist(1,1,1,1), mo_num*mo_num*mo_num)
+ do s = 1, mo_num
- deallocate(a2)
+ call dgemm( 'T', 'N', ao_num*ao_num, mo_num, ao_num, 1.d0 &
+ , ao_two_e_tc_tot_tmp(1,1,1), ao_num, mo_l_coef(1,1), ao_num &
+ , 0.d0, a_jkp(1,1,1), ao_num*ao_num)
+ call dgemm( 'T', 'N', ao_num*mo_num, mo_num, ao_num, 1.d0 &
+ , a_jkp(1,1,1), ao_num, mo_r_coef(1,1), ao_num &
+ , 0.d0, a_kpq(1,1,1), ao_num*mo_num)
+
+ call dgemm( 'T', 'N', mo_num*mo_num, mo_num, ao_num, mo_r_coef(l,s) &
+ , a_kpq(1,1,1), ao_num, mo_l_coef(1,1), ao_num &
+ , 1.d0, mo_bi_ortho_tc_two_e_chemist(1,1,1,s), mo_num*mo_num)
+
+ enddo ! s
+
+ if(l == 2) then
+ call wall_time(tt2)
+ print*, ' 1 / mo_num done in (min)', (tt2-tt1)/60.d0
+ print*, ' estimated time required (min)', dble(mo_num-1)*(tt2-tt1)/60.d0
+ elseif(l == 11) then
+ call wall_time(tt2)
+ print*, ' 10 / mo_num done in (min)', (tt2-tt1)/60.d0
+ print*, ' estimated time required (min)', dble(mo_num-10)*(tt2-tt1)/(60.d0*10.d0)
+ elseif(l == 101) then
+ call wall_time(tt2)
+ print*, ' 100 / mo_num done in (min)', (tt2-tt1)/60.d0
+ print*, ' estimated time required (min)', dble(mo_num-100)*(tt2-tt1)/(60.d0*100.d0)
+ endif
+ enddo ! l
+
+ close(11)
+
+ deallocate(a_jkp, a_kpq, ao_two_e_tc_tot_tmp)
+
+ else
+
+ print*, ' memory scale of TC ao -> mo: O(N4) '
+
+ allocate(a2(ao_num,ao_num,ao_num,mo_num))
+
+ call dgemm( 'T', 'N', ao_num*ao_num*ao_num, mo_num, ao_num, 1.d0 &
+ , ao_two_e_tc_tot(1,1,1,1), ao_num, mo_l_coef(1,1), ao_num &
+ , 0.d0, a2(1,1,1,1), ao_num*ao_num*ao_num)
+
+ FREE ao_two_e_tc_tot
+
+ allocate(a1(ao_num,ao_num,mo_num,mo_num))
+
+ call dgemm( 'T', 'N', ao_num*ao_num*mo_num, mo_num, ao_num, 1.d0 &
+ , a2(1,1,1,1), ao_num, mo_r_coef(1,1), ao_num &
+ , 0.d0, a1(1,1,1,1), ao_num*ao_num*mo_num)
+
+ deallocate(a2)
+ allocate(a2(ao_num,mo_num,mo_num,mo_num))
+
+ call dgemm( 'T', 'N', ao_num*mo_num*mo_num, mo_num, ao_num, 1.d0 &
+ , a1(1,1,1,1), ao_num, mo_l_coef(1,1), ao_num &
+ , 0.d0, a2(1,1,1,1), ao_num*mo_num*mo_num)
+
+ deallocate(a1)
+
+ call dgemm( 'T', 'N', mo_num*mo_num*mo_num, mo_num, ao_num, 1.d0 &
+ , a2(1,1,1,1), ao_num, mo_r_coef(1,1), ao_num &
+ , 0.d0, mo_bi_ortho_tc_two_e_chemist(1,1,1,1), mo_num*mo_num*mo_num)
+
+ deallocate(a2)
+
+ endif
!allocate(a1(mo_num,ao_num,ao_num,ao_num))
!a1 = 0.d0
@@ -135,6 +203,10 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num,
!enddo
!deallocate(a1)
+ call wall_time(t2)
+ print *, ' WALL TIME for PROVIDING mo_bi_ortho_tc_two_e_chemist (min)', (t2-t1)/60.d0
+ call print_memory_usage()
+
END_PROVIDER
! ---
@@ -176,6 +248,34 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e, (mo_num, mo_num, mo_num,
END_PROVIDER
+BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_two_e_transp, (mo_num, mo_num, mo_num, mo_num)]
+ implicit none
+ BEGIN_DOC
+ !
+ ! mo_bi_ortho_tc_two_e_transp(i,j,k,l) = = transpose of mo_bi_ortho_tc_two_e
+ !
+ ! the potential V(r_12) contains ALL TWO-E CONTRIBUTION OF THE TC-HAMILTONIAN
+ !
+ END_DOC
+
+ integer :: i,j,k,l
+ print*,'Providing mo_bi_ortho_tc_two_e_transp'
+ double precision :: t0,t1
+ call wall_time(t0)
+ do i = 1, mo_num
+ do j = 1, mo_num
+ do k = 1, mo_num
+ do l = 1, mo_num
+ mo_bi_ortho_tc_two_e_transp(i,j,k,l) = mo_bi_ortho_tc_two_e(k,l,i,j)
+ enddo
+ enddo
+ enddo
+ enddo
+ call wall_time(t1)
+
+ print *, ' WALL TIME for PROVIDING mo_bi_ortho_tc_two_e_transp (min)', (t1-t0)/60.d0
+
+END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_two_e_jj, (mo_num,mo_num)]
@@ -232,3 +332,23 @@ END_PROVIDER
! ---
+ BEGIN_PROVIDER [double precision, tc_2e_3idx_coulomb_integrals_transp , (mo_num,mo_num,mo_num)]
+&BEGIN_PROVIDER [double precision, tc_2e_3idx_exchange_integrals_transp, (mo_num,mo_num,mo_num)]
+
+ BEGIN_DOC
+ ! tc_2e_3idx_coulomb_integrals_transp (j,k,i) =
+ ! tc_2e_3idx_exchange_integrals_transp(j,k,i) =
+ END_DOC
+ implicit none
+ integer :: i, j, k
+
+ do i = 1, mo_num
+ do k = 1, mo_num
+ do j = 1, mo_num
+ tc_2e_3idx_coulomb_integrals_transp(j, k,i) = mo_bi_ortho_tc_two_e_transp(j ,k ,j ,i )
+ tc_2e_3idx_exchange_integrals_transp(j,k,i) = mo_bi_ortho_tc_two_e_transp(k ,j ,j ,i )
+ enddo
+ enddo
+ enddo
+
+END_PROVIDER
diff --git a/plugins/local/bi_ortho_mos/overlap.irp.f b/plugins/local/bi_ortho_mos/overlap.irp.f
index ff5d5c84..7f07929f 100644
--- a/plugins/local/bi_ortho_mos/overlap.irp.f
+++ b/plugins/local/bi_ortho_mos/overlap.irp.f
@@ -56,10 +56,10 @@
print*,'Average trace of overlap_bi_ortho is different from 1 by ', dabs(accu_d-1.d0)
print*,'And bi orthogonality is off by an average of ',accu_nd
print*,'****************'
- print*,'Overlap matrix betwee mo_l_coef and mo_r_coef '
- do i = 1, mo_num
- write(*,'(100(F16.10,X))')overlap_bi_ortho(i,:)
- enddo
+ !print*,'Overlap matrix betwee mo_l_coef and mo_r_coef '
+ !do i = 1, mo_num
+ ! write(*,'(100(F16.10,X))')overlap_bi_ortho(i,:)
+ !enddo
endif
print*,'Average trace of overlap_bi_ortho (should be 1.)'
print*,'accu_d = ',accu_d
diff --git a/plugins/local/cipsi_tc_bi_ortho/get_d0_transp.irp.f b/plugins/local/cipsi_tc_bi_ortho/get_d0_transp.irp.f
new file mode 100644
index 00000000..f149e7c6
--- /dev/null
+++ b/plugins/local/cipsi_tc_bi_ortho/get_d0_transp.irp.f
@@ -0,0 +1,108 @@
+subroutine get_d0_transp(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, coefs)
+ !todo: indices/conjg should be okay for complex
+ use bitmasks
+ implicit none
+
+ integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2)
+ integer(bit_kind), intent(in) :: phasemask(N_int,2)
+ logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2)
+ integer(bit_kind) :: det(N_int, 2)
+ double precision, intent(in) :: coefs(N_states,2)
+ double precision, intent(inout) :: mat_l(N_states, mo_num, mo_num)
+ double precision, intent(inout) :: mat_r(N_states, mo_num, mo_num)
+ integer, intent(in) :: h(0:2,2), p(0:4,2), sp
+
+ integer :: i, j, k, s, h1, h2, p1, p2, puti, putj, mm
+ double precision :: phase
+ double precision :: hij,hji
+ double precision, external :: get_phase_bi
+ logical :: ok
+
+ integer, parameter :: bant=1
+ double precision, allocatable :: hij_cache1(:), hij_cache2(:)
+ allocate (hij_cache1(mo_num),hij_cache2(mo_num))
+ double precision, allocatable :: hji_cache1(:), hji_cache2(:)
+ allocate (hji_cache1(mo_num),hji_cache2(mo_num))
+! print*,'in get_d0_new'
+! call debug_det(gen,N_int)
+! print*,'coefs',coefs(1,:)
+
+ if(sp == 3) then ! AB
+ h1 = p(1,1)
+ h2 = p(1,2)
+ do p1=1, mo_num
+ if(bannedOrb(p1, 1)) cycle
+! call get_mo_two_e_integrals_complex(p1,h2,h1,mo_num,hij_cache1,mo_integrals_map)
+ do mm = 1, mo_num
+ hij_cache1(mm) = mo_bi_ortho_tc_two_e(mm,p1,h2,h1)
+ hji_cache1(mm) = mo_bi_ortho_tc_two_e_transp(mm,p1,h2,h1)
+ enddo
+ !!!!!!!!!!
+ do p2=1, mo_num
+ if(bannedOrb(p2,2)) cycle
+ if(banned(p1, p2, bant)) cycle ! rentable?
+ if(p1 == h1 .or. p2 == h2) then
+ call apply_particles(mask, 1,p1,2,p2, det, ok, N_int)
+ ! call i_h_j_complex(gen, det, N_int, hij) ! need to take conjugate of this
+! call i_h_j_complex(det, gen, N_int, hij)
+ call htilde_mu_mat_opt_bi_ortho_no_3e_both(det,gen,N_int, hij,hji)
+ else
+ phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int)
+ hij = hij_cache1(p2) * phase
+ hji = hji_cache1(p2) * phase
+ end if
+ if (hij == 0.d0.or.hji == 0.d0) cycle
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ mat_r(k, p1, p2) = mat_r(k, p1, p2) + coefs(k,2) * hij ! HOTSPOT
+ mat_l(k, p1, p2) = mat_l(k, p1, p2) + coefs(k,1) * hji ! HOTSPOT
+ enddo
+ end do
+ end do
+
+ else ! AA BB
+ p1 = p(1,sp)
+ p2 = p(2,sp)
+ do puti=1, mo_num
+ if(bannedOrb(puti, sp)) cycle
+! call get_mo_two_e_integrals_complex(puti,p2,p1,mo_num,hij_cache1,mo_integrals_map,mo_integrals_map_2)
+! call get_mo_two_e_integrals_complex(puti,p1,p2,mo_num,hij_cache2,mo_integrals_map,mo_integrals_map_2)
+ do mm = 1, mo_num
+ hij_cache1(mm) = mo_bi_ortho_tc_two_e(mm,puti,p2,p1)
+ hij_cache2(mm) = mo_bi_ortho_tc_two_e(mm,puti,p1,p2)
+ hji_cache1(mm) = mo_bi_ortho_tc_two_e_transp(mm,puti,p2,p1)
+ hji_cache2(mm) = mo_bi_ortho_tc_two_e_transp(mm,puti,p1,p2)
+ enddo
+ !!!!!!!!!!
+ do putj=puti+1, mo_num
+ if(bannedOrb(putj, sp)) cycle
+ if(banned(puti, putj, bant)) cycle ! rentable?
+ if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then
+ call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int)
+ !call i_h_j_complex(gen, det, N_int, hij) ! need to take conjugate of this
+! call i_h_j_complex(det, gen, N_int, hij)
+ call htilde_mu_mat_opt_bi_ortho_no_3e_both(det,gen,N_int, hij,hji)
+ if (hij == 0.d0.or.hji == 0.d0) cycle
+ else
+! hij = (mo_two_e_integral_complex(p1, p2, puti, putj) - mo_two_e_integral_complex(p2, p1, puti, putj))
+! hij = (mo_bi_ortho_tc_two_e(p1, p2, puti, putj) - mo_bi_ortho_tc_two_e(p2, p1, puti, putj))
+ hij = (mo_bi_ortho_tc_two_e(puti, putj, p1, p2) - mo_bi_ortho_tc_two_e(puti, putj, p2, p1))
+ hji = (mo_bi_ortho_tc_two_e_transp(puti, putj, p1, p2) - mo_bi_ortho_tc_two_e_transp(puti, putj, p2, p1))
+ if (hij == 0.d0.or.hji == 0.d0) cycle
+ phase = get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2, N_int)
+ hij = (hij) * phase
+ hji = (hji) * phase
+ end if
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,2) * hij
+ mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,1) * hji
+ enddo
+ end do
+
+ end do
+ end if
+
+ deallocate(hij_cache1,hij_cache2)
+end
+
diff --git a/plugins/local/cipsi_tc_bi_ortho/get_d1_transp.irp.f b/plugins/local/cipsi_tc_bi_ortho/get_d1_transp.irp.f
new file mode 100644
index 00000000..84a1ce24
--- /dev/null
+++ b/plugins/local/cipsi_tc_bi_ortho/get_d1_transp.irp.f
@@ -0,0 +1,350 @@
+subroutine get_d1_transp(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, coefs)
+ !todo: indices should be okay for complex?
+ use bitmasks
+ implicit none
+
+ integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2)
+ integer(bit_kind), intent(in) :: phasemask(N_int,2)
+ logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2)
+ integer(bit_kind) :: det(N_int, 2)
+ double precision, intent(in) :: coefs(N_states,2)
+ double precision, intent(inout) :: mat_l(N_states, mo_num, mo_num)
+ double precision, intent(inout) :: mat_r(N_states, mo_num, mo_num)
+ integer, intent(in) :: h(0:2,2), p(0:4,2), sp
+ double precision, external :: get_phase_bi
+ double precision, external :: mo_two_e_integral_complex
+ logical :: ok
+
+ logical, allocatable :: lbanned(:,:)
+ integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j
+ integer :: hfix, pfix, h1, h2, p1, p2, ib, k, l, mm
+
+ integer, parameter :: turn2(2) = (/2,1/)
+ integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/))
+
+ integer :: bant
+ double precision, allocatable :: hij_cache(:,:)
+ double precision :: hij, tmp_rowij(N_states, mo_num), tmp_rowij2(N_states, mo_num),phase
+ double precision, allocatable :: hji_cache(:,:)
+ double precision :: hji, tmp_rowji(N_states, mo_num), tmp_rowji2(N_states, mo_num)
+! PROVIDE mo_integrals_map N_int
+! print*,'in get_d1_new'
+! call debug_det(gen,N_int)
+! print*,'coefs',coefs(1,:)
+
+ allocate (lbanned(mo_num, 2))
+ allocate (hij_cache(mo_num,2))
+ allocate (hji_cache(mo_num,2))
+ lbanned = bannedOrb
+
+ do i=1, p(0,1)
+ lbanned(p(i,1), 1) = .true.
+ end do
+ do i=1, p(0,2)
+ lbanned(p(i,2), 2) = .true.
+ end do
+
+ ma = 1
+ if(p(0,2) >= 2) ma = 2
+ mi = turn2(ma)
+
+ bant = 1
+
+ if(sp == 3) then
+ !move MA
+ if(ma == 2) bant = 2
+ puti = p(1,mi)
+ hfix = h(1,ma)
+ p1 = p(1,ma)
+ p2 = p(2,ma)
+ if(.not. bannedOrb(puti, mi)) then
+! call get_mo_two_e_integrals_complex(hfix,p1,p2,mo_num,hij_cache(1,1),mo_integrals_map,mo_integrals_map_2)
+! call get_mo_two_e_integrals_complex(hfix,p2,p1,mo_num,hij_cache(1,2),mo_integrals_map,mo_integrals_map_2)
+ do mm = 1, mo_num
+ hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,p1,p2)
+ hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,p2,p1)
+ hji_cache(mm,1) = mo_bi_ortho_tc_two_e_transp(mm,hfix,p1,p2)
+ hji_cache(mm,2) = mo_bi_ortho_tc_two_e_transp(mm,hfix,p2,p1)
+ enddo
+ !!
+ tmp_rowij = 0.d0
+ tmp_rowji = 0.d0
+ do putj=1, hfix-1
+ if(lbanned(putj, ma)) cycle
+ if(banned(putj, puti,bant)) cycle
+ hij = hij_cache(putj,1) - hij_cache(putj,2)
+ hji = hji_cache(putj,1) - hji_cache(putj,2)
+ if (hij /= 0.d0.and.hji/=0.d0) then
+ phase = get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int)
+ hij = hij * phase
+ hji = hji * phase
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ tmp_rowij(k,putj) = tmp_rowij(k,putj) + hij * coefs(k,2)
+ tmp_rowji(k,putj) = tmp_rowji(k,putj) + hji * coefs(k,1)
+ enddo
+ endif
+ end do
+ do putj=hfix+1, mo_num
+ if(lbanned(putj, ma)) cycle
+ if(banned(putj, puti,bant)) cycle
+ hij = hij_cache(putj,2) - hij_cache(putj,1)
+ hji = hji_cache(putj,2) - hji_cache(putj,1)
+ if (hij /= 0.d0.and.hji/=0.d0) then
+ phase = get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int)
+ hij = hij * phase
+ hji = hji * phase
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ tmp_rowij(k,putj) = tmp_rowij(k,putj) + hij * coefs(k,2)
+ tmp_rowji(k,putj) = tmp_rowji(k,putj) + hji * coefs(k,1)
+ enddo
+ endif
+ end do
+
+ if(ma == 1) then
+ mat_r(1:N_states,1:mo_num,puti) = mat_r(1:N_states,1:mo_num,puti) + tmp_rowij(1:N_states,1:mo_num)
+ mat_l(1:N_states,1:mo_num,puti) = mat_l(1:N_states,1:mo_num,puti) + tmp_rowji(1:N_states,1:mo_num)
+ else
+ do l=1,mo_num
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ mat_r(k,puti,l) = mat_r(k,puti,l) + tmp_rowij(k,l)
+ mat_l(k,puti,l) = mat_l(k,puti,l) + tmp_rowji(k,l)
+ enddo
+ enddo
+ end if
+
+ end if
+
+ !MOVE MI
+ pfix = p(1,mi)
+ tmp_rowij = 0.d0
+ tmp_rowij2 = 0.d0
+ tmp_rowji = 0.d0
+ tmp_rowji2 = 0.d0
+! call get_mo_two_e_integrals_complex(hfix,pfix,p1,mo_num,hij_cache(1,1),mo_integrals_map,mo_integrals_map_2)
+! call get_mo_two_e_integrals_complex(hfix,pfix,p2,mo_num,hij_cache(1,2),mo_integrals_map,mo_integrals_map_2)
+ do mm = 1, mo_num
+ hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,pfix,p1)
+ hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,pfix,p2)
+ hji_cache(mm,1) = mo_bi_ortho_tc_two_e_transp(mm,hfix,pfix,p1)
+ hji_cache(mm,2) = mo_bi_ortho_tc_two_e_transp(mm,hfix,pfix,p2)
+ enddo
+ putj = p1
+ !!
+ do puti=1,mo_num !HOT
+ if(lbanned(puti,mi)) cycle
+ !p1 fixed
+ putj = p1
+ if(.not. banned(putj,puti,bant)) then
+ hij = hij_cache(puti,2)
+ hji = hji_cache(puti,2)
+ if (hij /= 0.d0.and.hji/=0.d0) then
+ phase = get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix, N_int)
+ hij = hij * phase
+ hji = hji * phase
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ tmp_rowij(k,puti) = tmp_rowij(k,puti) + hij * coefs(k,2)
+ tmp_rowji(k,puti) = tmp_rowji(k,puti) + hji * coefs(k,1)
+ enddo
+ endif
+ end if
+!
+ putj = p2
+ if(.not. banned(putj,puti,bant)) then
+ hij = hij_cache(puti,1)
+ hji = hji_cache(puti,1)
+ if (hij /= 0.d0.and.hji/=0.d0) then
+ phase = get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix, N_int)
+ hij = hij * phase
+ hji = hji * phase
+ do k=1,N_states
+ tmp_rowij2(k,puti) = tmp_rowij2(k,puti) + hij * coefs(k,2)
+ tmp_rowji2(k,puti) = tmp_rowji2(k,puti) + hji * coefs(k,1)
+ enddo
+ endif
+ end if
+ end do
+
+ if(mi == 1) then
+ mat_r(:,:,p1) = mat_r(:,:,p1) + tmp_rowij(:,:)
+ mat_r(:,:,p2) = mat_r(:,:,p2) + tmp_rowij2(:,:)
+ mat_l(:,:,p1) = mat_l(:,:,p1) + tmp_rowji(:,:)
+ mat_l(:,:,p2) = mat_l(:,:,p2) + tmp_rowji2(:,:)
+ else
+ do l=1,mo_num
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ mat_r(k,p1,l) = mat_r(k,p1,l) + tmp_rowij(k,l)
+ mat_r(k,p2,l) = mat_r(k,p2,l) + tmp_rowij2(k,l)
+ mat_l(k,p1,l) = mat_l(k,p1,l) + tmp_rowji(k,l)
+ mat_l(k,p2,l) = mat_l(k,p2,l) + tmp_rowji2(k,l)
+ enddo
+ enddo
+ end if
+
+ else ! sp /= 3
+
+ if(p(0,ma) == 3) then
+ do i=1,3
+ hfix = h(1,ma)
+ puti = p(i, ma)
+ p1 = p(turn3(1,i), ma)
+ p2 = p(turn3(2,i), ma)
+! call get_mo_two_e_integrals_complex(hfix,p1,p2,mo_num,hij_cache(1,1),mo_integrals_map,mo_integrals_map_2)
+! call get_mo_two_e_integrals_complex(hfix,p2,p1,mo_num,hij_cache(1,2),mo_integrals_map,mo_integrals_map_2)
+ do mm = 1, mo_num
+ hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,p1,p2)
+ hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,p2,p1)
+ hji_cache(mm,1) = mo_bi_ortho_tc_two_e_transp(mm,hfix,p1,p2)
+ hji_cache(mm,2) = mo_bi_ortho_tc_two_e_transp(mm,hfix,p2,p1)
+ enddo
+ !!
+ tmp_rowij = 0.d0
+ tmp_rowji = 0.d0
+ do putj=1,hfix-1
+ if(banned(putj,puti,1)) cycle
+ if(lbanned(putj,ma)) cycle
+ hij = hij_cache(putj,1) - hij_cache(putj,2)
+ hji = hji_cache(putj,1) - hji_cache(putj,2)
+ if (hij /= 0.d0.and.hji/=0.d0) then
+ phase = get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int)
+ hij = hij * phase
+ hji = hji * phase
+ tmp_rowij(:,putj) = tmp_rowij(:,putj) + hij * coefs(:,2)
+ tmp_rowji(:,putj) = tmp_rowji(:,putj) + hji * coefs(:,1)
+ endif
+ end do
+ do putj=hfix+1,mo_num
+ if(banned(putj,puti,1)) cycle
+ if(lbanned(putj,ma)) cycle
+ hij = hij_cache(putj,2) - hij_cache(putj,1)
+ hji = hji_cache(putj,2) - hji_cache(putj,1)
+ if (hij /= 0.d0.and.hji/=0.d0) then
+ phase = get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int)
+ hij = hij * phase
+ hji = hji * phase
+ tmp_rowij(:,putj) = tmp_rowij(:,putj) + hij * coefs(:,2)
+ tmp_rowji(:,putj) = tmp_rowji(:,putj) + hji * coefs(:,1)
+ endif
+ end do
+
+ mat_r(:, :puti-1, puti) = mat_r(:, :puti-1, puti) + tmp_rowij(:,:puti-1)
+ mat_l(:, :puti-1, puti) = mat_l(:, :puti-1, puti) + tmp_rowji(:,:puti-1)
+ do l=puti,mo_num
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ mat_r(k, puti, l) = mat_r(k, puti,l) + tmp_rowij(k,l)
+ mat_l(k, puti, l) = mat_l(k, puti,l) + tmp_rowji(k,l)
+ enddo
+ enddo
+ end do
+ else
+ hfix = h(1,mi)
+ pfix = p(1,mi)
+ p1 = p(1,ma)
+ p2 = p(2,ma)
+ tmp_rowij = 0.d0
+ tmp_rowij2 = 0.d0
+ tmp_rowji = 0.d0
+ tmp_rowji2 = 0.d0
+! call get_mo_two_e_integrals_complex(hfix,p1,pfix,mo_num,hij_cache(1,1),mo_integrals_map,mo_integrals_map_2)
+! call get_mo_two_e_integrals_complex(hfix,p2,pfix,mo_num,hij_cache(1,2),mo_integrals_map,mo_integrals_map_2)
+ do mm = 1, mo_num
+ hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,p1,pfix)
+ hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,p2,pfix)
+ hji_cache(mm,1) = mo_bi_ortho_tc_two_e_transp(mm,hfix,p1,pfix)
+ hji_cache(mm,2) = mo_bi_ortho_tc_two_e_transp(mm,hfix,p2,pfix)
+ enddo
+ putj = p2
+ !!
+ do puti=1,mo_num
+ if(lbanned(puti,ma)) cycle
+ putj = p2
+ if(.not. banned(puti,putj,1)) then
+ hij = hij_cache(puti,1)
+ hji = hji_cache(puti,1)
+ if (hij /= 0.d0.and.hji/=0.d0) then
+ phase = get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1, N_int)
+ hij = hij * phase
+ hji = hji * phase
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ tmp_rowij(k,puti) = tmp_rowij(k,puti) + hij * coefs(k,2)
+ tmp_rowji(k,puti) = tmp_rowji(k,puti) + hji * coefs(k,1)
+ enddo
+ endif
+ end if
+
+ putj = p1
+ if(.not. banned(puti,putj,1)) then
+ hij = hij_cache(puti,2)
+ hji = hji_cache(puti,2)
+ if (hij /= 0.d0.and.hji/=0.d0) then
+ phase = get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2, N_int)
+ hij = hij * phase
+ hji = hji * phase
+ do k=1,N_states
+ tmp_rowij2(k,puti) = tmp_rowij2(k,puti) + hij * coefs(k,2)
+ tmp_rowji2(k,puti) = tmp_rowji2(k,puti) + hji * coefs(k,1)
+ enddo
+ endif
+ end if
+ end do
+ mat_r(:,:p2-1,p2) = mat_r(:,:p2-1,p2) + tmp_rowij(:,:p2-1)
+ mat_l(:,:p2-1,p2) = mat_l(:,:p2-1,p2) + tmp_rowji(:,:p2-1)
+ do l=p2,mo_num
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ mat_r(k,p2,l) = mat_r(k,p2,l) + tmp_rowij(k,l)
+ mat_l(k,p2,l) = mat_l(k,p2,l) + tmp_rowji(k,l)
+ enddo
+ enddo
+ mat_r(:,:p1-1,p1) = mat_r(:,:p1-1,p1) + tmp_rowij2(:,:p1-1)
+ mat_l(:,:p1-1,p1) = mat_l(:,:p1-1,p1) + tmp_rowji2(:,:p1-1)
+ do l=p1,mo_num
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ mat_r(k,p1,l) = mat_r(k,p1,l) + tmp_rowij2(k,l)
+ mat_l(k,p1,l) = mat_l(k,p1,l) + tmp_rowji2(k,l)
+ enddo
+ enddo
+ end if
+ end if
+ deallocate(lbanned,hij_cache, hji_cache)
+
+ !! MONO
+ if(sp == 3) then
+ s1 = 1
+ s2 = 2
+ else
+ s1 = sp
+ s2 = sp
+ end if
+
+ do i1=1,p(0,s1)
+ ib = 1
+ if(s1 == s2) ib = i1+1
+ do i2=ib,p(0,s2)
+ p1 = p(i1,s1)
+ p2 = p(i2,s2)
+ if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2) .or. banned(p1, p2, 1)) cycle
+ call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int)
+ ! gen is a selector; mask is ionized generator; det is alpha
+ ! hij is contribution to
+! call i_h_j_complex(gen, det, N_int, hij)
+ call htilde_mu_mat_opt_bi_ortho_no_3e_both(det, gen, N_int, hij,hji)
+! call htilde_mu_mat_opt_bi_ortho_no_3e(gen, det, N_int, hji)
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ ! take conjugate to get contribution to instead of
+! mat_r(k, p1, p2) = mat_r(k, p1, p2) + coefs(k,1) * dconjg(hij)
+ mat_r(k, p1, p2) = mat_r(k, p1, p2) + coefs(k,2) * hij
+ mat_l(k, p1, p2) = mat_l(k, p1, p2) + coefs(k,1) * hji
+ enddo
+ end do
+ end do
+end
+
diff --git a/plugins/local/cipsi_tc_bi_ortho/get_d2_good.irp.f b/plugins/local/cipsi_tc_bi_ortho/get_d2_good.irp.f
index d01ed433..86922ae9 100644
--- a/plugins/local/cipsi_tc_bi_ortho/get_d2_good.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/get_d2_good.irp.f
@@ -25,9 +25,6 @@ subroutine get_d2_new(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask, h,
integer :: bant
bant = 1
-! print*, 'in get_d2_new'
-! call debug_det(gen,N_int)
-! print*,'coefs',coefs(1,:)
tip = p(0,1) * p(0,2) ! number of alpha particles times number of beta particles
diff --git a/plugins/local/cipsi_tc_bi_ortho/get_d2_transp.irp.f b/plugins/local/cipsi_tc_bi_ortho/get_d2_transp.irp.f
new file mode 100644
index 00000000..b2a7ea31
--- /dev/null
+++ b/plugins/local/cipsi_tc_bi_ortho/get_d2_transp.irp.f
@@ -0,0 +1,235 @@
+
+subroutine get_d2_new_transp(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, coefs)
+ !todo: indices/conjg should be correct for complex
+ use bitmasks
+ implicit none
+
+ integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2)
+ integer(bit_kind), intent(in) :: phasemask(N_int,2)
+ logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2)
+ double precision, intent(in) :: coefs(N_states,2)
+ double precision, intent(inout) :: mat_r(N_states, mo_num, mo_num)
+ double precision, intent(inout) :: mat_l(N_states, mo_num, mo_num)
+ integer, intent(in) :: h(0:2,2), p(0:4,2), sp
+
+ double precision, external :: get_phase_bi
+
+ integer :: i, j, k, tip, ma, mi, puti, putj
+ integer :: h1, h2, p1, p2, i1, i2
+ double precision :: phase
+ double precision :: hij,hji
+
+ integer, parameter:: turn2d(2,3,4) = reshape((/0,0, 0,0, 0,0, 3,4, 0,0, 0,0, 2,4, 1,4, 0,0, 2,3, 1,3, 1,2 /), (/2,3,4/))
+ integer, parameter :: turn2(2) = (/2, 1/)
+ integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/))
+
+ integer :: bant
+ bant = 1
+
+ tip = p(0,1) * p(0,2) ! number of alpha particles times number of beta particles
+
+ ma = sp !1:(alpha,alpha); 2:(b,b); 3:(a,b)
+ if(p(0,1) > p(0,2)) ma = 1 ! more alpha particles than beta particles
+ if(p(0,1) < p(0,2)) ma = 2 ! fewer alpha particles than beta particles
+ mi = mod(ma, 2) + 1
+
+ if(sp == 3) then ! if one alpha and one beta xhole
+ !(where xholes refer to the ionizations from the generator, not the holes occupied in the ionized generator)
+ if(ma == 2) bant = 2 ! if more beta particles than alpha particles
+
+ if(tip == 3) then ! if 3 of one particle spin and 1 of the other particle spin
+ puti = p(1, mi)
+ if(bannedOrb(puti, mi)) return
+ h1 = h(1, ma)
+ h2 = h(2, ma)
+
+ !!
+ do i = 1, 3 ! loop over all 3 combinations of 2 particles with spin ma
+ putj = p(i, ma)
+ if(banned(putj,puti,bant)) cycle
+ i1 = turn3(1,i)
+ i2 = turn3(2,i)
+ p1 = p(i1, ma)
+ p2 = p(i2, ma)
+
+ ! |G> = |psi_{gen,i}>
+ ! |G'> = a_{x1} a_{x2} |G>
+ ! |alpha> = a_{puti}^{\dagger} a_{putj}^{\dagger} |G'>
+ ! |alpha> = t_{x1,x2}^{puti,putj} |G>
+ ! hij =
+ ! |alpha> = t_{p1,p2}^{h1,h2}|psi_{selectors,i}>
+ !todo: = ( - ) * phase
+ ! += dconjg(c_i) *
+ ! = ( - ) * phase
+ ! += * c_i
+
+!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!
+ ! take the transpose of what's written above because later use the complex conjugate
+
+! hij = mo_bi_ortho_tc_two_e(h1, h2, p1, p2) - mo_bi_ortho_tc_two_e( h1, h2, p2, p1)
+! hji = mo_bi_ortho_tc_two_e_transp(h1, h2, p1, p2) - mo_bi_ortho_tc_two_e_transp( h1, h2, p2, p1)
+ hij = mo_bi_ortho_tc_two_e_transp(p1, p2,h1, h2) - mo_bi_ortho_tc_two_e_transp( p1, p2, h2, h1)
+ hji = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e( p1, p2, h2, h1)
+ if (hij == 0.d0.or.hji==0.d0) cycle
+
+ ! take conjugate to get contribution to instead of
+! hij = dconjg(hij) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
+ phase = get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
+ hij = hij * phase
+ hji = hji * phase
+
+ if(ma == 1) then ! if particle spins are (alpha,alpha,alpha,beta), then puti is beta and putj is alpha
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ mat_r(k, putj, puti) = mat_r(k, putj, puti) + coefs(k,2) * hij
+ mat_l(k, putj, puti) = mat_l(k, putj, puti) + coefs(k,1) * hji
+ enddo
+ else ! if particle spins are (beta,beta,beta,alpha), then puti is alpha and putj is beta
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,2) * hij
+ mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,1) * hji
+ enddo
+ end if
+ end do
+ else ! if 2 alpha and 2 beta particles
+ h1 = h(1,1)
+ h2 = h(1,2)
+ !!
+ do j = 1,2 ! loop over all 4 combinations of one alpha and one beta particle
+ putj = p(j, 2)
+ if(bannedOrb(putj, 2)) cycle
+ p2 = p(turn2(j), 2)
+ do i = 1,2
+ puti = p(i, 1)
+ if(banned(puti,putj,bant) .or. bannedOrb(puti,1)) cycle
+ p1 = p(turn2(i), 1)
+ ! hij =
+! hij = mo_bi_ortho_tc_two_e(p1, p2, h1, h2)
+!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!
+ ! take the transpose of what's written above because later use the complex conjugate
+! hij = mo_bi_ortho_tc_two_e(h1, h2, p1, p2 )
+! hji = mo_bi_ortho_tc_two_e_transp(h1, h2, p1, p2 )
+ hij = mo_bi_ortho_tc_two_e_transp(p1, p2 ,h1, h2 )
+ hji = mo_bi_ortho_tc_two_e( p1, p2, h1, h2)
+ if (hij /= 0.d0.or.hji==0.d0) then
+ ! take conjugate to get contribution to instead of
+! hij = dconjg(hij) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int)
+ phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int)
+ hij = hij * phase
+ hji = hji * phase
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,2) * hij
+ mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,1) * hji
+ enddo
+ endif
+ end do
+ end do
+ end if
+
+ else ! if holes are (a,a) or (b,b)
+ if(tip == 0) then ! if particles are (a,a,a,a) or (b,b,b,b)
+ h1 = h(1, ma)
+ h2 = h(2, ma)
+ !!
+ do i=1,3
+ puti = p(i, ma)
+ if(bannedOrb(puti,ma)) cycle
+ do j=i+1,4
+ putj = p(j, ma)
+ if(bannedOrb(putj,ma)) cycle
+ if(banned(puti,putj,1)) cycle
+
+ i1 = turn2d(1, i, j)
+ i2 = turn2d(2, i, j)
+ p1 = p(i1, ma)
+ p2 = p(i2, ma)
+! hij = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e(p2,p1, h1, h2)
+!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!
+ ! take the transpose of what's written above because later use the complex conjugate
+ hij = mo_bi_ortho_tc_two_e_transp(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e_transp(p1, p2, h2,h1 )
+ hji = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e(p1, p2, h2,h1 )
+ if (hij == 0.d0.or.hji == 0.d0) cycle
+
+ ! take conjugate to get contribution to instead of
+! hij = dconjg(hij) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
+ phase = get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
+ hij = hij * phase
+ hji = hji * phase
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ mat_r(k, puti, putj) = mat_r(k, puti, putj) +coefs(k,2) * hij
+ mat_l(k, puti, putj) = mat_l(k, puti, putj) +coefs(k,1) * hji
+ enddo
+ end do
+ end do
+ else if(tip == 3) then ! if particles are (a,a,a,b) (ma=1,mi=2) or (a,b,b,b) (ma=2,mi=1)
+ h1 = h(1, mi)
+ h2 = h(1, ma)
+ p1 = p(1, mi)
+ !!
+ do i=1,3
+ puti = p(turn3(1,i), ma)
+ if(bannedOrb(puti,ma)) cycle
+ putj = p(turn3(2,i), ma)
+ if(bannedOrb(putj,ma)) cycle
+ if(banned(puti,putj,1)) cycle
+ p2 = p(i, ma)
+
+! hij = mo_bi_ortho_tc_two_e(p1, p2, h1, h2)
+!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!
+ ! take the transpose of what's written above because later use the complex conjugate
+ hij = mo_bi_ortho_tc_two_e_transp(p1, p2 ,h1, h2)
+ hji = mo_bi_ortho_tc_two_e(p1, p2,h1, h2 )
+ if (hij == 0.d0) cycle
+
+ ! take conjugate to get contribution to instead of
+! hij = dconjg(hij) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2, N_int)
+ phase = get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2, N_int)
+ hij = hij * phase
+ hji = hji * phase
+ if (puti < putj) then
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,2) * hij
+ mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,1) * hji
+ enddo
+ else
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ mat_r(k, putj, puti) = mat_r(k, putj, puti) + coefs(k,2) * hij
+ mat_l(k, putj, puti) = mat_l(k, putj, puti) + coefs(k,1) * hji
+ enddo
+ endif
+ end do
+ else ! tip == 4 (a,a,b,b)
+ puti = p(1, sp)
+ putj = p(2, sp)
+ if(.not. banned(puti,putj,1)) then
+ p1 = p(1, mi)
+ p2 = p(2, mi)
+ h1 = h(1, mi)
+ h2 = h(2, mi)
+ !!
+! hij = (mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e(p2,p1, h1, h2))
+!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!
+ ! take the transpose of what's written above because later use the complex conjugate
+ hij = (mo_bi_ortho_tc_two_e_transp(p1, p2,h1, h2) - mo_bi_ortho_tc_two_e_transp(p2,p1,h1, h2))
+ hji = (mo_bi_ortho_tc_two_e(p1, p2,h1, h2) - mo_bi_ortho_tc_two_e(p2,p1,h1, h2))
+ if (hij /= 0.d0.or.hji==0.d0) then
+ ! take conjugate to get contribution to instead of
+! hij = dconjg(hij) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2, N_int)
+ phase = get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2, N_int)
+ hij = hij * phase
+ hji = hji* phase
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,2) * hij
+ mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,1) * hji
+ enddo
+ end if
+ end if
+ end if
+ end if
+end
diff --git a/plugins/local/cipsi_tc_bi_ortho/pt2.irp.f b/plugins/local/cipsi_tc_bi_ortho/pt2.irp.f
index 833cc0ea..ada19c6b 100644
--- a/plugins/local/cipsi_tc_bi_ortho/pt2.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/pt2.irp.f
@@ -67,6 +67,7 @@ subroutine tc_pt2
call pt2_alloc(pt2_data_err, N_states)
call ZMQ_pt2(E_tc, pt2_data, pt2_data_err, relative_error,0) ! Stochastic PT2 and selection
call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2)
+ call print_summary_tc(psi_energy_with_nucl_rep, pt2_data, pt2_data_err, N_det, N_configuration, N_states, psi_s2)
end
diff --git a/plugins/local/cipsi_tc_bi_ortho/selection.irp.f b/plugins/local/cipsi_tc_bi_ortho/selection.irp.f
index d41d3cdb..17d34f43 100644
--- a/plugins/local/cipsi_tc_bi_ortho/selection.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/selection.irp.f
@@ -636,10 +636,7 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, intere
negMask(i,2) = not(mask(i,2))
end do
-! print*,'in selection '
do i = 1, N_sel
-! call debug_det(det(1,1,i),N_int)
-! print*,i,dabs(psi_selectors_coef_transp_tc(1,2,i) * psi_selectors_coef_transp_tc(1,1,i))
if(interesting(i) < 0) then
stop 'prefetch interesting(i) and det(i)'
endif
@@ -691,11 +688,23 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, intere
call get_mask_phase(psi_det_sorted_tc(1,1,interesting(i)), phasemask,N_int)
if(nt == 4) then
- call get_d2_new(det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
+ if(transpose_two_e_int)then
+ call get_d2_new_transp(det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
+ else
+ call get_d2_new(det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
+ endif
elseif(nt == 3) then
- call get_d1_new(det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
+ if(transpose_two_e_int)then
+ call get_d1_transp(det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
+ else
+ call get_d1_new(det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
+ endif
else
+ if(transpose_two_e_int)then
+ call get_d0_transp (det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
+ else
call get_d0_new (det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
+ endif
endif
elseif(nt == 4) then
call bitstring_to_list_in_selection(mobMask(1,1), p(1,1), p(0,1), N_int)
@@ -795,6 +804,11 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int)
+ if (do_ormas) then
+ logical, external :: det_allowed_ormas
+ if (.not.det_allowed_ormas(det)) cycle
+ endif
+
if(do_only_cas) then
if( number_of_particles(det) > 0 ) cycle
if( number_of_holes(det) > 0 ) cycle
@@ -882,80 +896,12 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
call diag_htilde_mu_mat_fock_bi_ortho(N_int, det, hmono, htwoe, hthree, hii)
do istate = 1,N_states
delta_E = E0(istate) - Hii + E_shift
- double precision :: alpha_h_psi_tmp, psi_h_alpha_tmp, error
- if(debug_tc_pt2 == 1)then !! Using the old version
- psi_h_alpha = 0.d0
- alpha_h_psi = 0.d0
- do iii = 1, N_det_selectors
- call htilde_mu_mat_bi_ortho_tot_slow(psi_selectors(1,1,iii), det, N_int, i_h_alpha)
- call htilde_mu_mat_bi_ortho_tot_slow(det, psi_selectors(1,1,iii), N_int, alpha_h_i)
- call get_excitation_degree(psi_selectors(1,1,iii), det,degree,N_int)
- if(degree == 0)then
- print*,'problem !!!'
- print*,'a determinant is already in the wave function !!'
- print*,'it corresponds to the selector number ',iii
- call debug_det(det,N_int)
- stop
- endif
-! call htilde_mu_mat_opt_bi_ortho_no_3e(psi_selectors(1,1,iii), det, N_int, i_h_alpha)
-! call htilde_mu_mat_opt_bi_ortho_no_3e(det, psi_selectors(1,1,iii), N_int, alpha_h_i)
- psi_h_alpha += i_h_alpha * psi_selectors_coef_tc(iii,2,1) ! left function
- alpha_h_psi += alpha_h_i * psi_selectors_coef_tc(iii,1,1) ! right function
- enddo
- else if(debug_tc_pt2 == 2)then !! debugging the new version
-! psi_h_alpha_tmp = 0.d0
-! alpha_h_psi_tmp = 0.d0
-! do iii = 1, N_det_selectors ! old version
-! call htilde_mu_mat_opt_bi_ortho_no_3e(psi_selectors(1,1,iii), det, N_int, i_h_alpha)
-! call htilde_mu_mat_opt_bi_ortho_no_3e(det, psi_selectors(1,1,iii), N_int, alpha_h_i)
-! psi_h_alpha_tmp += i_h_alpha * psi_selectors_coef_tc(iii,1,1) ! left function
-! alpha_h_psi_tmp += alpha_h_i * psi_selectors_coef_tc(iii,2,1) ! right function
-! enddo
- psi_h_alpha_tmp = mat_l(istate, p1, p2) ! new version
- alpha_h_psi_tmp = mat_r(istate, p1, p2) ! new version
- psi_h_alpha = 0.d0
- alpha_h_psi = 0.d0
- do iii = 1, N_det ! old version
- call htilde_mu_mat_opt_bi_ortho_no_3e(psi_det(1,1,iii), det, N_int, i_h_alpha)
- call htilde_mu_mat_opt_bi_ortho_no_3e(det, psi_det(1,1,iii), N_int, alpha_h_i)
- psi_h_alpha += i_h_alpha * psi_l_coef_bi_ortho(iii,1) ! left function
- alpha_h_psi += alpha_h_i * psi_r_coef_bi_ortho(iii,1) ! right function
- enddo
- if(dabs(psi_h_alpha*alpha_h_psi/delta_E).gt.1.d-10)then
- error = dabs(psi_h_alpha * alpha_h_psi - psi_h_alpha_tmp * alpha_h_psi_tmp)/dabs(psi_h_alpha * alpha_h_psi)
- if(error.gt.1.d-2)then
- call debug_det(det, N_int)
- print*,'error =',error,psi_h_alpha * alpha_h_psi/delta_E,psi_h_alpha_tmp * alpha_h_psi_tmp/delta_E
- print*,psi_h_alpha , alpha_h_psi
- print*,psi_h_alpha_tmp , alpha_h_psi_tmp
- print*,'selectors '
- do iii = 1, N_det_selectors ! old version
- print*,'iii',iii,psi_selectors_coef_tc(iii,1,1),psi_selectors_coef_tc(iii,2,1)
- call htilde_mu_mat_opt_bi_ortho_no_3e(psi_selectors(1,1,iii), det, N_int, i_h_alpha)
- call htilde_mu_mat_opt_bi_ortho_no_3e(det, psi_selectors(1,1,iii), N_int, alpha_h_i)
- print*,i_h_alpha,alpha_h_i
- call debug_det(psi_selectors(1,1,iii),N_int)
- enddo
-! print*,'psi_det '
-! do iii = 1, N_det! old version
-! print*,'iii',iii,psi_l_coef_bi_ortho(iii,1),psi_r_coef_bi_ortho(iii,1)
-! call debug_det(psi_det(1,1,iii),N_int)
-! enddo
- stop
- endif
- endif
- else
- psi_h_alpha = mat_l(istate, p1, p2)
- alpha_h_psi = mat_r(istate, p1, p2)
- endif
+ psi_h_alpha = mat_l(istate, p1, p2)
+ alpha_h_psi = mat_r(istate, p1, p2)
val = 4.d0 * psi_h_alpha * alpha_h_psi
tmp = dsqrt(delta_E * delta_E + val)
-! if (delta_E < 0.d0) then
-! tmp = -tmp
-! endif
e_pert(istate) = 0.25 * val / delta_E
-! e_pert(istate) = 0.5d0 * (tmp - delta_E)
- if(dsqrt(dabs(tmp)).gt.1.d-4.and.dabs(alpha_h_psi).gt.1.d-4)then
+ if(dsqrt(tmp).gt.1.d-4.and.dabs(psi_h_alpha).gt.1.d-4)then
coef(istate) = e_pert(istate) / psi_h_alpha
else
coef(istate) = alpha_h_psi / delta_E
@@ -971,15 +917,6 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
if(e_pert(istate).gt.0.d0)e_pert(istate)=0.d0
endif
-! if(selection_tc == 1 )then
-! if(e_pert(istate).lt.0.d0)then
-! e_pert(istate) = 0.d0
-! endif
-! else if(selection_tc == -1)then
-! if(e_pert(istate).gt.0.d0)then
-! e_pert(istate) = 0.d0
-! endif
-! endif
enddo
diff --git a/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f b/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f
index 99a8de7e..bb5a89a1 100644
--- a/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f
@@ -88,6 +88,9 @@ subroutine run_stochastic_cipsi
call pt2_dealloc(pt2_data_err)
call pt2_alloc(pt2_data, N_states)
call pt2_alloc(pt2_data_err, N_states)
+ if(transpose_two_e_int)then
+ provide mo_bi_ortho_tc_two_e_transp
+ endif
call ZMQ_pt2(E_tc, pt2_data, pt2_data_err, relative_error,to_select) ! Stochastic PT2 and selection
! stop
diff --git a/plugins/local/fci_tc_bi/pt2_tc.irp.f b/plugins/local/fci_tc_bi/pt2_tc.irp.f
index 390042bf..3c07e367 100644
--- a/plugins/local/fci_tc_bi/pt2_tc.irp.f
+++ b/plugins/local/fci_tc_bi/pt2_tc.irp.f
@@ -13,6 +13,8 @@ program tc_pt2_prog
pruning = -1.d0
touch pruning
+ read_wf = .True.
+ touch read_wf
! pt2_relative_error = 0.01d0
! touch pt2_relative_error
diff --git a/plugins/local/fci_tc_bi/script_tc_bh_h2o_gd_exc.sh b/plugins/local/fci_tc_bi/script_tc_bh_h2o_gd_exc.sh
new file mode 100755
index 00000000..0d655fdd
--- /dev/null
+++ b/plugins/local/fci_tc_bi/script_tc_bh_h2o_gd_exc.sh
@@ -0,0 +1,85 @@
+#!/bin/bash
+
+source ~/qp2/quantum_package.rc
+
+## Define the system/basis/charge/mult and genric keywords
+system=H2O
+xyz=${system}.xyz
+basis=6-31g
+mult=1
+charge=0
+j2e_type="Boys_Handy"
+thresh_tcscf=1e-10
+io_tc_integ="Write"
+nstates=4
+
+
+
+##################### Function to create the EZFIO
+function create_ezfio (){
+ qp create_ezfio -b $basis -m $mult -c $charge $xyz -o $ezfio
+ qp run scf | tee ${EZFIO_FILE}.scf.out
+}
+
+##################### Function to set parameters for BH9 jastrow
+function BH_9 (){
+ j2e_type="Boys_Handy" # type of correlation factor: Boys Handy type
+ env_type="None" # Boys Handy J does not use our envelopes
+ j1e_type="None" # Boys Handy J does not use our J1body
+ tc_integ_type="numeric" # Boys Handy requires numerical integrals
+ jBH_size=9 # Number of parameters for the BH
+
+######## All parameters for the H2O and Boys Handy Jastrow
+ jBH_c=[[0.50000,-0.57070,0.49861,-0.78663,0.01990,0.13386,-0.60446,-1.67160,1.36590],[0.0,0.0,0.0,0.0,0.12063,-0.18527,0.12324,-0.11187,-0.06558],[0.0,0.0,0.0,0.0,0.12063,-0.18527,0.12324,-0.11187,-0.06558]]
+ jBH_m=[[0,0,0,0,2,3,4,2,2],[0,0,0,0,2,3,4,2,2],[0,0,0,0,2,3,4,2,2]]
+ jBH_n=[[0,0,0,0,0,0,0,2,0],[0,0,0,0,0,0,0,2,0],[0,0,0,0,0,0,0,2,0]]
+ jBH_o=[[1,2,3,4,0,0,0,0,2],[1,2,3,4,0,0,0,0,2],[1,2,3,4,0,0,0,0,2]]
+ jBH_ee=[1.0,1.0,1.0]
+ jBH_en=[1.0,1.0,1.0]
+
+ set_BH_J_keywords
+}
+
+
+function set_BH_J_keywords (){
+ qp set jastrow j2e_type $j2e_type # set the jastrow two-e type
+ qp set jastrow env_type $env_type
+ qp set jastrow j1e_type $j1e_type
+ qp set jastrow jBH_size $jBH_size # set the number of parameters in Boys-Handy jastrow
+ qp set jastrow jBH_c "$jBH_c" # set the parameters which are lists for Boys-Handy
+ qp set jastrow jBH_m "$jBH_m" #
+ qp set jastrow jBH_n "$jBH_n" #
+ qp set jastrow jBH_o "$jBH_o" #
+ qp set jastrow jBH_ee $jBH_ee #
+ qp set jastrow jBH_en $jBH_en #
+ qp set tc_keywords tc_integ_type $tc_integ_type # set the analytical or numerical integrals
+ qp set tc_keywords thresh_tcscf $thresh_tcscf
+ qp set tc_keywords io_tc_integ $io_tc_integ # set the io
+ rm ${EZFIO_FILE}/tc_bi_ortho/psi_*
+}
+
+function run_ground_state (){
+ qp set tc_keywords minimize_lr_angles True
+ qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out
+ qp set_frozen_core
+ qp set determinants n_det_max 1e6
+ qp run fci_tc_bi_ortho | tee ${EZFIO_FILE}.fci_tc_bi.out
+}
+
+function run_excited_state (){
+ qp set determinants n_states $nstates
+ qp run cis | tee ${EZFIO_FILE}.cis.out
+ rm ${EZFIO_FILE}/tc_bi_ortho/psi_*
+ qp run tc_bi_ortho | tee ${EZFIO_FILE}.tc_cis_nst_${nstates}.out
+ qp set determinants read_wf True
+ qp run fci_tc_bi_ortho | tee ${EZFIO_FILE}.fci_tc_bi_nst_${nstates}.out
+
+}
+
+
+## BH9 calculations
+ezfio=${system}_${charge}_${basis}_${j2e_type}
+create_ezfio
+BH_9
+run_ground_state
+run_excited_state
diff --git a/plugins/local/fci_tc_bi/script_tc_jmu_h2o_gd_exc.sh b/plugins/local/fci_tc_bi/script_tc_jmu_h2o_gd_exc.sh
new file mode 100755
index 00000000..e74888ec
--- /dev/null
+++ b/plugins/local/fci_tc_bi/script_tc_jmu_h2o_gd_exc.sh
@@ -0,0 +1,84 @@
+#!/bin/bash
+source ~/qp2/quantum_package.rc
+
+## Define the system/basis/charge/mult and genric keywords
+system=H2O
+xyz=${system}.xyz
+basis=6-31g
+mult=1
+charge=0
+j2e_type=Mu
+thresh_tcscf=1e-10
+io_tc_integ="Write"
+nstates=4
+nol_standard=False
+tc_integ_type=numeric # can be changed for semi-analytic
+
+if (( $nol_standard == "False" ))
+then
+ three_body_h_tc=True
+else
+ three_body_h_tc=False
+fi
+
+
+##################### Function to create the EZFIO
+function create_ezfio (){
+ qp create_ezfio -b $basis -m $mult -c $charge $xyz -o $ezfio
+ qp run scf | tee ${EZFIO_FILE}.scf.out
+}
+
+function set_env_j_keywords (){
+
+ qp set hamiltonian mu_erf 0.87
+ qp set jastrow env_type Sum_Gauss
+ qp set jastrow env_coef "${coef}"
+ qp set tc_keywords tc_integ_type $tc_integ_type
+ qp set jastrow j1e_type $j1e_type
+ qp set jastrow j2e_type $j2e_type
+ qp set jastrow env_expo "${alpha}"
+}
+
+function run_ground_state (){
+ qp set tc_keywords minimize_lr_angles True
+ qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out
+ qp set_frozen_core
+ qp set determinants n_det_max 1e6
+ qp set perturbation pt2_max 0.001
+ qp set tc_keywords nol_standard $nol_standard
+ qp set tc_keywords three_body_h_tc $three_body_h_tc
+ qp run fci_tc_bi_ortho | tee ${EZFIO_FILE}.fci_tc_bi.out
+}
+
+function run_excited_state (){
+ qp set determinants n_states $nstates
+ qp run cis | tee ${EZFIO_FILE}.cis.out
+ rm ${EZFIO_FILE}/tc_bi_ortho/psi_*
+ qp run tc_bi_ortho | tee ${EZFIO_FILE}.tc_cis_nst_${nstates}.out
+ qp set determinants read_wf True
+ qp run fci_tc_bi_ortho | tee ${EZFIO_FILE}.fci_tc_bi_nst_${nstates}.out
+
+}
+
+
+# Define J(mu) with envelope and without j1e
+j2e_type=Mu
+j1e_type=None
+ezfio=${system}_${charge}_${basis}_${j2e_type}_${j1e_type}
+create_ezfio
+alpha=[2.0,1000.,1000.] # parameters for H2O
+coef=[1.,1.,1.] # parameters for H2O
+set_env_j_keywords
+run_ground_state
+run_excited_state
+
+# Define J(mu) with envelope and with a charge Harmonizer for J1e
+j2e_type=Mu
+j1e_type=Charge_Harmonizer
+ezfio=${system}_${charge}_${basis}_${j2e_type}_${j1e_type}
+create_ezfio
+alpha=[2.5,1000.,1000.] # parameters for H2O
+coef=[1.,1.,1.] # parameters for H2O
+set_env_j_keywords
+run_ground_state
+run_excited_state
diff --git a/plugins/local/mo_localization/README.md b/plugins/local/mo_localization/README.md
index c28a5ee1..512e36af 100644
--- a/plugins/local/mo_localization/README.md
+++ b/plugins/local/mo_localization/README.md
@@ -3,7 +3,7 @@ To localize the MOs:
```
qp run localization
```
-By default, the different otbital classes are automatically set by splitting
+By default, the different orbital classes are automatically set by splitting
the orbitales in the following classes:
- Core -> Core
- Active, doubly occupied -> Inactive
diff --git a/plugins/local/non_h_ints_mu/NEED b/plugins/local/non_h_ints_mu/NEED
index 48c1c24b..5ca1d543 100644
--- a/plugins/local/non_h_ints_mu/NEED
+++ b/plugins/local/non_h_ints_mu/NEED
@@ -3,3 +3,4 @@ hamiltonian
jastrow
ao_tc_eff_map
bi_ortho_mos
+trexio
diff --git a/plugins/local/non_h_ints_mu/deb_aos.irp.f b/plugins/local/non_h_ints_mu/deb_aos.irp.f
index c9bc9c9a..4012f47c 100644
--- a/plugins/local/non_h_ints_mu/deb_aos.irp.f
+++ b/plugins/local/non_h_ints_mu/deb_aos.irp.f
@@ -31,24 +31,63 @@ subroutine print_aos()
integer :: i, ipoint
double precision :: r(3)
double precision :: ao_val, ao_der(3), ao_lap
+ double precision :: mo_val, mo_der(3), mo_lap
PROVIDE final_grid_points aos_in_r_array aos_grad_in_r_array aos_lapl_in_r_array
do ipoint = 1, n_points_final_grid
r(:) = final_grid_points(:,ipoint)
- print*, r
+ write(1000, '(3(f15.7, 3X))') r
enddo
+
+double precision :: accu_vgl(5)
+double precision :: accu_vgl_nrm(5)
do ipoint = 1, n_points_final_grid
- r(:) = final_grid_points(:,ipoint)
do i = 1, ao_num
ao_val = aos_in_r_array (i,ipoint)
ao_der(:) = aos_grad_in_r_array(i,ipoint,:)
ao_lap = aos_lapl_in_r_array(1,i,ipoint) + aos_lapl_in_r_array(2,i,ipoint) + aos_lapl_in_r_array(3,i,ipoint)
- write(*, '(5(f15.7, 3X))') ao_val, ao_der, ao_lap
+ write(111, '(5(f15.7, 3X))') ao_val, ao_der, ao_lap
enddo
enddo
+ do ipoint = 1, n_points_final_grid
+ do i = 1, ao_num
+ ao_val = aos_in_r_array_qmckl (i,ipoint)
+ ao_der(:) = aos_grad_in_r_array_qmckl(i,ipoint,:)
+ ao_lap = aos_lapl_in_r_array_qmckl(i,ipoint)
+ write(222, '(5(f15.7, 3X))') ao_val, ao_der, ao_lap
+ enddo
+ enddo
+
+ accu_vgl = 0.d0
+ accu_vgl_nrm = 0.d0
+ do ipoint = 1, n_points_final_grid
+ do i = 1, ao_num
+ ao_val = aos_in_r_array (i,ipoint)
+ ao_der(:) = aos_grad_in_r_array(i,ipoint,:)
+ ao_lap = aos_lapl_in_r_array(1,i,ipoint) + aos_lapl_in_r_array(2,i,ipoint) + aos_lapl_in_r_array(3,i,ipoint)
+ accu_vgl_nrm(1) += dabs(ao_val)
+ accu_vgl_nrm(2) += dabs(ao_der(1))
+ accu_vgl_nrm(3) += dabs(ao_der(2))
+ accu_vgl_nrm(4) += dabs(ao_der(3))
+ accu_vgl_nrm(5) += dabs(ao_lap)
+
+ ao_val -= aos_in_r_array_qmckl (i,ipoint)
+ ao_der(:) -= aos_grad_in_r_array_qmckl(i,ipoint,:)
+ ao_lap -= aos_lapl_in_r_array_qmckl(i,ipoint)
+ accu_vgl(1) += dabs(ao_val)
+ accu_vgl(2) += dabs(ao_der(1))
+ accu_vgl(3) += dabs(ao_der(2))
+ accu_vgl(4) += dabs(ao_der(3))
+ accu_vgl(5) += dabs(ao_lap)
+ enddo
+
+ enddo
+ accu_vgl(:) *= 1.d0 / accu_vgl_nrm(:)
+ print *, accu_vgl
+
return
end
diff --git a/plugins/local/non_h_ints_mu/jast_1e_utils.irp.f b/plugins/local/non_h_ints_mu/jast_1e_utils.irp.f
index 9cfabf58..c6b2b0a0 100644
--- a/plugins/local/non_h_ints_mu/jast_1e_utils.irp.f
+++ b/plugins/local/non_h_ints_mu/jast_1e_utils.irp.f
@@ -132,6 +132,7 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
double precision, allocatable :: A(:,:,:,:), b(:), A_tmp(:,:,:,:)
double precision, allocatable :: Pa(:,:), Pb(:,:), Pt(:,:)
double precision, allocatable :: u1e_tmp(:), tmp(:,:,:)
+ double precision, allocatable :: tmp1(:,:,:), tmp2(:,:,:)
double precision, allocatable :: U(:,:), D(:), Vt(:,:), work(:)
@@ -176,26 +177,27 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
! --- --- ---
! get A
- allocate(tmp(n_points_final_grid,ao_num,ao_num))
+ allocate(tmp1(n_points_final_grid,ao_num,ao_num), tmp2(n_points_final_grid,ao_num,ao_num))
allocate(A(ao_num,ao_num,ao_num,ao_num))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, ipoint) &
- !$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp)
+ !$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp1, tmp2)
!$OMP DO COLLAPSE(2)
do j = 1, ao_num
do i = 1, ao_num
do ipoint = 1, n_points_final_grid
- tmp(ipoint,i,j) = dsqrt(final_weight_at_r_vector(ipoint)) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
+ tmp1(ipoint,i,j) = final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
+ tmp2(ipoint,i,j) = aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
- call dgemm( "T", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
- , tmp(1,1,1), n_points_final_grid, tmp(1,1,1), n_points_final_grid &
+ call dgemm( "T", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
+ , tmp1(1,1,1), n_points_final_grid, tmp2(1,1,1), n_points_final_grid &
, 0.d0, A(1,1,1,1), ao_num*ao_num)
allocate(A_tmp(ao_num,ao_num,ao_num,ao_num))
@@ -207,13 +209,13 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
allocate(b(ao_num*ao_num))
do ipoint = 1, n_points_final_grid
- u1e_tmp(ipoint) = dsqrt(final_weight_at_r_vector(ipoint)) * u1e_tmp(ipoint)
+ u1e_tmp(ipoint) = u1e_tmp(ipoint)
enddo
- call dgemv("T", n_points_final_grid, ao_num*ao_num, 1.d0, tmp(1,1,1), n_points_final_grid, u1e_tmp(1), 1, 0.d0, b(1), 1)
+ call dgemv("T", n_points_final_grid, ao_num*ao_num, 1.d0, tmp1(1,1,1), n_points_final_grid, u1e_tmp(1), 1, 0.d0, b(1), 1)
deallocate(u1e_tmp)
- deallocate(tmp)
+ deallocate(tmp1, tmp2)
! --- --- ---
! solve Ax = b
diff --git a/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f b/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
index 31ad5756..db06e835 100644
--- a/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
+++ b/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
@@ -169,7 +169,7 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
double precision :: r2(3)
double precision :: dx, dy, dz, r12, tmp
double precision :: mu_val, mu_tmp, mu_der(3)
- double precision :: rn(3), f1A, gard1_f1A(3), f2A, gard2_f2A(3), g12, gard1_g12(3)
+ double precision :: rn(3), f1A, grad1_f1A(3), f2A, grad2_f2A(3), g12, grad1_g12(3)
double precision :: tmp1, tmp2
@@ -281,6 +281,27 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
elseif(j2e_type .eq. "Boys_Handy") then
+ integer :: powmax1, powmax, powmax2
+ double precision, allocatable :: f1A_power(:), f2A_power(:), double_p(:), g12_power(:)
+
+ powmax1 = max(maxval(jBH_m), maxval(jBH_n))
+ powmax2 = maxval(jBH_o)
+ powmax = max(powmax1, powmax2)
+
+ allocate(f1A_power(-1:powmax), f2A_power(-1:powmax), g12_power(-1:powmax), double_p(0:powmax))
+
+ do p = 0, powmax
+ double_p(p) = dble(p)
+ enddo
+
+ f1A_power(-1) = 0.d0
+ f2A_power(-1) = 0.d0
+ g12_power(-1) = 0.d0
+
+ f1A_power(0) = 1.d0
+ f2A_power(0) = 1.d0
+ g12_power(0) = 1.d0
+
do jpoint = 1, n_points_extra_final_grid ! r2
r2(1) = final_grid_points_extra(1,jpoint)
@@ -296,9 +317,18 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
rn(2) = nucl_coord(i_nucl,2)
rn(3) = nucl_coord(i_nucl,3)
- call jBH_elem_fct_grad(jBH_en(i_nucl), r1, rn, f1A, gard1_f1A)
- call jBH_elem_fct_grad(jBH_en(i_nucl), r2, rn, f2A, gard2_f2A)
- call jBH_elem_fct_grad(jBH_ee(i_nucl), r1, r2, g12, gard1_g12)
+ call jBH_elem_fct_grad(jBH_en(i_nucl), r1, rn, f1A, grad1_f1A)
+ call jBH_elem_fct_grad(jBH_en(i_nucl), r2, rn, f2A, grad2_f2A)
+ call jBH_elem_fct_grad(jBH_ee(i_nucl), r1, r2, g12, grad1_g12)
+
+ ! Compute powers of f1A and f2A
+ do p = 1, powmax1
+ f1A_power(p) = f1A_power(p-1) * f1A
+ f2A_power(p) = f2A_power(p-1) * f2A
+ enddo
+ do p = 1, powmax2
+ g12_power(p) = g12_power(p-1) * g12
+ enddo
do p = 1, jBH_size
mpA = jBH_m(p,i_nucl)
@@ -309,23 +339,26 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
tmp = tmp * 0.5d0
endif
- tmp1 = 0.d0
- if(mpA .gt. 0) then
- tmp1 = tmp1 + dble(mpA) * f1A**dble(mpA-1) * f2A**dble(npA)
- endif
- if(npA .gt. 0) then
- tmp1 = tmp1 + dble(npA) * f1A**dble(npA-1) * f2A**dble(mpA)
- endif
- tmp1 = tmp1 * g12**dble(opA)
+ tmp1 = double_p(mpA) * f1A_power(mpA-1) * f2A_power(npA) + double_p(npA) * f1A_power(npA-1) * f2A_power(mpA)
+ tmp1 = tmp1 * g12_power(opA)
+ tmp2 = double_p(opA) * g12_power(opA-1) * (f1A_power(mpA) * f2A_power(npA) + f1A_power(npA) * f2A_power(mpA))
- tmp2 = 0.d0
- if(opA .gt. 0) then
- tmp2 = tmp2 + dble(opA) * g12**dble(opA-1) * (f1A**dble(mpA) * f2A**dble(npA) + f1A**dble(npA) * f2A**dble(mpA))
- endif
+ !tmp1 = 0.d0
+ !if(mpA .gt. 0) then
+ ! tmp1 = tmp1 + dble(mpA) * f1A**dble(mpA-1) * f2A**dble(npA)
+ !endif
+ !if(npA .gt. 0) then
+ ! tmp1 = tmp1 + dble(npA) * f1A**dble(npA-1) * f2A**dble(mpA)
+ !endif
+ !tmp1 = tmp1 * g12**dble(opA)
+ !tmp2 = 0.d0
+ !if(opA .gt. 0) then
+ ! tmp2 = tmp2 + dble(opA) * g12**dble(opA-1) * (f1A**dble(mpA) * f2A**dble(npA) + f1A**dble(npA) * f2A**dble(mpA))
+ !endif
- gradx(jpoint) = gradx(jpoint) + tmp * (tmp1 * gard1_f1A(1) + tmp2 * gard1_g12(1))
- grady(jpoint) = grady(jpoint) + tmp * (tmp1 * gard1_f1A(2) + tmp2 * gard1_g12(2))
- gradz(jpoint) = gradz(jpoint) + tmp * (tmp1 * gard1_f1A(3) + tmp2 * gard1_g12(3))
+ gradx(jpoint) = gradx(jpoint) + tmp * (tmp1 * grad1_f1A(1) + tmp2 * grad1_g12(1))
+ grady(jpoint) = grady(jpoint) + tmp * (tmp1 * grad1_f1A(2) + tmp2 * grad1_g12(2))
+ gradz(jpoint) = gradz(jpoint) + tmp * (tmp1 * grad1_f1A(3) + tmp2 * grad1_g12(3))
enddo ! p
enddo ! i_nucl
enddo ! jpoint
@@ -820,11 +853,11 @@ end
! ---
-subroutine jBH_elem_fct_grad(alpha, r1, r2, fct, gard1_fct)
+subroutine jBH_elem_fct_grad(alpha, r1, r2, fct, grad1_fct)
implicit none
double precision, intent(in) :: alpha, r1(3), r2(3)
- double precision, intent(out) :: fct, gard1_fct(3)
+ double precision, intent(out) :: fct, grad1_fct(3)
double precision :: dist, tmp1, tmp2
dist = dsqrt( (r1(1) - r2(1)) * (r1(1) - r2(1)) &
@@ -836,14 +869,14 @@ subroutine jBH_elem_fct_grad(alpha, r1, r2, fct, gard1_fct)
fct = alpha * dist * tmp1
if(dist .lt. 1d-10) then
- gard1_fct(1) = 0.d0
- gard1_fct(2) = 0.d0
- gard1_fct(3) = 0.d0
+ grad1_fct(1) = 0.d0
+ grad1_fct(2) = 0.d0
+ grad1_fct(3) = 0.d0
else
tmp2 = alpha * tmp1 * tmp1 / dist
- gard1_fct(1) = tmp2 * (r1(1) - r2(1))
- gard1_fct(2) = tmp2 * (r1(2) - r2(2))
- gard1_fct(3) = tmp2 * (r1(3) - r2(3))
+ grad1_fct(1) = tmp2 * (r1(1) - r2(1))
+ grad1_fct(2) = tmp2 * (r1(2) - r2(2))
+ grad1_fct(3) = tmp2 * (r1(3) - r2(3))
endif
return
diff --git a/plugins/local/non_h_ints_mu/numerical_integ.irp.f b/plugins/local/non_h_ints_mu/numerical_integ.irp.f
index 5436b857..2737774a 100644
--- a/plugins/local/non_h_ints_mu/numerical_integ.irp.f
+++ b/plugins/local/non_h_ints_mu/numerical_integ.irp.f
@@ -179,7 +179,7 @@ double precision function num_v_ij_erf_rk_cst_mu_env(i, j, ipoint)
dx = r1(1) - r2(1)
dy = r1(2) - r2(2)
dz = r1(3) - r2(3)
- r12 = dsqrt( dx * dx + dy * dy + dz * dz )
+ r12 = dsqrt(dx*dx + dy*dy + dz*dz)
if(r12 .lt. 1d-10) cycle
tmp1 = (derf(mu_erf * r12) - 1.d0) / r12
@@ -228,7 +228,7 @@ subroutine num_x_v_ij_erf_rk_cst_mu_env(i, j, ipoint, integ)
dx = r1(1) - r2(1)
dy = r1(2) - r2(2)
dz = r1(3) - r2(3)
- r12 = dsqrt( dx * dx + dy * dy + dz * dz )
+ r12 = dsqrt(dx*dx + dy*dy + dz*dz)
if(r12 .lt. 1d-10) cycle
tmp1 = (derf(mu_erf * r12) - 1.d0) / r12
@@ -530,7 +530,7 @@ subroutine num_int2_u_grad1u_total_env2(i, j, ipoint, integ)
dx = r1(1) - r2(1)
dy = r1(2) - r2(2)
dz = r1(3) - r2(3)
- r12 = dsqrt( dx * dx + dy * dy + dz * dz )
+ r12 = dsqrt(dx*dx + dy*dy + dz*dz)
if(r12 .lt. 1d-10) cycle
tmp0 = env_nucl(r2)
diff --git a/plugins/local/non_h_ints_mu/qmckl.irp.f b/plugins/local/non_h_ints_mu/qmckl.irp.f
index 1df80457..4d419e24 100644
--- a/plugins/local/non_h_ints_mu/qmckl.irp.f
+++ b/plugins/local/non_h_ints_mu/qmckl.irp.f
@@ -75,3 +75,107 @@ BEGIN_PROVIDER [ integer*8, qmckl_ctx_jastrow ]
endif
END_PROVIDER
+
+
+ BEGIN_PROVIDER [ double precision, aos_in_r_array_qmckl, (ao_num,n_points_final_grid)]
+&BEGIN_PROVIDER [ double precision, aos_grad_in_r_array_qmckl, (ao_num,n_points_final_grid,3)]
+&BEGIN_PROVIDER [ double precision, aos_lapl_in_r_array_qmckl, (ao_num, n_points_final_grid)]
+ implicit none
+ BEGIN_DOC
+ ! AOS computed with qmckl
+ END_DOC
+ use qmckl
+
+ integer*8 :: qmckl_ctx
+ integer(qmckl_exit_code) :: rc
+
+ qmckl_ctx = qmckl_context_create()
+
+ rc = qmckl_trexio_read(qmckl_ctx, trexio_file, 1_8*len(trim(trexio_filename)))
+ if (rc /= QMCKL_SUCCESS) then
+ print *, irp_here, 'qmckl error in read_trexio'
+ rc = qmckl_check(qmckl_ctx, rc)
+ stop -1
+ endif
+
+ rc = qmckl_set_point(qmckl_ctx, 'N', n_points_final_grid*1_8, final_grid_points, n_points_final_grid*3_8)
+ if (rc /= QMCKL_SUCCESS) then
+ print *, irp_here, 'qmckl error in set_electron_point'
+ rc = qmckl_check(qmckl_ctx, rc)
+ stop -1
+ endif
+
+ double precision, allocatable :: vgl(:,:,:)
+ allocate( vgl(ao_num,5,n_points_final_grid))
+ rc = qmckl_get_ao_basis_ao_vgl_inplace(qmckl_ctx, vgl, n_points_final_grid*ao_num*5_8)
+ if (rc /= QMCKL_SUCCESS) then
+ print *, irp_here, 'qmckl error in get_ao_vgl'
+ rc = qmckl_check(qmckl_ctx, rc)
+ stop -1
+ endif
+
+ integer :: i,k
+ do k=1,n_points_final_grid
+ do i=1,ao_num
+ aos_in_r_array_qmckl(i,k) = vgl(i,1,k)
+ aos_grad_in_r_array_qmckl(i,k,1) = vgl(i,2,k)
+ aos_grad_in_r_array_qmckl(i,k,2) = vgl(i,3,k)
+ aos_grad_in_r_array_qmckl(i,k,3) = vgl(i,4,k)
+ aos_lapl_in_r_array_qmckl(i,k) = vgl(i,5,k)
+ enddo
+ enddo
+
+END_PROVIDER
+
+
+ BEGIN_PROVIDER [ double precision, mos_in_r_array_qmckl, (mo_num,n_points_final_grid)]
+&BEGIN_PROVIDER [ double precision, mos_grad_in_r_array_qmckl, (mo_num,n_points_final_grid,3)]
+&BEGIN_PROVIDER [ double precision, mos_lapl_in_r_array_qmckl, (mo_num, n_points_final_grid)]
+ implicit none
+ BEGIN_DOC
+ ! moS computed with qmckl
+ END_DOC
+ use qmckl
+
+ integer*8 :: qmckl_ctx
+ integer(qmckl_exit_code) :: rc
+
+ qmckl_ctx = qmckl_context_create()
+
+ rc = qmckl_trexio_read(qmckl_ctx, trexio_file, 1_8*len(trim(trexio_filename)))
+ if (rc /= QMCKL_SUCCESS) then
+ print *, irp_here, 'qmckl error in read_trexio'
+ rc = qmckl_check(qmckl_ctx, rc)
+ stop -1
+ endif
+
+ rc = qmckl_set_point(qmckl_ctx, 'N', n_points_final_grid*1_8, final_grid_points, n_points_final_grid*3_8)
+ if (rc /= QMCKL_SUCCESS) then
+ print *, irp_here, 'qmckl error in set_electron_point'
+ rc = qmckl_check(qmckl_ctx, rc)
+ stop -1
+ endif
+
+ double precision, allocatable :: vgl(:,:,:)
+ allocate( vgl(mo_num,5,n_points_final_grid))
+ rc = qmckl_get_mo_basis_mo_vgl_inplace(qmckl_ctx, vgl, n_points_final_grid*mo_num*5_8)
+ if (rc /= QMCKL_SUCCESS) then
+ print *, irp_here, 'qmckl error in get_mo_vgl'
+ rc = qmckl_check(qmckl_ctx, rc)
+ stop -1
+ endif
+
+ integer :: i,k
+ do k=1,n_points_final_grid
+ do i=1,mo_num
+ mos_in_r_array_qmckl(i,k) = vgl(i,1,k)
+ mos_grad_in_r_array_qmckl(i,k,1) = vgl(i,2,k)
+ mos_grad_in_r_array_qmckl(i,k,2) = vgl(i,3,k)
+ mos_grad_in_r_array_qmckl(i,k,3) = vgl(i,4,k)
+ mos_lapl_in_r_array_qmckl(i,k) = vgl(i,5,k)
+ enddo
+ enddo
+
+END_PROVIDER
+
+
diff --git a/plugins/local/non_h_ints_mu/tc_integ.irp.f b/plugins/local/non_h_ints_mu/tc_integ.irp.f
index 775a9e4c..58e3db48 100644
--- a/plugins/local/non_h_ints_mu/tc_integ.irp.f
+++ b/plugins/local/non_h_ints_mu/tc_integ.irp.f
@@ -44,14 +44,92 @@ BEGIN_PROVIDER [double precision, int2_grad1_u12_ao, (ao_num, ao_num, n_points_f
elseif(tc_integ_type .eq. "numeric") then
print *, ' Numerical integration over r1 and r2 will be performed'
-
- ! TODO combine 1shot & int2_grad1_u12_ao_num
- PROVIDE int2_grad1_u12_ao_num
- int2_grad1_u12_ao = int2_grad1_u12_ao_num
+ if(tc_save_mem) then
- !PROVIDE int2_grad1_u12_ao_num_1shot
- !int2_grad1_u12_ao = int2_grad1_u12_ao_num_1shot
+ integer :: n_blocks, n_rest, n_pass
+ integer :: i_blocks, i_rest, i_pass, ii
+ double precision :: mem, n_double
+ double precision, allocatable :: tmp(:,:,:), xx(:)
+ double precision, allocatable :: tmp_grad1_u12(:,:,:)
+
+ PROVIDE final_weight_at_r_vector_extra aos_in_r_array_extra
+
+ allocate(tmp(n_points_extra_final_grid,ao_num,ao_num), xx(n_points_extra_final_grid))
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (j, i, jpoint) &
+ !$OMP SHARED (tmp, ao_num, n_points_extra_final_grid, final_weight_at_r_vector_extra, aos_in_r_array_extra_transp)
+ !$OMP DO COLLAPSE(2)
+ do j = 1, ao_num
+ do i = 1, ao_num
+ do jpoint = 1, n_points_extra_final_grid
+ tmp(jpoint,i,j) = final_weight_at_r_vector_extra(jpoint) * aos_in_r_array_extra_transp(jpoint,i) * aos_in_r_array_extra_transp(jpoint,j)
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+ call total_memory(mem)
+ mem = max(1.d0, qp_max_mem - mem)
+ n_double = mem * 1.d8
+ n_blocks = int(min(n_double / (n_points_extra_final_grid * 4.d0), 1.d0*n_points_final_grid))
+ n_rest = int(mod(n_points_final_grid, n_blocks))
+ n_pass = int((n_points_final_grid - n_rest) / n_blocks)
+ call write_int(6, n_pass, 'Number of passes')
+ call write_int(6, n_blocks, 'Size of the blocks')
+ call write_int(6, n_rest, 'Size of the last block')
+ allocate(tmp_grad1_u12(n_points_extra_final_grid,n_blocks,3))
+ do i_pass = 1, n_pass
+ ii = (i_pass-1)*n_blocks + 1
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i_blocks, ipoint) &
+ !$OMP SHARED (n_blocks, n_points_extra_final_grid, ii, final_grid_points, xx, tmp_grad1_u12)
+ !$OMP DO
+ do i_blocks = 1, n_blocks
+ ipoint = ii - 1 + i_blocks ! r1
+ call get_grad1_u12_withsq_r1_seq(ipoint, n_points_extra_final_grid, tmp_grad1_u12(1,i_blocks,1), tmp_grad1_u12(1,i_blocks,2), tmp_grad1_u12(1,i_blocks,3), xx(1))
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+ do m = 1, 3
+ call dgemm( "T", "N", ao_num*ao_num, n_blocks, n_points_extra_final_grid, 1.d0 &
+ , tmp(1,1,1), n_points_extra_final_grid, tmp_grad1_u12(1,1,m), n_points_extra_final_grid &
+ , 0.d0, int2_grad1_u12_ao(1,1,ii,m), ao_num*ao_num)
+ enddo
+ enddo
+ deallocate(tmp_grad1_u12)
+ if(n_rest .gt. 0) then
+ allocate(tmp_grad1_u12(n_points_extra_final_grid,n_rest,3))
+ ii = n_pass*n_blocks + 1
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i_rest, ipoint) &
+ !$OMP SHARED (n_rest, n_points_extra_final_grid, ii, final_grid_points, xx, tmp_grad1_u12)
+ !$OMP DO
+ do i_rest = 1, n_rest
+ ipoint = ii - 1 + i_rest ! r1
+ call get_grad1_u12_withsq_r1_seq(ipoint, n_points_extra_final_grid, tmp_grad1_u12(1,i_rest,1), tmp_grad1_u12(1,i_rest,2), tmp_grad1_u12(1,i_rest,3), xx(1))
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+ do m = 1, 3
+ call dgemm( "T", "N", ao_num*ao_num, n_rest, n_points_extra_final_grid, 1.d0 &
+ , tmp(1,1,1), n_points_extra_final_grid, tmp_grad1_u12(1,1,m), n_points_extra_final_grid &
+ , 0.d0, int2_grad1_u12_ao(1,1,ii,m), ao_num*ao_num)
+ enddo
+ deallocate(tmp_grad1_u12)
+ endif
+ deallocate(tmp,xx)
+
+ else
+ ! TODO combine 1shot & int2_grad1_u12_ao_num
+ PROVIDE int2_grad1_u12_ao_num
+ int2_grad1_u12_ao = int2_grad1_u12_ao_num
+ !PROVIDE int2_grad1_u12_ao_num_1shot
+ !int2_grad1_u12_ao = int2_grad1_u12_ao_num_1shot
+ endif
elseif(tc_integ_type .eq. "semi-analytic") then
@@ -177,13 +255,88 @@ BEGIN_PROVIDER [double precision, int2_grad1_u12_square_ao, (ao_num, ao_num, n_p
print *, ' Numerical integration over r1 and r2 will be performed'
- ! TODO combine 1shot & int2_grad1_u12_square_ao_num
+ if(tc_save_mem) then
- PROVIDE int2_grad1_u12_square_ao_num
- int2_grad1_u12_square_ao = int2_grad1_u12_square_ao_num
+ integer :: n_blocks, n_rest, n_pass
+ integer :: i_blocks, i_rest, i_pass, ii
+ double precision :: mem, n_double
+ double precision, allocatable :: tmp(:,:,:), xx(:,:,:)
+ double precision, allocatable :: tmp_grad1_u12_squared(:,:)
- !PROVIDE int2_grad1_u12_square_ao_num_1shot
- !int2_grad1_u12_square_ao = int2_grad1_u12_square_ao_num_1shot
+ PROVIDE final_weight_at_r_vector_extra aos_in_r_array_extra
+
+ allocate(tmp(n_points_extra_final_grid,ao_num,ao_num))
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (j, i, jpoint) &
+ !$OMP SHARED (tmp, ao_num, n_points_extra_final_grid, final_weight_at_r_vector_extra, aos_in_r_array_extra_transp)
+ !$OMP DO COLLAPSE(2)
+ do j = 1, ao_num
+ do i = 1, ao_num
+ do jpoint = 1, n_points_extra_final_grid
+ tmp(jpoint,i,j) = final_weight_at_r_vector_extra(jpoint) * aos_in_r_array_extra_transp(jpoint,i) * aos_in_r_array_extra_transp(jpoint,j)
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+ call total_memory(mem)
+ mem = max(1.d0, qp_max_mem - mem)
+ n_double = mem * 1.d8
+ n_blocks = int(min(n_double / (n_points_extra_final_grid * 4.d0), 1.d0*n_points_final_grid))
+ n_rest = int(mod(n_points_final_grid, n_blocks))
+ n_pass = int((n_points_final_grid - n_rest) / n_blocks)
+ call write_int(6, n_pass, 'Number of passes')
+ call write_int(6, n_blocks, 'Size of the blocks')
+ call write_int(6, n_rest, 'Size of the last block')
+ allocate(tmp_grad1_u12_squared(n_points_extra_final_grid,n_blocks), xx(n_points_extra_final_grid,n_blocks,3))
+ do i_pass = 1, n_pass
+ ii = (i_pass-1)*n_blocks + 1
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i_blocks, ipoint) &
+ !$OMP SHARED (n_blocks, n_points_extra_final_grid, ii, xx, final_grid_points, tmp_grad1_u12_squared)
+ !$OMP DO
+ do i_blocks = 1, n_blocks
+ ipoint = ii - 1 + i_blocks ! r1
+ call get_grad1_u12_withsq_r1_seq(ipoint, n_points_extra_final_grid, xx(1,i_blocks,1), xx(1,i_blocks,2), xx(1,i_blocks,3), tmp_grad1_u12_squared(1,i_blocks))
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+ call dgemm( "T", "N", ao_num*ao_num, n_blocks, n_points_extra_final_grid, -0.5d0 &
+ , tmp(1,1,1), n_points_extra_final_grid, tmp_grad1_u12_squared(1,1), n_points_extra_final_grid &
+ , 0.d0, int2_grad1_u12_square_ao(1,1,ii), ao_num*ao_num)
+ enddo
+ deallocate(tmp_grad1_u12_squared, xx)
+ if(n_rest .gt. 0) then
+ ii = n_pass*n_blocks + 1
+ allocate(tmp_grad1_u12_squared(n_points_extra_final_grid,n_rest), xx(n_points_extra_final_grid,n_rest,3))
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i_rest, ipoint) &
+ !$OMP SHARED (n_rest, n_points_extra_final_grid, ii, xx, final_grid_points, tmp_grad1_u12_squared)
+ !$OMP DO
+ do i_rest = 1, n_rest
+ ipoint = ii - 1 + i_rest ! r1
+ call get_grad1_u12_withsq_r1_seq(ipoint, n_points_extra_final_grid, xx(1,i_rest,1), xx(1,i_rest,2), xx(1,i_rest,3), tmp_grad1_u12_squared(1,i_rest))
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+ call dgemm( "T", "N", ao_num*ao_num, n_rest, n_points_extra_final_grid, -0.5d0 &
+ , tmp(1,1,1), n_points_extra_final_grid, tmp_grad1_u12_squared(1,1), n_points_extra_final_grid &
+ , 0.d0, int2_grad1_u12_square_ao(1,1,ii), ao_num*ao_num)
+ deallocate(tmp_grad1_u12_squared, xx)
+ endif
+ deallocate(tmp)
+
+ else
+
+ ! TODO combine 1shot & int2_grad1_u12_square_ao_num
+ PROVIDE int2_grad1_u12_square_ao_num
+ int2_grad1_u12_square_ao = int2_grad1_u12_square_ao_num
+ !PROVIDE int2_grad1_u12_square_ao_num_1shot
+ !int2_grad1_u12_square_ao = int2_grad1_u12_square_ao_num_1shot
+ endif
elseif(tc_integ_type .eq. "semi-analytic") then
diff --git a/plugins/local/non_h_ints_mu/tc_integ_num.irp.f b/plugins/local/non_h_ints_mu/tc_integ_num.irp.f
index e5d75c3d..9d9601c0 100644
--- a/plugins/local/non_h_ints_mu/tc_integ_num.irp.f
+++ b/plugins/local/non_h_ints_mu/tc_integ_num.irp.f
@@ -63,12 +63,10 @@
do i_pass = 1, n_pass
ii = (i_pass-1)*n_blocks + 1
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (i_blocks, ipoint) &
- !$OMP SHARED (n_blocks, n_points_extra_final_grid, ii, &
- !$OMP final_grid_points, tmp_grad1_u12, &
- !$OMP tmp_grad1_u12_squared)
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i_blocks, ipoint) &
+ !$OMP SHARED (n_blocks, n_points_extra_final_grid, ii, final_grid_points, tmp_grad1_u12, tmp_grad1_u12_squared)
!$OMP DO
do i_blocks = 1, n_blocks
ipoint = ii - 1 + i_blocks ! r1
@@ -99,12 +97,10 @@
ii = n_pass*n_blocks + 1
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (i_rest, ipoint) &
- !$OMP SHARED (n_rest, n_points_extra_final_grid, ii, &
- !$OMP final_grid_points, tmp_grad1_u12, &
- !$OMP tmp_grad1_u12_squared)
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i_rest, ipoint) &
+ !$OMP SHARED (n_rest, n_points_extra_final_grid, ii, final_grid_points, tmp_grad1_u12, tmp_grad1_u12_squared)
!$OMP DO
do i_rest = 1, n_rest
ipoint = ii - 1 + i_rest ! r1
@@ -131,7 +127,7 @@
deallocate(tmp)
call wall_time(time1)
- print*, ' wall time for int2_grad1_u12_ao_num & int2_grad1_u12_square_ao_num =', time1-time0
+ print*, ' wall time for int2_grad1_u12_ao_num & int2_grad1_u12_square_ao_num = (min)', (time1-time0) / 60.d0
call print_memory_usage()
END_PROVIDER
diff --git a/plugins/local/non_h_ints_mu/test_non_h_ints.irp.f b/plugins/local/non_h_ints_mu/test_non_h_ints.irp.f
index 464a1c1f..4c63dec4 100644
--- a/plugins/local/non_h_ints_mu/test_non_h_ints.irp.f
+++ b/plugins/local/non_h_ints_mu/test_non_h_ints.irp.f
@@ -1125,6 +1125,7 @@ subroutine test_fit_coef_A1()
double precision :: accu, norm, diff
double precision, allocatable :: A1(:,:)
double precision, allocatable :: A2(:,:,:,:), tmp(:,:,:)
+ double precision, allocatable :: tmp1(:,:,:), tmp2(:,:,:)
! ---
@@ -1165,16 +1166,17 @@ subroutine test_fit_coef_A1()
call wall_time(t1)
- allocate(tmp(ao_num,ao_num,n_points_final_grid))
+ allocate(tmp1(ao_num,ao_num,n_points_final_grid), tmp2(ao_num,ao_num,n_points_final_grid))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, ipoint) &
- !$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp)
+ !$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp1, tmp2)
!$OMP DO COLLAPSE(2)
do j = 1, ao_num
do i = 1, ao_num
do ipoint = 1, n_points_final_grid
- tmp(i,j,ipoint) = dsqrt(final_weight_at_r_vector(ipoint)) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
+ tmp1(i,j,ipoint) = final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
+ tmp2(i,j,ipoint) = aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
enddo
enddo
enddo
@@ -1184,9 +1186,9 @@ subroutine test_fit_coef_A1()
allocate(A2(ao_num,ao_num,ao_num,ao_num))
call dgemm( "N", "T", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
- , tmp(1,1,1), ao_num*ao_num, tmp(1,1,1), ao_num*ao_num &
+ , tmp1(1,1,1), ao_num*ao_num, tmp2(1,1,1), ao_num*ao_num &
, 0.d0, A2(1,1,1,1), ao_num*ao_num)
- deallocate(tmp)
+ deallocate(tmp1, tmp2)
call wall_time(t2)
print*, ' WALL TIME FOR A2 (min) =', (t2-t1)/60.d0
@@ -1238,6 +1240,7 @@ subroutine test_fit_coef_inv()
double precision, allocatable :: A1(:,:), A1_inv(:,:), A1_tmp(:,:)
double precision, allocatable :: A2(:,:,:,:), tmp(:,:,:), A2_inv(:,:,:,:)
double precision, allocatable :: U(:,:), D(:), Vt(:,:), work(:), A2_tmp(:,:,:,:)
+ double precision, allocatable :: tmp1(:,:,:), tmp2(:,:,:)
cutoff_svd = 5d-8
@@ -1286,16 +1289,17 @@ subroutine test_fit_coef_inv()
call wall_time(t1)
- allocate(tmp(n_points_final_grid,ao_num,ao_num))
+ allocate(tmp1(n_points_final_grid,ao_num,ao_num), tmp2(n_points_final_grid,ao_num,ao_num))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, ipoint) &
- !$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp)
+ !$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp1, tmp2)
!$OMP DO COLLAPSE(2)
do j = 1, ao_num
do i = 1, ao_num
do ipoint = 1, n_points_final_grid
- tmp(ipoint,i,j) = dsqrt(final_weight_at_r_vector(ipoint)) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
+ tmp1(ipoint,i,j) = final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
+ tmp2(ipoint,i,j) = aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
enddo
enddo
enddo
@@ -1304,11 +1308,11 @@ subroutine test_fit_coef_inv()
allocate(A2(ao_num,ao_num,ao_num,ao_num))
- call dgemm( "T", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
- , tmp(1,1,1), n_points_final_grid, tmp(1,1,1), n_points_final_grid &
+ call dgemm( "T", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
+ , tmp1(1,1,1), n_points_final_grid, tmp2(1,1,1), n_points_final_grid &
, 0.d0, A2(1,1,1,1), ao_num*ao_num)
- deallocate(tmp)
+ deallocate(tmp1, tmp2)
call wall_time(t2)
print*, ' WALL TIME FOR A2 (min) =', (t2-t1)/60.d0
diff --git a/plugins/local/non_h_ints_mu/total_tc_int.irp.f b/plugins/local/non_h_ints_mu/total_tc_int.irp.f
index 9d3cf565..a1bbd6e0 100644
--- a/plugins/local/non_h_ints_mu/total_tc_int.irp.f
+++ b/plugins/local/non_h_ints_mu/total_tc_int.irp.f
@@ -33,8 +33,10 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
double precision :: weight1, ao_k_r, ao_i_r
double precision :: der_envsq_x, der_envsq_y, der_envsq_z, lap_envsq
double precision :: time0, time1
- double precision, allocatable :: b_mat(:,:,:,:), c_mat(:,:,:)
+ double precision, allocatable :: c_mat(:,:,:)
+ logical, external :: ao_two_e_integral_zero
double precision, external :: get_ao_two_e_integral
+ double precision, external :: ao_two_e_integral
PROVIDe tc_integ_type
PROVIDE env_type
@@ -53,7 +55,9 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
print*, ' Reading ao_two_e_tc_tot from ', trim(ezfio_filename) // '/work/ao_two_e_tc_tot'
open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/ao_two_e_tc_tot', action="read")
- read(11) ao_two_e_tc_tot
+ do i = 1, ao_num
+ read(11) ao_two_e_tc_tot(:,:,:,i)
+ enddo
close(11)
else
@@ -65,27 +69,59 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
PROVIDE int2_grad1_u12_square_ao
- allocate(c_mat(n_points_final_grid,ao_num,ao_num))
+ if(tc_save_mem_loops) then
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (i, k, ipoint) &
- !$OMP SHARED (aos_in_r_array_transp, c_mat, ao_num, n_points_final_grid, final_weight_at_r_vector)
- !$OMP DO SCHEDULE (static)
- do i = 1, ao_num
- do k = 1, ao_num
- do ipoint = 1, n_points_final_grid
- c_mat(ipoint,k,i) = final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,k)
+ print*, ' LOOPS are used to evaluate Hermitian part of ao_two_e_tc_tot ...'
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i, j, k, l, ipoint, ao_i_r, ao_k_r, weight1) &
+ !$OMP SHARED (ao_num, n_points_final_grid, ao_two_e_tc_tot, &
+ !$OMP aos_in_r_array_transp, final_weight_at_r_vector, int2_grad1_u12_square_ao)
+ !$OMP DO COLLAPSE(4)
+ do i = 1, ao_num
+ do k = 1, ao_num
+ do l = 1, ao_num
+ do j = 1, ao_num
+ ao_two_e_tc_tot(j,l,k,i) = 0.d0
+ do ipoint = 1, n_points_final_grid
+ weight1 = final_weight_at_r_vector(ipoint)
+ ao_i_r = aos_in_r_array_transp(ipoint,i)
+ ao_k_r = aos_in_r_array_transp(ipoint,k)
+ ao_two_e_tc_tot(j,l,k,i) = ao_two_e_tc_tot(j,l,k,i) + int2_grad1_u12_square_ao(j,l,ipoint) * weight1 * ao_i_r * ao_k_r
+ enddo
+ enddo
+ enddo
enddo
enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
+ !$OMP END DO
+ !$OMP END PARALLEL
- call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
- , int2_grad1_u12_square_ao(1,1,1), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid &
- , 0.d0, ao_two_e_tc_tot, ao_num*ao_num)
+ else
+ print*, ' DGEMM are used to evaluate Hermitian part of ao_two_e_tc_tot ...'
+
+ allocate(c_mat(n_points_final_grid,ao_num,ao_num))
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i, k, ipoint) &
+ !$OMP SHARED (aos_in_r_array_transp, c_mat, ao_num, n_points_final_grid, final_weight_at_r_vector)
+ !$OMP DO SCHEDULE (static)
+ do i = 1, ao_num
+ do k = 1, ao_num
+ do ipoint = 1, n_points_final_grid
+ c_mat(ipoint,k,i) = final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,k)
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+ call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
+ , int2_grad1_u12_square_ao(1,1,1), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid &
+ , 0.d0, ao_two_e_tc_tot, ao_num*ao_num)
+ deallocate(c_mat)
+ endif
+
FREE int2_grad1_u12_square_ao
if( (tc_integ_type .eq. "semi-analytic") .and. &
@@ -96,6 +132,7 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
! an additional term is added here directly instead of
! being added in int2_grad1_u12_square_ao for performance
+ allocate(c_mat(n_points_final_grid,ao_num,ao_num))
PROVIDE int2_u2_env2
!$OMP PARALLEL &
@@ -127,10 +164,13 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
, int2_u2_env2(1,1,1), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid &
, 1.d0, ao_two_e_tc_tot(1,1,1,1), ao_num*ao_num)
+ deallocate(c_mat)
FREE int2_u2_env2
endif ! use_ipp
- deallocate(c_mat)
+ call wall_time(time1)
+ print*, ' done with Hermitian part after (min) ', (time1 - time0) / 60.d0
+ call print_memory_usage()
! ---
@@ -138,39 +178,71 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
PROVIDE int2_grad1_u12_ao
- allocate(b_mat(n_points_final_grid,ao_num,ao_num,3))
+ if(tc_save_mem_loops) then
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (i, k, ipoint, weight1, ao_i_r, ao_k_r) &
- !$OMP SHARED (aos_in_r_array_transp, aos_grad_in_r_array_transp_bis, b_mat, &
- !$OMP ao_num, n_points_final_grid, final_weight_at_r_vector)
- !$OMP DO SCHEDULE (static)
- do i = 1, ao_num
- do k = 1, ao_num
- do ipoint = 1, n_points_final_grid
+ print*, ' LOOPS are used to evaluate non-Hermitian part of ao_two_e_tc_tot ...'
- weight1 = 0.5d0 * final_weight_at_r_vector(ipoint)
- ao_i_r = aos_in_r_array_transp(ipoint,i)
- ao_k_r = aos_in_r_array_transp(ipoint,k)
-
- b_mat(ipoint,k,i,1) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,1) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,1))
- b_mat(ipoint,k,i,2) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,2) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,2))
- b_mat(ipoint,k,i,3) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,3) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,3))
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i, j, k, l, ipoint, ao_i_r, ao_k_r, weight1) &
+ !$OMP SHARED (ao_num, n_points_final_grid, ao_two_e_tc_tot, &
+ !$OMP aos_in_r_array_transp, final_weight_at_r_vector, &
+ !$OMP int2_grad1_u12_ao, aos_grad_in_r_array_transp_bis)
+ !$OMP DO COLLAPSE(4)
+ do i = 1, ao_num
+ do k = 1, ao_num
+ do l = 1, ao_num
+ do j = 1, ao_num
+ do ipoint = 1, n_points_final_grid
+ weight1 = 0.5d0 * final_weight_at_r_vector(ipoint)
+ ao_i_r = aos_in_r_array_transp(ipoint,i)
+ ao_k_r = aos_in_r_array_transp(ipoint,k)
+ ao_two_e_tc_tot(j,l,k,i) = ao_two_e_tc_tot(j,l,k,i) &
+ - weight1 * int2_grad1_u12_ao(j,l,ipoint,1) * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,1) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,1)) &
+ - weight1 * int2_grad1_u12_ao(j,l,ipoint,2) * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,2) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,2)) &
+ - weight1 * int2_grad1_u12_ao(j,l,ipoint,3) * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,3) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,3))
+ enddo
+ enddo
+ enddo
enddo
enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
+ !$OMP END DO
+ !$OMP END PARALLEL
- do m = 1, 3
- call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, -1.d0 &
- , int2_grad1_u12_ao(1,1,1,m), ao_num*ao_num, b_mat(1,1,1,m), n_points_final_grid &
- , 1.d0, ao_two_e_tc_tot(1,1,1,1), ao_num*ao_num)
- enddo
- deallocate(b_mat)
+ else
- FREE int2_grad1_u12_ao
+ print*, ' DGEMM are used to evaluate non-Hermitian part of ao_two_e_tc_tot ...'
+
+ allocate(c_mat(n_points_final_grid,ao_num,ao_num))
+ do m = 1, 3
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i, k, ipoint, weight1, ao_i_r, ao_k_r) &
+ !$OMP SHARED (aos_in_r_array_transp, aos_grad_in_r_array_transp_bis, c_mat, &
+ !$OMP ao_num, n_points_final_grid, final_weight_at_r_vector, m)
+ !$OMP DO SCHEDULE (static)
+ do i = 1, ao_num
+ do k = 1, ao_num
+ do ipoint = 1, n_points_final_grid
+
+ weight1 = 0.5d0 * final_weight_at_r_vector(ipoint)
+ ao_i_r = aos_in_r_array_transp(ipoint,i)
+ ao_k_r = aos_in_r_array_transp(ipoint,k)
+
+ c_mat(ipoint,k,i) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,m) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,m))
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, -1.d0 &
+ , int2_grad1_u12_ao(1,1,1,m), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid &
+ , 1.d0, ao_two_e_tc_tot(1,1,1,1), ao_num*ao_num)
+ enddo
+ deallocate(c_mat)
+
+ end if
if(tc_integ_type .eq. "semi-analytic") then
FREE int2_grad1_u2e_ao
@@ -178,30 +250,67 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
endif ! var_tc
+ call wall_time(time1)
+ print*, ' done with non-Hermitian part after (min) ', (time1 - time0) / 60.d0
+ call print_memory_usage()
+
! ---
call sum_A_At(ao_two_e_tc_tot(1,1,1,1), ao_num*ao_num)
- PROVIDE ao_integrals_map
+ ! ---
+
+ logical :: integ_zero
+ double precision :: integ_val
- !$OMP PARALLEL DEFAULT(NONE) &
- !$OMP SHARED(ao_num, ao_two_e_tc_tot, ao_integrals_map) &
- !$OMP PRIVATE(i, j, k, l)
- !$OMP DO
- do j = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do k = 1, ao_num
- ! < 1:i, 2:j | 1:k, 2:l >
- ao_two_e_tc_tot(k,i,l,j) = ao_two_e_tc_tot(k,i,l,j) + get_ao_two_e_integral(i, j, k, l, ao_integrals_map)
+ print*, ' adding ERI to ao_two_e_tc_tot ...'
+
+ if(tc_save_mem) then
+ print*, ' ao_integrals_map will not be used'
+ !$OMP PARALLEL DEFAULT(NONE) &
+ !$OMP PRIVATE(i, j, k, l, integ_zero, integ_val) &
+ !$OMP SHARED(ao_num, ao_two_e_tc_tot)
+ !$OMP DO COLLAPSE(4)
+ do j = 1, ao_num
+ do l = 1, ao_num
+ do i = 1, ao_num
+ do k = 1, ao_num
+ integ_zero = ao_two_e_integral_zero(i,j,k,l)
+ if(.not. integ_zero) then
+ ! i,k : r1 j,l : r2
+ integ_val = ao_two_e_integral(i,k,j,l)
+ ao_two_e_tc_tot(k,i,l,j) = ao_two_e_tc_tot(k,i,l,j) + integ_val
+ endif
+ enddo
enddo
enddo
enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
+ !$OMP END DO
+ !$OMP END PARALLEL
+ else
+ print*, ' ao_integrals_map will be used'
+ PROVIDE ao_integrals_map
+ !$OMP PARALLEL DEFAULT(NONE) &
+ !$OMP SHARED(ao_num, ao_two_e_tc_tot, ao_integrals_map) &
+ !$OMP PRIVATE(i, j, k, l)
+ !$OMP DO COLLAPSE(4)
+ do j = 1, ao_num
+ do l = 1, ao_num
+ do i = 1, ao_num
+ do k = 1, ao_num
+ ! < 1:i, 2:j | 1:k, 2:l >
+ ao_two_e_tc_tot(k,i,l,j) = ao_two_e_tc_tot(k,i,l,j) + get_ao_two_e_integral(i, j, k, l, ao_integrals_map)
+ enddo
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+ !call clear_ao_map()
+ FREE ao_integrals_map
+ endif
- if(tc_integ_type .eq. "numeric") then
+ if((tc_integ_type .eq. "numeric") .and. (.not. tc_save_mem)) then
FREE int2_grad1_u12_ao_num int2_grad1_u12_square_ao_num
endif
@@ -211,7 +320,9 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
print*, ' Saving ao_two_e_tc_tot in ', trim(ezfio_filename) // '/work/ao_two_e_tc_tot'
open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/ao_two_e_tc_tot', action="write")
call ezfio_set_work_empty(.False.)
- write(11) ao_two_e_tc_tot
+ do i = 1, ao_num
+ write(11) ao_two_e_tc_tot(:,:,:,i)
+ enddo
close(11)
call ezfio_set_tc_keywords_io_tc_integ('Read')
endif
diff --git a/plugins/local/non_hermit_dav/biorthog.irp.f b/plugins/local/non_hermit_dav/biorthog.irp.f
index 2229e17d..4b618228 100644
--- a/plugins/local/non_hermit_dav/biorthog.irp.f
+++ b/plugins/local/non_hermit_dav/biorthog.irp.f
@@ -1,254 +1,3 @@
-subroutine non_hrmt_diag_split_degen(n, A, leigvec, reigvec, n_real_eigv, eigval)
-
- BEGIN_DOC
- !
- ! routine which returns the sorted REAL EIGENVALUES ONLY and corresponding LEFT/RIGHT eigenvetors
- !
- ! of a non hermitian matrix A(n,n)
- !
- ! n_real_eigv is the number of real eigenvalues, which might be smaller than the dimension "n"
- !
- END_DOC
-
- implicit none
-
- integer, intent(in) :: n
- double precision, intent(in) :: A(n,n)
- integer, intent(out) :: n_real_eigv
- double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n)
- double precision, allocatable :: reigvec_tmp(:,:), leigvec_tmp(:,:)
-
- integer :: i, j, n_degen,k , iteration
- integer :: n_good
- double precision :: shift,shift_current
- double precision :: r,thr
- integer, allocatable :: list_good(:), iorder_origin(:),iorder(:)
- double precision, allocatable :: WR(:), WI(:), Vl(:,:), VR(:,:),S(:,:)
- double precision, allocatable :: Aw(:,:),diag_elem(:),A_save(:,:)
- double precision, allocatable :: im_part(:),re_part(:)
-
-
- print*,'Computing the left/right eigenvectors ...'
- print*,'Using the degeneracy splitting algorithm'
-
-
- ! pre-processing the matrix :: sorting by diagonal elements
- allocate(reigvec_tmp(n,n), leigvec_tmp(n,n))
- allocate(diag_elem(n),iorder_origin(n),A_save(n,n))
- do i = 1, n
- iorder_origin(i) = i
- diag_elem(i) = A(i,i)
- enddo
- call dsort(diag_elem, iorder_origin, n)
- do i = 1, n
- do j = 1, n
- A_save(j,i) = A(iorder_origin(j),iorder_origin(i))
- enddo
- enddo
-
- shift = 1.d-15
- shift_current = shift
- iteration = 1
- logical :: good_ortho
- good_ortho = .False.
- do while(n_real_eigv.ne.n.or. .not.good_ortho)
- if(shift.gt.1.d-3)then
- print*,'shift > 1.d-3 !!'
- print*,'Your matrix intrinsically contains complex eigenvalues'
- stop
- endif
- print*,'***** iteration = ',iteration
- print*,'shift = ',shift
- allocate(WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n))
- Aw = A_save
- do i = 1, n
- do j = 1, n
- if(dabs(Aw(j,i)).lt.shift)then
- Aw(j,i) = 0.d0
- endif
- enddo
- enddo
- call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
- allocate(im_part(n),iorder(n))
- do i = 1, n
- im_part(i) = -dabs(WI(i))
- iorder(i) = i
- enddo
- call dsort(im_part, iorder, n)
-
- shift_current = max(10.d0 * dabs(im_part(1)),shift)
- print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
- print*,'Splitting the degeneracies by ',shift_current
- Aw = A_save
- call split_matrix_degen(Aw,n,shift_current)
- deallocate( im_part, iorder )
- call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
- ! You track the real eigenvalues
- n_good = 0
- do i = 1, n
- if(dabs(WI(i)).lt.1.d-20)then
- n_good += 1
- else
- print*,'Found an imaginary component to eigenvalue'
- print*,'Re(i) + Im(i)',WR(i),WI(i)
- endif
- enddo
- allocate( list_good(n_good), iorder(n_good) )
- n_good = 0
- do i = 1, n
- if(dabs(WI(i)).lt.1.d-20)then
- n_good += 1
- list_good(n_good) = i
- eigval(n_good) = WR(i)
- endif
- enddo
- deallocate( WR, WI )
-
- n_real_eigv = n_good
- do i = 1, n_good
- iorder(i) = i
- enddo
-
- ! You sort the real eigenvalues
- call dsort(eigval, iorder, n_good)
-
- reigvec(:,:) = 0.d0
- leigvec(:,:) = 0.d0
- do i = 1, n_real_eigv
- do j = 1, n
- reigvec_tmp(j,i) = VR(j,list_good(iorder(i)))
- leigvec_tmp(j,i) = Vl(j,list_good(iorder(i)))
- enddo
- enddo
-
- if(n_real_eigv == n)then
- allocate(S(n,n))
- call check_bi_ortho(reigvec_tmp,leigvec_tmp,n,S,accu_nd)
- print*,'accu_nd = ',accu_nd
- double precision :: accu_nd
- good_ortho = accu_nd .lt. 1.d-10
- deallocate(S)
- endif
-
- deallocate( list_good, iorder )
- deallocate( VL, VR, Aw)
- shift *= 10.d0
- iteration += 1
- enddo
- do i = 1, n
- do j = 1, n
- reigvec(iorder_origin(j),i) = reigvec_tmp(j,i)
- leigvec(iorder_origin(j),i) = leigvec_tmp(j,i)
- enddo
- enddo
-
-end
-
-! ---
-
-subroutine non_hrmt_real_diag_new(n, A, leigvec, reigvec, n_real_eigv, eigval)
-
- BEGIN_DOC
- !
- ! routine which returns the sorted REAL EIGENVALUES ONLY and corresponding LEFT/RIGHT eigenvetors
- !
- ! of a non hermitian matrix A(n,n)
- !
- ! n_real_eigv is the number of real eigenvalues, which might be smaller than the dimension "n"
- !
- END_DOC
-
- implicit none
-
- integer, intent(in) :: n
- double precision, intent(in) :: A(n,n)
- integer, intent(out) :: n_real_eigv
- double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n)
-
- integer :: i, j
- integer :: n_good
- double precision :: shift,shift_current
- double precision :: r,thr
- integer, allocatable :: list_good(:), iorder(:)
- double precision, allocatable :: WR(:), WI(:), Vl(:,:), VR(:,:)
- double precision, allocatable :: Aw(:,:)
- double precision, allocatable :: im_part(:)
-
-
- print*,'Computing the left/right eigenvectors ...'
-
- ! Eigvalue(n) = WR(n) + i * WI(n)
- shift = 1.d-10
- do while(n_real_eigv.ne.n.or.shift.gt.1.d-3)
- allocate(WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n))
- Aw = A
- call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
- allocate(im_part(n), iorder(n))
- do i = 1, n
- im_part(i) = -dabs(WI(i))
- iorder(i) = i
- enddo
- shift_current = max(10.d0 * dabs(im_part(1)),shift)
- print*,'adding random number of magnitude ',shift_current
- Aw = A
- do i = 1, n
- call RANDOM_NUMBER(r)
- Aw(i,i) += shift_current * r
- enddo
- deallocate( im_part, iorder )
- call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
-
- ! You track the real eigenvalues
- thr = 1.d-10
- n_good = 0
- do i = 1, n
- if(dabs(WI(i)).lt.thr)then
- n_good += 1
- else
- print*,'Found an imaginary component to eigenvalue'
- print*,'Re(i) + Im(i)',WR(i),WI(i)
- endif
- enddo
-
- allocate( list_good(n_good), iorder(n_good) )
- n_good = 0
- do i = 1, n
- if(dabs(WI(i)).lt.thr)then
- n_good += 1
- list_good(n_good) = i
- eigval(n_good) = WR(i)
- endif
- enddo
-
- deallocate( WR, WI )
-
- n_real_eigv = n_good
- do i = 1, n_good
- iorder(i) = i
- enddo
-
- ! You sort the real eigenvalues
- call dsort(eigval, iorder, n_good)
-
- reigvec(:,:) = 0.d0
- leigvec(:,:) = 0.d0
- do i = 1, n_real_eigv
- do j = 1, n
- reigvec(j,i) = VR(j,list_good(iorder(i)))
- leigvec(j,i) = Vl(j,list_good(iorder(i)))
- enddo
- enddo
-
- deallocate( list_good, iorder )
- deallocate( VL, VR, Aw)
- shift *= 10.d0
- enddo
- if(shift.gt.1.d-3)then
- print*,'shift > 1.d-3 !!'
- print*,'Your matrix intrinsically contains complex eigenvalues'
- endif
-
-end
! ---
@@ -282,126 +31,20 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei
allocate(phi_1_tilde(n),phi_2_tilde(n),chi_1_tilde(n),chi_2_tilde(n))
-
- ! -------------------------------------------------------------------------------------
- !
-
- !print *, ' '
- !print *, ' Computing the left/right eigenvectors ...'
- !print *, ' '
-
allocate(WR(n), WI(n), VL(n,n), VR(n,n))
-
- !print *, ' fock matrix'
- !do i = 1, n
- ! write(*, '(1000(F16.10,X))') A(i,:)
- !enddo
- !thr_cut = 1.d-15
- !call cancel_small_elmts(A, n, thr_cut)
-
- !call lapack_diag_non_sym_right(n, A, WR, WI, VR)
call lapack_diag_non_sym(n, A, WR, WI, VL, VR)
- !call lapack_diag_non_sym_new(n, A, WR, WI, VL, VR)
-
-
-
- !print *, ' '
- !print *, ' eigenvalues'
- i = 1
- do while(i .le. n)
- !write(*, '(I3,X,1000(F16.10,X))')i, WR(i), WI(i)
- if(.false.)then
- if(WI(i).ne.0.d0)then
- print*,'*****************'
- print*,'WARNING ! IMAGINARY EIGENVALUES !!!'
- write(*, '(1000(F16.10,X))') WR(i), WI(i+1)
- ! phi = VR(:,i), psi = VR(:,i+1), |Phi_i> = phi + j psi , |Phi_i+1> = phi - j psi
- ! chi = VL(:,i), xhi = VL(:,i+1), |Chi_i> = chi + j xhi , |Chi_i+1> = chi - j xhi
- !
- accu_chi_phi = 0.d0
- accu_xhi_psi = 0.d0
- accu_chi_psi = 0.d0
- accu_xhi_phi = 0.d0
- double precision :: accu_chi_phi, accu_xhi_psi, accu_chi_psi, accu_xhi_phi
- double precision :: mat_ovlp(2,2),eigval_tmp(2),eigvec(2,2),mat_ovlp_orig(2,2)
- do j = 1, n
- accu_chi_phi += VL(j,i) * VR(j,i)
- accu_xhi_psi += VL(j,i+1) * VR(j,i+1)
- accu_chi_psi += VL(j,i) * VR(j,i+1)
- accu_xhi_phi += VL(j,i+1) * VR(j,i)
- enddo
- mat_ovlp_orig(1,1) = accu_chi_phi
- mat_ovlp_orig(2,1) = accu_xhi_phi
- mat_ovlp_orig(1,2) = accu_chi_psi
- mat_ovlp_orig(2,2) = accu_xhi_psi
- print*,'old overlap matrix '
- write(*,'(100(F16.10,X))')mat_ovlp_orig(1:2,1)
- write(*,'(100(F16.10,X))')mat_ovlp_orig(1:2,2)
-
-
- mat_ovlp(1,1) = accu_xhi_phi
- mat_ovlp(2,1) = accu_chi_phi
- mat_ovlp(1,2) = accu_xhi_psi
- mat_ovlp(2,2) = accu_chi_psi
- !print*,'accu_chi_phi = ',accu_chi_phi
- !print*,'accu_xhi_psi = ',accu_xhi_psi
- !print*,'accu_chi_psi = ',accu_chi_psi
- !print*,'accu_xhi_phi = ',accu_xhi_phi
- print*,'new overlap matrix '
- write(*,'(100(F16.10,X))')mat_ovlp(1:2,1)
- write(*,'(100(F16.10,X))')mat_ovlp(1:2,2)
- call lapack_diag(eigval_tmp,eigvec,mat_ovlp,2,2)
- print*,'eigval_tmp(1) = ',eigval_tmp(1)
- print*,'eigvec(1) = ',eigvec(1:2,1)
- print*,'eigval_tmp(2) = ',eigval_tmp(2)
- print*,'eigvec(2) = ',eigvec(1:2,2)
- print*,'*****************'
- phi_1_tilde = 0.d0
- phi_2_tilde = 0.d0
- chi_1_tilde = 0.d0
- chi_2_tilde = 0.d0
- do j = 1, n
- phi_1_tilde(j) += VR(j,i) * eigvec(1,1) + VR(j,i+1) * eigvec(2,1)
- phi_2_tilde(j) += VR(j,i) * eigvec(1,2) + VR(j,i+1) * eigvec(2,2)
- chi_1_tilde(j) += VL(j,i+1) * eigvec(1,1) + VL(j,i) * eigvec(2,1)
- chi_2_tilde(j) += VL(j,i+1) * eigvec(1,2) + VL(j,i) * eigvec(2,2)
- enddo
- VR(1:n,i) = phi_1_tilde(1:n)
- VR(1:n,i+1) = phi_2_tilde(1:n)
-! Vl(1:n,i) = -chi_1_tilde(1:n)
-! Vl(1:n,i+1) = chi_2_tilde(1:n)
- i+=1
- endif
- endif
- i+=1
- enddo
- !print *, ' right eigenvect bef'
- !do i = 1, n
- ! write(*, '(1000(F16.10,X))') VR(:,i)
- !enddo
- !print *, ' left eigenvect bef'
- !do i = 1, n
- ! write(*, '(1000(F16.10,X))') VL(:,i)
- !enddo
thr_diag = 1d-06
thr_norm = 1d+10
- !call check_EIGVEC(n, n, A, WR, VL, VR, thr_diag, thr_norm, .false.)
-
- !
- ! -------------------------------------------------------------------------------------
! ---
- ! -------------------------------------------------------------------------------------
- ! track & sort the real eigenvalues
+ ! track & sort the real eigenvalues
n_good = 0
- !thr = 100d0
- thr = Im_thresh_tcscf
+ thr = Im_thresh_tc
do i = 1, n
- !print*, 'Re(i) + Im(i)', WR(i), WI(i)
if(dabs(WI(i)) .lt. thr) then
n_good += 1
else
@@ -410,11 +53,12 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei
endif
enddo
- if(n_good.ne.n)then
- print*,'there are some imaginary eigenvalues '
- thr_diag = 1d-03
- n_good = n
+ if(n_good.ne.n) then
+ print*,'there are some imaginary eigenvalues '
+ thr_diag = 1d-03
+ n_good = n
endif
+
allocate(list_good(n_good), iorder(n_good))
n_good = 0
@@ -446,26 +90,9 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei
ASSERT(n==n_real_eigv)
- !print *, ' eigenvalues'
- !do i = 1, n
- ! write(*, '(1000(F16.10,X))') eigval(i)
- !enddo
- !print *, ' right eigenvect aft ord'
- !do i = 1, n
- ! write(*, '(1000(F16.10,X))') reigvec(:,i)
- !enddo
- !print *, ' left eigenvect aft ord'
- !do i = 1, n
- ! write(*, '(1000(F16.10,X))') leigvec(:,i)
- !enddo
-
- !
- ! -------------------------------------------------------------------------------------
-
! ---
- ! -------------------------------------------------------------------------------------
- ! check bi-orthogonality
+ ! check bi-orthogonality
thr_diag = 10.d0
thr_norm = 1d+10
@@ -495,8 +122,6 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei
print *, ' lapack vectors are not normalized neither bi-orthogonalized'
- ! ---
-
allocate(deg_num(n))
call reorder_degen_eigvec(n, deg_num, eigval, leigvec, reigvec)
call impose_biorthog_degen_eigvec(n, deg_num, eigval, leigvec, reigvec)
@@ -508,700 +133,36 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei
endif
call check_biorthog(n, n_real_eigv, leigvec, reigvec, accu_d, accu_nd, S, thr_d, thr_nd, .true.)
- !call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, thr_diag, thr_norm, .true.)
-
deallocate(S)
endif
- !
- ! -------------------------------------------------------------------------------------
-
return
end
! ---
-subroutine non_hrmt_bieig_random_diag(n, A, leigvec, reigvec, n_real_eigv, eigval)
+subroutine check_bi_ortho(reigvec, leigvec, n, S, accu_nd)
BEGIN_DOC
- !
- ! routine which returns the sorted REAL EIGENVALUES ONLY and corresponding LEFT/RIGHT eigenvetors
- ! of a non hermitian matrix A(n,n)
- !
- ! n_real_eigv is the number of real eigenvalues, which might be smaller than the dimension "n"
+ ! retunrs the overlap matrix S = Leigvec^T Reigvec
!
+ ! and the square root of the sum of the squared off-diagonal elements of S
END_DOC
implicit none
integer, intent(in) :: n
- double precision, intent(in) :: A(n,n)
- integer, intent(out) :: n_real_eigv
- double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n)
+ double precision, intent(in) :: reigvec(n,n), leigvec(n,n)
+ double precision, intent(out) :: S(n,n), accu_nd
- integer :: i, j
- integer :: n_good
- double precision :: thr
- double precision :: accu_nd
+ integer :: i,j
- integer, allocatable :: list_good(:), iorder(:)
- double precision, allocatable :: Aw(:,:)
- double precision, allocatable :: WR(:), WI(:), VL(:,:), VR(:,:)
- double precision, allocatable :: S(:,:)
- double precision :: r
-
-
- ! -------------------------------------------------------------------------------------
- !
-
- print *, 'Computing the left/right eigenvectors ...'
- allocate( WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n) )
-
- Aw(:,:) = A(:,:)
- call lapack_diag_non_sym_new(n, Aw, WR, WI, VL, VR)
-
- thr = 1.d-12
- double precision, allocatable :: im_part(:)
- n_good = 0
- do i = 1, n
- if( dabs(WI(i)).lt.thr ) then
- n_good += 1
- else
- print*, 'Found an imaginary component to eigenvalue on i = ', i
- print*, 'Re(i) + Im(i)', WR(i), WI(i)
- endif
- enddo
- print*,'n_good = ',n_good
- if(n_good .lt. n)then
- print*,'Removing degeneracies to remove imaginary parts'
- allocate(im_part(n),iorder(n))
- r = 0.d0
- do i = 1, n
- im_part(i) = -dabs(WI(i))
- iorder(i) = i
- enddo
- call dsort(im_part,iorder,n)
- thr = 10.d0 * dabs(im_part(1))
- print*,'adding random numbers on the diagonal of magnitude ',thr
- Aw(:,:) = A(:,:)
- do i = 1, n
- call RANDOM_NUMBER(r)
- print*,'r = ',r*thr
- Aw(i,i) += thr * r
- enddo
- print*,'Rediagonalizing the matrix with random numbers'
- call lapack_diag_non_sym_new(n, Aw, WR, WI, VL, VR)
- deallocate(im_part,iorder)
- endif
- deallocate( Aw )
-
- !
- ! -------------------------------------------------------------------------------------
-
- ! ---
-
- ! -------------------------------------------------------------------------------------
- ! track & sort the real eigenvalues
-
- n_good = 0
- thr = 1.d-5
- do i = 1, n
- if( dabs(WI(i)).lt.thr ) then
- n_good += 1
- else
- print*, 'Found an imaginary component to eigenvalue on i = ', i
- print*, 'Re(i) + Im(i)', WR(i), WI(i)
- endif
- enddo
- print*,'n_good = ',n_good
- allocate( list_good(n_good), iorder(n_good) )
-
- n_good = 0
- do i = 1, n
- if( dabs(WI(i)).lt.thr ) then
- n_good += 1
- list_good(n_good) = i
- eigval(n_good) = WR(i)
- endif
- enddo
-
- deallocate( WR, WI )
-
- n_real_eigv = n_good
- do i = 1, n_good
- iorder(i) = i
- enddo
- call dsort(eigval, iorder, n_good)
-
- reigvec(:,:) = 0.d0
- leigvec(:,:) = 0.d0
- do i = 1, n_real_eigv
- do j = 1, n
- reigvec(j,i) = VR(j,list_good(iorder(i)))
- leigvec(j,i) = VL(j,list_good(iorder(i)))
- enddo
- enddo
-
- deallocate( list_good, iorder )
- deallocate( VL, VR )
-
- !
- ! -------------------------------------------------------------------------------------
-
- ! ---
-
- ! -------------------------------------------------------------------------------------
- ! check bi-orthogonality
-
- allocate( S(n_real_eigv,n_real_eigv) )
-
- ! S = VL x VR
- call dgemm( 'T', 'N', n_real_eigv, n_real_eigv, n, 1.d0 &
- , leigvec, size(leigvec, 1), reigvec, size(reigvec, 1) &
- , 0.d0, S, size(S, 1) )
-
- accu_nd = 0.d0
- do i = 1, n_real_eigv
- do j = 1, n_real_eigv
- if(i==j) cycle
- accu_nd = accu_nd + S(j,i) * S(j,i)
- enddo
- enddo
- accu_nd = dsqrt(accu_nd)
-
- if(accu_nd .lt. thresh_biorthog_nondiag) then
- ! L x R is already bi-orthogonal
-
- print *, ' L & T bi-orthogonality: ok'
- deallocate( S )
- return
-
- else
- ! impose bi-orthogonality
-
- print *, ' L & T bi-orthogonality: not imposed yet'
- print *, ' accu_nd = ', accu_nd
- call impose_biorthog_qr(n, n_real_eigv, thresh_biorthog_diag, thresh_biorthog_nondiag, leigvec, reigvec)
- deallocate( S )
-
- endif
-
- !
- ! -------------------------------------------------------------------------------------
-
- return
-
-end
-
-! ---
-
-subroutine non_hrmt_real_im(n, A, leigvec, reigvec, n_real_eigv, eigval)
-
- BEGIN_DOC
- !
- ! routine which returns the EIGENVALUES sorted the REAL part and corresponding LEFT/RIGHT eigenvetors
- ! of a non hermitian matrix A(n,n)
- !
- ! n_real_eigv is the number of real eigenvalues, which might be smaller than the dimension "n"
- !
- END_DOC
-
- implicit none
- integer, intent(in) :: n
- double precision, intent(in) :: A(n,n)
- integer, intent(out) :: n_real_eigv
- double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n)
-
- integer :: i, j
- integer :: n_bad
- double precision :: thr
- double precision :: accu_nd
-
- integer, allocatable :: iorder(:)
- double precision, allocatable :: Aw(:,:)
- double precision, allocatable :: WR(:), WI(:), VL(:,:), VR(:,:)
- double precision, allocatable :: S(:,:)
- double precision :: r
-
- ! -------------------------------------------------------------------------------------
- !
-
- print *, 'Computing the left/right eigenvectors ...'
- allocate( WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n), iorder(n))
-
- Aw(:,:) = A(:,:)
- do i = 1, n
- call RANDOM_NUMBER(r)
- Aw(i,i) += 10.d-10* r
- enddo
- call lapack_diag_non_sym(n, Aw, WR, WI, VL, VR)
-
- ! -------------------------------------------------------------------------------------
- ! track & sort the real eigenvalues
-
- i = 1
- thr = 1.d-15
- n_real_eigv = 0
- do while (i.le.n)
-! print*,i,dabs(WI(i))
- if( dabs(WI(i)).gt.thr ) then
- print*, 'Found an imaginary component to eigenvalue on i = ', i
- print*, 'Re(i) , Im(i) ', WR(i), WI(i)
- iorder(i) = i
- eigval(i) = WR(i)
- i+=1
- print*, 'Re(i+1),Im(i+1)',WR(i), WI(i)
- iorder(i) = i
- eigval(i) = WR(i)
- i+=1
- else
- n_real_eigv += 1
- iorder(i) = i
- eigval(i) = WR(i)
- i+=1
- endif
- enddo
- call dsort(eigval, iorder, n)
- reigvec(:,:) = 0.d0
- leigvec(:,:) = 0.d0
- do i = 1, n
- do j = 1, n
- reigvec(j,i) = VR(j,iorder(i))
- leigvec(j,i) = VL(j,iorder(i))
- enddo
- enddo
-
- deallocate( iorder )
- deallocate( VL, VR )
-
- !
- ! -------------------------------------------------------------------------------------
-
- ! ---
-
- ! -------------------------------------------------------------------------------------
- ! check bi-orthogonality
-
- allocate( S(n,n) )
-
- ! S = VL x VR
- call dgemm( 'T', 'N', n, n, n, 1.d0 &
- , leigvec, size(leigvec, 1), reigvec, size(reigvec, 1) &
- , 0.d0, S, size(S, 1) )
-
- accu_nd = 0.d0
- do i = 1, n
- do j = 1, n
- if(i==j) cycle
- accu_nd = accu_nd + S(j,i) * S(j,i)
- enddo
- enddo
- accu_nd = dsqrt(accu_nd)
-
- deallocate( S )
-
-end
-
-! ---
-
-subroutine non_hrmt_generalized_real_im(n, A, B, leigvec, reigvec, n_real_eigv, eigval)
-
- BEGIN_DOC
- !
- ! routine which returns the EIGENVALUES sorted the REAL part and corresponding LEFT/RIGHT eigenvetors
- ! for A R = lambda B R and A^\dagger L = lambda B^\dagger L
- !
- ! n_real_eigv is the number of real eigenvalues, which might be smaller than the dimension "n"
- !
- END_DOC
-
- implicit none
- integer, intent(in) :: n
- double precision, intent(in) :: A(n,n),B(n,n)
- integer, intent(out) :: n_real_eigv
- double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n)
-
- integer :: i, j
- integer :: n_bad
- double precision :: thr
- double precision :: accu_nd
-
- integer, allocatable :: iorder(:)
- double precision, allocatable :: Aw(:,:),Bw(:,:)
- double precision, allocatable :: WR(:), WI(:), VL(:,:), VR(:,:), beta(:)
- double precision, allocatable :: S(:,:)
- double precision :: r
-
- ! -------------------------------------------------------------------------------------
- !
-
- print *, 'Computing the left/right eigenvectors ...'
- allocate( WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n), Bw(n,n),iorder(n),beta(n))
-
- Aw(:,:) = A(:,:)
- Bw(:,:) = B(:,:)
- call lapack_diag_general_non_sym(n,Aw,Bw,WR,beta,WI,VL,VR)
-
- ! -------------------------------------------------------------------------------------
- ! track & sort the real eigenvalues
-
- i = 1
- thr = 1.d-10
- n_real_eigv = 0
- do while (i.le.n)
- if( dabs(WI(i)).gt.thr ) then
- print*, 'Found an imaginary component to eigenvalue on i = ', i
- print*, 'Re(i) , Im(i) ', WR(i), WI(i)
- iorder(i) = i
- eigval(i) = WR(i)/(beta(i) + 1.d-10)
- i+=1
- print*, 'Re(i+1),Im(i+1)',WR(i), WI(i)
- iorder(i) = i
- eigval(i) = WR(i)/(beta(i) + 1.d-10)
- i+=1
- else
- n_real_eigv += 1
- iorder(i) = i
- eigval(i) = WR(i)/(beta(i) + 1.d-10)
- i+=1
- endif
- enddo
- call dsort(eigval, iorder, n)
- reigvec(:,:) = 0.d0
- leigvec(:,:) = 0.d0
- do i = 1, n
- do j = 1, n
- reigvec(j,i) = VR(j,iorder(i))
- leigvec(j,i) = VL(j,iorder(i))
- enddo
- enddo
-
- deallocate( iorder )
- deallocate( VL, VR )
-
- !
- ! -------------------------------------------------------------------------------------
-
- ! ---
-
- ! -------------------------------------------------------------------------------------
- ! check bi-orthogonality
-
- allocate( S(n,n) )
-
- ! S = VL x VR
- call dgemm( 'T', 'N', n, n, n, 1.d0 &
- , leigvec, size(leigvec, 1), reigvec, size(reigvec, 1) &
- , 0.d0, S, size(S, 1) )
-
- accu_nd = 0.d0
- do i = 1, n
- do j = 1, n
- if(i==j) cycle
- accu_nd = accu_nd + S(j,i) * S(j,i)
- enddo
- enddo
- accu_nd = dsqrt(accu_nd)
-
- deallocate( S )
-
-end
-
-! ---
-
-subroutine non_hrmt_bieig_fullvect(n, A, leigvec, reigvec, n_real_eigv, eigval)
-
- BEGIN_DOC
- !
- ! routine which returns the sorted REAL EIGENVALUES ONLY and corresponding LEFT/RIGHT eigenvetors
- ! of a non hermitian matrix A(n,n)
- !
- ! n_real_eigv is the number of real eigenvalues, which might be smaller than the dimension "n"
- !
- END_DOC
-
- implicit none
- integer, intent(in) :: n
- double precision, intent(in) :: A(n,n)
- integer, intent(out) :: n_real_eigv
- double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n)
-
- integer :: i, j
- integer :: n_good
- double precision :: thr
- double precision :: accu_nd
-
- integer, allocatable :: iorder(:)
- double precision, allocatable :: Aw(:,:)
- double precision, allocatable :: WR(:), WI(:), VL(:,:), VR(:,:)
- double precision, allocatable :: S(:,:)
- double precision, allocatable :: eigval_sorted(:)
-
-
- ! -------------------------------------------------------------------------------------
- !
-
- print *, 'Computing the left/right eigenvectors ...'
-
- allocate( WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n) )
- Aw(:,:) = A(:,:)
-
- call lapack_diag_non_sym_new(n, Aw, WR, WI, VL, VR)
-
- deallocate( Aw )
-
- !
- ! -------------------------------------------------------------------------------------
-
- ! ---
-
- ! -------------------------------------------------------------------------------------
- ! track & sort the real eigenvalues
-
- allocate( eigval_sorted(n), iorder(n) )
-
- n_good = 0
- thr = 1.d-10
-
- do i = 1, n
-
- iorder(i) = i
- eigval_sorted(i) = WR(i)
-
- if(dabs(WI(i)) .gt. thr) then
- print*, ' Found an imaginary component to eigenvalue on i = ', i
- print*, ' Re(i) + Im(i)', WR(i), WI(i)
- else
- n_good += 1
- endif
-
- enddo
-
- n_real_eigv = n_good
-
- call dsort(eigval_sorted, iorder, n)
-
- reigvec(:,:) = 0.d0
- leigvec(:,:) = 0.d0
- do i = 1, n
- eigval(i) = WR(i)
- do j = 1, n
- reigvec(j,i) = VR(j,iorder(i))
- leigvec(j,i) = VL(j,iorder(i))
- enddo
- enddo
-
- deallocate( eigval_sorted, iorder )
- deallocate( WR, WI )
- deallocate( VL, VR )
-
- !
- ! -------------------------------------------------------------------------------------
-
- ! ---
-
- ! -------------------------------------------------------------------------------------
- ! check bi-orthogonality
-
- allocate( S(n,n) )
-
- ! S = VL x VR
- call dgemm( 'T', 'N', n, n, n, 1.d0 &
- , leigvec, size(leigvec, 1), reigvec, size(reigvec, 1) &
- , 0.d0, S, size(S, 1) )
-
- accu_nd = 0.d0
- do i = 1, n
- do j = 1, n
- if(i==j) cycle
- accu_nd = accu_nd + S(j,i) * S(j,i)
- enddo
- enddo
- accu_nd = dsqrt(accu_nd)
-
- if(accu_nd .lt. thresh_biorthog_nondiag) then
- ! L x R is already bi-orthogonal
-
- !print *, ' L & T bi-orthogonality: ok'
- deallocate( S )
- return
-
- else
- ! impose bi-orthogonality
-
- !print *, ' L & T bi-orthogonality: not imposed yet'
- !print *, ' accu_nd = ', accu_nd
- call impose_biorthog_qr(n, n, thresh_biorthog_diag, thresh_biorthog_nondiag, leigvec, reigvec)
- deallocate( S )
-
- endif
-
- !
- ! -------------------------------------------------------------------------------------
-
- return
-
-end
-
-! ---
-
-
-subroutine split_matrix_degen(aw,n,shift)
- implicit none
- BEGIN_DOC
- ! subroutines that splits the degeneracies of a matrix by adding a splitting of magnitude thr * n_degen/2
- !
- ! WARNING !! THE MATRIX IS ASSUMED TO BE PASSED WITH INCREASING DIAGONAL ELEMENTS
- END_DOC
- double precision,intent(inout) :: Aw(n,n)
- double precision,intent(in) :: shift
- integer, intent(in) :: n
- integer :: i,j,n_degen
- logical :: keep_on
- i=1
- do while(i.lt.n)
- if(dabs(Aw(i,i)-Aw(i+1,i+1)).lt.shift)then
- j=1
- keep_on = .True.
- do while(keep_on)
- if(i+j.gt.n)then
- keep_on = .False.
- exit
- endif
- if(dabs(Aw(i,i)-Aw(i+j,i+j)).lt.shift)then
- j+=1
- else
- keep_on=.False.
- exit
- endif
- enddo
- n_degen = j
- j=0
- keep_on = .True.
- do while(keep_on)
- if(i+j+1.gt.n)then
- keep_on = .False.
- exit
- endif
- if(dabs(Aw(i+j,i+j)-Aw(i+j+1,i+j+1)).lt.shift)then
- Aw(i+j,i+j) += (j-n_degen/2) * shift
- j+=1
- else
- keep_on = .False.
- exit
- endif
- enddo
- Aw(i+n_degen-1,i+n_degen-1) += (n_degen-1-n_degen/2) * shift
- i+=n_degen
- else
- i+=1
- endif
- enddo
-
-end
-
-subroutine give_degen(a,n,shift,list_degen,n_degen_list)
- implicit none
- BEGIN_DOC
- ! returns n_degen_list :: the number of degenerated SET of elements (i.e. with |A(i)-A(i+1)| below shift)
- !
- ! for each of these sets, list_degen(1,i) = first degenerate element of the set i,
- !
- ! list_degen(2,i) = last degenerate element of the set i.
- END_DOC
- double precision,intent(in) :: A(n)
- double precision,intent(in) :: shift
- integer, intent(in) :: n
- integer, intent(out) :: list_degen(2,n),n_degen_list
- integer :: i,j,n_degen,k
- logical :: keep_on
- double precision,allocatable :: Aw(:)
- list_degen = -1
- allocate(Aw(n))
- Aw = A
- i=1
- k = 0
- do while(i.lt.n)
- if(dabs(Aw(i)-Aw(i+1)).lt.shift)then
- k+=1
- j=1
- list_degen(1,k) = i
- keep_on = .True.
- do while(keep_on)
- if(i+j.gt.n)then
- keep_on = .False.
- exit
- endif
- if(dabs(Aw(i)-Aw(i+j)).lt.shift)then
- j+=1
- else
- keep_on=.False.
- exit
- endif
- enddo
- n_degen = j
- list_degen(2,k) = list_degen(1,k)-1 + n_degen
- j=0
- keep_on = .True.
- do while(keep_on)
- if(i+j+1.gt.n)then
- keep_on = .False.
- exit
- endif
- if(dabs(Aw(i+j)-Aw(i+j+1)).lt.shift)then
- Aw(i+j) += (j-n_degen/2) * shift
- j+=1
- else
- keep_on = .False.
- exit
- endif
- enddo
- Aw(i+n_degen-1) += (n_degen-1-n_degen/2) * shift
- i+=n_degen
- else
- i+=1
- endif
- enddo
- n_degen_list = k
-
-end
-
-subroutine cancel_small_elmts(aw,n,shift)
- implicit none
- BEGIN_DOC
- ! subroutines that splits the degeneracies of a matrix by adding a splitting of magnitude thr * n_degen/2
- !
- ! WARNING !! THE MATRIX IS ASSUMED TO BE PASSED WITH INCREASING DIAGONAL ELEMENTS
- END_DOC
- double precision,intent(inout) :: Aw(n,n)
- double precision,intent(in) :: shift
- integer, intent(in) :: n
- integer :: i,j
- do i = 1, n
- do j = 1, n
- if(dabs(Aw(j,i)).lt.shift)then
- Aw(j,i) = 0.d0
- endif
- enddo
- enddo
-end
-
-subroutine check_bi_ortho(reigvec,leigvec,n,S,accu_nd)
- implicit none
- integer, intent(in) :: n
- double precision,intent(in) :: reigvec(n,n),leigvec(n,n)
- double precision, intent(out) :: S(n,n),accu_nd
- BEGIN_DOC
-! retunrs the overlap matrix S = Leigvec^T Reigvec
-!
-! and the square root of the sum of the squared off-diagonal elements of S
- END_DOC
- integer :: i,j
! S = VL x VR
call dgemm( 'T', 'N', n, n, n, 1.d0 &
, leigvec, size(leigvec, 1), reigvec, size(reigvec, 1) &
, 0.d0, S, size(S, 1) )
+
accu_nd = 0.d0
do i = 1, n
do j = 1, n
@@ -1213,3 +174,5 @@ subroutine check_bi_ortho(reigvec,leigvec,n,S,accu_nd)
accu_nd = dsqrt(accu_nd)
end
+
+
diff --git a/plugins/local/non_hermit_dav/lapack_diag_non_hermit.irp.f b/plugins/local/non_hermit_dav/lapack_diag_non_hermit.irp.f
index cb38347e..2c053ac8 100644
--- a/plugins/local/non_hermit_dav/lapack_diag_non_hermit.irp.f
+++ b/plugins/local/non_hermit_dav/lapack_diag_non_hermit.irp.f
@@ -273,60 +273,6 @@ end
! ---
-subroutine lapack_diag_non_sym_right(n, A, WR, WI, VR)
-
- implicit none
-
- integer, intent(in) :: n
- double precision, intent(in) :: A(n,n)
- double precision, intent(out) :: WR(n), WI(n), VR(n,n)
-
- integer :: i, lda, ldvl, ldvr, LWORK, INFO
- double precision, allocatable :: Atmp(:,:), WORK(:), VL(:,:)
-
- lda = n
- ldvl = 1
- ldvr = n
-
- allocate( Atmp(n,n), VL(1,1) )
- Atmp(1:n,1:n) = A(1:n,1:n)
-
- allocate(WORK(1))
- LWORK = -1
- call dgeev('N', 'V', n, Atmp, lda, WR, WI, VL, ldvl, VR, ldvr, WORK, LWORK, INFO)
- if(INFO.gt.0)then
- print*,'dgeev failed !!',INFO
- stop
- endif
-
- LWORK = max(int(WORK(1)), 1) ! this is the optimal size of WORK
- deallocate(WORK)
-
- allocate(WORK(LWORK))
-
- ! Actual diagonalization
- call dgeev('N', 'V', n, Atmp, lda, WR, WI, VL, ldvl, VR, ldvr, WORK, LWORK, INFO)
- if(INFO.ne.0) then
- print*,'dgeev failed !!', INFO
- stop
- endif
-
- deallocate(Atmp, WORK, VL)
-
-! print *, ' JOBL = F'
-! print *, ' eigenvalues'
-! do i = 1, n
-! write(*, '(1000(F16.10,X))') WR(i), WI(i)
-! enddo
-! print *, ' right eigenvect'
-! do i = 1, n
-! write(*, '(1000(F16.10,X))') VR(:,i)
-! enddo
-
-end
-
-! ---
-
subroutine non_hrmt_real_diag(n, A, leigvec, reigvec, n_real_eigv, eigval)
BEGIN_DOC
@@ -1780,70 +1726,6 @@ end
! ---
-subroutine check_weighted_biorthog(n, m, W, Vl, Vr, thr_d, thr_nd, accu_d, accu_nd, S, stop_ifnot)
-
- implicit none
-
- integer, intent(in) :: n, m
- double precision, intent(in) :: Vl(n,m), Vr(n,m), W(n,n)
- double precision, intent(in) :: thr_d, thr_nd
- logical, intent(in) :: stop_ifnot
- double precision, intent(out) :: accu_d, accu_nd, S(m,m)
-
- integer :: i, j
- double precision, allocatable :: SS(:,:), tmp(:,:)
-
- print *, ' check weighted bi-orthogonality'
-
- ! ---
-
- allocate(tmp(m,n))
- call dgemm( 'T', 'N', m, n, n, 1.d0 &
- , Vl, size(Vl, 1), W, size(W, 1) &
- , 0.d0, tmp, size(tmp, 1) )
- call dgemm( 'N', 'N', m, m, n, 1.d0 &
- , tmp, size(tmp, 1), Vr, size(Vr, 1) &
- , 0.d0, S, size(S, 1) )
- deallocate(tmp)
-
- !print *, ' overlap matrix:'
- !do i = 1, m
- ! write(*,'(1000(F16.10,X))') S(i,:)
- !enddo
-
- accu_d = 0.d0
- accu_nd = 0.d0
- do i = 1, m
- do j = 1, m
- if(i==j) then
- accu_d = accu_d + dabs(S(i,i))
- else
- accu_nd = accu_nd + S(j,i) * S(j,i)
- endif
- enddo
- enddo
- accu_nd = dsqrt(accu_nd)
-
- print *, ' accu_nd = ', accu_nd
- print *, ' accu_d = ', dabs(accu_d-dble(m))/dble(m)
-
- ! ---
-
- if( stop_ifnot .and. ((accu_nd .gt. thr_nd) .or. dabs(accu_d-dble(m))/dble(m) .gt. thr_d) ) then
- print *, ' non bi-orthogonal vectors !'
- print *, ' accu_nd = ', accu_nd
- print *, ' accu_d = ', dabs(accu_d-dble(m))/dble(m)
- !print *, ' overlap matrix:'
- !do i = 1, m
- ! write(*,'(1000(F16.10,X))') S(i,:)
- !enddo
- stop
- endif
-
-end
-
-! ---
-
subroutine check_biorthog(n, m, Vl, Vr, accu_d, accu_nd, S, thr_d, thr_nd, stop_ifnot)
implicit none
@@ -2144,6 +2026,7 @@ subroutine impose_biorthog_degen_eigvec(n, deg_num, e0, L0, R0)
enddo
!print*,' accu_nd after = ', accu_nd
if(accu_nd .gt. 1d-12) then
+ print*, ' accu_nd =', accu_nd
print*, ' your strategy for degenerates orbitals failed !'
print*, m, 'deg on', i
stop
diff --git a/plugins/local/non_hermit_dav/new_routines.irp.f b/plugins/local/non_hermit_dav/new_routines.irp.f
deleted file mode 100644
index 8db044d3..00000000
--- a/plugins/local/non_hermit_dav/new_routines.irp.f
+++ /dev/null
@@ -1,670 +0,0 @@
-subroutine non_hrmt_diag_split_degen_bi_orthog(n, A, leigvec, reigvec, n_real_eigv, eigval)
-
- BEGIN_DOC
- !
- ! routine which returns the sorted REAL EIGENVALUES ONLY and corresponding LEFT/RIGHT eigenvetors
- !
- ! of a non hermitian matrix A(n,n)
- !
- ! n_real_eigv is the number of real eigenvalues, which might be smaller than the dimension "n"
- !
- END_DOC
-
- implicit none
-
- integer, intent(in) :: n
- double precision, intent(in) :: A(n,n)
- integer, intent(out) :: n_real_eigv
- double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n)
- double precision, allocatable :: reigvec_tmp(:,:), leigvec_tmp(:,:)
-
- integer :: i, j, n_degen,k , iteration
- double precision :: shift_current
- double precision :: r,thr,accu_d, accu_nd
- integer, allocatable :: iorder_origin(:),iorder(:)
- double precision, allocatable :: WR(:), WI(:), Vl(:,:), VR(:,:),S(:,:)
- double precision, allocatable :: Aw(:,:),diag_elem(:),A_save(:,:)
- double precision, allocatable :: im_part(:),re_part(:)
- double precision :: accu,thr_cut, thr_norm=1d0
-
-
- thr_cut = 1.d-15
- print*,'Computing the left/right eigenvectors ...'
- print*,'Using the degeneracy splitting algorithm'
- ! initialization
- shift_current = 1.d-15
- iteration = 0
- print*,'***** iteration = ',iteration
-
-
- ! pre-processing the matrix :: sorting by diagonal elements
- allocate(reigvec_tmp(n,n), leigvec_tmp(n,n))
- allocate(diag_elem(n),iorder_origin(n),A_save(n,n))
-! print*,'Aw'
- do i = 1, n
- iorder_origin(i) = i
- diag_elem(i) = A(i,i)
-! write(*,'(100(F16.10,X))')A(:,i)
- enddo
- call dsort(diag_elem, iorder_origin, n)
- do i = 1, n
- do j = 1, n
- A_save(j,i) = A(iorder_origin(j),iorder_origin(i))
- enddo
- enddo
-
- allocate(WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n))
- allocate(im_part(n),iorder(n))
- allocate( S(n,n) )
-
-
- Aw = A_save
- call cancel_small_elmts(aw,n,thr_cut)
- call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
- do i = 1, n
- im_part(i) = -dabs(WI(i))
- iorder(i) = i
- enddo
- call dsort(im_part, iorder, n)
- n_real_eigv = 0
- do i = 1, n
- if(dabs(WI(i)).lt.1.d-20)then
- n_real_eigv += 1
- else
-! print*,'Found an imaginary component to eigenvalue'
-! print*,'Re(i) + Im(i)',WR(i),WI(i)
- endif
- enddo
- if(n_real_eigv.ne.n)then
- shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
- print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
- print*,'Splitting the degeneracies by ',shift_current
- else
- print*,'All eigenvalues are real !'
- endif
-
-
- do while(n_real_eigv.ne.n)
- iteration += 1
- print*,'***** iteration = ',iteration
- if(shift_current.gt.1.d-3)then
- print*,'shift_current > 1.d-3 !!'
- print*,'Your matrix intrinsically contains complex eigenvalues'
- stop
- endif
- Aw = A_save
- call cancel_small_elmts(Aw,n,thr_cut)
- call split_matrix_degen(Aw,n,shift_current)
- call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
- n_real_eigv = 0
- do i = 1, n
- if(dabs(WI(i)).lt.1.d-20)then
- n_real_eigv+= 1
- else
-! print*,'Found an imaginary component to eigenvalue'
-! print*,'Re(i) + Im(i)',WR(i),WI(i)
- endif
- enddo
- if(n_real_eigv.ne.n)then
- do i = 1, n
- im_part(i) = -dabs(WI(i))
- iorder(i) = i
- enddo
- call dsort(im_part, iorder, n)
- shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
- print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
- print*,'Splitting the degeneracies by ',shift_current
- else
- print*,'All eigenvalues are real !'
- endif
- enddo
- !!!!!!!!!!!!!!!! SORTING THE EIGENVALUES
- do i = 1, n
- eigval(i) = WR(i)
- iorder(i) = i
- enddo
- call dsort(eigval,iorder,n)
- do i = 1, n
-! print*,'eigval(i) = ',eigval(i)
- reigvec_tmp(:,i) = VR(:,iorder(i))
- leigvec_tmp(:,i) = Vl(:,iorder(i))
- enddo
-
-!!! ONCE ALL EIGENVALUES ARE REAL ::: CHECK BI-ORTHONORMALITY
- ! check bi-orthogonality
- call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
- print *, ' accu_nd bi-orthog = ', accu_nd
- if(accu_nd .lt. thresh_biorthog_nondiag) then
- print *, ' bi-orthogonality: ok'
- else
- print *, ' '
- print *, ' bi-orthogonality: not imposed yet'
- print *, ' '
- print *, ' '
- print *, ' orthog between degen eigenvect'
- print *, ' '
- double precision, allocatable :: S_nh_inv_half(:,:)
- allocate(S_nh_inv_half(n,n))
- logical :: complex_root
- deallocate(S_nh_inv_half)
- call impose_orthog_degen_eigvec(n, eigval, reigvec_tmp)
- call impose_orthog_degen_eigvec(n, eigval, leigvec_tmp)
- call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
- if(accu_nd .lt. thresh_biorthog_nondiag) then
- print *, ' bi-orthogonality: ok'
- else
- print*,'New vectors not bi-orthonormals at ',accu_nd
- call impose_biorthog_qr(n, n, leigvec_tmp, reigvec_tmp, S)
- call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
- if(accu_nd .lt. thresh_biorthog_nondiag) then
- print *, ' bi-orthogonality: ok'
- else
- print*,'New vectors not bi-orthonormals at ',accu_nd
- print*,'Must be a deep problem ...'
- stop
- endif
- endif
- endif
-
- !! EIGENVECTORS SORTED AND BI-ORTHONORMAL
- do i = 1, n
- do j = 1, n
- VR(iorder_origin(j),i) = reigvec_tmp(j,i)
- VL(iorder_origin(j),i) = leigvec_tmp(j,i)
- enddo
- enddo
-
- !! RECOMPUTING THE EIGENVALUES
- eigval = 0.d0
- do i = 1, n
- iorder(i) = i
- accu = 0.d0
- do j = 1, n
- accu += VL(j,i) * VR(j,i)
- do k = 1, n
- eigval(i) += VL(j,i) * A(j,k) * VR(k,i)
- enddo
- enddo
- eigval(i) *= 1.d0/accu
-! print*,'eigval(i) = ',eigval(i)
- enddo
- !! RESORT JUST TO BE SURE
- call dsort(eigval, iorder, n)
- do i = 1, n
- do j = 1, n
- reigvec(j,i) = VR(j,iorder(i))
- leigvec(j,i) = VL(j,iorder(i))
- enddo
- enddo
- print*,'Checking for final reigvec/leigvec'
- shift_current = max(1.d-10,shift_current)
- print*,'Thr for eigenvectors = ',shift_current
- call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, shift_current, thr_norm, .false.)
- call check_biorthog(n, n, leigvec, reigvec, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
- print *, ' accu_nd bi-orthog = ', accu_nd
-
- if(accu_nd .lt. thresh_biorthog_nondiag) then
- print *, ' bi-orthogonality: ok'
- else
- print*,'Something went wrong in non_hrmt_diag_split_degen_bi_orthog'
- print*,'Eigenvectors are not bi orthonormal ..'
- print*,'accu_nd = ',accu_nd
- stop
- endif
-
-end
-
-
-
-subroutine non_hrmt_diag_split_degen_s_inv_half(n, A, leigvec, reigvec, n_real_eigv, eigval)
-
- BEGIN_DOC
- !
- ! routine which returns the sorted REAL EIGENVALUES ONLY and corresponding LEFT/RIGHT eigenvetors
- !
- ! of a non hermitian matrix A(n,n)
- !
- ! n_real_eigv is the number of real eigenvalues, which might be smaller than the dimension "n"
- !
- END_DOC
-
- implicit none
-
- integer, intent(in) :: n
- double precision, intent(in) :: A(n,n)
- integer, intent(out) :: n_real_eigv
- double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n)
- double precision, allocatable :: reigvec_tmp(:,:), leigvec_tmp(:,:)
-
- integer :: i, j, n_degen,k , iteration
- double precision :: shift_current
- double precision :: r,thr,accu_d, accu_nd
- integer, allocatable :: iorder_origin(:),iorder(:)
- double precision, allocatable :: WR(:), WI(:), Vl(:,:), VR(:,:),S(:,:)
- double precision, allocatable :: Aw(:,:),diag_elem(:),A_save(:,:)
- double precision, allocatable :: im_part(:),re_part(:)
- double precision :: accu,thr_cut, thr_norm=1.d0
- double precision, allocatable :: S_nh_inv_half(:,:)
- logical :: complex_root
-
-
- thr_cut = 1.d-15
- print*,'Computing the left/right eigenvectors ...'
- print*,'Using the degeneracy splitting algorithm'
- ! initialization
- shift_current = 1.d-15
- iteration = 0
- print*,'***** iteration = ',iteration
-
-
- ! pre-processing the matrix :: sorting by diagonal elements
- allocate(reigvec_tmp(n,n), leigvec_tmp(n,n))
- allocate(diag_elem(n),iorder_origin(n),A_save(n,n))
-! print*,'Aw'
- do i = 1, n
- iorder_origin(i) = i
- diag_elem(i) = A(i,i)
-! write(*,'(100(F16.10,X))')A(:,i)
- enddo
- call dsort(diag_elem, iorder_origin, n)
- do i = 1, n
- do j = 1, n
- A_save(j,i) = A(iorder_origin(j),iorder_origin(i))
- enddo
- enddo
-
- allocate(WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n))
- allocate(im_part(n),iorder(n))
- allocate( S(n,n) )
- allocate(S_nh_inv_half(n,n))
-
-
- Aw = A_save
- call cancel_small_elmts(aw,n,thr_cut)
- call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
- do i = 1, n
- im_part(i) = -dabs(WI(i))
- iorder(i) = i
- enddo
- call dsort(im_part, iorder, n)
- n_real_eigv = 0
- do i = 1, n
- if(dabs(WI(i)).lt.1.d-20)then
- n_real_eigv += 1
- else
-! print*,'Found an imaginary component to eigenvalue'
-! print*,'Re(i) + Im(i)',WR(i),WI(i)
- endif
- enddo
- if(n_real_eigv.ne.n)then
- shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
- print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
- print*,'Splitting the degeneracies by ',shift_current
- else
- print*,'All eigenvalues are real !'
- endif
-
-
- do while(n_real_eigv.ne.n)
- iteration += 1
- print*,'***** iteration = ',iteration
- if(shift_current.gt.1.d-3)then
- print*,'shift_current > 1.d-3 !!'
- print*,'Your matrix intrinsically contains complex eigenvalues'
- stop
- endif
- Aw = A_save
-! thr_cut = shift_current
- call cancel_small_elmts(Aw,n,thr_cut)
- call split_matrix_degen(Aw,n,shift_current)
- call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
- n_real_eigv = 0
- do i = 1, n
- if(dabs(WI(i)).lt.1.d-20)then
- n_real_eigv+= 1
- else
-! print*,'Found an imaginary component to eigenvalue'
-! print*,'Re(i) + Im(i)',WR(i),WI(i)
- endif
- enddo
- if(n_real_eigv.ne.n)then
- do i = 1, n
- im_part(i) = -dabs(WI(i))
- iorder(i) = i
- enddo
- call dsort(im_part, iorder, n)
- shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
- print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
- print*,'Splitting the degeneracies by ',shift_current
- else
- print*,'All eigenvalues are real !'
- endif
- enddo
- !!!!!!!!!!!!!!!! SORTING THE EIGENVALUES
- do i = 1, n
- eigval(i) = WR(i)
- iorder(i) = i
- enddo
- call dsort(eigval,iorder,n)
- do i = 1, n
-! print*,'eigval(i) = ',eigval(i)
- reigvec_tmp(:,i) = VR(:,iorder(i))
- leigvec_tmp(:,i) = Vl(:,iorder(i))
- enddo
-
-!!! ONCE ALL EIGENVALUES ARE REAL ::: CHECK BI-ORTHONORMALITY
- ! check bi-orthogonality
- call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
- print *, ' accu_nd bi-orthog = ', accu_nd
- if(accu_nd .lt. thresh_biorthog_nondiag) then
- print *, ' bi-orthogonality: ok'
- else
- print *, ' '
- print *, ' bi-orthogonality: not imposed yet'
- if(complex_root) then
- print *, ' '
- print *, ' '
- print *, ' orthog between degen eigenvect'
- print *, ' '
- ! bi-orthonormalization using orthogonalization of left, right and then QR between left and right
- call impose_orthog_degen_eigvec(n, eigval, reigvec_tmp) ! orthogonalization of reigvec
- call impose_orthog_degen_eigvec(n, eigval, leigvec_tmp) ! orthogonalization of leigvec
- call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
-
- if(accu_nd .lt. thresh_biorthog_nondiag) then
- print *, ' bi-orthogonality: ok'
- else
- print*,'New vectors not bi-orthonormals at ', accu_nd
- call get_inv_half_nonsymmat_diago(S, n, S_nh_inv_half, complex_root)
- if(complex_root)then
- call impose_biorthog_qr(n, n, leigvec_tmp, reigvec_tmp, S) ! bi-orthonormalization using QR
- else
- print*,'S^{-1/2} exists !!'
- call bi_ortho_s_inv_half(n,leigvec_tmp,reigvec_tmp,S_nh_inv_half) ! use of S^{-1/2} bi-orthonormalization
- endif
- endif
- else ! the matrix S^{-1/2} exists
- print*,'S^{-1/2} exists !!'
- call bi_ortho_s_inv_half(n,leigvec_tmp,reigvec_tmp,S_nh_inv_half) ! use of S^{-1/2} bi-orthonormalization
- endif
- call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
- if(accu_nd .lt. thresh_biorthog_nondiag) then
- print *, ' bi-orthogonality: ok'
- else
- print*,'New vectors not bi-orthonormals at ',accu_nd
- print*,'Must be a deep problem ...'
- stop
- endif
- endif
-
- !! EIGENVECTORS SORTED AND BI-ORTHONORMAL
- do i = 1, n
- do j = 1, n
- VR(iorder_origin(j),i) = reigvec_tmp(j,i)
- VL(iorder_origin(j),i) = leigvec_tmp(j,i)
- enddo
- enddo
-
- !! RECOMPUTING THE EIGENVALUES
- eigval = 0.d0
- do i = 1, n
- iorder(i) = i
- accu = 0.d0
- do j = 1, n
- accu += VL(j,i) * VR(j,i)
- do k = 1, n
- eigval(i) += VL(j,i) * A(j,k) * VR(k,i)
- enddo
- enddo
- eigval(i) *= 1.d0/accu
-! print*,'eigval(i) = ',eigval(i)
- enddo
- !! RESORT JUST TO BE SURE
- call dsort(eigval, iorder, n)
- do i = 1, n
- do j = 1, n
- reigvec(j,i) = VR(j,iorder(i))
- leigvec(j,i) = VL(j,iorder(i))
- enddo
- enddo
- print*,'Checking for final reigvec/leigvec'
- shift_current = max(1.d-10,shift_current)
- print*,'Thr for eigenvectors = ',shift_current
- call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, shift_current, thr_norm, .false.)
- call check_biorthog(n, n, leigvec, reigvec, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
- print *, ' accu_nd bi-orthog = ', accu_nd
-
- if(accu_nd .lt. thresh_biorthog_nondiag) then
- print *, ' bi-orthogonality: ok'
- else
- print*,'Something went wrong in non_hrmt_diag_split_degen_bi_orthog'
- print*,'Eigenvectors are not bi orthonormal ..'
- print*,'accu_nd = ',accu_nd
- stop
- endif
-
-end
-
-
-subroutine non_hrmt_fock_mat(n, A, leigvec, reigvec, n_real_eigv, eigval)
-
- BEGIN_DOC
- !
- ! routine returning the eigenvalues and left/right eigenvectors of the TC fock matrix
- !
- END_DOC
-
- implicit none
-
- integer, intent(in) :: n
- double precision, intent(in) :: A(n,n)
- integer, intent(out) :: n_real_eigv
- double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n)
- double precision, allocatable :: reigvec_tmp(:,:), leigvec_tmp(:,:)
-
- integer :: i, j, n_degen,k , iteration
- double precision :: shift_current
- double precision :: r,thr,accu_d, accu_nd
- integer, allocatable :: iorder_origin(:),iorder(:)
- double precision, allocatable :: WR(:), WI(:), Vl(:,:), VR(:,:),S(:,:)
- double precision, allocatable :: Aw(:,:),diag_elem(:),A_save(:,:)
- double precision, allocatable :: im_part(:),re_part(:)
- double precision :: accu,thr_cut
- double precision, allocatable :: S_nh_inv_half(:,:)
- logical :: complex_root
- double precision :: thr_norm=1d0
-
-
- thr_cut = 1.d-15
- print*,'Computing the left/right eigenvectors ...'
- print*,'Using the degeneracy splitting algorithm'
- ! initialization
- shift_current = 1.d-15
- iteration = 0
- print*,'***** iteration = ',iteration
-
-
- ! pre-processing the matrix :: sorting by diagonal elements
- allocate(reigvec_tmp(n,n), leigvec_tmp(n,n))
- allocate(diag_elem(n),iorder_origin(n),A_save(n,n))
-! print*,'Aw'
- do i = 1, n
- iorder_origin(i) = i
- diag_elem(i) = A(i,i)
-! write(*,'(100(F16.10,X))')A(:,i)
- enddo
- call dsort(diag_elem, iorder_origin, n)
- do i = 1, n
- do j = 1, n
- A_save(j,i) = A(iorder_origin(j),iorder_origin(i))
- enddo
- enddo
-
- allocate(WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n))
- allocate(im_part(n),iorder(n))
- allocate( S(n,n) )
- allocate(S_nh_inv_half(n,n))
-
-
- Aw = A_save
- call cancel_small_elmts(aw,n,thr_cut)
- call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
- do i = 1, n
- im_part(i) = -dabs(WI(i))
- iorder(i) = i
- enddo
- call dsort(im_part, iorder, n)
- n_real_eigv = 0
- do i = 1, n
- if(dabs(WI(i)).lt.1.d-20)then
- n_real_eigv += 1
- else
-! print*,'Found an imaginary component to eigenvalue'
-! print*,'Re(i) + Im(i)',WR(i),WI(i)
- endif
- enddo
- if(n_real_eigv.ne.n)then
- shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
- print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
- print*,'Splitting the degeneracies by ',shift_current
- else
- print*,'All eigenvalues are real !'
- endif
-
-
- do while(n_real_eigv.ne.n)
- iteration += 1
- print*,'***** iteration = ',iteration
- if(shift_current.gt.1.d-3)then
- print*,'shift_current > 1.d-3 !!'
- print*,'Your matrix intrinsically contains complex eigenvalues'
- stop
- endif
- Aw = A_save
-! thr_cut = shift_current
- call cancel_small_elmts(Aw,n,thr_cut)
- call split_matrix_degen(Aw,n,shift_current)
- call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
- n_real_eigv = 0
- do i = 1, n
- if(dabs(WI(i)).lt.1.d-20)then
- n_real_eigv+= 1
- else
-! print*,'Found an imaginary component to eigenvalue'
-! print*,'Re(i) + Im(i)',WR(i),WI(i)
- endif
- enddo
- if(n_real_eigv.ne.n)then
- do i = 1, n
- im_part(i) = -dabs(WI(i))
- iorder(i) = i
- enddo
- call dsort(im_part, iorder, n)
- shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
- print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
- print*,'Splitting the degeneracies by ',shift_current
- else
- print*,'All eigenvalues are real !'
- endif
- enddo
- !!!!!!!!!!!!!!!! SORTING THE EIGENVALUES
- do i = 1, n
- eigval(i) = WR(i)
- iorder(i) = i
- enddo
- call dsort(eigval,iorder,n)
- do i = 1, n
-! print*,'eigval(i) = ',eigval(i)
- reigvec_tmp(:,i) = VR(:,iorder(i))
- leigvec_tmp(:,i) = Vl(:,iorder(i))
- enddo
-
-!!! ONCE ALL EIGENVALUES ARE REAL ::: CHECK BI-ORTHONORMALITY
- ! check bi-orthogonality
- call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
- print *, ' accu_nd bi-orthog = ', accu_nd
- if(accu_nd .lt. thresh_biorthog_nondiag) then
- print *, ' bi-orthogonality: ok'
- else
- print *, ' '
- print *, ' bi-orthogonality: not imposed yet'
- print *, ' '
- print *, ' '
- print *, ' Using impose_unique_biorthog_degen_eigvec'
- print *, ' '
- ! bi-orthonormalization using orthogonalization of left, right and then QR between left and right
- call impose_unique_biorthog_degen_eigvec(n, eigval, mo_coef, leigvec_tmp, reigvec_tmp)
- call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
- print*,'accu_nd = ',accu_nd
- if(accu_nd .lt. thresh_biorthog_nondiag) then
- print *, ' bi-orthogonality: ok'
- else
- print*,'New vectors not bi-orthonormals at ',accu_nd
- call get_inv_half_nonsymmat_diago(S, n, S_nh_inv_half,complex_root)
- if(complex_root)then
- print*,'S^{-1/2} does not exits, using QR bi-orthogonalization'
- call impose_biorthog_qr(n, n, leigvec_tmp, reigvec_tmp, S) ! bi-orthonormalization using QR
- else
- print*,'S^{-1/2} exists !!'
- call bi_ortho_s_inv_half(n,leigvec_tmp,reigvec_tmp,S_nh_inv_half) ! use of S^{-1/2} bi-orthonormalization
- endif
- endif
- call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
- if(accu_nd .lt. thresh_biorthog_nondiag) then
- print *, ' bi-orthogonality: ok'
- else
- print*,'New vectors not bi-orthonormals at ',accu_nd
- print*,'Must be a deep problem ...'
- stop
- endif
- endif
-
- !! EIGENVECTORS SORTED AND BI-ORTHONORMAL
- do i = 1, n
- do j = 1, n
- VR(iorder_origin(j),i) = reigvec_tmp(j,i)
- VL(iorder_origin(j),i) = leigvec_tmp(j,i)
- enddo
- enddo
-
- !! RECOMPUTING THE EIGENVALUES
- eigval = 0.d0
- do i = 1, n
- iorder(i) = i
- accu = 0.d0
- do j = 1, n
- accu += VL(j,i) * VR(j,i)
- do k = 1, n
- eigval(i) += VL(j,i) * A(j,k) * VR(k,i)
- enddo
- enddo
- eigval(i) *= 1.d0/accu
-! print*,'eigval(i) = ',eigval(i)
- enddo
- !! RESORT JUST TO BE SURE
- call dsort(eigval, iorder, n)
- do i = 1, n
- do j = 1, n
- reigvec(j,i) = VR(j,iorder(i))
- leigvec(j,i) = VL(j,iorder(i))
- enddo
- enddo
- print*,'Checking for final reigvec/leigvec'
- shift_current = max(1.d-10,shift_current)
- print*,'Thr for eigenvectors = ',shift_current
- call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, shift_current, thr_norm, .false.)
- call check_biorthog(n, n, leigvec, reigvec, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
- print *, ' accu_nd bi-orthog = ', accu_nd
-
- if(accu_nd .lt. thresh_biorthog_nondiag) then
- print *, ' bi-orthogonality: ok'
- else
- print*,'Something went wrong in non_hrmt_diag_split_degen_bi_orthog'
- print*,'Eigenvectors are not bi orthonormal ..'
- print*,'accu_nd = ',accu_nd
- stop
- endif
-
-end
-
-
diff --git a/plugins/local/normal_order_old/NEED b/plugins/local/normal_order_old/NEED
new file mode 100644
index 00000000..e8c8c478
--- /dev/null
+++ b/plugins/local/normal_order_old/NEED
@@ -0,0 +1 @@
+tc_scf
diff --git a/plugins/local/normal_order_old/README.rst b/plugins/local/normal_order_old/README.rst
new file mode 100644
index 00000000..a284fcfd
--- /dev/null
+++ b/plugins/local/normal_order_old/README.rst
@@ -0,0 +1,4 @@
+================
+normal_order_old
+================
+
diff --git a/plugins/local/tc_bi_ortho/normal_ordered.irp.f b/plugins/local/normal_order_old/normal_ordered.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/normal_ordered.irp.f
rename to plugins/local/normal_order_old/normal_ordered.irp.f
diff --git a/plugins/local/tc_bi_ortho/normal_ordered_contractions.irp.f b/plugins/local/normal_order_old/normal_ordered_contractions.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/normal_ordered_contractions.irp.f
rename to plugins/local/normal_order_old/normal_ordered_contractions.irp.f
diff --git a/plugins/local/tc_bi_ortho/normal_ordered_old.irp.f b/plugins/local/normal_order_old/normal_ordered_old.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/normal_ordered_old.irp.f
rename to plugins/local/normal_order_old/normal_ordered_old.irp.f
diff --git a/plugins/local/tc_bi_ortho/normal_ordered_v0.irp.f b/plugins/local/normal_order_old/normal_ordered_v0.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/normal_ordered_v0.irp.f
rename to plugins/local/normal_order_old/normal_ordered_v0.irp.f
diff --git a/plugins/local/old_delta_tc_qmc/NEED b/plugins/local/old_delta_tc_qmc/NEED
new file mode 100644
index 00000000..8b137891
--- /dev/null
+++ b/plugins/local/old_delta_tc_qmc/NEED
@@ -0,0 +1 @@
+
diff --git a/plugins/local/old_delta_tc_qmc/README.rst b/plugins/local/old_delta_tc_qmc/README.rst
new file mode 100644
index 00000000..1d56f96c
--- /dev/null
+++ b/plugins/local/old_delta_tc_qmc/README.rst
@@ -0,0 +1,4 @@
+================
+old_delta_tc_qmc
+================
+
diff --git a/plugins/local/tc_bi_ortho/compute_deltamu_right.irp.f b/plugins/local/old_delta_tc_qmc/compute_deltamu_right.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/compute_deltamu_right.irp.f
rename to plugins/local/old_delta_tc_qmc/compute_deltamu_right.irp.f
diff --git a/plugins/local/tc_bi_ortho/dressing_vectors_lr.irp.f b/plugins/local/old_delta_tc_qmc/dressing_vectors_lr.irp.f
similarity index 88%
rename from plugins/local/tc_bi_ortho/dressing_vectors_lr.irp.f
rename to plugins/local/old_delta_tc_qmc/dressing_vectors_lr.irp.f
index 0aff9980..135f9d17 100644
--- a/plugins/local/tc_bi_ortho/dressing_vectors_lr.irp.f
+++ b/plugins/local/old_delta_tc_qmc/dressing_vectors_lr.irp.f
@@ -27,7 +27,7 @@ subroutine get_delta_bitc_right(psidet, psicoef, ndet, Nint, delta)
i = 1
j = 1
- call htilde_mu_mat_bi_ortho_slow(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
+ call htilde_mu_mat_opt_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
call hmat_bi_ortho (psidet(1,1,i), psidet(1,1,j), Nint, h_mono, h_twoe, h_tot)
delta = 0.d0
@@ -39,7 +39,7 @@ subroutine get_delta_bitc_right(psidet, psicoef, ndet, Nint, delta)
do j = 1, ndet
! < I |Htilde | J >
- call htilde_mu_mat_bi_ortho_slow(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
+ call htilde_mu_mat_opt_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
! < I |H | J >
call hmat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, h_mono, h_twoe, h_tot)
@@ -78,7 +78,7 @@ subroutine get_htc_bitc_right(psidet, psicoef, ndet, Nint, delta)
i = 1
j = 1
- call htilde_mu_mat_bi_ortho_slow(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
+ call htilde_mu_mat_opt_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
delta = 0.d0
!$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) &
@@ -88,7 +88,7 @@ subroutine get_htc_bitc_right(psidet, psicoef, ndet, Nint, delta)
do j = 1, ndet
! < I |Htilde | J >
- call htilde_mu_mat_bi_ortho_slow(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
+ call htilde_mu_mat_opt_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
delta(i) = delta(i) + psicoef(j) * htc_tot
enddo
diff --git a/plugins/local/tc_keywords/tc_keywords.irp.f b/plugins/local/old_delta_tc_qmc/old_delta_tc_qmc.irp.f
similarity index 82%
rename from plugins/local/tc_keywords/tc_keywords.irp.f
rename to plugins/local/old_delta_tc_qmc/old_delta_tc_qmc.irp.f
index 3bc68550..5ff08bd6 100644
--- a/plugins/local/tc_keywords/tc_keywords.irp.f
+++ b/plugins/local/old_delta_tc_qmc/old_delta_tc_qmc.irp.f
@@ -1,4 +1,4 @@
-program tc_keywords
+program old_delta_tc_qmc
implicit none
BEGIN_DOC
! TODO : Put the documentation of the program here
diff --git a/plugins/local/ortho_three_e_ints/mu_j_ints_usual_mos.irp.f b/plugins/local/ortho_three_e_ints/mu_j_ints_usual_mos.irp.f
index a3f1b6ef..cb7cdb22 100644
--- a/plugins/local/ortho_three_e_ints/mu_j_ints_usual_mos.irp.f
+++ b/plugins/local/ortho_three_e_ints/mu_j_ints_usual_mos.irp.f
@@ -183,11 +183,3 @@ BEGIN_PROVIDER [ double precision, x_W_ij_erf_rk, ( n_points_final_grid,3,mo_num
END_PROVIDER
-BEGIN_PROVIDER [ double precision, sqrt_weight_at_r, (n_points_final_grid)]
- implicit none
- integer :: ipoint
- do ipoint = 1, n_points_final_grid
- sqrt_weight_at_r(ipoint) = dsqrt(final_weight_at_r_vector(ipoint))
- enddo
-END_PROVIDER
-
diff --git a/plugins/local/slater_tc/NEED b/plugins/local/slater_tc/NEED
new file mode 100644
index 00000000..a8669866
--- /dev/null
+++ b/plugins/local/slater_tc/NEED
@@ -0,0 +1,8 @@
+determinants
+normal_order_old
+bi_ort_ints
+bi_ortho_mos
+tc_keywords
+non_hermit_dav
+dav_general_mat
+tc_scf
diff --git a/plugins/local/tc_bi_ortho/h_mat_triple.irp.f b/plugins/local/slater_tc/h_mat_triple.irp.f
similarity index 53%
rename from plugins/local/tc_bi_ortho/h_mat_triple.irp.f
rename to plugins/local/slater_tc/h_mat_triple.irp.f
index 6f5697a2..9cb4b60a 100644
--- a/plugins/local/tc_bi_ortho/h_mat_triple.irp.f
+++ b/plugins/local/slater_tc/h_mat_triple.irp.f
@@ -1,196 +1,3 @@
-subroutine get_excitation_general(key_i,key_j, Nint,degree_array,holes_array, particles_array,phase)
- use bitmasks
- BEGIN_DOC
-! returns the array, for each spin, of holes/particles between key_i and key_j
-!
-! with the following convention: a^+_{particle} a_{hole}|key_i> = |key_j>
- END_DOC
- include 'utils/constants.include.F'
- implicit none
- integer, intent(in) :: Nint
- integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2)
- integer, intent(out) :: holes_array(100,2),particles_array(100,2),degree_array(2)
- double precision, intent(out) :: phase
- integer :: ispin,k,i,pos
- integer(bit_kind) :: key_hole, key_particle
- integer(bit_kind) :: xorvec(N_int_max,2)
- holes_array = -1
- particles_array = -1
- degree_array = 0
- do i = 1, N_int
- xorvec(i,1) = xor( key_i(i,1), key_j(i,1))
- xorvec(i,2) = xor( key_i(i,2), key_j(i,2))
- degree_array(1) += popcnt(xorvec(i,1))
- degree_array(2) += popcnt(xorvec(i,2))
- enddo
- degree_array(1) = shiftr(degree_array(1),1)
- degree_array(2) = shiftr(degree_array(2),1)
-
- do ispin = 1, 2
- k = 1
- !!! GETTING THE HOLES
- do i = 1, N_int
- key_hole = iand(xorvec(i,ispin),key_i(i,ispin))
- do while(key_hole .ne.0_bit_kind)
- pos = trailz(key_hole)
- holes_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos
- key_hole = ibclr(key_hole,pos)
- k += 1
- if(k .gt.100)then
- print*,'WARNING in get_excitation_general'
- print*,'More than a 100-th excitation for spin ',ispin
- print*,'stoping ...'
- stop
- endif
- enddo
- enddo
- enddo
- do ispin = 1, 2
- k = 1
- !!! GETTING THE PARTICLES
- do i = 1, N_int
- key_particle = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_j(i,ispin))
- do while(key_particle .ne.0_bit_kind)
- pos = trailz(key_particle)
- particles_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos
- key_particle = ibclr(key_particle,pos)
- k += 1
- if(k .gt.100)then
- print*,'WARNING in get_excitation_general '
- print*,'More than a 100-th excitation for spin ',ispin
- print*,'stoping ...'
- stop
- endif
- enddo
- enddo
- enddo
- integer :: h,p, i_ok
- integer(bit_kind), allocatable :: det_i(:,:),det_ip(:,:)
- integer :: exc(0:2,2,2)
- double precision :: phase_tmp
- allocate(det_i(Nint,2),det_ip(N_int,2))
- det_i = key_i
- phase = 1.d0
- do ispin = 1, 2
- do i = 1, degree_array(ispin)
- h = holes_array(i,ispin)
- p = particles_array(i,ispin)
- det_ip = det_i
- call do_single_excitation(det_ip,h,p,ispin,i_ok)
- if(i_ok == -1)then
- print*,'excitation was not possible '
- stop
- endif
- call get_single_excitation(det_i,det_ip,exc,phase_tmp,Nint)
- phase *= phase_tmp
- det_i = det_ip
- enddo
- enddo
-
-end
-
-subroutine get_holes_general(key_i, key_j,Nint, holes_array)
- use bitmasks
- BEGIN_DOC
-! returns the array, per spin, of holes between key_i and key_j
-!
-! with the following convention: a_{hole}|key_i> --> |key_j>
- END_DOC
- implicit none
- integer, intent(in) :: Nint
- integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2)
- integer, intent(out) :: holes_array(100,2)
- integer(bit_kind) :: key_hole
- integer :: ispin,k,i,pos
- holes_array = -1
- do ispin = 1, 2
- k = 1
- do i = 1, N_int
- key_hole = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_i(i,ispin))
- do while(key_hole .ne.0_bit_kind)
- pos = trailz(key_hole)
- holes_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos
- key_hole = ibclr(key_hole,pos)
- k += 1
- if(k .gt.100)then
- print*,'WARNING in get_holes_general'
- print*,'More than a 100-th excitation for spin ',ispin
- print*,'stoping ...'
- stop
- endif
- enddo
- enddo
- enddo
-end
-
-subroutine get_particles_general(key_i, key_j,Nint,particles_array)
- use bitmasks
- BEGIN_DOC
-! returns the array, per spin, of particles between key_i and key_j
-!
-! with the following convention: a^dagger_{particle}|key_i> --> |key_j>
- END_DOC
- implicit none
- integer, intent(in) :: Nint
- integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2)
- integer, intent(out) :: particles_array(100,2)
- integer(bit_kind) :: key_particle
- integer :: ispin,k,i,pos
- particles_array = -1
- do ispin = 1, 2
- k = 1
- do i = 1, N_int
- key_particle = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_j(i,ispin))
- do while(key_particle .ne.0_bit_kind)
- pos = trailz(key_particle)
- particles_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos
- key_particle = ibclr(key_particle,pos)
- k += 1
- if(k .gt.100)then
- print*,'WARNING in get_holes_general'
- print*,'More than a 100-th excitation for spin ',ispin
- print*,'Those are the two determinants'
- call debug_det(key_i, N_int)
- call debug_det(key_j, N_int)
- print*,'stoping ...'
- stop
- endif
- enddo
- enddo
- enddo
-end
-
-subroutine get_phase_general(key_i,Nint,degree, holes_array, particles_array,phase)
- implicit none
- integer, intent(in) :: degree(2), Nint
- integer(bit_kind), intent(in) :: key_i(Nint,2)
- integer, intent(in) :: holes_array(100,2),particles_array(100,2)
- double precision, intent(out) :: phase
- integer :: i,ispin,h,p, i_ok
- integer(bit_kind), allocatable :: det_i(:,:),det_ip(:,:)
- integer :: exc(0:2,2,2)
- double precision :: phase_tmp
- allocate(det_i(Nint,2),det_ip(N_int,2))
- det_i = key_i
- phase = 1.d0
- do ispin = 1, 2
- do i = 1, degree(ispin)
- h = holes_array(i,ispin)
- p = particles_array(i,ispin)
- det_ip = det_i
- call do_single_excitation(det_ip,h,p,ispin,i_ok)
- if(i_ok == -1)then
- print*,'excitation was not possible '
- stop
- endif
- call get_single_excitation(det_i,det_ip,exc,phase_tmp,Nint)
- phase *= phase_tmp
- det_i = det_ip
- enddo
- enddo
-
-end
-
subroutine H_tc_s2_u_0_with_pure_three(v_0, s_0, u_0, N_st, sze)
BEGIN_DOC
! Computes $v_0 = H^TC | u_0\rangle$ WITH PURE TRIPLE EXCITATION TERMS
diff --git a/plugins/local/tc_bi_ortho/h_tc_s2_u0.irp.f b/plugins/local/slater_tc/h_tc_s2_u0.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/h_tc_s2_u0.irp.f
rename to plugins/local/slater_tc/h_tc_s2_u0.irp.f
diff --git a/plugins/local/tc_bi_ortho/slater_tc_opt.irp.f b/plugins/local/slater_tc/slater_tc_opt.irp.f
similarity index 80%
rename from plugins/local/tc_bi_ortho/slater_tc_opt.irp.f
rename to plugins/local/slater_tc/slater_tc_opt.irp.f
index 59efc943..5651a299 100644
--- a/plugins/local/tc_bi_ortho/slater_tc_opt.irp.f
+++ b/plugins/local/slater_tc/slater_tc_opt.irp.f
@@ -181,3 +181,48 @@ end
! ---
+subroutine htilde_mu_mat_opt_bi_ortho_no_3e_both(key_j, key_i, Nint, hji,hij)
+
+ BEGIN_DOC
+ !
+ ! where |key_j> is developed on the LEFT basis and |key_i> is developed on the RIGHT basis
+ !!
+ ! Returns the detail of the matrix element WITHOUT ANY CONTRIBUTION FROM THE THREE ELECTRON TERMS
+ !! WARNING !!
+ !
+ ! Non hermitian !!
+ !
+ END_DOC
+
+ use bitmasks
+
+ implicit none
+ integer, intent(in) :: Nint
+ integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
+ double precision, intent(out) :: hji,hij
+ integer :: degree
+
+ hji = 0.d0
+ hij = 0.d0
+
+ call get_excitation_degree(key_i, key_j, degree, Nint)
+ if(degree.gt.2) return
+
+ if(degree == 0) then
+ call diag_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_i,hji)
+ hij = hji
+ else if (degree == 1) then
+ call single_htilde_mu_mat_fock_bi_ortho_no_3e_both(Nint,key_j, key_i , hji,hij)
+ else if(degree == 2) then
+ call double_htilde_mu_mat_fock_bi_ortho_no_3e_both(Nint, key_j, key_i, hji,hij)
+ endif
+
+ if(degree==0) then
+ hji += nuclear_repulsion
+ hij += nuclear_repulsion
+ endif
+
+end
+
+! ---
+
diff --git a/plugins/local/tc_bi_ortho/slater_tc_opt_diag.irp.f b/plugins/local/slater_tc/slater_tc_opt_diag.irp.f
similarity index 61%
rename from plugins/local/tc_bi_ortho/slater_tc_opt_diag.irp.f
rename to plugins/local/slater_tc/slater_tc_opt_diag.irp.f
index 78f9dc66..3c5a5d12 100644
--- a/plugins/local/tc_bi_ortho/slater_tc_opt_diag.irp.f
+++ b/plugins/local/slater_tc/slater_tc_opt_diag.irp.f
@@ -19,13 +19,13 @@
PROVIDE HF_bitmask
PROVIDE mo_l_coef mo_r_coef
- call diag_htilde_mu_mat_bi_ortho_slow(N_int, HF_bitmask, hmono, htwoe, htot)
+ call diag_htc_bi_orth_2e_brute(N_int, HF_bitmask, hmono, htwoe, htot)
ref_tc_energy_1e = hmono
ref_tc_energy_2e = htwoe
if(three_body_h_tc) then
- call diag_htilde_three_body_ints_bi_ort_slow(N_int, HF_bitmask, hthree)
+ call diag_htc_bi_orth_3e_brute(N_int, HF_bitmask, hthree)
ref_tc_energy_3e = hthree
else
ref_tc_energy_3e = 0.d0
@@ -524,3 +524,310 @@ end
! ---
+subroutine diag_htc_bi_orth_2e_brute(Nint, key_i, hmono, htwoe, htot)
+
+ BEGIN_DOC
+ !
+ ! diagonal element of htilde ONLY FOR ONE- AND TWO-BODY TERMS
+ !
+ END_DOC
+
+ use bitmasks
+
+ implicit none
+ integer, intent(in) :: Nint
+ integer(bit_kind), intent(in) :: key_i(Nint,2)
+ double precision, intent(out) :: hmono,htwoe,htot
+ integer :: occ(Nint*bit_kind_size,2)
+ integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk
+ double precision :: get_mo_two_e_integral_tc_int
+ integer(bit_kind) :: key_i_core(Nint,2)
+
+ PROVIDE mo_bi_ortho_tc_two_e
+
+ hmono = 0.d0
+ htwoe = 0.d0
+ htot = 0.d0
+
+ call bitstring_to_list_ab(key_i, occ, Ne, Nint)
+
+ do ispin = 1, 2
+ do i = 1, Ne(ispin)
+ ii = occ(i,ispin)
+ hmono += mo_bi_ortho_tc_one_e(ii,ii)
+ enddo
+ enddo
+
+ ! alpha/beta two-body
+ ispin = 1
+ jspin = 2
+ do i = 1, Ne(ispin) ! electron 1 (so it can be associated to mu(r1))
+ ii = occ(i,ispin)
+ do j = 1, Ne(jspin) ! electron 2
+ jj = occ(j,jspin)
+ htwoe += mo_bi_ortho_tc_two_e(jj,ii,jj,ii)
+ enddo
+ enddo
+
+ ! alpha/alpha two-body
+ do i = 1, Ne(ispin)
+ ii = occ(i,ispin)
+ do j = i+1, Ne(ispin)
+ jj = occ(j,ispin)
+ htwoe += mo_bi_ortho_tc_two_e(ii,jj,ii,jj) - mo_bi_ortho_tc_two_e(ii,jj,jj,ii)
+ enddo
+ enddo
+
+ ! beta/beta two-body
+ do i = 1, Ne(jspin)
+ ii = occ(i,jspin)
+ do j = i+1, Ne(jspin)
+ jj = occ(j,jspin)
+ htwoe += mo_bi_ortho_tc_two_e(ii,jj,ii,jj) - mo_bi_ortho_tc_two_e(ii,jj,jj,ii)
+ enddo
+ enddo
+
+ htot = hmono + htwoe
+
+end
+
+! ---
+
+subroutine diag_htc_bi_orth_3e_brute(Nint, key_i, hthree)
+
+ BEGIN_DOC
+ ! diagonal element of htilde ONLY FOR THREE-BODY TERMS WITH BI ORTHONORMAL ORBITALS
+ END_DOC
+
+ use bitmasks
+
+ implicit none
+ integer, intent(in) :: Nint
+ integer(bit_kind), intent(in) :: key_i(Nint,2)
+ double precision, intent(out) :: hthree
+ integer :: occ(Nint*bit_kind_size,2)
+ integer :: Ne(2),i,j,ii,jj,ispin,jspin,m,mm
+ integer(bit_kind) :: key_i_core(Nint,2)
+ double precision :: direct_int, exchange_int, ref
+ double precision, external :: sym_3_e_int_from_6_idx_tensor
+ double precision, external :: three_e_diag_parrallel_spin
+
+ PROVIDE mo_l_coef mo_r_coef
+
+ if(core_tc_op) then
+ do i = 1, Nint
+ key_i_core(i,1) = xor(key_i(i,1), core_bitmask(i,1))
+ key_i_core(i,2) = xor(key_i(i,2), core_bitmask(i,2))
+ enddo
+ call bitstring_to_list_ab(key_i_core, occ, Ne, Nint)
+ else
+ call bitstring_to_list_ab(key_i, occ, Ne, Nint)
+ endif
+
+ hthree = 0.d0
+
+ if((Ne(1)+Ne(2)) .ge. 3) then
+
+ ! alpha/alpha/beta three-body
+ do i = 1, Ne(1)
+ ii = occ(i,1)
+ do j = i+1, Ne(1)
+ jj = occ(j,1)
+ do m = 1, Ne(2)
+ mm = occ(m,2)
+ !direct_int = three_body_ints_bi_ort(mm,jj,ii,mm,jj,ii) !uses the 6-idx tensor
+ !exchange_int = three_body_ints_bi_ort(mm,jj,ii,mm,ii,jj) !uses the 6-idx tensor
+ direct_int = three_e_3_idx_direct_bi_ort(mm,jj,ii) !uses 3-idx tensor
+ exchange_int = three_e_3_idx_exch12_bi_ort(mm,jj,ii) !uses 3-idx tensor
+ hthree += direct_int - exchange_int
+ enddo
+ enddo
+ enddo
+
+ ! beta/beta/alpha three-body
+ do i = 1, Ne(2)
+ ii = occ(i,2)
+ do j = i+1, Ne(2)
+ jj = occ(j,2)
+ do m = 1, Ne(1)
+ mm = occ(m,1)
+ !direct_int = three_body_ints_bi_ort(mm,jj,ii,mm,jj,ii) !uses the 6-idx tensor
+ !exchange_int = three_body_ints_bi_ort(mm,jj,ii,mm,ii,jj) !uses the 6-idx tensor
+ direct_int = three_e_3_idx_direct_bi_ort(mm,jj,ii)
+ exchange_int = three_e_3_idx_exch12_bi_ort(mm,jj,ii)
+ hthree += direct_int - exchange_int
+ enddo
+ enddo
+ enddo
+
+ ! alpha/alpha/alpha three-body
+ do i = 1, Ne(1)
+ ii = occ(i,1) ! 1
+ do j = i+1, Ne(1)
+ jj = occ(j,1) ! 2
+ do m = j+1, Ne(1)
+ mm = occ(m,1) ! 3
+ !hthree += sym_3_e_int_from_6_idx_tensor(mm,jj,ii,mm,jj,ii) !uses the 6 idx tensor
+ hthree += three_e_diag_parrallel_spin(mm,jj,ii) !uses only 3-idx tensors
+ enddo
+ enddo
+ enddo
+
+ ! beta/beta/beta three-body
+ do i = 1, Ne(2)
+ ii = occ(i,2) ! 1
+ do j = i+1, Ne(2)
+ jj = occ(j,2) ! 2
+ do m = j+1, Ne(2)
+ mm = occ(m,2) ! 3
+ !hthree += sym_3_e_int_from_6_idx_tensor(mm,jj,ii,mm,jj,ii) !uses the 6 idx tensor
+ hthree += three_e_diag_parrallel_spin(mm,jj,ii) !uses only 3-idx tensors
+ enddo
+ enddo
+ enddo
+
+ endif
+
+end
+
+
+
+BEGIN_PROVIDER [ double precision, three_e_diag_parrallel_spin_prov, (mo_num, mo_num, mo_num)]
+
+ BEGIN_DOC
+ !
+ ! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS
+ !
+ ! three_e_diag_parrallel_spin_prov(m,j,i) = All combinations of the form for same spin matrix elements
+ !
+ ! notice the -1 sign: in this way three_e_diag_parrallel_spin_prov can be directly used to compute Slater rules with a + sign
+ !
+ END_DOC
+
+ implicit none
+ integer :: i, j, m
+ double precision :: integral, wall1, wall0, three_e_diag_parrallel_spin
+
+ three_e_diag_parrallel_spin_prov = 0.d0
+ print *, ' Providing the three_e_diag_parrallel_spin_prov ...'
+
+ integral = three_e_diag_parrallel_spin(1,1,1) ! to provide all stuffs
+ call wall_time(wall0)
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i,j,m,integral) &
+ !$OMP SHARED (mo_num,three_e_diag_parrallel_spin_prov)
+ !$OMP DO SCHEDULE (dynamic)
+ do i = 1, mo_num
+ do j = 1, mo_num
+ do m = j, mo_num
+ three_e_diag_parrallel_spin_prov(m,j,i) = three_e_diag_parrallel_spin(m,j,i)
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ do i = 1, mo_num
+ do j = 1, mo_num
+ do m = 1, j
+ three_e_diag_parrallel_spin_prov(m,j,i) = three_e_diag_parrallel_spin_prov(j,m,i)
+ enddo
+ enddo
+ enddo
+
+ call wall_time(wall1)
+ print *, ' wall time for three_e_diag_parrallel_spin_prov', wall1 - wall0
+
+END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, three_e_single_parrallel_spin_prov, (mo_num, mo_num, mo_num, mo_num)]
+
+ BEGIN_DOC
+ !
+ ! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
+ !
+ ! three_e_single_parrallel_spin_prov(m,j,k,i) = All combination of for same spin matrix elements
+ !
+ ! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
+ !
+ END_DOC
+
+ implicit none
+ integer :: i, j, k, m
+ double precision :: integral, wall1, wall0, three_e_single_parrallel_spin
+
+ three_e_single_parrallel_spin_prov = 0.d0
+ print *, ' Providing the three_e_single_parrallel_spin_prov ...'
+
+ integral = three_e_single_parrallel_spin(1,1,1,1)
+ call wall_time(wall0)
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i,j,k,m,integral) &
+ !$OMP SHARED (mo_num,three_e_single_parrallel_spin_prov)
+ !$OMP DO SCHEDULE (dynamic)
+ do i = 1, mo_num
+ do k = 1, mo_num
+ do j = 1, mo_num
+ do m = 1, mo_num
+ three_e_single_parrallel_spin_prov(m,j,k,i) = three_e_single_parrallel_spin(m,j,k,i)
+ enddo
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ call wall_time(wall1)
+ print *, ' wall time for three_e_single_parrallel_spin_prov', wall1 - wall0
+
+END_PROVIDER
+
+
+! ---
+
+BEGIN_PROVIDER [ double precision, three_e_double_parrallel_spin_prov, (mo_num, mo_num, mo_num, mo_num, mo_num)]
+
+ BEGIN_DOC
+ !
+ ! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
+ !
+ ! three_e_double_parrallel_spin_prov(m,l,j,k,i) = ::: notice that i is the RIGHT MO and k is the LEFT MO
+ !
+ ! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
+ END_DOC
+
+ implicit none
+ integer :: i, j, k, m, l
+ double precision :: integral, wall1, wall0, three_e_double_parrallel_spin
+
+ three_e_double_parrallel_spin_prov = 0.d0
+ print *, ' Providing the three_e_double_parrallel_spin_prov ...'
+ call wall_time(wall0)
+
+ integral = three_e_double_parrallel_spin(1,1,1,1,1)
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i,j,k,m,l,integral) &
+ !$OMP SHARED (mo_num,three_e_double_parrallel_spin_prov)
+ !$OMP DO SCHEDULE (dynamic)
+ do i = 1, mo_num
+ do k = 1, mo_num
+ do j = 1, mo_num
+ do l = 1, mo_num
+ do m = 1, mo_num
+ three_e_double_parrallel_spin_prov(m,l,j,k,i) = three_e_double_parrallel_spin(m,l,j,k,i)
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ call wall_time(wall1)
+ print *, ' wall time for three_e_double_parrallel_spin_prov', wall1 - wall0
+
+END_PROVIDER
+
diff --git a/plugins/local/tc_bi_ortho/slater_tc_opt_double.irp.f b/plugins/local/slater_tc/slater_tc_opt_double.irp.f
similarity index 90%
rename from plugins/local/tc_bi_ortho/slater_tc_opt_double.irp.f
rename to plugins/local/slater_tc/slater_tc_opt_double.irp.f
index 4067473c..181ae11d 100644
--- a/plugins/local/tc_bi_ortho/slater_tc_opt_double.irp.f
+++ b/plugins/local/slater_tc/slater_tc_opt_double.irp.f
@@ -505,3 +505,63 @@ subroutine double_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_j, key_i, htot)
end
+subroutine double_htilde_mu_mat_fock_bi_ortho_no_3e_both(Nint, key_j, key_i, hji,hij)
+
+ BEGIN_DOC
+ ! and for double excitation ONLY FOR ONE- AND TWO-BODY TERMS
+ !!
+ !! WARNING !!
+ !
+ ! Non hermitian !!
+ END_DOC
+
+ use bitmasks
+
+ implicit none
+ integer, intent(in) :: Nint
+ integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2)
+ double precision, intent(out) :: hji,hij
+ double precision :: hmono, htwoe_ji, htwoe_ij
+ integer :: occ(Nint*bit_kind_size,2)
+ integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk
+ integer :: degree,exc(0:2,2,2)
+ integer :: h1, p1, h2, p2, s1, s2
+ double precision :: get_mo_two_e_integral_tc_int,phase
+
+
+ call get_excitation_degree(key_i, key_j, degree, Nint)
+
+ hmono = 0.d0
+ htwoe_ji = 0.d0
+ htwoe_ij = 0.d0
+ hji = 0.d0
+ hij = 0.d0
+
+ if(degree.ne.2)then
+ return
+ endif
+ integer :: degree_i,degree_j
+ call get_excitation_degree(ref_bitmask,key_i,degree_i,N_int)
+ call get_excitation_degree(ref_bitmask,key_j,degree_j,N_int)
+ call get_double_excitation(key_i, key_j, exc, phase, Nint)
+ call decode_exc(exc, 2, h1, p1, h2, p2, s1, s2)
+
+ if(s1.ne.s2)then
+ ! opposite spin two-body
+ htwoe_ji = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)
+ htwoe_ij = mo_bi_ortho_tc_two_e_transp(p2,p1,h2,h1)
+ else
+ ! same spin two-body
+ ! direct terms
+ htwoe_ji = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)
+ htwoe_ij = mo_bi_ortho_tc_two_e_transp(p2,p1,h2,h1)
+ ! exchange terms
+ htwoe_ji -= mo_bi_ortho_tc_two_e(p1,p2,h2,h1)
+ htwoe_ij -= mo_bi_ortho_tc_two_e_transp(p1,p2,h2,h1)
+ endif
+ htwoe_ji *= phase
+ hji = htwoe_ji
+ htwoe_ij *= phase
+ hij = htwoe_ij
+
+end
diff --git a/plugins/local/tc_bi_ortho/slater_tc_opt_single.irp.f b/plugins/local/slater_tc/slater_tc_opt_single.irp.f
similarity index 81%
rename from plugins/local/tc_bi_ortho/slater_tc_opt_single.irp.f
rename to plugins/local/slater_tc/slater_tc_opt_single.irp.f
index e57cb05c..47bcbe34 100644
--- a/plugins/local/tc_bi_ortho/slater_tc_opt_single.irp.f
+++ b/plugins/local/slater_tc/slater_tc_opt_single.irp.f
@@ -618,3 +618,145 @@ subroutine get_single_excitation_from_fock_tc_no_3e(Nint, key_i, key_j, h, p, sp
end
+
+subroutine single_htilde_mu_mat_fock_bi_ortho_no_3e_both(Nint, key_j, key_i, hji,hij)
+
+ BEGIN_DOC
+ ! and for single excitation ONLY FOR ONE- AND TWO-BODY TERMS
+ !!
+ !! WARNING !!
+ !
+ ! Non hermitian !!
+ END_DOC
+
+ use bitmasks
+
+ implicit none
+ integer, intent(in) :: Nint
+ integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2)
+ double precision, intent(out) :: hji,hij
+
+ double precision :: hmono, htwoe
+ integer :: occ(Nint*bit_kind_size,2)
+ integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk
+ integer :: degree,exc(0:2,2,2)
+ integer :: h1, p1, h2, p2, s1, s2
+ double precision :: get_mo_two_e_integral_tc_int, phase
+ double precision :: direct_int, exchange_int_12, exchange_int_23, exchange_int_13
+ integer :: other_spin(2)
+ integer(bit_kind) :: key_j_core(Nint,2), key_i_core(Nint,2)
+
+ other_spin(1) = 2
+ other_spin(2) = 1
+
+ hmono = 0.d0
+ htwoe = 0.d0
+ hji = 0.d0
+ hij = 0.d0
+ call get_excitation_degree(key_i, key_j, degree, Nint)
+ if(degree.ne.1)then
+ return
+ endif
+ call bitstring_to_list_ab(key_i, occ, Ne, Nint)
+
+ call get_single_excitation(key_i, key_j, exc, phase, Nint)
+ call decode_exc(exc,1,h1,p1,h2,p2,s1,s2)
+ call get_single_excitation_from_fock_tc_no_3e_both(Nint, key_i, key_j, h1, p1, s1, phase, hji,hij)
+
+end
+
+! ---
+
+subroutine get_single_excitation_from_fock_tc_no_3e_both(Nint, key_i, key_j, h, p, spin, phase, hji,hij)
+
+ use bitmasks
+
+ implicit none
+ integer, intent(in) :: Nint
+ integer, intent(in) :: h, p, spin
+ double precision, intent(in) :: phase
+ integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
+ double precision, intent(out) :: hji,hij
+ double precision :: hmono_ji,htwoe_ji
+ double precision :: hmono_ij,htwoe_ij
+
+ integer(bit_kind) :: differences(Nint,2)
+ integer(bit_kind) :: hole(Nint,2)
+ integer(bit_kind) :: partcl(Nint,2)
+ integer :: occ_hole(Nint*bit_kind_size,2)
+ integer :: occ_partcl(Nint*bit_kind_size,2)
+ integer :: n_occ_ab_hole(2),n_occ_ab_partcl(2)
+ integer :: i0,i
+ double precision :: buffer_c_ji(mo_num), buffer_x_ji(mo_num)
+ double precision :: buffer_c_ij(mo_num), buffer_x_ij(mo_num)
+
+ do i = 1, mo_num
+ buffer_c_ji(i) = tc_2e_3idx_coulomb_integrals(i,p,h)
+ buffer_x_ji(i) = tc_2e_3idx_exchange_integrals(i,p,h)
+ buffer_c_ij(i) = tc_2e_3idx_coulomb_integrals_transp(i,p,h)
+ buffer_x_ij(i) = tc_2e_3idx_exchange_integrals_transp(i,p,h)
+ enddo
+
+ do i = 1, Nint
+ differences(i,1) = xor(key_i(i,1),ref_closed_shell_bitmask(i,1))
+ differences(i,2) = xor(key_i(i,2),ref_closed_shell_bitmask(i,2))
+ hole(i,1) = iand(differences(i,1),ref_closed_shell_bitmask(i,1))
+ hole(i,2) = iand(differences(i,2),ref_closed_shell_bitmask(i,2))
+ partcl(i,1) = iand(differences(i,1),key_i(i,1))
+ partcl(i,2) = iand(differences(i,2),key_i(i,2))
+ enddo
+
+ call bitstring_to_list_ab(hole, occ_hole, n_occ_ab_hole, Nint)
+ call bitstring_to_list_ab(partcl, occ_partcl, n_occ_ab_partcl, Nint)
+ hmono_ji = mo_bi_ortho_tc_one_e(p,h)
+ htwoe_ji = fock_op_2_e_tc_closed_shell(p,h)
+ hmono_ij = mo_bi_ortho_tc_one_e(h,p)
+ htwoe_ij = fock_op_2_e_tc_closed_shell(h,p)
+
+ ! holes :: direct terms
+ do i0 = 1, n_occ_ab_hole(1)
+ i = occ_hole(i0,1)
+ htwoe_ji -= buffer_c_ji(i)
+ htwoe_ij -= buffer_c_ij(i)
+ enddo
+ do i0 = 1, n_occ_ab_hole(2)
+ i = occ_hole(i0,2)
+ htwoe_ji -= buffer_c_ji(i)
+ htwoe_ij -= buffer_c_ij(i)
+ enddo
+
+ ! holes :: exchange terms
+ do i0 = 1, n_occ_ab_hole(spin)
+ i = occ_hole(i0,spin)
+ htwoe_ji += buffer_x_ji(i)
+ htwoe_ij += buffer_x_ij(i)
+ enddo
+
+ ! particles :: direct terms
+ do i0 = 1, n_occ_ab_partcl(1)
+ i = occ_partcl(i0,1)
+ htwoe_ji += buffer_c_ji(i)
+ htwoe_ij += buffer_c_ij(i)
+ enddo
+ do i0 = 1, n_occ_ab_partcl(2)
+ i = occ_partcl(i0,2)
+ htwoe_ji += buffer_c_ji(i)
+ htwoe_ij += buffer_c_ij(i)
+ enddo
+
+ ! particles :: exchange terms
+ do i0 = 1, n_occ_ab_partcl(spin)
+ i = occ_partcl(i0,spin)
+ htwoe_ji -= buffer_x_ji(i)
+ htwoe_ij -= buffer_x_ij(i)
+ enddo
+ htwoe_ji = htwoe_ji * phase
+ hmono_ji = hmono_ji * phase
+ hji = htwoe_ji + hmono_ji
+
+ htwoe_ij = htwoe_ij * phase
+ hmono_ij = hmono_ij * phase
+ hij = htwoe_ij + hmono_ij
+
+end
+
diff --git a/plugins/local/tc_bi_ortho/tc_hmat.irp.f b/plugins/local/slater_tc/tc_hmat.irp.f
similarity index 98%
rename from plugins/local/tc_bi_ortho/tc_hmat.irp.f
rename to plugins/local/slater_tc/tc_hmat.irp.f
index abec410d..cc780364 100644
--- a/plugins/local/tc_bi_ortho/tc_hmat.irp.f
+++ b/plugins/local/slater_tc/tc_hmat.irp.f
@@ -22,6 +22,7 @@ BEGIN_PROVIDER [double precision, htilde_matrix_elmt_bi_ortho, (N_det,N_det)]
if(noL_standard) then
PROVIDE noL_0e
+ print*, "noL_0e =", noL_0e
PROVIDE noL_1e
PROVIDE noL_2e
endif
diff --git a/plugins/local/slater_tc_no_opt/.gitignore b/plugins/local/slater_tc_no_opt/.gitignore
new file mode 100644
index 00000000..1561915b
--- /dev/null
+++ b/plugins/local/slater_tc_no_opt/.gitignore
@@ -0,0 +1,59 @@
+IRPF90_temp/
+IRPF90_man/
+build.ninja
+irpf90.make
+ezfio_interface.irp.f
+irpf90_entities
+tags
+Makefile
+ao_basis
+ao_one_e_ints
+ao_two_e_erf_ints
+ao_two_e_ints
+aux_quantities
+becke_numerical_grid
+bitmask
+cis
+cisd
+cipsi
+davidson
+davidson_dressed
+davidson_undressed
+density_for_dft
+determinants
+dft_keywords
+dft_utils_in_r
+dft_utils_one_e
+dft_utils_two_body
+dressing
+dummy
+electrons
+ezfio_files
+fci
+generators_cas
+generators_full
+hartree_fock
+iterations
+kohn_sham
+kohn_sham_rs
+mo_basis
+mo_guess
+mo_one_e_ints
+mo_two_e_erf_ints
+mo_two_e_ints
+mpi
+mrpt_utils
+nuclei
+perturbation
+pseudo
+psiref_cas
+psiref_utils
+scf_utils
+selectors_cassd
+selectors_full
+selectors_utils
+single_ref_method
+slave
+tools
+utils
+zmq
diff --git a/plugins/local/slater_tc_no_opt/NEED b/plugins/local/slater_tc_no_opt/NEED
new file mode 100644
index 00000000..a8669866
--- /dev/null
+++ b/plugins/local/slater_tc_no_opt/NEED
@@ -0,0 +1,8 @@
+determinants
+normal_order_old
+bi_ort_ints
+bi_ortho_mos
+tc_keywords
+non_hermit_dav
+dav_general_mat
+tc_scf
diff --git a/plugins/local/slater_tc_no_opt/README.rst b/plugins/local/slater_tc_no_opt/README.rst
new file mode 100644
index 00000000..90679e4c
--- /dev/null
+++ b/plugins/local/slater_tc_no_opt/README.rst
@@ -0,0 +1,4 @@
+================
+slater_tc_no_opt
+================
+
diff --git a/plugins/local/tc_bi_ortho/h_biortho.irp.f b/plugins/local/slater_tc_no_opt/h_biortho.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/h_biortho.irp.f
rename to plugins/local/slater_tc_no_opt/h_biortho.irp.f
diff --git a/plugins/local/tc_bi_ortho/h_tc_bi_ortho_psi.irp.f b/plugins/local/slater_tc_no_opt/h_tc_bi_ortho_psi.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/h_tc_bi_ortho_psi.irp.f
rename to plugins/local/slater_tc_no_opt/h_tc_bi_ortho_psi.irp.f
diff --git a/plugins/local/tc_bi_ortho/slater_tc_3e_slow.irp.f b/plugins/local/slater_tc_no_opt/slater_tc_3e_slow.irp.f
similarity index 99%
rename from plugins/local/tc_bi_ortho/slater_tc_3e_slow.irp.f
rename to plugins/local/slater_tc_no_opt/slater_tc_3e_slow.irp.f
index cb33d343..f7919653 100644
--- a/plugins/local/tc_bi_ortho/slater_tc_3e_slow.irp.f
+++ b/plugins/local/slater_tc_no_opt/slater_tc_3e_slow.irp.f
@@ -1,7 +1,7 @@
! ---
-subroutine diag_htilde_three_body_ints_bi_ort_slow(Nint, key_i, hthree)
+subroutine diag_htc_bi_orth_3e_brute(Nint, key_i, hthree)
BEGIN_DOC
! diagonal element of htilde ONLY FOR THREE-BODY TERMS WITH BI ORTHONORMAL ORBITALS
diff --git a/plugins/local/slater_tc_no_opt/slater_tc_no_opt.irp.f b/plugins/local/slater_tc_no_opt/slater_tc_no_opt.irp.f
new file mode 100644
index 00000000..0fcc587f
--- /dev/null
+++ b/plugins/local/slater_tc_no_opt/slater_tc_no_opt.irp.f
@@ -0,0 +1,7 @@
+program slater_tc_no_opt
+ implicit none
+ BEGIN_DOC
+! TODO : Put the documentation of the program here
+ END_DOC
+ print *, 'Hello world'
+end
diff --git a/plugins/local/tc_bi_ortho/slater_tc_slow.irp.f b/plugins/local/slater_tc_no_opt/slater_tc_slow.irp.f
similarity index 80%
rename from plugins/local/tc_bi_ortho/slater_tc_slow.irp.f
rename to plugins/local/slater_tc_no_opt/slater_tc_slow.irp.f
index caf7d665..b06fd12f 100644
--- a/plugins/local/tc_bi_ortho/slater_tc_slow.irp.f
+++ b/plugins/local/slater_tc_no_opt/slater_tc_slow.irp.f
@@ -61,7 +61,7 @@ subroutine htilde_mu_mat_bi_ortho_slow(key_j, key_i, Nint, hmono, htwoe, hthree,
if(degree.gt.2) return
if(degree == 0) then
- call diag_htilde_mu_mat_bi_ortho_slow(Nint, key_i, hmono, htwoe, htot)
+ call diag_htc_bi_orth_2e_brute(Nint, key_i, hmono, htwoe, htot)
else if (degree == 1) then
call single_htilde_mu_mat_bi_ortho_slow(Nint, key_j, key_i, hmono, htwoe, htot)
else if(degree == 2) then
@@ -76,7 +76,7 @@ subroutine htilde_mu_mat_bi_ortho_slow(key_j, key_i, Nint, hmono, htwoe, hthree,
else if((degree == 1) .and. (elec_num .gt. 2) .and. three_e_4_idx_term) then
call single_htilde_three_body_ints_bi_ort_slow(Nint, key_j, key_i, hthree)
else if((degree == 0) .and. (elec_num .gt. 2) .and. three_e_3_idx_term) then
- call diag_htilde_three_body_ints_bi_ort_slow(Nint, key_i, hthree)
+ call diag_htc_bi_orth_3e_brute(Nint, key_i, hthree)
endif
endif
@@ -95,75 +95,6 @@ end
! ---
-subroutine diag_htilde_mu_mat_bi_ortho_slow(Nint, key_i, hmono, htwoe, htot)
-
- BEGIN_DOC
- !
- ! diagonal element of htilde ONLY FOR ONE- AND TWO-BODY TERMS
- !
- END_DOC
-
- use bitmasks
-
- implicit none
- integer, intent(in) :: Nint
- integer(bit_kind), intent(in) :: key_i(Nint,2)
- double precision, intent(out) :: hmono,htwoe,htot
- integer :: occ(Nint*bit_kind_size,2)
- integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk
- double precision :: get_mo_two_e_integral_tc_int
- integer(bit_kind) :: key_i_core(Nint,2)
-
- PROVIDE mo_bi_ortho_tc_two_e
-
- hmono = 0.d0
- htwoe = 0.d0
- htot = 0.d0
-
- call bitstring_to_list_ab(key_i, occ, Ne, Nint)
-
- do ispin = 1, 2
- do i = 1, Ne(ispin)
- ii = occ(i,ispin)
- hmono += mo_bi_ortho_tc_one_e(ii,ii)
- enddo
- enddo
-
- ! alpha/beta two-body
- ispin = 1
- jspin = 2
- do i = 1, Ne(ispin) ! electron 1 (so it can be associated to mu(r1))
- ii = occ(i,ispin)
- do j = 1, Ne(jspin) ! electron 2
- jj = occ(j,jspin)
- htwoe += mo_bi_ortho_tc_two_e(jj,ii,jj,ii)
- enddo
- enddo
-
- ! alpha/alpha two-body
- do i = 1, Ne(ispin)
- ii = occ(i,ispin)
- do j = i+1, Ne(ispin)
- jj = occ(j,ispin)
- htwoe += mo_bi_ortho_tc_two_e(ii,jj,ii,jj) - mo_bi_ortho_tc_two_e(ii,jj,jj,ii)
- enddo
- enddo
-
- ! beta/beta two-body
- do i = 1, Ne(jspin)
- ii = occ(i,jspin)
- do j = i+1, Ne(jspin)
- jj = occ(j,jspin)
- htwoe += mo_bi_ortho_tc_two_e(ii,jj,ii,jj) - mo_bi_ortho_tc_two_e(ii,jj,jj,ii)
- enddo
- enddo
-
- htot = hmono + htwoe
-
-end
-
-! ---
-
subroutine double_htilde_mu_mat_bi_ortho_slow(Nint, key_j, key_i, hmono, htwoe, htot)
BEGIN_DOC
diff --git a/plugins/local/tc_bi_ortho/test_tc_bi_ortho.irp.f b/plugins/local/slater_tc_no_opt/test_tc_bi_ortho.irp.f
similarity index 96%
rename from plugins/local/tc_bi_ortho/test_tc_bi_ortho.irp.f
rename to plugins/local/slater_tc_no_opt/test_tc_bi_ortho.irp.f
index 369efd15..559c0200 100644
--- a/plugins/local/tc_bi_ortho/test_tc_bi_ortho.irp.f
+++ b/plugins/local/slater_tc_no_opt/test_tc_bi_ortho.irp.f
@@ -88,7 +88,7 @@ subroutine test_slater_tc_opt
i_count = 0.d0
do i = 1, N_det
do j = 1,N_det
- call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hnewmono, hnewtwoe, hnewthree, hnewtot)
if(dabs(htot).gt.1.d-15)then
i_count += 1.D0
@@ -124,7 +124,7 @@ subroutine timing_tot
do j = 1, N_det
! call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
i_count += 1.d0
- call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
enddo
enddo
call wall_time(wall1)
@@ -171,7 +171,7 @@ subroutine timing_diag
do i = 1, N_det
do j = i,i
i_count += 1.d0
- call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
enddo
enddo
call wall_time(wall1)
@@ -208,7 +208,7 @@ subroutine timing_single
if(degree.ne.1)cycle
i_count += 1.d0
call wall_time(wall0)
- call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
call wall_time(wall1)
accu += wall1 - wall0
enddo
@@ -250,7 +250,7 @@ subroutine timing_double
if(degree.ne.2)cycle
i_count += 1.d0
call wall_time(wall0)
- call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
call wall_time(wall1)
accu += wall1 - wall0
enddo
diff --git a/plugins/local/spher_harm/.gitignore b/plugins/local/spher_harm/.gitignore
new file mode 100644
index 00000000..1561915b
--- /dev/null
+++ b/plugins/local/spher_harm/.gitignore
@@ -0,0 +1,59 @@
+IRPF90_temp/
+IRPF90_man/
+build.ninja
+irpf90.make
+ezfio_interface.irp.f
+irpf90_entities
+tags
+Makefile
+ao_basis
+ao_one_e_ints
+ao_two_e_erf_ints
+ao_two_e_ints
+aux_quantities
+becke_numerical_grid
+bitmask
+cis
+cisd
+cipsi
+davidson
+davidson_dressed
+davidson_undressed
+density_for_dft
+determinants
+dft_keywords
+dft_utils_in_r
+dft_utils_one_e
+dft_utils_two_body
+dressing
+dummy
+electrons
+ezfio_files
+fci
+generators_cas
+generators_full
+hartree_fock
+iterations
+kohn_sham
+kohn_sham_rs
+mo_basis
+mo_guess
+mo_one_e_ints
+mo_two_e_erf_ints
+mo_two_e_ints
+mpi
+mrpt_utils
+nuclei
+perturbation
+pseudo
+psiref_cas
+psiref_utils
+scf_utils
+selectors_cassd
+selectors_full
+selectors_utils
+single_ref_method
+slave
+tools
+utils
+zmq
diff --git a/plugins/local/spher_harm/NEED b/plugins/local/spher_harm/NEED
new file mode 100644
index 00000000..92df7f12
--- /dev/null
+++ b/plugins/local/spher_harm/NEED
@@ -0,0 +1 @@
+dft_utils_in_r
diff --git a/plugins/local/spher_harm/README.rst b/plugins/local/spher_harm/README.rst
new file mode 100644
index 00000000..9c9b12a6
--- /dev/null
+++ b/plugins/local/spher_harm/README.rst
@@ -0,0 +1,7 @@
+==========
+spher_harm
+==========
+
+Routines for spherical Harmonics evaluation in real space.
+The main routine is "spher_harm_func_r3(r,l,m,re_ylm, im_ylm)".
+The test routine is "test_spher_harm" where everything is explained in details.
diff --git a/plugins/local/spher_harm/assoc_gaus_pol.irp.f b/plugins/local/spher_harm/assoc_gaus_pol.irp.f
new file mode 100644
index 00000000..fa790307
--- /dev/null
+++ b/plugins/local/spher_harm/assoc_gaus_pol.irp.f
@@ -0,0 +1,50 @@
+double precision function plgndr(l,m,x)
+ integer, intent(in) :: l,m
+ double precision, intent(in) :: x
+ BEGIN_DOC
+ ! associated Legenre polynom P_l,m(x). Used for the Y_lm(theta,phi)
+ ! Taken from https://iate.oac.uncor.edu/~mario/materia/nr/numrec/f6-8.pdf
+ END_DOC
+ integer :: i,ll
+ double precision :: fact,pll,pmm,pmmp1,somx2
+ if(m.lt.0.or.m.gt.l.or.dabs(x).gt.1.d0)then
+ print*,'bad arguments in plgndr'
+ pause
+ endif
+ pmm=1.d0
+ if(m.gt.0) then
+ somx2=dsqrt((1.d0-x)*(1.d0+x))
+ fact=1.d0
+ do i=1,m
+ pmm=-pmm*fact*somx2
+ fact=fact+2.d0
+ enddo
+ endif ! m > 0
+ if(l.eq.m) then
+ plgndr=pmm
+ else
+ pmmp1=x*(2*m+1)*pmm ! Compute P_m+1^m
+ if(l.eq.m+1) then
+ plgndr=pmmp1
+ else ! Compute P_l^m, l> m+1
+ do ll=m+2,l
+ pll=(x*dble(2*ll-1)*pmmp1-dble(ll+m-1)*pmm)/(ll-m)
+ pmm=pmmp1
+ pmmp1=pll
+ enddo
+ plgndr=pll
+ endif ! l.eq.m+1
+ endif ! l.eq.m
+ return
+end
+
+double precision function ortho_assoc_gaus_pol(l1,m1,l2)
+ implicit none
+ integer, intent(in) :: l1,m1,l2
+ double precision :: fact
+ if(l1.ne.l2)then
+ ortho_assoc_gaus_pol= 0.d0
+ else
+ ortho_assoc_gaus_pol = 2.d0*fact(l1+m1) / (dble(2*l1+1)*fact(l1-m1))
+ endif
+end
diff --git a/plugins/local/spher_harm/routines_test.irp.f b/plugins/local/spher_harm/routines_test.irp.f
new file mode 100644
index 00000000..fe8fc422
--- /dev/null
+++ b/plugins/local/spher_harm/routines_test.irp.f
@@ -0,0 +1,231 @@
+subroutine test_spher_harm
+ implicit none
+ BEGIN_DOC
+ ! routine to test the generic spherical harmonics routine "spher_harm_func_r3" from R^3 --> C
+ !
+ ! We test = delta_m1,m2 delta_l1,l2
+ !
+ ! The test is done through the integration on a sphere with the Lebedev grid.
+ END_DOC
+ include 'constants.include.F'
+ integer :: l1,m1,i,l2,m2,lmax
+ double precision :: r(3),weight,accu_re, accu_im,accu
+ double precision :: re_ylm_1, im_ylm_1,re_ylm_2, im_ylm_2
+ double precision :: theta,phi,r_abs
+ lmax = 5 ! Maximum angular momentum until which we are going to test orthogonality conditions
+ do l1 = 0,lmax
+ do m1 = -l1 ,l1
+ do l2 = 0,lmax
+ do m2 = -l2 ,l2
+ accu_re = 0.d0 ! accumulator for the REAL part of
+ accu_im = 0.d0 ! accumulator for the IMAGINARY part of
+ accu = 0.d0 ! accumulator for the weights ==> should be \int dOmega == 4 pi
+ ! = \int dOmega Y_l1,m1^* Y_l2,m2
+ ! \approx \sum_i W_i Y_l1,m1^*(r_i) Y_l2,m2(r_i) WITH r_i being on the spher of radius 1
+ do i = 1, n_points_integration_angular
+ r(1:3) = angular_quadrature_points(i,1:3) ! ith Lebedev point (x,y,z) on the sphere of radius 1
+ weight = weights_angular_points(i) ! associated Lebdev weight not necessarily positive
+
+!!!!!!!!!!! Test of the Cartesian --> Spherical coordinates
+ ! theta MUST belong to [0,pi] and phi to [0,2pi]
+ ! gets the cartesian to spherical change of coordinates
+ call cartesian_to_spherical(r,theta,phi,r_abs)
+ if(theta.gt.pi.or.theta.lt.0.d0)then
+ print*,'pb with theta, it should be in [0,pi]',theta
+ print*,r
+ endif
+ if(phi.gt.2.d0*pi.or.phi.lt.0.d0)then
+ print*,'pb with phi, it should be in [0,2 pi]',phi/pi
+ print*,r
+ endif
+
+!!!!!!!!!!! Routines returning the Spherical harmonics on the grid point
+ call spher_harm_func_r3(r,l1,m1,re_ylm_1, im_ylm_1)
+ call spher_harm_func_r3(r,l2,m2,re_ylm_2, im_ylm_2)
+
+!!!!!!!!!!! Integration of Y_l1,m1^*(r) Y_l2,m2(r)
+ ! = \int dOmega (re_ylm_1 -i im_ylm_1) * (re_ylm_2 +i im_ylm_2)
+ ! = \int dOmega (re_ylm_1*re_ylm_2 + im_ylm_1*im_ylm_2) +i (im_ylm_2*re_ylm_1 - im_ylm_1*re_ylm_2)
+ accu_re += weight * (re_ylm_1*re_ylm_2 + im_ylm_1*im_ylm_2)
+ accu_im += weight * (im_ylm_2*re_ylm_1 - im_ylm_1*re_ylm_2)
+ accu += weight
+ enddo
+ ! Test that the sum of the weights is 4 pi
+ if(dabs(accu - dfour_pi).gt.1.d-6)then
+ print*,'Problem !! The sum of the Lebedev weight is not 4 pi ..'
+ print*,accu
+ stop
+ endif
+ ! Test for the delta l1,l2 and delta m1,m2
+ !
+ ! Test for the off-diagonal part of the Kronecker delta
+ if(l1.ne.l2.or.m1.ne.m2)then
+ if(dabs(accu_re).gt.1.d-6.or.dabs(accu_im).gt.1.d-6)then
+ print*,'pb OFF DIAG !!!!! '
+ print*,'l1,m1,l2,m2',l1,m1,l2,m2
+ print*,'accu_re = ',accu_re
+ print*,'accu_im = ',accu_im
+ endif
+ endif
+ ! Test for the diagonal part of the Kronecker delta
+ if(l1==l2.and.m1==m2)then
+ if(dabs(accu_re-1.d0).gt.1.d-5.or.dabs(accu_im).gt.1.d-6)then
+ print*,'pb DIAG !!!!! '
+ print*,'l1,m1,l2,m2',l1,m1,l2,m2
+ print*,'accu_re = ',accu_re
+ print*,'accu_im = ',accu_im
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+end
+
+subroutine test_cart
+ implicit none
+ BEGIN_DOC
+ ! test for the cartesian --> spherical change of coordinates
+ !
+ ! test the routine "cartesian_to_spherical" such that the polar angle theta ranges in [0,pi]
+ !
+ ! and the asymuthal angle phi ranges in [0,2pi]
+ END_DOC
+ include 'constants.include.F'
+ double precision :: r(3),theta,phi,r_abs
+ print*,''
+ r = 0.d0
+ r(1) = 1.d0
+ r(2) = 1.d0
+ call cartesian_to_spherical(r,theta,phi,r_abs)
+ print*,r
+ print*,phi/pi
+ print*,''
+ r = 0.d0
+ r(1) =-1.d0
+ r(2) = 1.d0
+ call cartesian_to_spherical(r,theta,phi,r_abs)
+ print*,r
+ print*,phi/pi
+ print*,''
+ r = 0.d0
+ r(1) =-1.d0
+ r(2) =-1.d0
+ call cartesian_to_spherical(r,theta,phi,r_abs)
+ print*,r
+ print*,phi/pi
+ print*,''
+ r = 0.d0
+ r(1) = 1.d0
+ r(2) =-1.d0
+ call cartesian_to_spherical(r,theta,phi,r_abs)
+ print*,r
+ print*,phi/pi
+end
+
+
+subroutine test_brutal_spheric
+ implicit none
+ include 'constants.include.F'
+ BEGIN_DOC
+ ! Test for the = delta_m1,m2 delta_l1,l2 using the following two dimentional integration
+ !
+ ! \int_0^2pi d Phi \int_-1^+1 d(cos(Theta)) Y_l1,m1^*(Theta,Phi) Y_l2,m2(Theta,Phi)
+ !
+ != \int_0^2pi d Phi \int_0^pi dTheta sin(Theta) Y_l1,m1^*(Theta,Phi) Y_l2,m2(Theta,Phi)
+ !
+ ! Allows to test for the general functions "spher_harm_func_m_pos" with "spher_harm_func_expl"
+ END_DOC
+ integer :: itheta, iphi,ntheta,nphi
+ double precision :: theta_min, theta_max, dtheta,theta
+ double precision :: phi_min, phi_max, dphi,phi
+ double precision :: accu_re, accu_im,weight
+ double precision :: re_ylm_1, im_ylm_1 ,re_ylm_2, im_ylm_2,accu
+ integer :: l1,m1,i,l2,m2,lmax
+ phi_min = 0.d0
+ phi_max = 2.D0 * pi
+ theta_min = 0.d0
+ theta_max = 1.D0 * pi
+ ntheta = 1000
+ nphi = 1000
+ dphi = (phi_max - phi_min)/dble(nphi)
+ dtheta = (theta_max - theta_min)/dble(ntheta)
+
+ lmax = 2
+ do l1 = 0,lmax
+ do m1 = 0 ,l1
+ do l2 = 0,lmax
+ do m2 = 0 ,l2
+ accu_re = 0.d0
+ accu_im = 0.d0
+ accu = 0.d0
+ theta = theta_min
+ do itheta = 1, ntheta
+ phi = phi_min
+ do iphi = 1, nphi
+! call spher_harm_func_expl(l1,m1,theta,phi,re_ylm_1, im_ylm_1)
+! call spher_harm_func_expl(l2,m2,theta,phi,re_ylm_2, im_ylm_2)
+ call spher_harm_func_m_pos(l1,m1,theta,phi,re_ylm_1, im_ylm_1)
+ call spher_harm_func_m_pos(l2,m2,theta,phi,re_ylm_2, im_ylm_2)
+ weight = dtheta * dphi * dsin(theta)
+ accu_re += weight * (re_ylm_1*re_ylm_2 + im_ylm_1*im_ylm_2)
+ accu_im += weight * (im_ylm_2*re_ylm_1 - im_ylm_1*re_ylm_2)
+ accu += weight
+ phi += dphi
+ enddo
+ theta += dtheta
+ enddo
+ print*,'l1,m1,l2,m2',l1,m1,l2,m2
+ print*,'accu_re = ',accu_re
+ print*,'accu_im = ',accu_im
+ print*,'accu = ',accu
+ if(l1.ne.l2.or.m1.ne.m2)then
+ if(dabs(accu_re).gt.1.d-6.or.dabs(accu_im).gt.1.d-6)then
+ print*,'pb OFF DIAG !!!!! '
+ endif
+ endif
+ if(l1==l2.and.m1==m2)then
+ if(dabs(accu_re-1.d0).gt.1.d-5.or.dabs(accu_im).gt.1.d-6)then
+ print*,'pb DIAG !!!!! '
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+
+
+end
+
+subroutine test_assoc_leg_pol
+ implicit none
+ BEGIN_DOC
+! Test for the associated Legendre Polynoms. The test is done through the orthogonality condition.
+ END_DOC
+ print *, 'Hello world'
+ integer :: l1,m1,ngrid,i,l2,m2
+ l1 = 0
+ m1 = 0
+ l2 = 2
+ m2 = 0
+ double precision :: x, dx,xmax,accu,xmin
+ double precision :: plgndr,func_1,func_2,ortho_assoc_gaus_pol
+ ngrid = 100000
+ xmax = 1.d0
+ xmin = -1.d0
+ dx = (xmax-xmin)/dble(ngrid)
+ do l2 = 0,10
+ x = xmin
+ accu = 0.d0
+ do i = 1, ngrid
+ func_1 = plgndr(l1,m1,x)
+ func_2 = plgndr(l2,m2,x)
+ write(33,*)x, func_1,func_2
+ accu += func_1 * func_2 * dx
+ x += dx
+ enddo
+ print*,'l2 = ',l2
+ print*,'accu = ',accu
+ print*,ortho_assoc_gaus_pol(l1,m1,l2)
+ enddo
+end
diff --git a/plugins/local/spher_harm/spher_harm.irp.f b/plugins/local/spher_harm/spher_harm.irp.f
new file mode 100644
index 00000000..7a2eea06
--- /dev/null
+++ b/plugins/local/spher_harm/spher_harm.irp.f
@@ -0,0 +1,7 @@
+program spher_harm
+ implicit none
+! call test_spher_harm
+! call test_cart
+ call test_brutal_spheric
+end
+
diff --git a/plugins/local/spher_harm/spher_harm_func.irp.f b/plugins/local/spher_harm/spher_harm_func.irp.f
new file mode 100644
index 00000000..825bd8ac
--- /dev/null
+++ b/plugins/local/spher_harm/spher_harm_func.irp.f
@@ -0,0 +1,151 @@
+subroutine spher_harm_func_r3(r,l,m,re_ylm, im_ylm)
+ implicit none
+ integer, intent(in) :: l,m
+ double precision, intent(in) :: r(3)
+ double precision, intent(out) :: re_ylm, im_ylm
+
+ double precision :: theta, phi,r_abs
+ call cartesian_to_spherical(r,theta,phi,r_abs)
+ call spher_harm_func(l,m,theta,phi,re_ylm, im_ylm)
+end
+
+
+subroutine spher_harm_func_m_pos(l,m,theta,phi,re_ylm, im_ylm)
+ include 'constants.include.F'
+ implicit none
+ BEGIN_DOC
+! Y_lm(theta,phi) with m >0
+!
+ END_DOC
+ double precision, intent(in) :: theta, phi
+ integer, intent(in) :: l,m
+ double precision, intent(out):: re_ylm,im_ylm
+ double precision :: prefact,fact,cos_theta,plgndr,p_lm
+ double precision :: tmp
+ prefact = dble(2*l+1)*fact(l-m)/(dfour_pi * fact(l+m))
+ prefact = dsqrt(prefact)
+ cos_theta = dcos(theta)
+ p_lm = plgndr(l,m,cos_theta)
+ tmp = prefact * p_lm
+ re_ylm = dcos(dble(m)*phi) * tmp
+ im_ylm = dsin(dble(m)*phi) * tmp
+end
+
+subroutine spher_harm_func(l,m,theta,phi,re_ylm, im_ylm)
+ implicit none
+ BEGIN_DOC
+ ! Y_lm(theta,phi) with -l l in spher_harm_func !! stopping ...'
+ stop
+ endif
+ if(m.ge.0)then
+ call spher_harm_func_m_pos(l,m,theta,phi,re_ylm_pos, im_ylm_pos)
+ re_ylm = re_ylm_pos
+ im_ylm = im_ylm_pos
+ else
+ minus_m = -m !> 0
+ call spher_harm_func_m_pos(l,minus_m,theta,phi,re_ylm_pos, im_ylm_pos)
+ tmp = (-1)**minus_m
+ re_ylm = tmp * re_ylm_pos
+ im_ylm = -tmp * im_ylm_pos ! complex conjugate
+ endif
+end
+
+subroutine cartesian_to_spherical(r,theta,phi,r_abs)
+ implicit none
+ double precision, intent(in) :: r(3)
+ double precision, intent(out):: theta, phi,r_abs
+ double precision :: r_2,x_2_y_2,tmp
+ include 'constants.include.F'
+ x_2_y_2 = r(1)*r(1) + r(2)*r(2)
+ r_2 = x_2_y_2 + r(3)*r(3)
+ r_abs = dsqrt(r_2)
+
+ if(r_abs.gt.1.d-20)then
+ theta = dacos(r(3)/r_abs)
+ else
+ theta = 0.d0
+ endif
+
+ if(.true.)then
+ if(dabs(r(1)).gt.0.d0)then
+ tmp = datan(r(2)/r(1))
+! phi = datan2(r(2),r(1))
+ endif
+ ! From Wikipedia on Spherical Harmonics
+ if(r(1).gt.0.d0)then
+ phi = tmp
+ else if(r(1).lt.0.d0.and.r(2).ge.0.d0)then
+ phi = tmp + pi
+ else if(r(1).lt.0.d0.and.r(2).lt.0.d0)then
+ phi = tmp - pi
+ else if(r(1)==0.d0.and.r(2).gt.0.d0)then
+ phi = 0.5d0*pi
+ else if(r(1)==0.d0.and.r(2).lt.0.d0)then
+ phi =-0.5d0*pi
+ else if(r(1)==0.d0.and.r(2)==0.d0)then
+ phi = 0.d0
+ endif
+ if(r(2).lt.0.d0.and.r(1).le.0.d0)then
+ tmp = pi - dabs(phi)
+ phi = pi + tmp
+ else if(r(2).lt.0.d0.and.r(1).gt.0.d0)then
+ phi = dtwo_pi + phi
+ endif
+ endif
+
+ if(.false.)then
+ x_2_y_2 = dsqrt(x_2_y_2)
+ if(dabs(x_2_y_2).gt.1.d-20.and.dabs(r(2)).gt.1.d-20)then
+ phi = dabs(r(2))/r(2) * dacos(r(1)/x_2_y_2)
+ else
+ phi = 0.d0
+ endif
+ endif
+end
+
+
+subroutine spher_harm_func_expl(l,m,theta,phi,re_ylm, im_ylm)
+ implicit none
+ BEGIN_DOC
+ ! Y_lm(theta,phi) with -l for same spin matrix elements
- !
- ! notice the -1 sign: in this way three_e_diag_parrallel_spin_prov can be directly used to compute Slater rules with a + sign
- !
- END_DOC
-
- implicit none
- integer :: i, j, m
- double precision :: integral, wall1, wall0, three_e_diag_parrallel_spin
-
- three_e_diag_parrallel_spin_prov = 0.d0
- print *, ' Providing the three_e_diag_parrallel_spin_prov ...'
-
- integral = three_e_diag_parrallel_spin(1,1,1) ! to provide all stuffs
- call wall_time(wall0)
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (i,j,m,integral) &
- !$OMP SHARED (mo_num,three_e_diag_parrallel_spin_prov)
- !$OMP DO SCHEDULE (dynamic)
- do i = 1, mo_num
- do j = 1, mo_num
- do m = j, mo_num
- three_e_diag_parrallel_spin_prov(m,j,i) = three_e_diag_parrallel_spin(m,j,i)
- enddo
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- do i = 1, mo_num
- do j = 1, mo_num
- do m = 1, j
- three_e_diag_parrallel_spin_prov(m,j,i) = three_e_diag_parrallel_spin_prov(j,m,i)
- enddo
- enddo
- enddo
-
- call wall_time(wall1)
- print *, ' wall time for three_e_diag_parrallel_spin_prov', wall1 - wall0
-
-END_PROVIDER
-
-BEGIN_PROVIDER [ double precision, three_e_single_parrallel_spin_prov, (mo_num, mo_num, mo_num, mo_num)]
-
- BEGIN_DOC
- !
- ! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
- !
- ! three_e_single_parrallel_spin_prov(m,j,k,i) = All combination of for same spin matrix elements
- !
- ! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
- !
- END_DOC
-
- implicit none
- integer :: i, j, k, m
- double precision :: integral, wall1, wall0, three_e_single_parrallel_spin
-
- three_e_single_parrallel_spin_prov = 0.d0
- print *, ' Providing the three_e_single_parrallel_spin_prov ...'
-
- integral = three_e_single_parrallel_spin(1,1,1,1)
- call wall_time(wall0)
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (i,j,k,m,integral) &
- !$OMP SHARED (mo_num,three_e_single_parrallel_spin_prov)
- !$OMP DO SCHEDULE (dynamic)
- do i = 1, mo_num
- do k = 1, mo_num
- do j = 1, mo_num
- do m = 1, mo_num
- three_e_single_parrallel_spin_prov(m,j,k,i) = three_e_single_parrallel_spin(m,j,k,i)
- enddo
- enddo
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- call wall_time(wall1)
- print *, ' wall time for three_e_single_parrallel_spin_prov', wall1 - wall0
-
-END_PROVIDER
-
-
-! ---
-
-BEGIN_PROVIDER [ double precision, three_e_double_parrallel_spin_prov, (mo_num, mo_num, mo_num, mo_num, mo_num)]
-
- BEGIN_DOC
- !
- ! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
- !
- ! three_e_double_parrallel_spin_prov(m,l,j,k,i) = ::: notice that i is the RIGHT MO and k is the LEFT MO
- !
- ! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
- END_DOC
-
- implicit none
- integer :: i, j, k, m, l
- double precision :: integral, wall1, wall0, three_e_double_parrallel_spin
-
- three_e_double_parrallel_spin_prov = 0.d0
- print *, ' Providing the three_e_double_parrallel_spin_prov ...'
- call wall_time(wall0)
-
- integral = three_e_double_parrallel_spin(1,1,1,1,1)
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (i,j,k,m,l,integral) &
- !$OMP SHARED (mo_num,three_e_double_parrallel_spin_prov)
- !$OMP DO SCHEDULE (dynamic)
- do i = 1, mo_num
- do k = 1, mo_num
- do j = 1, mo_num
- do l = 1, mo_num
- do m = 1, mo_num
- three_e_double_parrallel_spin_prov(m,l,j,k,i) = three_e_double_parrallel_spin(m,l,j,k,i)
- enddo
- enddo
- enddo
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- call wall_time(wall1)
- print *, ' wall time for three_e_double_parrallel_spin_prov', wall1 - wall0
-
-END_PROVIDER
-
diff --git a/plugins/local/tc_bi_ortho/tc_cisd_sc2.irp.f b/plugins/local/tc_bi_ortho/tc_cisd_sc2.irp.f
deleted file mode 100644
index d4c8c55d..00000000
--- a/plugins/local/tc_bi_ortho/tc_cisd_sc2.irp.f
+++ /dev/null
@@ -1,36 +0,0 @@
-
-! ---
-
-program tc_cisd_sc2
-
- BEGIN_DOC
- ! TODO : Put the documentation of the program here
- END_DOC
-
- implicit none
-
- print *, 'Hello world'
-
- my_grid_becke = .True.
- PROVIDE tc_grid1_a tc_grid1_r
- my_n_pt_r_grid = tc_grid1_r
- my_n_pt_a_grid = tc_grid1_a
- touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
-
- read_wf = .True.
- touch read_wf
-
- call test
-
-end
-
-! ---
-
-subroutine test()
- implicit none
-! double precision, allocatable :: dressing_dets(:),e_corr_dets(:)
-! allocate(dressing_dets(N_det),e_corr_dets(N_det))
-! e_corr_dets = 0.d0
-! call get_cisd_sc2_dressing(psi_det,e_corr_dets,N_det,dressing_dets)
- provide eigval_tc_cisd_sc2_bi_ortho
-end
diff --git a/plugins/local/tc_bi_ortho/tc_cisd_sc2_utils.irp.f b/plugins/local/tc_bi_ortho/tc_cisd_sc2_utils.irp.f
deleted file mode 100644
index 4c3c0788..00000000
--- a/plugins/local/tc_bi_ortho/tc_cisd_sc2_utils.irp.f
+++ /dev/null
@@ -1,145 +0,0 @@
- BEGIN_PROVIDER [ double precision, reigvec_tc_cisd_sc2_bi_ortho, (N_det,N_states)]
-&BEGIN_PROVIDER [ double precision, leigvec_tc_cisd_sc2_bi_ortho, (N_det,N_states)]
-&BEGIN_PROVIDER [ double precision, eigval_tc_cisd_sc2_bi_ortho, (N_states)]
- implicit none
- integer :: it,n_real,degree,i,istate
- double precision :: e_before, e_current,thr, hmono,htwoe,hthree,accu
- double precision, allocatable :: e_corr_dets(:),h0j(:), h_sc2(:,:), dressing_dets(:)
- double precision, allocatable :: leigvec_tc_bi_orth_tmp(:,:),reigvec_tc_bi_orth_tmp(:,:),eigval_right_tmp(:)
- allocate(leigvec_tc_bi_orth_tmp(N_det,N_det),reigvec_tc_bi_orth_tmp(N_det,N_det),eigval_right_tmp(N_det))
- allocate(e_corr_dets(N_det),h0j(N_det),h_sc2(N_det,N_det),dressing_dets(N_det))
- allocate(H_jj(N_det),vec_tmp(N_det,n_states_diag),eigval_tmp(N_states))
- dressing_dets = 0.d0
- do i = 1, N_det
- call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,i), psi_det(1,1,i), N_int, H_jj(i))
- call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
- if(degree == 1 .or. degree == 2)then
- call htilde_mu_mat_bi_ortho_slow(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,h0j(i))
- endif
- enddo
- reigvec_tc_bi_orth_tmp = 0.d0
- do i = 1, N_det
- reigvec_tc_bi_orth_tmp(i,1) = psi_r_coef_bi_ortho(i,1)
- enddo
- vec_tmp = 0.d0
- do istate = 1, N_states
- vec_tmp(:,istate) = reigvec_tc_bi_orth_tmp(:,istate)
- enddo
- do istate = N_states+1, n_states_diag
- vec_tmp(istate,istate) = 1.d0
- enddo
- print*,'Diagonalizing the TC CISD '
- call davidson_general_diag_dressed_ext_rout_nonsym_b1space(vec_tmp, H_jj, dressing_dets,eigval_tmp, N_det, n_states, n_states_diag, converged, htc_bi_ortho_calc_tdav_slow)
- do i = 1, N_det
- e_corr_dets(i) = reigvec_tc_bi_orth_tmp(i,1) * h0j(i)/reigvec_tc_bi_orth_tmp(1,1)
- enddo
- E_before = eigval_tmp(1)
- print*,'Starting from ',E_before
-
- e_current = 10.d0
- thr = 1.d-5
- it = 0
- dressing_dets = 0.d0
- double precision, allocatable :: H_jj(:),vec_tmp(:,:),eigval_tmp(:)
- external htc_bi_ortho_calc_tdav_slow
- external htcdag_bi_ortho_calc_tdav_slow
- logical :: converged
- do while (dabs(E_before-E_current).gt.thr)
- it += 1
- E_before = E_current
-! h_sc2 = htilde_matrix_elmt_bi_ortho
- call get_cisd_sc2_dressing(psi_det,e_corr_dets,N_det,dressing_dets)
- do i = 1, N_det
-! print*,'dressing_dets(i) = ',dressing_dets(i)
- h_sc2(i,i) += dressing_dets(i)
- enddo
- print*,'********************'
- print*,'iteration ',it
-! call non_hrmt_real_diag(N_det,h_sc2,&
-! leigvec_tc_bi_orth_tmp,reigvec_tc_bi_orth_tmp,&
-! n_real,eigval_right_tmp)
-! print*,'eigval_right_tmp(1)',eigval_right_tmp(1)
- vec_tmp = 0.d0
- do istate = 1, N_states
- vec_tmp(:,istate) = reigvec_tc_bi_orth_tmp(:,istate)
- enddo
- do istate = N_states+1, n_states_diag
- vec_tmp(istate,istate) = 1.d0
- enddo
- call davidson_general_diag_dressed_ext_rout_nonsym_b1space(vec_tmp, H_jj, dressing_dets,eigval_tmp, N_det, n_states, n_states_diag, converged, htc_bi_ortho_calc_tdav_slow)
- print*,'outside Davidson'
- print*,'eigval_tmp(1) = ',eigval_tmp(1)
- do i = 1, N_det
- reigvec_tc_bi_orth_tmp(i,1) = vec_tmp(i,1)
- e_corr_dets(i) = reigvec_tc_bi_orth_tmp(i,1) * h0j(i)/reigvec_tc_bi_orth_tmp(1,1)
- enddo
-! E_current = eigval_right_tmp(1)
- E_current = eigval_tmp(1)
- print*,'it, E(SC)^2 = ',it,E_current
- enddo
- eigval_tc_cisd_sc2_bi_ortho(1:N_states) = eigval_right_tmp(1:N_states)
- reigvec_tc_cisd_sc2_bi_ortho(1:N_det,1:N_states) = reigvec_tc_bi_orth_tmp(1:N_det,1:N_states)
- leigvec_tc_cisd_sc2_bi_ortho(1:N_det,1:N_states) = leigvec_tc_bi_orth_tmp(1:N_det,1:N_states)
-
-END_PROVIDER
-
-subroutine get_cisd_sc2_dressing(dets,e_corr_dets,ndet,dressing_dets)
- implicit none
- use bitmasks
- integer, intent(in) :: ndet
- integer(bit_kind), intent(in) :: dets(N_int,2,ndet)
- double precision, intent(in) :: e_corr_dets(ndet)
- double precision, intent(out) :: dressing_dets(ndet)
- integer, allocatable :: degree(:),hole(:,:),part(:,:),spin(:,:)
- integer(bit_kind), allocatable :: hole_part(:,:,:)
- integer :: i,j,k, exc(0:2,2,2),h1,p1,h2,p2,s1,s2
- integer(bit_kind) :: xorvec(2,N_int)
-
- double precision :: phase
- dressing_dets = 0.d0
- allocate(degree(ndet),hole(2,ndet),part(2,ndet), spin(2,ndet),hole_part(N_int,2,ndet))
- do i = 2, ndet
- call get_excitation_degree(HF_bitmask,dets(1,1,i),degree(i),N_int)
- do j = 1, N_int
- hole_part(j,1,i) = xor( HF_bitmask(j,1), dets(j,1,i))
- hole_part(j,2,i) = xor( HF_bitmask(j,2), dets(j,2,i))
- enddo
- if(degree(i) == 1)then
- call get_single_excitation(HF_bitmask,psi_det(1,1,i),exc,phase,N_int)
- else if(degree(i) == 2)then
- call get_double_excitation(HF_bitmask,psi_det(1,1,i),exc,phase,N_int)
- endif
- call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
- hole(1,i) = h1
- hole(2,i) = h2
- part(1,i) = p1
- part(2,i) = p2
- spin(1,i) = s1
- spin(2,i) = s2
- enddo
-
- integer :: same
- if(elec_alpha_num+elec_beta_num<3)return
- do i = 2, ndet
- do j = i+1, ndet
- same = 0
- if(degree(i) == degree(j) .and. degree(i)==1)cycle
- do k = 1, N_int
- xorvec(k,1) = iand(hole_part(k,1,i),hole_part(k,1,j))
- xorvec(k,2) = iand(hole_part(k,2,i),hole_part(k,2,j))
- same += popcnt(xorvec(k,1)) + popcnt(xorvec(k,2))
- enddo
-! print*,'i,j',i,j
-! call debug_det(dets(1,1,i),N_int)
-! call debug_det(hole_part(1,1,i),N_int)
-! call debug_det(dets(1,1,j),N_int)
-! call debug_det(hole_part(1,1,j),N_int)
-! print*,'same = ',same
- if(same.eq.0)then
- dressing_dets(i) += e_corr_dets(j)
- dressing_dets(j) += e_corr_dets(i)
- endif
- enddo
- enddo
-
-end
diff --git a/plugins/local/tc_bi_ortho/tc_utils.irp.f b/plugins/local/tc_bi_ortho/tc_utils.irp.f
index 53fe5884..2aa148a3 100644
--- a/plugins/local/tc_bi_ortho/tc_utils.irp.f
+++ b/plugins/local/tc_bi_ortho/tc_utils.irp.f
@@ -2,12 +2,67 @@
subroutine write_tc_energy()
implicit none
- integer :: i, j, k
- double precision :: hmono, htwoe, hthree, htot
- double precision :: E_TC, O_TC
- double precision :: E_1e, E_2e, E_3e
+ integer :: i, j, k
+ double precision :: hmono, htwoe, hthree, htot
+ double precision :: E_TC, O_TC
+ double precision :: E_1e, E_2e, E_3e
+ double precision, allocatable :: E_TC_tmp(:), E_1e_tmp(:), E_2e_tmp(:), E_3e_tmp(:)
- do k = 1, n_states
+ ! GS
+ ! ---
+
+ allocate(E_TC_tmp(N_det), E_1e_tmp(N_det), E_2e_tmp(N_det), E_3e_tmp(N_det))
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE(i, j, hmono, htwoe, hthree, htot) &
+ !$OMP SHARED(N_det, psi_det, N_int, psi_l_coef_bi_ortho, psi_r_coef_bi_ortho, &
+ !$OMP E_TC_tmp, E_1e_tmp, E_2e_tmp, E_3e_tmp)
+ !$OMP DO
+ do i = 1, N_det
+ E_TC_tmp(i) = 0.d0
+ E_1e_tmp(i) = 0.d0
+ E_2e_tmp(i) = 0.d0
+ E_3e_tmp(i) = 0.d0
+ do j = 1, N_det
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i), psi_det(1,1,j), N_int, hmono, htwoe, hthree, htot)
+ E_TC_tmp(i) = E_TC_tmp(i) + psi_l_coef_bi_ortho(i,1) * psi_r_coef_bi_ortho(j,1) * htot
+ E_1e_tmp(i) = E_1e_tmp(i) + psi_l_coef_bi_ortho(i,1) * psi_r_coef_bi_ortho(j,1) * hmono
+ E_2e_tmp(i) = E_2e_tmp(i) + psi_l_coef_bi_ortho(i,1) * psi_r_coef_bi_ortho(j,1) * htwoe
+ E_3e_tmp(i) = E_3e_tmp(i) + psi_l_coef_bi_ortho(i,1) * psi_r_coef_bi_ortho(j,1) * hthree
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ E_1e = 0.d0
+ E_2e = 0.d0
+ E_3e = 0.d0
+ E_TC = 0.d0
+ O_TC = 0.d0
+ do i = 1, N_det
+ E_1e = E_1e + E_1e_tmp(i)
+ E_2e = E_2e + E_2e_tmp(i)
+ E_3e = E_3e + E_3e_tmp(i)
+ E_TC = E_TC + E_TC_tmp(i)
+ O_TC = O_TC + psi_l_coef_bi_ortho(i,1) * psi_r_coef_bi_ortho(i,1)
+ enddo
+
+ print *, ' state :', 1
+ print *, " E_TC = ", E_TC / O_TC
+ print *, " E_1e = ", E_1e / O_TC
+ print *, " E_2e = ", E_2e / O_TC
+ print *, " E_3e = ", E_3e / O_TC
+ print *, " O_TC = ", O_TC
+
+ call ezfio_set_tc_bi_ortho_tc_gs_energy(E_TC/O_TC)
+
+ ! ---
+
+ ! ES
+ ! ---
+
+ do k = 2, n_states
E_TC = 0.d0
E_1e = 0.d0
@@ -15,7 +70,7 @@ subroutine write_tc_energy()
E_3e = 0.d0
do i = 1, N_det
do j = 1, N_det
- call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i), psi_det(1,1,j), N_int, hmono, htwoe, hthree, htot)
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i), psi_det(1,1,j), N_int, hmono, htwoe, hthree, htot)
E_TC = E_TC + psi_l_coef_bi_ortho(i,k) * psi_r_coef_bi_ortho(j,k) * htot
E_1e = E_1e + psi_l_coef_bi_ortho(i,k) * psi_r_coef_bi_ortho(j,k) * hmono
E_2e = E_2e + psi_l_coef_bi_ortho(i,k) * psi_r_coef_bi_ortho(j,k) * htwoe
@@ -37,6 +92,8 @@ subroutine write_tc_energy()
enddo
+ deallocate(E_TC_tmp, E_1e_tmp, E_2e_tmp, E_3e_tmp)
+
end
! ---
@@ -52,8 +109,8 @@ subroutine write_tc_var()
SIGMA_TC = 0.d0
do j = 2, N_det
- call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,1), psi_det(1,1,j), N_int, hmono, htwoe, hthree, htot_1j)
- call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot_j1)
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,1), psi_det(1,1,j), N_int, hmono, htwoe, hthree, htot_1j)
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot_j1)
SIGMA_TC = SIGMA_TC + htot_1j * htot_j1
enddo
@@ -66,3 +123,25 @@ end
! ---
+subroutine write_tc_gs_var_HF()
+
+ implicit none
+ integer :: i, j, k
+ double precision :: hmono, htwoe, hthree, htot
+ double precision :: SIGMA_TC
+
+ SIGMA_TC = 0.d0
+ do j = 2, N_det
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot)
+ SIGMA_TC = SIGMA_TC + htot * htot
+ enddo
+
+ print *, " SIGMA_TC = ", SIGMA_TC
+
+ call ezfio_set_tc_bi_ortho_tc_gs_var(SIGMA_TC)
+
+end
+
+! ---
+
+
diff --git a/plugins/local/tc_bi_ortho/test_natorb.irp.f b/plugins/local/tc_bi_ortho/test_natorb.irp.f
deleted file mode 100644
index 5b8801f7..00000000
--- a/plugins/local/tc_bi_ortho/test_natorb.irp.f
+++ /dev/null
@@ -1,64 +0,0 @@
-
-! ---
-
-program test_natorb
-
- BEGIN_DOC
- ! TODO : Reads psi_det in the EZFIO folder and prints out the left- and right-eigenvectors together with the energy. Saves the left-right wave functions at the end.
- END_DOC
-
- implicit none
-
- print *, 'Hello world'
-
- my_grid_becke = .True.
- PROVIDE tc_grid1_a tc_grid1_r
- my_n_pt_r_grid = tc_grid1_r
- my_n_pt_a_grid = tc_grid1_a
- touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
-
- read_wf = .True.
- touch read_wf
-
- call routine()
- ! call test()
-
-end
-
-! ---
-
-subroutine routine()
-
- implicit none
- double precision, allocatable :: fock_diag(:),eigval(:),leigvec(:,:),reigvec(:,:),mat_ref(:,:)
- allocate(eigval(mo_num),leigvec(mo_num,mo_num),reigvec(mo_num,mo_num),fock_diag(mo_num),mat_ref(mo_num, mo_num))
- double precision, allocatable :: eigval_ref(:),leigvec_ref(:,:),reigvec_ref(:,:)
- allocate(eigval_ref(mo_num),leigvec_ref(mo_num,mo_num),reigvec_ref(mo_num,mo_num))
-
- double precision :: thr_deg
- integer :: i,n_real,j
- print*,'fock_matrix'
- do i = 1, mo_num
- fock_diag(i) = Fock_matrix_mo(i,i)
- print*,i,fock_diag(i)
- enddo
- thr_deg = 1.d-6
- mat_ref = -one_e_dm_mo
- print*,'diagonalization by block'
- call diag_mat_per_fock_degen(fock_diag,mat_ref,mo_num,thr_deg,leigvec,reigvec,eigval)
- call non_hrmt_bieig( mo_num, mat_ref&
- , leigvec_ref, reigvec_ref&
- , n_real, eigval_ref)
- print*,'TEST ***********************************'
- double precision :: accu_l, accu_r
- do i = 1, mo_num
- accu_l = 0.d0
- accu_r = 0.d0
- do j = 1, mo_num
- accu_r += reigvec_ref(j,i) * reigvec(j,i)
- accu_l += leigvec_ref(j,i) * leigvec(j,i)
- enddo
- print*,i
- write(*,'(I3,X,100(F16.10,X))')i,eigval(i),eigval_ref(i),accu_l,accu_r
- enddo
-end
diff --git a/plugins/local/tc_bi_ortho/test_normal_order.irp.f b/plugins/local/tc_bi_ortho/test_normal_order.irp.f
deleted file mode 100644
index 0cf27396..00000000
--- a/plugins/local/tc_bi_ortho/test_normal_order.irp.f
+++ /dev/null
@@ -1,173 +0,0 @@
-
-! ---
-
-program test_normal_order
-
- BEGIN_DOC
- ! TODO : Put the documentation of the program here
- END_DOC
-
- implicit none
-
- print *, 'Hello world'
-
- my_grid_becke = .True.
- PROVIDE tc_grid1_a tc_grid1_r
- my_n_pt_r_grid = tc_grid1_r
- my_n_pt_a_grid = tc_grid1_a
- touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
-
- read_wf = .True.
- touch read_wf
-
- call provide_all_three_ints_bi_ortho()
- call test()
-
-end
-
-! ---
-
-subroutine test
- implicit none
- use bitmasks ! you need to include the bitmasks_module.f90 features
- integer :: h1,h2,p1,p2,s1,s2,i_ok,degree,Ne(2)
- integer :: exc(0:2,2,2)
- integer(bit_kind), allocatable :: det_i(:,:)
- double precision :: hmono,htwoe,hthree,htilde_ij,accu,phase,normal,hthree_tmp
- integer, allocatable :: occ(:,:)
- allocate( occ(N_int*bit_kind_size,2) )
- call bitstring_to_list_ab(ref_bitmask, occ, Ne, N_int)
- allocate(det_i(N_int,2))
- s1 = 1
- s2 = 2
- accu = 0.d0
- do h1 = 1, elec_beta_num
- do p1 = elec_alpha_num+1, mo_num
- do h2 = 1, elec_beta_num
- do p2 = elec_beta_num+1, mo_num
- hthree = 0.d0
-
- det_i = ref_bitmask
- s1 = 1
- s2 = 2
- call do_single_excitation(det_i,h1,p1,s1,i_ok)
- if(i_ok.ne.1)cycle
- call do_single_excitation(det_i,h2,p2,s2,i_ok)
- if(i_ok.ne.1)cycle
- call htilde_mu_mat_bi_ortho_slow(det_i,HF_bitmask,N_int,hmono,htwoe,hthree_tmp,htilde_ij)
- call get_excitation_degree(ref_bitmask,det_i,degree,N_int)
- call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int)
- hthree_tmp *= phase
- hthree += 0.5d0 * hthree_tmp
- det_i = ref_bitmask
- s1 = 2
- s2 = 1
- call do_single_excitation(det_i,h1,p1,s1,i_ok)
- if(i_ok.ne.1)cycle
- call do_single_excitation(det_i,h2,p2,s2,i_ok)
- if(i_ok.ne.1)cycle
- call htilde_mu_mat_bi_ortho_slow(det_i,HF_bitmask,N_int,hmono,htwoe,hthree_tmp,htilde_ij)
- call get_excitation_degree(ref_bitmask,det_i,degree,N_int)
- call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int)
- hthree_tmp *= phase
- hthree += 0.5d0 * hthree_tmp
-
-
-! normal = normal_two_body_bi_orth_ab(p2,h2,p1,h1)
- call give_aba_contraction(N_int, h1, h2, p1, p2, Ne, occ, normal)
- if(dabs(hthree).lt.1.d-10)cycle
- if(dabs(hthree-normal).gt.1.d-10)then
-! print*,pp2,pp1,hh2,hh1
- print*,p2,p1,h2,h1
- print*,hthree,normal,dabs(hthree-normal)
- stop
- endif
-! call three_comp_two_e_elem(det_i,h1,h2,p1,p2,s1,s2,normal)
-! normal = eff_2_e_from_3_e_ab(p2,p1,h2,h1)
- accu += dabs(hthree-normal)
- enddo
- enddo
- enddo
- enddo
-print*,'accu opposite spin = ',accu
-stop
-
-! p2=6
-! p1=5
-! h2=2
-! h1=1
-
-s1 = 1
-s2 = 1
-accu = 0.d0
-do h1 = 1, elec_alpha_num
- do p1 = elec_alpha_num+1, mo_num
- do p2 = p1+1, mo_num
- do h2 = h1+1, elec_alpha_num
- det_i = ref_bitmask
- call do_single_excitation(det_i,h1,p1,s1,i_ok)
- if(i_ok.ne.1)cycle
- call do_single_excitation(det_i,h2,p2,s2,i_ok)
- if(i_ok.ne.1)cycle
- call htilde_mu_mat_bi_ortho_slow(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
- call get_excitation_degree(ref_bitmask,det_i,degree,N_int)
- call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int)
- integer :: hh1, pp1, hh2, pp2, ss1, ss2
- call decode_exc(exc, 2, hh1, pp1, hh2, pp2, ss1, ss2)
- hthree *= phase
- normal = normal_two_body_bi_orth_aa_bb(p2,h2,p1,h1)
-! normal = eff_2_e_from_3_e_aa(p2,p1,h2,h1)
- if(dabs(hthree).lt.1.d-10)cycle
- if(dabs(hthree-normal).gt.1.d-10)then
- print*,pp2,pp1,hh2,hh1
- print*,p2,p1,h2,h1
- print*,hthree,normal,dabs(hthree-normal)
- stop
- endif
-! print*,hthree,normal,dabs(hthree-normal)
- accu += dabs(hthree-normal)
- enddo
- enddo
- enddo
-enddo
-print*,'accu same spin alpha = ',accu
-
-
-s1 = 2
-s2 = 2
-accu = 0.d0
-do h1 = 1, elec_beta_num
- do p1 = elec_beta_num+1, mo_num
- do p2 = p1+1, mo_num
- do h2 = h1+1, elec_beta_num
- det_i = ref_bitmask
- call do_single_excitation(det_i,h1,p1,s1,i_ok)
- if(i_ok.ne.1)cycle
- call do_single_excitation(det_i,h2,p2,s2,i_ok)
- if(i_ok.ne.1)cycle
- call htilde_mu_mat_bi_ortho_slow(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
- call get_excitation_degree(ref_bitmask,det_i,degree,N_int)
- call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int)
- call decode_exc(exc, 2, hh1, pp1, hh2, pp2, ss1, ss2)
- hthree *= phase
-! normal = normal_two_body_bi_orth_aa_bb(p2,h2,p1,h1)
- normal = eff_2_e_from_3_e_bb(p2,p1,h2,h1)
- if(dabs(hthree).lt.1.d-10)cycle
- if(dabs(hthree-normal).gt.1.d-10)then
- print*,pp2,pp1,hh2,hh1
- print*,p2,p1,h2,h1
- print*,hthree,normal,dabs(hthree-normal)
- stop
- endif
-! print*,hthree,normal,dabs(hthree-normal)
- accu += dabs(hthree-normal)
- enddo
- enddo
- enddo
-enddo
-print*,'accu same spin beta = ',accu
-
-
-end
-
-
diff --git a/plugins/local/tc_bi_ortho/test_s2_tc.irp.f b/plugins/local/tc_bi_ortho/test_s2_tc.irp.f
deleted file mode 100644
index 7c70b119..00000000
--- a/plugins/local/tc_bi_ortho/test_s2_tc.irp.f
+++ /dev/null
@@ -1,170 +0,0 @@
-
-! ---
-
-program test_tc
-
- implicit none
-
- my_grid_becke = .True.
- PROVIDE tc_grid1_a tc_grid1_r
- my_n_pt_r_grid = tc_grid1_r
- my_n_pt_a_grid = tc_grid1_a
- touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
-
- read_wf = .True.
- touch read_wf
-
- call provide_all_three_ints_bi_ortho()
- call routine_h_triple_left
- call routine_h_triple_right
-! call routine_test_s2_davidson
-
-end
-
-subroutine routine_h_triple_right
- implicit none
- logical :: do_right
- integer :: sze ,i, N_st, j
- double precision :: sij, accu_e, accu_s, accu_e_0, accu_s_0
- double precision, allocatable :: v_0_ref(:,:),u_0(:,:),s_0_ref(:,:)
- double precision, allocatable :: v_0_new(:,:),s_0_new(:,:)
- sze = N_det
- N_st = 1
- allocate(v_0_ref(N_det,1),u_0(N_det,1),s_0_ref(N_det,1),s_0_new(N_det,1),v_0_new(N_det,1))
- print*,'Checking first the Right '
- do i = 1, sze
- u_0(i,1) = psi_r_coef_bi_ortho(i,1)
- enddo
- double precision :: wall0,wall1
- call wall_time(wall0)
- call H_tc_s2_u_0_with_pure_three_omp(v_0_ref,s_0_ref, u_0,N_st,sze)
- call wall_time(wall1)
- print*,'time for omp',wall1 - wall0
- call wall_time(wall0)
- call H_tc_s2_u_0_with_pure_three(v_0_new, s_0_new, u_0, N_st, sze)
- call wall_time(wall1)
- print*,'time serial ',wall1 - wall0
- accu_e = 0.d0
- accu_s = 0.d0
- do i = 1, sze
- accu_e += dabs(v_0_ref(i,1) - v_0_new(i,1))
- accu_s += dabs(s_0_ref(i,1) - s_0_new(i,1))
- enddo
- print*,'accu_e = ',accu_e
- print*,'accu_s = ',accu_s
-
-end
-
-subroutine routine_h_triple_left
- implicit none
- logical :: do_right
- integer :: sze ,i, N_st, j
- double precision :: sij, accu_e, accu_s, accu_e_0, accu_s_0
- double precision, allocatable :: v_0_ref(:,:),u_0(:,:),s_0_ref(:,:)
- double precision, allocatable :: v_0_new(:,:),s_0_new(:,:)
- sze = N_det
- N_st = 1
- allocate(v_0_ref(N_det,1),u_0(N_det,1),s_0_ref(N_det,1),s_0_new(N_det,1),v_0_new(N_det,1))
- print*,'Checking the Left '
- do i = 1, sze
- u_0(i,1) = psi_l_coef_bi_ortho(i,1)
- enddo
- double precision :: wall0,wall1
- call wall_time(wall0)
- call H_tc_s2_dagger_u_0_with_pure_three_omp(v_0_ref,s_0_ref, u_0,N_st,sze)
- call wall_time(wall1)
- print*,'time for omp',wall1 - wall0
- call wall_time(wall0)
- call H_tc_s2_dagger_u_0_with_pure_three(v_0_new, s_0_new, u_0, N_st, sze)
- call wall_time(wall1)
- print*,'time serial ',wall1 - wall0
- accu_e = 0.d0
- accu_s = 0.d0
- do i = 1, sze
- accu_e += dabs(v_0_ref(i,1) - v_0_new(i,1))
- accu_s += dabs(s_0_ref(i,1) - s_0_new(i,1))
- enddo
- print*,'accu_e = ',accu_e
- print*,'accu_s = ',accu_s
-
-end
-
-
-subroutine routine_test_s2_davidson
- implicit none
- double precision, allocatable :: H_jj(:),vec_tmp(:,:), energies(:) , s2(:)
- integer :: i,istate
- logical :: converged
- external H_tc_s2_dagger_u_0_opt
- external H_tc_s2_u_0_opt
- allocate(H_jj(N_det),vec_tmp(N_det,n_states_diag),energies(n_states_diag), s2(n_states_diag))
- do i = 1, N_det
- call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,i), psi_det(1,1,i), N_int, H_jj(i))
- enddo
- ! Preparing the left-eigenvector
- print*,'Computing the left-eigenvector '
- vec_tmp = 0.d0
- do istate = 1, N_states
- vec_tmp(1:N_det,istate) = psi_l_coef_bi_ortho(1:N_det,istate)
- enddo
- do istate = N_states+1, n_states_diag
- vec_tmp(istate,istate) = 1.d0
- enddo
- do istate = 1, N_states
- leigvec_tc_bi_orth(1:N_det,istate) = vec_tmp(1:N_det,istate)
- enddo
- integer :: n_it_max
- n_it_max = 1
- call davidson_hs2_nonsym_b1space(vec_tmp, H_jj, s2, energies, N_det, n_states, n_states_diag, n_it_max, converged, H_tc_s2_dagger_u_0_opt)
- double precision, allocatable :: v_0_new(:,:),s_0_new(:,:)
- integer :: sze,N_st
- logical :: do_right
- sze = N_det
- N_st = 1
- do_right = .False.
- allocate(s_0_new(N_det,1),v_0_new(N_det,1))
- call H_tc_s2_u_0_nstates_openmp(v_0_new,s_0_new,vec_tmp,N_st,sze, do_right)
- double precision :: accu_e_0, accu_s_0
- accu_e_0 = 0.d0
- accu_s_0 = 0.d0
- do i = 1, sze
- accu_e_0 += v_0_new(i,1) * vec_tmp(i,1)
- accu_s_0 += s_0_new(i,1) * vec_tmp(i,1)
- enddo
- print*,'energies = ',energies
- print*,'s2 = ',s2
- print*,'accu_e_0',accu_e_0
- print*,'accu_s_0',accu_s_0
-
- ! Preparing the right-eigenvector
- print*,'Computing the right-eigenvector '
- vec_tmp = 0.d0
- do istate = 1, N_states
- vec_tmp(1:N_det,istate) = psi_r_coef_bi_ortho(1:N_det,istate)
- enddo
- do istate = N_states+1, n_states_diag
- vec_tmp(istate,istate) = 1.d0
- enddo
- do istate = 1, N_states
- leigvec_tc_bi_orth(1:N_det,istate) = vec_tmp(1:N_det,istate)
- enddo
- n_it_max = 1
- call davidson_hs2_nonsym_b1space(vec_tmp, H_jj, s2, energies, N_det, n_states, n_states_diag, n_it_max, converged, H_tc_s2_u_0_opt)
- sze = N_det
- N_st = 1
- do_right = .True.
- v_0_new = 0.d0
- s_0_new = 0.d0
- call H_tc_s2_u_0_nstates_openmp(v_0_new,s_0_new,vec_tmp,N_st,sze, do_right)
- accu_e_0 = 0.d0
- accu_s_0 = 0.d0
- do i = 1, sze
- accu_e_0 += v_0_new(i,1) * vec_tmp(i,1)
- accu_s_0 += s_0_new(i,1) * vec_tmp(i,1)
- enddo
- print*,'energies = ',energies
- print*,'s2 = ',s2
- print*,'accu_e_0',accu_e_0
- print*,'accu_s_0',accu_s_0
-
-end
diff --git a/plugins/local/tc_bi_ortho/test_tc_fock.irp.f b/plugins/local/tc_bi_ortho/test_tc_fock.irp.f
deleted file mode 100644
index f1a7cc0a..00000000
--- a/plugins/local/tc_bi_ortho/test_tc_fock.irp.f
+++ /dev/null
@@ -1,204 +0,0 @@
-
-! ---
-
-program test_tc_fock
-
- BEGIN_DOC
- ! TODO : Put the documentation of the program here
- END_DOC
-
- implicit none
-
- print *, 'Hello world'
-
- my_grid_becke = .True.
- PROVIDE tc_grid1_a tc_grid1_r
- my_n_pt_r_grid = tc_grid1_r
- my_n_pt_a_grid = tc_grid1_a
- touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
-
- read_wf = .True.
- touch read_wf
-
- !call routine_1
- !call routine_2
-! call routine_3()
-
-! call test_3e
- call routine_tot
-
-end
-
-! ---
-
-subroutine test_3e
- implicit none
- double precision :: integral_aaa,integral_aab,integral_abb,integral_bbb,accu
- double precision :: hmono, htwoe, hthree, htot
- call htilde_mu_mat_bi_ortho_slow(ref_bitmask, ref_bitmask, N_int, hmono, htwoe, hthree, htot)
- print*,'hmono = ',hmono
- print*,'htwoe = ',htwoe
- print*,'hthree= ',hthree
- print*,'htot = ',htot
- print*,''
- print*,''
- print*,'TC_one= ',tc_hf_one_e_energy
- print*,'TC_two= ',TC_HF_two_e_energy
- print*,'TC_3e = ',diag_three_elem_hf
- print*,'TC_tot= ',TC_HF_energy
- print*,''
- print*,''
- call give_aaa_contrib(integral_aaa)
- print*,'integral_aaa = ',integral_aaa
- call give_aab_contrib(integral_aab)
- print*,'integral_aab = ',integral_aab
- call give_abb_contrib(integral_abb)
- print*,'integral_abb = ',integral_abb
- call give_bbb_contrib(integral_bbb)
- print*,'integral_bbb = ',integral_bbb
- accu = integral_aaa + integral_aab + integral_abb + integral_bbb
- print*,'accu = ',accu
- print*,'delta = ',hthree - accu
-
-end
-
-subroutine routine_3()
-
- use bitmasks ! you need to include the bitmasks_module.f90 features
-
- implicit none
- integer :: i, a, i_ok, s1
- double precision :: hmono, htwoe, hthree, htilde_ij
- double precision :: err_ai, err_tot, ref, new
- integer(bit_kind), allocatable :: det_i(:,:)
-
- allocate(det_i(N_int,2))
-
- err_tot = 0.d0
-
- do s1 = 1, 2
-
- det_i = ref_bitmask
- call debug_det(det_i, N_int)
- print*, ' HF det'
- call debug_det(det_i, N_int)
-
- do i = 1, elec_num_tab(s1)
- do a = elec_num_tab(s1)+1, mo_num ! virtual
-
-
- det_i = ref_bitmask
- call do_single_excitation(det_i, i, a, s1, i_ok)
- if(i_ok == -1) then
- print*, 'PB !!'
- print*, i, a
- stop
- endif
- print*, ' excited det'
- call debug_det(det_i, N_int)
-
- call htilde_mu_mat_bi_ortho_slow(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij)
- if(dabs(hthree).lt.1.d-10)cycle
- ref = hthree
- if(s1 == 1)then
- new = fock_a_tot_3e_bi_orth(a,i)
- else if(s1 == 2)then
- new = fock_b_tot_3e_bi_orth(a,i)
- endif
- err_ai = dabs(dabs(ref) - dabs(new))
- if(err_ai .gt. 1d-7) then
- print*,'s1 = ',s1
- print*, ' warning on', i, a
- print*, ref,new,err_ai
- endif
- print*, ref,new,err_ai
- err_tot += err_ai
-
- write(22, *) htilde_ij
- enddo
- enddo
- enddo
-
- print *, ' err_tot = ', err_tot
-
- deallocate(det_i)
-
-end subroutine routine_3
-
-! ---
-subroutine routine_tot()
-
- use bitmasks ! you need to include the bitmasks_module.f90 features
-
- implicit none
- integer :: i, a, i_ok, s1,other_spin(2)
- double precision :: hmono, htwoe, hthree, htilde_ij
- double precision :: err_ai, err_tot, ref, new
- integer(bit_kind), allocatable :: det_i(:,:)
-
- allocate(det_i(N_int,2))
- other_spin(1) = 2
- other_spin(2) = 1
-
- err_tot = 0.d0
-
-! do s1 = 1, 2
- s1 = 2
- det_i = ref_bitmask
- call debug_det(det_i, N_int)
- print*, ' HF det'
- call debug_det(det_i, N_int)
-
-! do i = 1, elec_num_tab(s1)
-! do a = elec_num_tab(s1)+1, mo_num ! virtual
- do i = 1, elec_beta_num
- do a = elec_beta_num+1, mo_num! virtual
- print*,i,a
-
- det_i = ref_bitmask
- call do_single_excitation(det_i, i, a, s1, i_ok)
- if(i_ok == -1) then
- print*, 'PB !!'
- print*, i, a
- stop
- endif
-
- call htilde_mu_mat_bi_ortho_slow(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij)
- print*,htilde_ij
-! if(dabs(htilde_ij).lt.1.d-10)cycle
- print*, ' excited det'
- call debug_det(det_i, N_int)
-
- if(s1 == 1)then
- new = Fock_matrix_tc_mo_alpha(a,i)
- else
- new = Fock_matrix_tc_mo_beta(a,i)
- endif
- ref = htilde_ij
-! if(s1 == 1)then
-! new = fock_a_tot_3e_bi_orth(a,i)
-! else if(s1 == 2)then
-! new = fock_b_tot_3e_bi_orth(a,i)
-! endif
- err_ai = dabs(dabs(ref) - dabs(new))
- if(err_ai .gt. 1d-7) then
- print*,'---------'
- print*,'s1 = ',s1
- print*, ' warning on', i, a
- print*, ref,new,err_ai
- print*,hmono, htwoe, hthree
- print*,'---------'
- endif
- print*, ref,new,err_ai
- err_tot += err_ai
-
- write(22, *) htilde_ij
- enddo
- enddo
-! enddo
-
- print *, ' err_tot = ', err_tot
-
- deallocate(det_i)
-
-end subroutine routine_3
diff --git a/plugins/local/tc_keywords/EZFIO.cfg b/plugins/local/tc_keywords/EZFIO.cfg
index 68fe9c94..9ac22779 100644
--- a/plugins/local/tc_keywords/EZFIO.cfg
+++ b/plugins/local/tc_keywords/EZFIO.cfg
@@ -100,30 +100,12 @@ doc: If |true|, the states are re-ordered to match the input states
default: False
interface: ezfio,provider,ocaml
-[bi_ortho]
-type: logical
-doc: If |true|, the MO basis is assumed to be bi-orthonormal
-interface: ezfio,provider,ocaml
-default: True
-
-[symetric_fock_tc]
+[symmetric_fock_tc]
type: logical
doc: If |true|, using F+F^t as Fock TC
interface: ezfio,provider,ocaml
default: False
-[thresh_tcscf]
-type: Threshold
-doc: Threshold on the convergence of the Hartree Fock energy.
-interface: ezfio,provider,ocaml
-default: 1.e-8
-
-[n_it_tcscf_max]
-type: Strictly_positive_int
-doc: Maximum number of SCF iterations
-interface: ezfio,provider,ocaml
-default: 50
-
[selection_tc]
type: integer
doc: if +1: only positive is selected, -1: only negative is selected, :0 both positive and negative
@@ -160,30 +142,6 @@ doc: If |true|, maximize the overlap between orthogonalized left- and right eige
interface: ezfio,provider,ocaml
default: False
-[max_dim_diis_tcscf]
-type: integer
-doc: Maximum size of the DIIS extrapolation procedure
-interface: ezfio,provider,ocaml
-default: 15
-
-[level_shift_tcscf]
-type: Positive_float
-doc: Energy shift on the virtual MOs to improve TCSCF convergence
-interface: ezfio,provider,ocaml
-default: 0.
-
-[tcscf_algorithm]
-type: character*(32)
-doc: Type of TCSCF algorithm used. Possible choices are [Simple | DIIS]
-interface: ezfio,provider,ocaml
-default: DIIS
-
-[im_thresh_tcscf]
-type: Threshold
-doc: Thresholds on the Imag part of energy
-interface: ezfio,provider,ocaml
-default: 1.e-7
-
[test_cycle_tc]
type: logical
doc: If |true|, the integrals of the three-body jastrow are computed with cycles
@@ -226,12 +184,6 @@ doc: Read/Write normal_two_body_bi_orth from/to disk [ Write | Read | None ]
interface: ezfio,provider,ocaml
default: None
-[debug_tc_pt2]
-type: integer
-doc: If :: 1 then you compute the TC-PT2 the old way, :: 2 then you check with the new version but without three-body
-interface: ezfio,provider,ocaml
-default: -1
-
[only_spin_tc_right]
type: logical
doc: If |true|, only the right part of WF is used to compute spin dens
@@ -280,8 +232,45 @@ doc: approach used to evaluate TC integrals [ analytic | numeric | semi-analytic
interface: ezfio,ocaml,provider
default: semi-analytic
+[minimize_lr_angles]
+type: logical
+doc: If |true|, you minimize the angle between the left and right vectors associated to degenerate orbitals
+interface: ezfio,provider,ocaml
+default: False
+
[thresh_de_tc_angles]
type: Threshold
doc: Thresholds on delta E for changing angles between orbitals
interface: ezfio,provider,ocaml
-default: 1.e-03
+default: 1.e-6
+
+[ao_to_mo_tc_n3]
+type: logical
+doc: If |true|, memory scale of TC ao -> mo: O(N3)
+interface: ezfio,provider,ocaml
+default: False
+
+[tc_save_mem_loops]
+type: logical
+doc: If |true|, use loops to save memory TC
+interface: ezfio,provider,ocaml
+default: False
+
+[tc_save_mem]
+type: logical
+doc: If |true|, more calc but less mem
+interface: ezfio,provider,ocaml
+default: False
+
+[im_thresh_tc]
+type: Threshold
+doc: Thresholds on the Imag part of TC energy
+interface: ezfio,provider,ocaml
+default: 1.e-7
+
+[transpose_two_e_int]
+type: logical
+doc: If |true|, you duplicate the two-electron TC integrals with the transpose matrix. Acceleates the PT2.
+interface: ezfio,provider,ocaml
+default: False
+>>>>>>> 8c4183cf6e38711b097df202d1f430b76823aeff
diff --git a/plugins/local/tc_progs/NEED b/plugins/local/tc_progs/NEED
new file mode 100644
index 00000000..9deb3db4
--- /dev/null
+++ b/plugins/local/tc_progs/NEED
@@ -0,0 +1 @@
+tc_bi_ortho
diff --git a/plugins/local/tc_bi_ortho/print_he_tc_energy.irp.f b/plugins/local/tc_progs/print_he_tc_energy.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/print_he_tc_energy.irp.f
rename to plugins/local/tc_progs/print_he_tc_energy.irp.f
diff --git a/plugins/local/tc_bi_ortho/print_tc_dump.irp.f b/plugins/local/tc_progs/print_tc_dump.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/print_tc_dump.irp.f
rename to plugins/local/tc_progs/print_tc_dump.irp.f
diff --git a/plugins/local/tc_progs/print_tc_energy.irp.f b/plugins/local/tc_progs/print_tc_energy.irp.f
new file mode 100644
index 00000000..979d792b
--- /dev/null
+++ b/plugins/local/tc_progs/print_tc_energy.irp.f
@@ -0,0 +1,53 @@
+program print_tc_energy
+
+ BEGIN_DOC
+ ! TODO : Put the documentation of the program here
+ END_DOC
+
+ implicit none
+
+ read_wf = .True.
+ touch read_wf
+
+ my_grid_becke = .True.
+ PROVIDE tc_grid1_a tc_grid1_r
+ my_n_pt_r_grid = tc_grid1_r
+ my_n_pt_a_grid = tc_grid1_a
+ touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
+
+ call write_int(6, my_n_pt_r_grid, 'radial external grid over')
+ call write_int(6, my_n_pt_a_grid, 'angular external grid over')
+
+ if(tc_integ_type .eq. "numeric") then
+ my_extra_grid_becke = .True.
+ PROVIDE tc_grid2_a tc_grid2_r
+ my_n_pt_r_extra_grid = tc_grid2_r
+ my_n_pt_a_extra_grid = tc_grid2_a
+ touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid
+
+ call write_int(6, my_n_pt_r_extra_grid, 'radial internal grid over')
+ call write_int(6, my_n_pt_a_extra_grid, 'angular internal grid over')
+ endif
+
+ call main()
+
+end
+
+! ---
+
+subroutine main()
+
+ implicit none
+
+ PROVIDE j2e_type
+ PROVIDE j1e_type
+ PROVIDE env_type
+
+ print *, ' j2e_type = ', j2e_type
+ print *, ' j1e_type = ', j1e_type
+ print *, ' env_type = ', env_type
+
+ call write_tc_energy()
+
+end
+
diff --git a/plugins/local/tc_bi_ortho/print_tc_spin_dens.irp.f b/plugins/local/tc_progs/print_tc_spin_dens.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/print_tc_spin_dens.irp.f
rename to plugins/local/tc_progs/print_tc_spin_dens.irp.f
diff --git a/plugins/local/tc_bi_ortho/print_tc_var.irp.f b/plugins/local/tc_progs/print_tc_var.irp.f
similarity index 70%
rename from plugins/local/tc_bi_ortho/print_tc_var.irp.f
rename to plugins/local/tc_progs/print_tc_var.irp.f
index bec34f18..6743cd11 100644
--- a/plugins/local/tc_bi_ortho/print_tc_var.irp.f
+++ b/plugins/local/tc_progs/print_tc_var.irp.f
@@ -6,7 +6,8 @@ program print_tc_var
implicit none
- print *, 'Hello world'
+ print *, ' TC VAR is available only for HF REF WF'
+ print *, ' DO NOT FORGET TO RUN A CISD CALCULATION BEF'
my_grid_becke = .True.
PROVIDE tc_grid1_a tc_grid1_r
@@ -17,7 +18,7 @@ program print_tc_var
read_wf = .True.
touch read_wf
- call write_tc_var()
+ call write_tc_gs_var_HF()
end
diff --git a/plugins/local/tc_bi_ortho/print_tc_wf.irp.f b/plugins/local/tc_progs/print_tc_wf.irp.f
similarity index 91%
rename from plugins/local/tc_bi_ortho/print_tc_wf.irp.f
rename to plugins/local/tc_progs/print_tc_wf.irp.f
index 4d9f7c48..3e010e01 100644
--- a/plugins/local/tc_bi_ortho/print_tc_wf.irp.f
+++ b/plugins/local/tc_progs/print_tc_wf.irp.f
@@ -61,12 +61,12 @@ subroutine routine
do i = 1, N_det
call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
if(degree == 1 .or. degree == 2)then
- call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
- call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0)
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0)
delta_e = e_tilde_00 - e_i0
coef_pt1 = htilde_ij / delta_e
- call htilde_mu_mat_bi_ortho_slow(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
+ call htilde_mu_mat_opt_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
contrib_pt = coef_pt1 * htilde_ij
e_pt2 += contrib_pt
diff --git a/plugins/local/tc_bi_ortho/save_bitcpsileft_for_qmcchem.irp.f b/plugins/local/tc_progs/save_bitcpsileft_for_qmcchem.irp.f
similarity index 91%
rename from plugins/local/tc_bi_ortho/save_bitcpsileft_for_qmcchem.irp.f
rename to plugins/local/tc_progs/save_bitcpsileft_for_qmcchem.irp.f
index efa4aa2c..ac90f737 100644
--- a/plugins/local/tc_bi_ortho/save_bitcpsileft_for_qmcchem.irp.f
+++ b/plugins/local/tc_progs/save_bitcpsileft_for_qmcchem.irp.f
@@ -38,9 +38,9 @@ subroutine main()
call ezfio_has_cisd_energy(exists)
if(.not.exists) then
- call ezfio_has_tc_scf_bitc_energy(exists)
+ call ezfio_has_tc_scf_tcscf_energy(exists)
if(exists) then
- call ezfio_get_tc_scf_bitc_energy(e_ref)
+ call ezfio_get_tc_scf_tcscf_energy(e_ref)
endif
else
@@ -59,7 +59,7 @@ subroutine main()
close(iunit)
-end subroutine main
+end
! --
@@ -89,7 +89,7 @@ subroutine write_lr_spindeterminants()
call ezfio_set_spindeterminants_psi_left_coef_matrix_values(buffer)
deallocate(buffer)
-end subroutine write_lr_spindeterminants
+end
! ---
diff --git a/plugins/local/tc_bi_ortho/save_tc_bi_ortho_nat.irp.f b/plugins/local/tc_progs/save_tc_bi_ortho_nat.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/save_tc_bi_ortho_nat.irp.f
rename to plugins/local/tc_progs/save_tc_bi_ortho_nat.irp.f
diff --git a/plugins/local/tc_bi_ortho/select_dets_bi_ortho.irp.f b/plugins/local/tc_progs/select_dets_bi_ortho.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/select_dets_bi_ortho.irp.f
rename to plugins/local/tc_progs/select_dets_bi_ortho.irp.f
diff --git a/plugins/local/tc_bi_ortho/tc_bi_ortho_prop.irp.f b/plugins/local/tc_progs/tc_bi_ortho_prop.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/tc_bi_ortho_prop.irp.f
rename to plugins/local/tc_progs/tc_bi_ortho_prop.irp.f
diff --git a/plugins/local/tc_bi_ortho/tc_som.irp.f b/plugins/local/tc_progs/tc_som.irp.f
similarity index 82%
rename from plugins/local/tc_bi_ortho/tc_som.irp.f
rename to plugins/local/tc_progs/tc_som.irp.f
index 1d11c81b..6bdcc1f0 100644
--- a/plugins/local/tc_bi_ortho/tc_som.irp.f
+++ b/plugins/local/tc_progs/tc_som.irp.f
@@ -49,8 +49,8 @@ subroutine main()
U_SOM = 0.d0
do i = 1, N_det
if(i == i_HF) cycle
- call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i_HF), psi_det(1,1,i), N_int, hmono_1, htwoe_1, hthree_1, htot_1)
- call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i), psi_det(1,1,i_HF), N_int, hmono_2, htwoe_2, hthree_2, htot_2)
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i_HF), psi_det(1,1,i), N_int, hmono_1, htwoe_1, hthree_1, htot_1)
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i), psi_det(1,1,i_HF), N_int, hmono_2, htwoe_2, hthree_2, htot_2)
U_SOM += htot_1 * htot_2
enddo
U_SOM = 0.5d0 * U_SOM
diff --git a/plugins/local/tc_bi_ortho/test_tc_two_rdm.irp.f b/plugins/local/tc_progs/test_tc_two_rdm.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/test_tc_two_rdm.irp.f
rename to plugins/local/tc_progs/test_tc_two_rdm.irp.f
diff --git a/plugins/local/tc_scf/EZFIO.cfg b/plugins/local/tc_scf/EZFIO.cfg
index 3dfa9a71..e3d24338 100644
--- a/plugins/local/tc_scf/EZFIO.cfg
+++ b/plugins/local/tc_scf/EZFIO.cfg
@@ -1,6 +1,6 @@
-[bitc_energy]
+[tcscf_energy]
type: Threshold
-doc: Energy bi-tc HF
+doc: TC-SCF ENERGY
interface: ezfio
[converged_tcscf]
@@ -9,3 +9,33 @@ doc: If |true|, tc-scf has converged
interface: ezfio,provider,ocaml
default: False
+[max_dim_diis_tcscf]
+type: integer
+doc: Maximum size of the DIIS extrapolation procedure
+interface: ezfio,provider,ocaml
+default: 15
+
+[level_shift_tcscf]
+type: Positive_float
+doc: Energy shift on the virtual MOs to improve TCSCF convergence
+interface: ezfio,provider,ocaml
+default: 0.
+
+[thresh_tcscf]
+type: Threshold
+doc: Threshold on the convergence of the Hartree Fock energy.
+interface: ezfio,provider,ocaml
+default: 1.e-8
+
+[n_it_tcscf_max]
+type: Strictly_positive_int
+doc: Maximum number of SCF iterations
+interface: ezfio,provider,ocaml
+default: 50
+
+[tc_Brillouin_Right]
+type: logical
+doc: If |true|, impose only right-Brillouin condition
+interface: ezfio,provider,ocaml
+default: False
+
diff --git a/plugins/local/tc_scf/combine_lr_tcscf.irp.f b/plugins/local/tc_scf/combine_lr_tcscf.irp.f
deleted file mode 100644
index a22614ba..00000000
--- a/plugins/local/tc_scf/combine_lr_tcscf.irp.f
+++ /dev/null
@@ -1,75 +0,0 @@
-
-! ---
-
-program combine_lr_tcscf
-
- BEGIN_DOC
- ! TODO : Put the documentation of the program here
- END_DOC
-
- implicit none
-
- my_grid_becke = .True.
- PROVIDE tc_grid1_a tc_grid1_r
- my_n_pt_r_grid = tc_grid1_r
- my_n_pt_a_grid = tc_grid1_a
- touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
-
- bi_ortho = .True.
- touch bi_ortho
-
- call comb_orbitals()
-
-end
-
-! ---
-
-subroutine comb_orbitals()
-
- implicit none
- integer :: i, m, n, nn, mm
- double precision :: accu_d, accu_nd
- double precision, allocatable :: R(:,:), L(:,:), Rnew(:,:), tmp(:,:), S(:,:)
-
- n = ao_num
- m = mo_num
- nn = elec_alpha_num
- mm = m - nn
-
- allocate(L(n,m), R(n,m), Rnew(n,m), S(m,m))
- L = mo_l_coef
- R = mo_r_coef
-
- call check_weighted_biorthog(n, m, ao_overlap, L, R, accu_d, accu_nd, S, .true.)
-
- allocate(tmp(n,nn))
- do i = 1, nn
- tmp(1:n,i) = R(1:n,i)
- enddo
- call impose_weighted_orthog_svd(n, nn, ao_overlap, tmp)
- do i = 1, nn
- Rnew(1:n,i) = tmp(1:n,i)
- enddo
- deallocate(tmp)
-
- allocate(tmp(n,mm))
- do i = 1, mm
- tmp(1:n,i) = L(1:n,i+nn)
- enddo
- call impose_weighted_orthog_svd(n, mm, ao_overlap, tmp)
- do i = 1, mm
- Rnew(1:n,i+nn) = tmp(1:n,i)
- enddo
- deallocate(tmp)
-
- call check_weighted_biorthog(n, m, ao_overlap, Rnew, Rnew, accu_d, accu_nd, S, .true.)
-
- mo_r_coef = Rnew
- call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef)
-
- deallocate(L, R, Rnew, S)
-
-end subroutine comb_orbitals
-
-! ---
-
diff --git a/plugins/local/tc_scf/diago_vartcfock.irp.f b/plugins/local/tc_scf/diago_vartcfock.irp.f
deleted file mode 100644
index 0c881dcb..00000000
--- a/plugins/local/tc_scf/diago_vartcfock.irp.f
+++ /dev/null
@@ -1,96 +0,0 @@
-
-! ---
-
-BEGIN_PROVIDER [ double precision, fock_vartc_eigvec_mo, (mo_num, mo_num)]
-
- implicit none
-
- integer :: i, j
- integer :: liwork, lwork, n, info
- integer, allocatable :: iwork(:)
- double precision, allocatable :: work(:), F(:,:), F_save(:,:)
- double precision, allocatable :: diag(:)
-
- PROVIDE mo_r_coef
- PROVIDE Fock_matrix_vartc_mo_tot
-
- allocate( F(mo_num,mo_num), F_save(mo_num,mo_num) )
- allocate (diag(mo_num) )
-
- do j = 1, mo_num
- do i = 1, mo_num
- F(i,j) = Fock_matrix_vartc_mo_tot(i,j)
- enddo
- enddo
-
- ! Insert level shift here
- do i = elec_beta_num+1, elec_alpha_num
- F(i,i) += 0.5d0 * level_shift_tcscf
- enddo
- do i = elec_alpha_num+1, mo_num
- F(i,i) += level_shift_tcscf
- enddo
-
- n = mo_num
- lwork = 1+6*n + 2*n*n
- liwork = 3 + 5*n
-
- allocate(work(lwork))
- allocate(iwork(liwork) )
-
- lwork = -1
- liwork = -1
-
- F_save = F
- call dsyevd('V', 'U', mo_num, F, size(F, 1), diag, work, lwork, iwork, liwork, info)
-
- if (info /= 0) then
- print *, irp_here//' DSYEVD failed : ', info
- stop 1
- endif
- lwork = int(work(1))
- liwork = iwork(1)
- deallocate(iwork)
- deallocate(work)
-
- allocate(work(lwork))
- allocate(iwork(liwork) )
- call dsyevd('V', 'U', mo_num, F, size(F, 1), diag, work, lwork, iwork, liwork, info)
- deallocate(iwork)
-
- if (info /= 0) then
- F = F_save
- call dsyev('V', 'L', mo_num, F, size(F, 1), diag, work, lwork, info)
-
- if (info /= 0) then
- print *, irp_here//' DSYEV failed : ', info
- stop 1
- endif
- endif
-
- do i = 1, mo_num
- do j = 1, mo_num
- fock_vartc_eigvec_mo(j,i) = F(j,i)
- enddo
- enddo
-
- deallocate(work, F, F_save, diag)
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [ double precision, fock_vartc_eigvec_ao, (ao_num, mo_num)]
-
- implicit none
-
- PROVIDE mo_r_coef
-
- call dgemm( 'N', 'N', ao_num, mo_num, mo_num, 1.d0 &
- , mo_r_coef, size(mo_r_coef, 1), fock_vartc_eigvec_mo, size(fock_vartc_eigvec_mo, 1) &
- , 0.d0, fock_vartc_eigvec_ao, size(fock_vartc_eigvec_ao, 1))
-
-END_PROVIDER
-
-! ---
-
diff --git a/plugins/local/tc_scf/diis_tcscf.irp.f b/plugins/local/tc_scf/diis_tcscf.irp.f
index 5d7d6b2e..ccc8eb15 100644
--- a/plugins/local/tc_scf/diis_tcscf.irp.f
+++ b/plugins/local/tc_scf/diis_tcscf.irp.f
@@ -91,28 +91,14 @@ BEGIN_PROVIDER [double precision, FQS_SQF_ao, (ao_num, ao_num)]
double precision, allocatable :: tmp(:,:)
double precision, allocatable :: F(:,:)
- !print *, ' Providing FQS_SQF_ao ...'
- !call wall_time(t0)
+ PROVIDE Fock_matrix_tc_ao_tot
allocate(F(ao_num,ao_num))
- if(var_tc) then
-
- do i = 1, ao_num
- do j = 1, ao_num
- F(j,i) = Fock_matrix_vartc_ao_tot(j,i)
- enddo
+ do i = 1, ao_num
+ do j = 1, ao_num
+ F(j,i) = Fock_matrix_tc_ao_tot(j,i)
enddo
-
- else
-
- PROVIDE Fock_matrix_tc_ao_tot
- do i = 1, ao_num
- do j = 1, ao_num
- F(j,i) = Fock_matrix_tc_ao_tot(j,i)
- enddo
- enddo
-
- endif
+ enddo
allocate(tmp(ao_num,ao_num))
@@ -140,9 +126,6 @@ BEGIN_PROVIDER [double precision, FQS_SQF_ao, (ao_num, ao_num)]
deallocate(tmp)
deallocate(F)
- !call wall_time(t1)
- !print *, ' Wall time for FQS_SQF_ao =', t1-t0
-
END_PROVIDER
! ---
@@ -152,61 +135,13 @@ BEGIN_PROVIDER [double precision, FQS_SQF_mo, (mo_num, mo_num)]
implicit none
double precision :: t0, t1
- !print*, ' Providing FQS_SQF_mo ...'
- !call wall_time(t0)
-
PROVIDE mo_r_coef mo_l_coef
PROVIDE FQS_SQF_ao
call ao_to_mo_bi_ortho( FQS_SQF_ao, size(FQS_SQF_ao, 1) &
, FQS_SQF_mo, size(FQS_SQF_mo, 1) )
- !call wall_time(t1)
- !print*, ' Wall time for FQS_SQF_mo =', t1-t0
-
END_PROVIDER
! ---
-! BEGIN_PROVIDER [ double precision, eigenval_Fock_tc_ao, (ao_num) ]
-!&BEGIN_PROVIDER [ double precision, eigenvec_Fock_tc_ao, (ao_num,ao_num) ]
-!
-! BEGIN_DOC
-! !
-! ! Eigenvalues and eigenvectors of the Fock matrix over the ao basis
-! !
-! ! F' = X.T x F x X where X = ao_overlap^(-1/2)
-! !
-! ! F' x Cr' = Cr' x E ==> F Cr = Cr x E with Cr = X x Cr'
-! ! F'.T x Cl' = Cl' x E ==> F.T Cl = Cl x E with Cl = X x Cl'
-! !
-! END_DOC
-!
-! implicit none
-! double precision, allocatable :: tmp1(:,:), tmp2(:,:)
-!
-! ! ---
-! ! Fock matrix in orthogonal basis: F' = X.T x F x X
-!
-! allocate(tmp1(ao_num,ao_num))
-! call dgemm( 'N', 'N', ao_num, ao_num, ao_num, 1.d0 &
-! , Fock_matrix_tc_ao_tot, size(Fock_matrix_tc_ao_tot, 1), S_half_inv, size(S_half_inv, 1) &
-! , 0.d0, tmp1, size(tmp1, 1) )
-!
-! allocate(tmp2(ao_num,ao_num))
-! call dgemm( 'T', 'N', ao_num, ao_num, ao_num, 1.d0 &
-! , S_half_inv, size(S_half_inv, 1), tmp1, size(tmp1, 1) &
-! , 0.d0, tmp2, size(tmp2, 1) )
-!
-! ! ---
-!
-! ! Diagonalize F' to obtain eigenvectors in orthogonal basis C' and eigenvalues
-! ! TODO
-!
-! ! Back-transform eigenvectors: C =X.C'
-!
-!END_PROVIDER
-
-! ---
-
-~
diff --git a/plugins/local/tc_scf/fock_3e_bi_ortho_cs.irp.f b/plugins/local/tc_scf/fock_3e_bi_ortho_cs.irp.f
deleted file mode 100644
index 0b883865..00000000
--- a/plugins/local/tc_scf/fock_3e_bi_ortho_cs.irp.f
+++ /dev/null
@@ -1,280 +0,0 @@
-
-! ---
-
-BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_cs, (mo_num, mo_num)]
-
- implicit none
- integer :: a, b, i, j, ipoint
- double precision :: ti, tf
- double precision :: loc_1, loc_2, loc_3
- double precision, allocatable :: Okappa(:), Jkappa(:,:)
- double precision, allocatable :: tmp_omp_d1(:), tmp_omp_d2(:,:)
- double precision, allocatable :: tmp_1(:,:), tmp_2(:,:,:,:)
- double precision, allocatable :: tmp_3(:,:,:), tmp_4(:,:,:)
-
- PROVIDE mo_l_coef mo_r_coef
-
- !print *, ' PROVIDING fock_3e_uhf_mo_cs ...'
- !call wall_time(ti)
-
- ! ---
-
- allocate(Jkappa(n_points_final_grid,3), Okappa(n_points_final_grid))
- Jkappa = 0.d0
- Okappa = 0.d0
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, i, tmp_omp_d1, tmp_omp_d2) &
- !$OMP SHARED (n_points_final_grid, elec_beta_num, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, Okappa, Jkappa)
-
- allocate(tmp_omp_d2(n_points_final_grid,3), tmp_omp_d1(n_points_final_grid))
- tmp_omp_d2 = 0.d0
- tmp_omp_d1 = 0.d0
-
- !$OMP DO
- do i = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
- tmp_omp_d2(ipoint,1) += int2_grad1_u12_bimo_t(ipoint,1,i,i)
- tmp_omp_d2(ipoint,2) += int2_grad1_u12_bimo_t(ipoint,2,i,i)
- tmp_omp_d2(ipoint,3) += int2_grad1_u12_bimo_t(ipoint,3,i,i)
- tmp_omp_d1(ipoint) += mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
- do ipoint = 1, n_points_final_grid
- Jkappa(ipoint,1) += tmp_omp_d2(ipoint,1)
- Jkappa(ipoint,2) += tmp_omp_d2(ipoint,2)
- Jkappa(ipoint,3) += tmp_omp_d2(ipoint,3)
- Okappa(ipoint) += tmp_omp_d1(ipoint)
- enddo
- !$OMP END CRITICAL
-
- deallocate(tmp_omp_d2, tmp_omp_d1)
-
- !$OMP END PARALLEL
-
- ! ---
-
- allocate(tmp_1(n_points_final_grid,4))
-
- do ipoint = 1, n_points_final_grid
-
- loc_1 = 2.d0 * Okappa(ipoint)
-
- tmp_1(ipoint,1) = loc_1 * Jkappa(ipoint,1)
- tmp_1(ipoint,2) = loc_1 * Jkappa(ipoint,2)
- tmp_1(ipoint,3) = loc_1 * Jkappa(ipoint,3)
-
- tmp_1(ipoint,4) = Okappa(ipoint)
- enddo
-
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, i, j, loc_1, tmp_omp_d2) &
- !$OMP SHARED (n_points_final_grid, elec_beta_num, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, tmp_1)
-
- allocate(tmp_omp_d2(n_points_final_grid,3))
- tmp_omp_d2 = 0.d0
-
- !$OMP DO COLLAPSE(2)
- do i = 1, elec_beta_num
- do j = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
-
- loc_1 = mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
-
- tmp_omp_d2(ipoint,1) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,1,i,j)
- tmp_omp_d2(ipoint,2) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,2,i,j)
- tmp_omp_d2(ipoint,3) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,3,i,j)
- enddo
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
- do ipoint = 1, n_points_final_grid
- tmp_1(ipoint,1) += tmp_omp_d2(ipoint,1)
- tmp_1(ipoint,2) += tmp_omp_d2(ipoint,2)
- tmp_1(ipoint,3) += tmp_omp_d2(ipoint,3)
- enddo
- !$OMP END CRITICAL
-
- deallocate(tmp_omp_d2)
- !$OMP END PARALLEL
-
- ! ---
-
- allocate(tmp_2(n_points_final_grid,4,mo_num,mo_num))
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, a, b) &
- !$OMP SHARED (n_points_final_grid, mo_num, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, &
- !$OMP tmp_2)
- !$OMP DO COLLAPSE(2)
- do a = 1, mo_num
- do b = 1, mo_num
- do ipoint = 1, n_points_final_grid
- tmp_2(ipoint,1,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,b,a)
- tmp_2(ipoint,2,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,b,a)
- tmp_2(ipoint,3,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,b,a)
- enddo
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, a, b, i) &
- !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, &
- !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
- !$OMP tmp_2)
- !$OMP DO COLLAPSE(2)
- do a = 1, mo_num
- do b = 1, mo_num
- tmp_2(:,4,b,a) = 0.d0
- do i = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
- tmp_2(ipoint,4,b,a) -= final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,a) &
- + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,a) &
- + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,a) )
- enddo
- enddo
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- ! ---
-
- call dgemv( 'T', 4*n_points_final_grid, mo_num*mo_num, -2.d0 &
- , tmp_2(1,1,1,1), size(tmp_2, 1) * size(tmp_2, 2) &
- , tmp_1(1,1), 1 &
- , 0.d0, fock_3e_uhf_mo_cs(1,1), 1)
-
- deallocate(tmp_1, tmp_2)
-
- ! ---
-
- allocate(tmp_3(n_points_final_grid,5,mo_num), tmp_4(n_points_final_grid,5,mo_num))
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, b, loc_1, loc_2) &
- !$OMP SHARED (n_points_final_grid, mo_num, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP final_weight_at_r_vector, Jkappa, tmp_3, tmp_4)
- !$OMP DO
- do b = 1, mo_num
- tmp_3(:,:,b) = 0.d0
- tmp_4(:,:,b) = 0.d0
- do ipoint = 1, n_points_final_grid
- tmp_3(ipoint,1,b) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,b)
-
- tmp_4(ipoint,1,b) = -2.d0 * mos_r_in_r_array_transp(ipoint,b) * ( Jkappa(ipoint,1) * Jkappa(ipoint,1) &
- + Jkappa(ipoint,2) * Jkappa(ipoint,2) &
- + Jkappa(ipoint,3) * Jkappa(ipoint,3) )
- tmp_4(ipoint,5,b) = mos_r_in_r_array_transp(ipoint,b)
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, b, i, loc_1, loc_2) &
- !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, &
- !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP Jkappa, tmp_3, tmp_4)
- !$OMP DO
- do b = 1, mo_num
- do i = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
-
- loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
- loc_2 = mos_r_in_r_array_transp(ipoint,i)
-
- tmp_3(ipoint,2,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,1,b,i)
- tmp_3(ipoint,3,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,2,b,i)
- tmp_3(ipoint,4,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,3,b,i)
- tmp_3(ipoint,5,b) += 2.d0 * loc_1 * ( Jkappa(ipoint,1) * int2_grad1_u12_bimo_t(ipoint,1,b,i) &
- + Jkappa(ipoint,2) * int2_grad1_u12_bimo_t(ipoint,2,b,i) &
- + Jkappa(ipoint,3) * int2_grad1_u12_bimo_t(ipoint,3,b,i) )
-
- tmp_4(ipoint,2,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,1,i,b)
- tmp_4(ipoint,3,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,2,i,b)
- tmp_4(ipoint,4,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,3,i,b)
- tmp_4(ipoint,1,b) += 2.d0 * loc_2 * ( Jkappa(ipoint,1) * int2_grad1_u12_bimo_t(ipoint,1,i,b) &
- + Jkappa(ipoint,2) * int2_grad1_u12_bimo_t(ipoint,2,i,b) &
- + Jkappa(ipoint,3) * int2_grad1_u12_bimo_t(ipoint,3,i,b) )
- enddo
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, b, i, j, loc_1, loc_2, loc_3) &
- !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, &
- !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP tmp_3, tmp_4)
- !$OMP DO
- do b = 1, mo_num
- do i = 1, elec_beta_num
- do j = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
-
- loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,j)
- loc_2 = mos_r_in_r_array_transp(ipoint,b)
- loc_3 = mos_r_in_r_array_transp(ipoint,i)
-
- tmp_3(ipoint,5,b) -= loc_1 * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,j) &
- + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,j) &
- + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,j) )
-
- tmp_4(ipoint,1,b) += ( loc_2 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) ) &
- - loc_3 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,b) &
- + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,b) &
- + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,b) ) )
- enddo
- enddo
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- ! ---
-
- call dgemm( 'T', 'N', mo_num, mo_num, 5*n_points_final_grid, 1.d0 &
- , tmp_3(1,1,1), 5*n_points_final_grid &
- , tmp_4(1,1,1), 5*n_points_final_grid &
- , 1.d0, fock_3e_uhf_mo_cs(1,1), mo_num)
-
- deallocate(tmp_3, tmp_4)
- deallocate(Jkappa, Okappa)
-
- ! ---
-
- !call wall_time(tf)
- !print *, ' total Wall time for fock_3e_uhf_mo_cs =', tf - ti
-
-END_PROVIDER
-
-! ---
-
diff --git a/plugins/local/tc_scf/fock_3e_bi_ortho_os.irp.f b/plugins/local/tc_scf/fock_3e_bi_ortho_os.irp.f
deleted file mode 100644
index 4bbce720..00000000
--- a/plugins/local/tc_scf/fock_3e_bi_ortho_os.irp.f
+++ /dev/null
@@ -1,536 +0,0 @@
-
-! ---
-
- BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a_os, (mo_num, mo_num)]
-&BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b_os, (mo_num, mo_num)]
-
- BEGIN_DOC
- !
- ! Open Shell part of the Fock matrix from three-electron terms
- !
- ! WARNING :: non hermitian if bi-ortho MOS used
- !
- END_DOC
-
- implicit none
- integer :: a, b, i, j, ipoint
- double precision :: loc_1, loc_2, loc_3, loc_4
- double precision :: ti, tf
- double precision, allocatable :: Okappa(:), Jkappa(:,:), Obarkappa(:), Jbarkappa(:,:)
- double precision, allocatable :: tmp_omp_d1(:), tmp_omp_d2(:,:)
- double precision, allocatable :: tmp_1(:,:), tmp_2(:,:,:,:)
- double precision, allocatable :: tmp_3(:,:,:), tmp_4(:,:,:)
-
- PROVIDE mo_l_coef mo_r_coef
-
- !print *, ' Providing fock_3e_uhf_mo_a_os and fock_3e_uhf_mo_b_os ...'
- !call wall_time(ti)
-
- ! ---
-
- allocate(Jkappa(n_points_final_grid,3), Okappa(n_points_final_grid))
- allocate(Jbarkappa(n_points_final_grid,3), Obarkappa(n_points_final_grid))
- Jkappa = 0.d0
- Okappa = 0.d0
- Jbarkappa = 0.d0
- Obarkappa = 0.d0
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, i, tmp_omp_d1, tmp_omp_d2) &
- !$OMP SHARED (n_points_final_grid, elec_beta_num, elec_alpha_num, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, Okappa, Jkappa, Obarkappa, Jbarkappa)
-
- allocate(tmp_omp_d2(n_points_final_grid,3), tmp_omp_d1(n_points_final_grid))
-
- tmp_omp_d2 = 0.d0
- tmp_omp_d1 = 0.d0
- !$OMP DO
- do i = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
- tmp_omp_d2(ipoint,1) += int2_grad1_u12_bimo_t(ipoint,1,i,i)
- tmp_omp_d2(ipoint,2) += int2_grad1_u12_bimo_t(ipoint,2,i,i)
- tmp_omp_d2(ipoint,3) += int2_grad1_u12_bimo_t(ipoint,3,i,i)
- tmp_omp_d1(ipoint) += mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
- enddo
- enddo
- !$OMP END DO NOWAIT
- !$OMP CRITICAL
- do ipoint = 1, n_points_final_grid
- Jkappa(ipoint,1) += tmp_omp_d2(ipoint,1)
- Jkappa(ipoint,2) += tmp_omp_d2(ipoint,2)
- Jkappa(ipoint,3) += tmp_omp_d2(ipoint,3)
- Okappa(ipoint) += tmp_omp_d1(ipoint)
- enddo
- !$OMP END CRITICAL
-
- tmp_omp_d2 = 0.d0
- tmp_omp_d1 = 0.d0
- !$OMP DO
- do i = elec_beta_num+1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
- tmp_omp_d2(ipoint,1) += int2_grad1_u12_bimo_t(ipoint,1,i,i)
- tmp_omp_d2(ipoint,2) += int2_grad1_u12_bimo_t(ipoint,2,i,i)
- tmp_omp_d2(ipoint,3) += int2_grad1_u12_bimo_t(ipoint,3,i,i)
- tmp_omp_d1(ipoint) += mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
- enddo
- enddo
- !$OMP END DO NOWAIT
- !$OMP CRITICAL
- do ipoint = 1, n_points_final_grid
- Jbarkappa(ipoint,1) += tmp_omp_d2(ipoint,1)
- Jbarkappa(ipoint,2) += tmp_omp_d2(ipoint,2)
- Jbarkappa(ipoint,3) += tmp_omp_d2(ipoint,3)
- Obarkappa(ipoint) += tmp_omp_d1(ipoint)
- enddo
- !$OMP END CRITICAL
-
- deallocate(tmp_omp_d2, tmp_omp_d1)
- !$OMP END PARALLEL
-
- ! ---
-
- allocate(tmp_1(n_points_final_grid,4))
-
- do ipoint = 1, n_points_final_grid
-
- loc_1 = -2.d0 * Okappa (ipoint)
- loc_2 = -2.d0 * Obarkappa(ipoint)
- loc_3 = Obarkappa(ipoint)
-
- tmp_1(ipoint,1) = (loc_1 - loc_3) * Jbarkappa(ipoint,1) + loc_2 * Jkappa(ipoint,1)
- tmp_1(ipoint,2) = (loc_1 - loc_3) * Jbarkappa(ipoint,2) + loc_2 * Jkappa(ipoint,2)
- tmp_1(ipoint,3) = (loc_1 - loc_3) * Jbarkappa(ipoint,3) + loc_2 * Jkappa(ipoint,3)
-
- tmp_1(ipoint,4) = Obarkappa(ipoint)
- enddo
-
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, i, j, loc_1, loc_2, tmp_omp_d2) &
- !$OMP SHARED (n_points_final_grid, elec_beta_num, elec_alpha_num, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, tmp_1)
-
- allocate(tmp_omp_d2(n_points_final_grid,3))
-
- tmp_omp_d2 = 0.d0
- !$OMP DO COLLAPSE(2)
- do i = 1, elec_beta_num
- do j = elec_beta_num+1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
-
- loc_1 = mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
- loc_2 = mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
-
- tmp_omp_d2(ipoint,1) += loc_1 * int2_grad1_u12_bimo_t(ipoint,1,i,j) + loc_2 * int2_grad1_u12_bimo_t(ipoint,1,j,i)
- tmp_omp_d2(ipoint,2) += loc_1 * int2_grad1_u12_bimo_t(ipoint,2,i,j) + loc_2 * int2_grad1_u12_bimo_t(ipoint,2,j,i)
- tmp_omp_d2(ipoint,3) += loc_1 * int2_grad1_u12_bimo_t(ipoint,3,i,j) + loc_2 * int2_grad1_u12_bimo_t(ipoint,3,j,i)
- enddo
- enddo
- enddo
- !$OMP END DO NOWAIT
- !$OMP CRITICAL
- do ipoint = 1, n_points_final_grid
- tmp_1(ipoint,1) += tmp_omp_d2(ipoint,1)
- tmp_1(ipoint,2) += tmp_omp_d2(ipoint,2)
- tmp_1(ipoint,3) += tmp_omp_d2(ipoint,3)
- enddo
- !$OMP END CRITICAL
-
- tmp_omp_d2 = 0.d0
- !$OMP DO COLLAPSE(2)
- do i = elec_beta_num+1, elec_alpha_num
- do j = elec_beta_num+1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
-
- loc_1 = mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
-
- tmp_omp_d2(ipoint,1) += loc_1 * int2_grad1_u12_bimo_t(ipoint,1,i,j)
- tmp_omp_d2(ipoint,2) += loc_1 * int2_grad1_u12_bimo_t(ipoint,2,i,j)
- tmp_omp_d2(ipoint,3) += loc_1 * int2_grad1_u12_bimo_t(ipoint,3,i,j)
- enddo
- enddo
- enddo
- !$OMP END DO NOWAIT
- !$OMP CRITICAL
- do ipoint = 1, n_points_final_grid
- tmp_1(ipoint,1) += tmp_omp_d2(ipoint,1)
- tmp_1(ipoint,2) += tmp_omp_d2(ipoint,2)
- tmp_1(ipoint,3) += tmp_omp_d2(ipoint,3)
- enddo
- !$OMP END CRITICAL
-
- deallocate(tmp_omp_d2)
- !$OMP END PARALLEL
-
- ! ---
-
- allocate(tmp_2(n_points_final_grid,4,mo_num,mo_num))
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, a, b) &
- !$OMP SHARED (n_points_final_grid, mo_num, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, &
- !$OMP tmp_2)
- !$OMP DO COLLAPSE(2)
- do a = 1, mo_num
- do b = 1, mo_num
- do ipoint = 1, n_points_final_grid
- tmp_2(ipoint,1,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,b,a)
- tmp_2(ipoint,2,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,b,a)
- tmp_2(ipoint,3,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,b,a)
- enddo
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, a, b, i) &
- !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
- !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
- !$OMP tmp_2)
- !$OMP DO COLLAPSE(2)
- do a = 1, mo_num
- do b = 1, mo_num
-
- tmp_2(:,4,b,a) = 0.d0
- do i = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
- tmp_2(ipoint,4,b,a) += final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,a) &
- + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,a) &
- + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,a) )
- enddo
- enddo
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- ! ---
-
- call dgemv( 'T', 4*n_points_final_grid, mo_num*mo_num, 1.d0 &
- , tmp_2(1,1,1,1), size(tmp_2, 1) * size(tmp_2, 2) &
- , tmp_1(1,1), 1 &
- , 0.d0, fock_3e_uhf_mo_b_os(1,1), 1)
-
- deallocate(tmp_1, tmp_2)
-
- ! ---
-
- allocate(tmp_3(n_points_final_grid,2,mo_num), tmp_4(n_points_final_grid,2,mo_num))
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, b, loc_1, loc_2) &
- !$OMP SHARED (n_points_final_grid, mo_num, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP final_weight_at_r_vector, Jkappa, Jbarkappa, tmp_3, tmp_4)
- !$OMP DO
- do b = 1, mo_num
- tmp_3(:,:,b) = 0.d0
- tmp_4(:,:,b) = 0.d0
- do ipoint = 1, n_points_final_grid
-
- tmp_3(ipoint,1,b) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,b)
-
- loc_1 = -2.0d0 * mos_r_in_r_array_transp(ipoint,b)
-
- tmp_4(ipoint,1,b) = loc_1 * ( Jbarkappa(ipoint,1) * (Jkappa(ipoint,1) + 0.25d0 * Jbarkappa(ipoint,1)) &
- + Jbarkappa(ipoint,2) * (Jkappa(ipoint,2) + 0.25d0 * Jbarkappa(ipoint,2)) &
- + Jbarkappa(ipoint,3) * (Jkappa(ipoint,3) + 0.25d0 * Jbarkappa(ipoint,3)) )
-
- tmp_4(ipoint,2,b) = mos_r_in_r_array_transp(ipoint,b)
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, b, i, loc_1, loc_2, loc_3, loc_4) &
- !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
- !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP Jkappa, Jbarkappa, tmp_3, tmp_4)
- !$OMP DO
- do b = 1, mo_num
-
- do i = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
-
- loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
- loc_2 = mos_r_in_r_array_transp(ipoint,i)
-
- tmp_3(ipoint,2,b) += loc_1 * ( Jbarkappa(ipoint,1) * int2_grad1_u12_bimo_t(ipoint,1,b,i) &
- + Jbarkappa(ipoint,2) * int2_grad1_u12_bimo_t(ipoint,2,b,i) &
- + Jbarkappa(ipoint,3) * int2_grad1_u12_bimo_t(ipoint,3,b,i) )
-
- tmp_4(ipoint,1,b) += loc_2 * ( Jbarkappa(ipoint,1) * int2_grad1_u12_bimo_t(ipoint,1,i,b) &
- + Jbarkappa(ipoint,2) * int2_grad1_u12_bimo_t(ipoint,2,i,b) &
- + Jbarkappa(ipoint,3) * int2_grad1_u12_bimo_t(ipoint,3,i,b) )
- enddo
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, b, i, j, loc_1, loc_2, loc_3) &
- !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
- !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP tmp_3, tmp_4)
- !$OMP DO
- do b = 1, mo_num
- do i = 1, elec_beta_num
- do j = elec_beta_num+1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
-
- loc_2 = mos_r_in_r_array_transp(ipoint,b)
-
- tmp_4(ipoint,1,b) += loc_2 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) )
- enddo
- enddo
- enddo
-
- do i = elec_beta_num+1, elec_alpha_num
- do j = elec_beta_num+1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
-
- loc_2 = 0.5d0 * mos_r_in_r_array_transp(ipoint,b)
-
- tmp_4(ipoint,1,b) += loc_2 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) )
- enddo
- enddo
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- ! ---
-
- call dgemm( 'T', 'N', mo_num, mo_num, 2*n_points_final_grid, 1.d0 &
- , tmp_3(1,1,1), 2*n_points_final_grid &
- , tmp_4(1,1,1), 2*n_points_final_grid &
- , 1.d0, fock_3e_uhf_mo_b_os(1,1), mo_num)
-
- deallocate(tmp_3, tmp_4)
-
-
-
-
- ! ---
-
- fock_3e_uhf_mo_a_os = fock_3e_uhf_mo_b_os
-
- allocate(tmp_1(n_points_final_grid,1))
-
- do ipoint = 1, n_points_final_grid
- tmp_1(ipoint,1) = Obarkappa(ipoint) + 2.d0 * Okappa(ipoint)
- enddo
-
- allocate(tmp_2(n_points_final_grid,1,mo_num,mo_num))
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, a, b, i) &
- !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
- !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
- !$OMP tmp_2)
- !$OMP DO COLLAPSE(2)
- do a = 1, mo_num
- do b = 1, mo_num
-
- tmp_2(:,1,b,a) = 0.d0
- do i = elec_beta_num+1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
- tmp_2(ipoint,1,b,a) += final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,a) &
- + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,a) &
- + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,a) )
- enddo
- enddo
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- call dgemv( 'T', n_points_final_grid, mo_num*mo_num, 1.d0 &
- , tmp_2(1,1,1,1), size(tmp_2, 1) * size(tmp_2, 2) &
- , tmp_1(1,1), 1 &
- , 1.d0, fock_3e_uhf_mo_a_os(1,1), 1)
-
- deallocate(tmp_1, tmp_2)
-
- ! ---
-
- allocate(tmp_3(n_points_final_grid,8,mo_num), tmp_4(n_points_final_grid,8,mo_num))
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, b) &
- !$OMP SHARED (n_points_final_grid, mo_num, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP final_weight_at_r_vector, Jkappa, Jbarkappa, tmp_3, tmp_4)
- !$OMP DO
- do b = 1, mo_num
- tmp_3(:,:,b) = 0.d0
- tmp_4(:,:,b) = 0.d0
- do ipoint = 1, n_points_final_grid
-
- tmp_3(ipoint,1,b) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,b)
-
- tmp_4(ipoint,8,b) = mos_r_in_r_array_transp(ipoint,b)
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, b, i, loc_1, loc_2, loc_3, loc_4) &
- !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
- !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP Jkappa, Jbarkappa, tmp_3, tmp_4)
- !$OMP DO
- do b = 1, mo_num
- do i = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
-
- loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
- loc_2 = mos_r_in_r_array_transp(ipoint,i)
-
- tmp_3(ipoint,2,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,1,b,i)
- tmp_3(ipoint,3,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,2,b,i)
- tmp_3(ipoint,4,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,3,b,i)
-
- tmp_4(ipoint,5,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,1,i,b)
- tmp_4(ipoint,6,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,2,i,b)
- tmp_4(ipoint,7,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,3,i,b)
- enddo
- enddo
-
- do i = elec_beta_num+1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
-
- loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
- loc_3 = 2.d0 * loc_1
- loc_2 = mos_r_in_r_array_transp(ipoint,i)
- loc_4 = 2.d0 * loc_2
-
- tmp_3(ipoint,5,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,1,b,i)
- tmp_3(ipoint,6,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,2,b,i)
- tmp_3(ipoint,7,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,3,b,i)
-
- tmp_3(ipoint,8,b) += loc_3 * ( (Jkappa(ipoint,1) + 0.5d0 * Jbarkappa(ipoint,1)) * int2_grad1_u12_bimo_t(ipoint,1,b,i) &
- + (Jkappa(ipoint,2) + 0.5d0 * Jbarkappa(ipoint,2)) * int2_grad1_u12_bimo_t(ipoint,2,b,i) &
- + (Jkappa(ipoint,3) + 0.5d0 * Jbarkappa(ipoint,3)) * int2_grad1_u12_bimo_t(ipoint,3,b,i) )
-
- tmp_4(ipoint,1,b) += loc_4 * ( (Jkappa(ipoint,1) + 0.5d0 * Jbarkappa(ipoint,1)) * int2_grad1_u12_bimo_t(ipoint,1,i,b) &
- + (Jkappa(ipoint,2) + 0.5d0 * Jbarkappa(ipoint,2)) * int2_grad1_u12_bimo_t(ipoint,2,i,b) &
- + (Jkappa(ipoint,3) + 0.5d0 * Jbarkappa(ipoint,3)) * int2_grad1_u12_bimo_t(ipoint,3,i,b) )
-
- tmp_4(ipoint,2,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,1,i,b)
- tmp_4(ipoint,3,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,2,i,b)
- tmp_4(ipoint,4,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,3,i,b)
-
- tmp_4(ipoint,5,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,1,i,b)
- tmp_4(ipoint,6,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,2,i,b)
- tmp_4(ipoint,7,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,3,i,b)
- enddo
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, b, i, j, loc_1, loc_2, loc_3) &
- !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
- !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP tmp_3, tmp_4)
- !$OMP DO
- do b = 1, mo_num
-
- do i = 1, elec_beta_num
- do j = elec_beta_num+1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
-
- loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,j)
- loc_2 = mos_r_in_r_array_transp(ipoint,b)
- loc_3 = mos_r_in_r_array_transp(ipoint,i)
-
- tmp_3(ipoint,8,b) -= loc_1 * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,j) &
- + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,j) &
- + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,j) )
-
- tmp_4(ipoint,1,b) -= loc_3 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,b) &
- + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,b) &
- + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,b) )
-
- loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
- loc_3 = mos_r_in_r_array_transp(ipoint,j)
-
- tmp_3(ipoint,8,b) -= loc_1 * ( int2_grad1_u12_bimo_t(ipoint,1,b,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,2,b,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,3,b,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) )
-
- tmp_4(ipoint,1,b) -= loc_3 * ( int2_grad1_u12_bimo_t(ipoint,1,j,i) * int2_grad1_u12_bimo_t(ipoint,1,i,b) &
- + int2_grad1_u12_bimo_t(ipoint,2,j,i) * int2_grad1_u12_bimo_t(ipoint,2,i,b) &
- + int2_grad1_u12_bimo_t(ipoint,3,j,i) * int2_grad1_u12_bimo_t(ipoint,3,i,b) )
- enddo
- enddo
- enddo
-
- do i = elec_beta_num+1, elec_alpha_num
- do j = elec_beta_num+1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
-
- loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,j)
- loc_2 = 0.5d0 * mos_r_in_r_array_transp(ipoint,b)
- loc_3 = mos_r_in_r_array_transp(ipoint,i)
-
- tmp_3(ipoint,8,b) -= loc_1 * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,j) &
- + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,j) &
- + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,j) )
-
- tmp_4(ipoint,1,b) -= loc_3 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,b) &
- + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,b) &
- + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,b) )
- enddo
- enddo
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- ! ---
-
- call dgemm( 'T', 'N', mo_num, mo_num, 8*n_points_final_grid, 1.d0 &
- , tmp_3(1,1,1), 8*n_points_final_grid &
- , tmp_4(1,1,1), 8*n_points_final_grid &
- , 1.d0, fock_3e_uhf_mo_a_os(1,1), mo_num)
-
- deallocate(tmp_3, tmp_4)
- deallocate(Jkappa, Okappa)
-
- !call wall_time(tf)
- !print *, ' Wall time for fock_3e_uhf_mo_a_os and fock_3e_uhf_mo_b_os =', tf - ti
-
-END_PROVIDER
-
-! ---
-
diff --git a/plugins/local/tc_scf/fock_3e_bi_ortho_uhf.irp.f b/plugins/local/tc_scf/fock_3e_bi_ortho_uhf.irp.f
deleted file mode 100644
index 63a1e162..00000000
--- a/plugins/local/tc_scf/fock_3e_bi_ortho_uhf.irp.f
+++ /dev/null
@@ -1,77 +0,0 @@
-
-! ---
-
-BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a, (mo_num, mo_num)]
-
- BEGIN_DOC
- !
- ! Fock matrix alpha from three-electron terms
- !
- ! WARNING :: non hermitian if bi-ortho MOS used
- !
- END_DOC
-
- implicit none
- double precision :: ti, tf
-
- PROVIDE mo_l_coef mo_r_coef
-
- !print *, ' Providing fock_3e_uhf_mo_a ...'
- !call wall_time(ti)
-
- ! CLOSED-SHELL PART
- PROVIDE fock_3e_uhf_mo_cs
- fock_3e_uhf_mo_a = fock_3e_uhf_mo_cs
-
- if(elec_alpha_num .ne. elec_beta_num) then
-
- ! OPEN-SHELL PART
- PROVIDE fock_3e_uhf_mo_a_os
-
- fock_3e_uhf_mo_a += fock_3e_uhf_mo_a_os
- endif
-
- !call wall_time(tf)
- !print *, ' Wall time for fock_3e_uhf_mo_a =', tf - ti
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b, (mo_num, mo_num)]
-
- BEGIN_DOC
- !
- ! Fock matrix beta from three-electron terms
- !
- ! WARNING :: non hermitian if bi-ortho MOS used
- !
- END_DOC
-
- implicit none
- double precision :: ti, tf
-
- PROVIDE mo_l_coef mo_r_coef
-
- !print *, ' Providing and fock_3e_uhf_mo_b ...'
- !call wall_time(ti)
-
- ! CLOSED-SHELL PART
- PROVIDE fock_3e_uhf_mo_cs
- fock_3e_uhf_mo_b = fock_3e_uhf_mo_cs
-
- if(elec_alpha_num .ne. elec_beta_num) then
-
- ! OPEN-SHELL PART
- PROVIDE fock_3e_uhf_mo_b_os
-
- fock_3e_uhf_mo_b += fock_3e_uhf_mo_b_os
- endif
-
- !call wall_time(tf)
- !print *, ' Wall time for fock_3e_uhf_mo_b =', tf - ti
-
-END_PROVIDER
-
-! ---
-
diff --git a/plugins/local/tc_scf/fock_3e_bi_ortho_uhf_old.irp.f b/plugins/local/tc_scf/fock_3e_bi_ortho_uhf_old.irp.f
deleted file mode 100644
index 3bf6bd85..00000000
--- a/plugins/local/tc_scf/fock_3e_bi_ortho_uhf_old.irp.f
+++ /dev/null
@@ -1,490 +0,0 @@
-
-! ---
-
-BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_cs_old, (mo_num, mo_num)]
-
- implicit none
- integer :: a, b, i, j
- double precision :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
- double precision :: ti, tf
- double precision, allocatable :: tmp(:,:)
-
- PROVIDE mo_l_coef mo_r_coef
- call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, I_bij_aij)
-
- !print *, ' PROVIDING fock_3e_uhf_mo_cs_old ...'
- !call wall_time(ti)
-
- fock_3e_uhf_mo_cs_old = 0.d0
-
- !$OMP PARALLEL DEFAULT (NONE) &
- !$OMP PRIVATE (a, b, i, j, I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia, tmp) &
- !$OMP SHARED (mo_num, elec_beta_num, fock_3e_uhf_mo_cs_old)
-
- allocate(tmp(mo_num,mo_num))
- tmp = 0.d0
-
- !$OMP DO
- do a = 1, mo_num
- do b = 1, mo_num
-
- do j = 1, elec_beta_num
- do i = 1, elec_beta_num
-
- call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
- call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
- call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
- call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
- call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
- call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
-
- tmp(b,a) -= 0.5d0 * ( 4.d0 * I_bij_aij &
- + I_bij_ija &
- + I_bij_jai &
- - 2.d0 * I_bij_aji &
- - 2.d0 * I_bij_iaj &
- - 2.d0 * I_bij_jia )
-
- enddo
- enddo
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
- do a = 1, mo_num
- do b = 1, mo_num
- fock_3e_uhf_mo_cs_old(b,a) += tmp(b,a)
- enddo
- enddo
- !$OMP END CRITICAL
-
- deallocate(tmp)
- !$OMP END PARALLEL
-
- !call wall_time(tf)
- !print *, ' total Wall time for fock_3e_uhf_mo_cs_old =', tf - ti
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a_old, (mo_num, mo_num)]
-
- BEGIN_DOC
- !
- ! ALPHA part of the Fock matrix from three-electron terms
- !
- ! WARNING :: non hermitian if bi-ortho MOS used
- !
- END_DOC
-
- implicit none
- integer :: a, b, i, j, o
- double precision :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
- double precision :: ti, tf
- double precision, allocatable :: tmp(:,:)
-
- PROVIDE mo_l_coef mo_r_coef
- PROVIDE fock_3e_uhf_mo_cs
-
- !print *, ' Providing fock_3e_uhf_mo_a_old ...'
- !call wall_time(ti)
-
- o = elec_beta_num + 1
- call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, I_bij_aij)
-
- PROVIDE fock_3e_uhf_mo_cs_old
- fock_3e_uhf_mo_a_old = fock_3e_uhf_mo_cs_old
-
- !$OMP PARALLEL DEFAULT (NONE) &
- !$OMP PRIVATE (a, b, i, j, I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia, tmp) &
- !$OMP SHARED (mo_num, o, elec_alpha_num, elec_beta_num, fock_3e_uhf_mo_a_old)
-
- allocate(tmp(mo_num,mo_num))
- tmp = 0.d0
-
- !$OMP DO
- do a = 1, mo_num
- do b = 1, mo_num
-
- ! ---
-
- do j = o, elec_alpha_num
- do i = 1, elec_beta_num
-
- call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
- call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
- call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
- call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
- call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
- call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
-
- tmp(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
- + I_bij_ija &
- + I_bij_jai &
- - I_bij_aji &
- - I_bij_iaj &
- - 2.d0 * I_bij_jia )
-
- enddo
- enddo
-
- ! ---
-
- do j = 1, elec_beta_num
- do i = o, elec_alpha_num
-
- call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
- call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
- call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
- call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
- call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
- call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
-
- tmp(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
- + I_bij_ija &
- + I_bij_jai &
- - I_bij_aji &
- - 2.d0 * I_bij_iaj &
- - I_bij_jia )
-
- enddo
- enddo
-
- ! ---
-
- do j = o, elec_alpha_num
- do i = o, elec_alpha_num
-
- call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
- call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
- call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
- call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
- call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
- call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
-
- tmp(b,a) -= 0.5d0 * ( I_bij_aij &
- + I_bij_ija &
- + I_bij_jai &
- - I_bij_aji &
- - I_bij_iaj &
- - I_bij_jia )
-
- enddo
- enddo
-
- ! ---
-
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
- do a = 1, mo_num
- do b = 1, mo_num
- fock_3e_uhf_mo_a_old(b,a) += tmp(b,a)
- enddo
- enddo
- !$OMP END CRITICAL
-
- deallocate(tmp)
- !$OMP END PARALLEL
-
- !call wall_time(tf)
- !print *, ' Wall time for fock_3e_uhf_mo_a_old =', tf - ti
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b_old, (mo_num, mo_num)]
-
- BEGIN_DOC
- !
- ! BETA part of the Fock matrix from three-electron terms
- !
- ! WARNING :: non hermitian if bi-ortho MOS used
- !
- END_DOC
-
- implicit none
- integer :: a, b, i, j, o
- double precision :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
- double precision :: ti, tf
- double precision, allocatable :: tmp(:,:)
-
- PROVIDE mo_l_coef mo_r_coef
-
- !print *, ' PROVIDING fock_3e_uhf_mo_b_old ...'
- !call wall_time(ti)
-
- o = elec_beta_num + 1
- call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, I_bij_aij)
-
- PROVIDE fock_3e_uhf_mo_cs_old
- fock_3e_uhf_mo_b_old = fock_3e_uhf_mo_cs_old
-
- !$OMP PARALLEL DEFAULT (NONE) &
- !$OMP PRIVATE (a, b, i, j, I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia, tmp) &
- !$OMP SHARED (mo_num, o, elec_alpha_num, elec_beta_num, fock_3e_uhf_mo_b_old)
-
- allocate(tmp(mo_num,mo_num))
- tmp = 0.d0
-
- !$OMP DO
- do a = 1, mo_num
- do b = 1, mo_num
-
- ! ---
-
- do j = o, elec_alpha_num
- do i = 1, elec_beta_num
-
- call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
- call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
- call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
- call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
- call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
- call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
-
- tmp(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
- - I_bij_aji &
- - I_bij_iaj )
-
- enddo
- enddo
-
- ! ---
-
- do j = 1, elec_beta_num
- do i = o, elec_alpha_num
-
- call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
- call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
- call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
- call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
- call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
- call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
-
- tmp(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
- - I_bij_aji &
- - I_bij_jia )
-
- enddo
- enddo
-
- ! ---
-
- do j = o, elec_alpha_num
- do i = o, elec_alpha_num
-
- call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
- call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
- call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
- call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
- call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
- call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
-
- tmp(b,a) -= 0.5d0 * ( I_bij_aij &
- - I_bij_aji )
-
- enddo
- enddo
-
- ! ---
-
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
- do a = 1, mo_num
- do b = 1, mo_num
- fock_3e_uhf_mo_b_old(b,a) += tmp(b,a)
- enddo
- enddo
- !$OMP END CRITICAL
-
- deallocate(tmp)
- !$OMP END PARALLEL
-
- !call wall_time(tf)
- !print *, ' total Wall time for fock_3e_uhf_mo_b_old =', tf - ti
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [double precision, fock_3e_uhf_ao_a, (ao_num, ao_num)]
-
- BEGIN_DOC
- !
- ! Equations (B6) and (B7)
- !
- ! g <--> gamma
- ! d <--> delta
- ! e <--> eta
- ! k <--> kappa
- !
- END_DOC
-
- implicit none
- integer :: g, d, e, k, mu, nu
- double precision :: dm_ge_a, dm_ge_b, dm_ge
- double precision :: dm_dk_a, dm_dk_b, dm_dk
- double precision :: i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu
- double precision :: ti, tf
- double precision, allocatable :: f_tmp(:,:)
-
- !print *, ' PROVIDING fock_3e_uhf_ao_a ...'
- !call wall_time(ti)
-
- fock_3e_uhf_ao_a = 0.d0
-
- !$OMP PARALLEL DEFAULT (NONE) &
- !$OMP PRIVATE (g, e, d, k, mu, nu, dm_ge_a, dm_ge_b, dm_ge, dm_dk_a, dm_dk_b, dm_dk, f_tmp, &
- !$OMP i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu) &
- !$OMP SHARED (ao_num, TCSCF_bi_ort_dm_ao_alpha, TCSCF_bi_ort_dm_ao_beta, fock_3e_uhf_ao_a)
-
- allocate(f_tmp(ao_num,ao_num))
- f_tmp = 0.d0
-
- !$OMP DO
- do g = 1, ao_num
- do e = 1, ao_num
- dm_ge_a = TCSCF_bi_ort_dm_ao_alpha(g,e)
- dm_ge_b = TCSCF_bi_ort_dm_ao_beta (g,e)
- dm_ge = dm_ge_a + dm_ge_b
- do d = 1, ao_num
- do k = 1, ao_num
- dm_dk_a = TCSCF_bi_ort_dm_ao_alpha(d,k)
- dm_dk_b = TCSCF_bi_ort_dm_ao_beta (d,k)
- dm_dk = dm_dk_a + dm_dk_b
- do mu = 1, ao_num
- do nu = 1, ao_num
- call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, e, k, i_mugd_nuek)
- call give_integrals_3_body_bi_ort_ao(mu, g, d, e, k, nu, i_mugd_eknu)
- call give_integrals_3_body_bi_ort_ao(mu, g, d, k, nu, e, i_mugd_knue)
- call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, k, e, i_mugd_nuke)
- call give_integrals_3_body_bi_ort_ao(mu, g, d, e, nu, k, i_mugd_enuk)
- call give_integrals_3_body_bi_ort_ao(mu, g, d, k, e, nu, i_mugd_kenu)
- f_tmp(mu,nu) -= 0.5d0 * ( dm_ge * dm_dk * i_mugd_nuek &
- + dm_ge_a * dm_dk_a * i_mugd_eknu &
- + dm_ge_a * dm_dk_a * i_mugd_knue &
- - dm_ge_a * dm_dk * i_mugd_enuk &
- - dm_ge * dm_dk_a * i_mugd_kenu &
- - dm_ge_a * dm_dk_a * i_mugd_nuke &
- - dm_ge_b * dm_dk_b * i_mugd_nuke )
- enddo
- enddo
- enddo
- enddo
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
- do mu = 1, ao_num
- do nu = 1, ao_num
- fock_3e_uhf_ao_a(mu,nu) += f_tmp(mu,nu)
- enddo
- enddo
- !$OMP END CRITICAL
-
- deallocate(f_tmp)
- !$OMP END PARALLEL
-
- !call wall_time(tf)
- !print *, ' total Wall time for fock_3e_uhf_ao_a =', tf - ti
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [double precision, fock_3e_uhf_ao_b, (ao_num, ao_num)]
-
- BEGIN_DOC
- !
- ! Equations (B6) and (B7)
- !
- ! g <--> gamma
- ! d <--> delta
- ! e <--> eta
- ! k <--> kappa
- !
- END_DOC
-
- implicit none
- integer :: g, d, e, k, mu, nu
- double precision :: dm_ge_a, dm_ge_b, dm_ge
- double precision :: dm_dk_a, dm_dk_b, dm_dk
- double precision :: i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu
- double precision :: ti, tf
- double precision, allocatable :: f_tmp(:,:)
-
- !print *, ' PROVIDING fock_3e_uhf_ao_b ...'
- !call wall_time(ti)
-
- fock_3e_uhf_ao_b = 0.d0
-
- !$OMP PARALLEL DEFAULT (NONE) &
- !$OMP PRIVATE (g, e, d, k, mu, nu, dm_ge_a, dm_ge_b, dm_ge, dm_dk_a, dm_dk_b, dm_dk, f_tmp, &
- !$OMP i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu) &
- !$OMP SHARED (ao_num, TCSCF_bi_ort_dm_ao_alpha, TCSCF_bi_ort_dm_ao_beta, fock_3e_uhf_ao_b)
-
- allocate(f_tmp(ao_num,ao_num))
- f_tmp = 0.d0
-
- !$OMP DO
- do g = 1, ao_num
- do e = 1, ao_num
- dm_ge_a = TCSCF_bi_ort_dm_ao_alpha(g,e)
- dm_ge_b = TCSCF_bi_ort_dm_ao_beta (g,e)
- dm_ge = dm_ge_a + dm_ge_b
- do d = 1, ao_num
- do k = 1, ao_num
- dm_dk_a = TCSCF_bi_ort_dm_ao_alpha(d,k)
- dm_dk_b = TCSCF_bi_ort_dm_ao_beta (d,k)
- dm_dk = dm_dk_a + dm_dk_b
- do mu = 1, ao_num
- do nu = 1, ao_num
- call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, e, k, i_mugd_nuek)
- call give_integrals_3_body_bi_ort_ao(mu, g, d, e, k, nu, i_mugd_eknu)
- call give_integrals_3_body_bi_ort_ao(mu, g, d, k, nu, e, i_mugd_knue)
- call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, k, e, i_mugd_nuke)
- call give_integrals_3_body_bi_ort_ao(mu, g, d, e, nu, k, i_mugd_enuk)
- call give_integrals_3_body_bi_ort_ao(mu, g, d, k, e, nu, i_mugd_kenu)
- f_tmp(mu,nu) -= 0.5d0 * ( dm_ge * dm_dk * i_mugd_nuek &
- + dm_ge_b * dm_dk_b * i_mugd_eknu &
- + dm_ge_b * dm_dk_b * i_mugd_knue &
- - dm_ge_b * dm_dk * i_mugd_enuk &
- - dm_ge * dm_dk_b * i_mugd_kenu &
- - dm_ge_b * dm_dk_b * i_mugd_nuke &
- - dm_ge_a * dm_dk_a * i_mugd_nuke )
- enddo
- enddo
- enddo
- enddo
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
- do mu = 1, ao_num
- do nu = 1, ao_num
- fock_3e_uhf_ao_b(mu,nu) += f_tmp(mu,nu)
- enddo
- enddo
- !$OMP END CRITICAL
-
- deallocate(f_tmp)
- !$OMP END PARALLEL
-
- !call wall_time(tf)
- !print *, ' total Wall time for fock_3e_uhf_ao_b =', tf - ti
-
-END_PROVIDER
-
-! ---
-
diff --git a/plugins/local/tc_scf/fock_hermit.irp.f b/plugins/local/tc_scf/fock_hermit.irp.f
deleted file mode 100644
index 5a51b324..00000000
--- a/plugins/local/tc_scf/fock_hermit.irp.f
+++ /dev/null
@@ -1,107 +0,0 @@
-
-! ---
-
-BEGIN_PROVIDER [ double precision, good_hermit_tc_fock_mat, (mo_num, mo_num)]
-
- BEGIN_DOC
-! good_hermit_tc_fock_mat = Hermitian Upper triangular Fock matrix
-!
-! The converged eigenvectors of such matrix yield to orthonormal vectors satisfying the left Brillouin theorem
- END_DOC
- implicit none
- integer :: i, j
-
- good_hermit_tc_fock_mat = Fock_matrix_tc_mo_tot
- do j = 1, mo_num
- do i = 1, j-1
- good_hermit_tc_fock_mat(i,j) = Fock_matrix_tc_mo_tot(j,i)
- enddo
- enddo
-
-END_PROVIDER
-
-BEGIN_PROVIDER [ double precision, hermit_average_tc_fock_mat, (mo_num, mo_num)]
-
- BEGIN_DOC
-! hermit_average_tc_fock_mat = (F + F^\dagger)/2
- END_DOC
- implicit none
- integer :: i, j
-
- hermit_average_tc_fock_mat = Fock_matrix_tc_mo_tot
- do j = 1, mo_num
- do i = 1, mo_num
- hermit_average_tc_fock_mat(i,j) = 0.5d0 * (Fock_matrix_tc_mo_tot(j,i) + Fock_matrix_tc_mo_tot(i,j))
- enddo
- enddo
-
-END_PROVIDER
-
-
-! ---
-BEGIN_PROVIDER [ double precision, grad_hermit]
- implicit none
- BEGIN_DOC
- ! square of gradient of the energy
- END_DOC
- if(symetric_fock_tc)then
- grad_hermit = grad_hermit_average_tc_fock_mat
- else
- grad_hermit = grad_good_hermit_tc_fock_mat
- endif
-
-END_PROVIDER
-
-BEGIN_PROVIDER [ double precision, grad_good_hermit_tc_fock_mat]
- implicit none
- BEGIN_DOC
- ! grad_good_hermit_tc_fock_mat = norm of gradients of the upper triangular TC fock
- END_DOC
- integer :: i, j
- grad_good_hermit_tc_fock_mat = 0.d0
- do i = 1, elec_alpha_num
- do j = elec_alpha_num+1, mo_num
- grad_good_hermit_tc_fock_mat += dabs(good_hermit_tc_fock_mat(i,j))
- enddo
- enddo
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [ double precision, grad_hermit_average_tc_fock_mat]
- implicit none
- BEGIN_DOC
- ! grad_hermit_average_tc_fock_mat = norm of gradients of the upper triangular TC fock
- END_DOC
- integer :: i, j
- grad_hermit_average_tc_fock_mat = 0.d0
- do i = 1, elec_alpha_num
- do j = elec_alpha_num+1, mo_num
- grad_hermit_average_tc_fock_mat += dabs(hermit_average_tc_fock_mat(i,j))
- enddo
- enddo
-END_PROVIDER
-
-
-! ---
-
-subroutine save_good_hermit_tc_eigvectors()
-
- implicit none
- integer :: sign
- character*(64) :: label
- logical :: output
-
- sign = 1
- label = "Canonical"
- output = .False.
-
- if(symetric_fock_tc)then
- call mo_as_eigvectors_of_mo_matrix(hermit_average_tc_fock_mat, mo_num, mo_num, label, sign, output)
- else
- call mo_as_eigvectors_of_mo_matrix(good_hermit_tc_fock_mat, mo_num, mo_num, label, sign, output)
- endif
-end subroutine save_good_hermit_tc_eigvectors
-
-! ---
-
diff --git a/plugins/local/tc_scf/fock_tc.irp.f b/plugins/local/tc_scf/fock_tc.irp.f
index 282f9873..16bb5c87 100644
--- a/plugins/local/tc_scf/fock_tc.irp.f
+++ b/plugins/local/tc_scf/fock_tc.irp.f
@@ -1,78 +1,15 @@
+
! ---
- BEGIN_PROVIDER [ double precision, two_e_tc_non_hermit_integral_seq_alpha, (ao_num, ao_num)]
-&BEGIN_PROVIDER [ double precision, two_e_tc_non_hermit_integral_seq_beta , (ao_num, ao_num)]
+ BEGIN_PROVIDER [ double precision, two_e_tc_integral_alpha, (ao_num, ao_num)]
+&BEGIN_PROVIDER [ double precision, two_e_tc_integral_beta , (ao_num, ao_num)]
BEGIN_DOC
!
- ! two_e_tc_non_hermit_integral_seq_alpha(k,i) = ON THE AO BASIS
+ ! two_e_tc_integral_alpha(k,i) = ON THE AO BASIS
!
- ! where F^tc is the TWO-BODY part of the TC Fock matrix and k,i are AO basis functions
- !
- ! works in SEQUENTIAL
- END_DOC
-
- implicit none
- integer :: i, j, k, l
- double precision :: density, density_a, density_b
- double precision :: t0, t1
-
- PROVIDE ao_two_e_tc_tot
-
- !print*, ' providing two_e_tc_non_hermit_integral_seq ...'
- !call wall_time(t0)
-
- two_e_tc_non_hermit_integral_seq_alpha = 0.d0
- two_e_tc_non_hermit_integral_seq_beta = 0.d0
-
- do i = 1, ao_num
- do k = 1, ao_num
- do j = 1, ao_num
- do l = 1, ao_num
-
- density_a = TCSCF_density_matrix_ao_alpha(l,j)
- density_b = TCSCF_density_matrix_ao_beta (l,j)
- density = density_a + density_b
-
- !! rho(l,j) * < k l| T | i j>
- !two_e_tc_non_hermit_integral_seq_alpha(k,i) += density * ao_two_e_tc_tot(l,j,k,i)
- !! rho(l,j) * < k l| T | i j>
- !two_e_tc_non_hermit_integral_seq_beta (k,i) += density * ao_two_e_tc_tot(l,j,k,i)
- !! rho_a(l,j) * < l k| T | i j>
- !two_e_tc_non_hermit_integral_seq_alpha(k,i) -= density_a * ao_two_e_tc_tot(k,j,l,i)
- !! rho_b(l,j) * < l k| T | i j>
- !two_e_tc_non_hermit_integral_seq_beta (k,i) -= density_b * ao_two_e_tc_tot(k,j,l,i)
-
- ! rho(l,j) * < k l| T | i j>
- two_e_tc_non_hermit_integral_seq_alpha(k,i) += density * ao_two_e_tc_tot(k,i,l,j)
- ! rho(l,j) * < k l| T | i j>
- two_e_tc_non_hermit_integral_seq_beta (k,i) += density * ao_two_e_tc_tot(k,i,l,j)
- ! rho_a(l,j) * < k l| T | j i>
- two_e_tc_non_hermit_integral_seq_alpha(k,i) -= density_a * ao_two_e_tc_tot(k,j,l,i)
- ! rho_b(l,j) * < k l| T | j i>
- two_e_tc_non_hermit_integral_seq_beta (k,i) -= density_b * ao_two_e_tc_tot(k,j,l,i)
-
- enddo
- enddo
- enddo
- enddo
-
- !call wall_time(t1)
- !print*, ' wall time for two_e_tc_non_hermit_integral_seq after = ', t1 - t0
-
-END_PROVIDER
-
-! ---
-
- BEGIN_PROVIDER [ double precision, two_e_tc_non_hermit_integral_alpha, (ao_num, ao_num)]
-&BEGIN_PROVIDER [ double precision, two_e_tc_non_hermit_integral_beta , (ao_num, ao_num)]
-
- BEGIN_DOC
- !
- ! two_e_tc_non_hermit_integral_alpha(k,i) = ON THE AO BASIS
- !
- ! where F^tc is the TWO-BODY part of the TC Fock matrix and k,i are AO basis functions
+ ! where F^tc_2e is the TWO-BODY part of the TC Fock matrix and k,i are AO basis functions
!
END_DOC
@@ -86,16 +23,13 @@ END_PROVIDER
PROVIDE mo_l_coef mo_r_coef
PROVIDE TCSCF_density_matrix_ao_alpha TCSCF_density_matrix_ao_beta
- !print*, ' Providing two_e_tc_non_hermit_integral ...'
- !call wall_time(t0)
-
- two_e_tc_non_hermit_integral_alpha = 0.d0
- two_e_tc_non_hermit_integral_beta = 0.d0
+ two_e_tc_integral_alpha = 0.d0
+ two_e_tc_integral_beta = 0.d0
!$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (i, j, k, l, density_a, density_b, density, tmp_a, tmp_b, I_coul, I_kjli) &
!$OMP SHARED (ao_num, TCSCF_density_matrix_ao_alpha, TCSCF_density_matrix_ao_beta, ao_two_e_tc_tot, &
- !$OMP two_e_tc_non_hermit_integral_alpha, two_e_tc_non_hermit_integral_beta)
+ !$OMP two_e_tc_integral_alpha, two_e_tc_integral_beta)
allocate(tmp_a(ao_num,ao_num), tmp_b(ao_num,ao_num))
tmp_a = 0.d0
@@ -124,8 +58,8 @@ END_PROVIDER
!$OMP CRITICAL
do i = 1, ao_num
do j = 1, ao_num
- two_e_tc_non_hermit_integral_alpha(j,i) += tmp_a(j,i)
- two_e_tc_non_hermit_integral_beta (j,i) += tmp_b(j,i)
+ two_e_tc_integral_alpha(j,i) += tmp_a(j,i)
+ two_e_tc_integral_beta (j,i) += tmp_b(j,i)
enddo
enddo
!$OMP END CRITICAL
@@ -133,9 +67,6 @@ END_PROVIDER
deallocate(tmp_a, tmp_b)
!$OMP END PARALLEL
- !call wall_time(t1)
- !print*, ' Wall time for two_e_tc_non_hermit_integral = ', t1 - t0
-
END_PROVIDER
! ---
@@ -149,13 +80,7 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_tc_ao_alpha, (ao_num, ao_num)]
implicit none
double precision :: t0, t1
- !print*, ' Providing Fock_matrix_tc_ao_alpha ...'
- !call wall_time(t0)
-
- Fock_matrix_tc_ao_alpha = ao_one_e_integrals_tc_tot + two_e_tc_non_hermit_integral_alpha
-
- !call wall_time(t1)
- !print*, ' Wall time for Fock_matrix_tc_ao_alpha =', t1-t0
+ Fock_matrix_tc_ao_alpha = ao_one_e_integrals_tc_tot + two_e_tc_integral_alpha
END_PROVIDER
@@ -169,13 +94,13 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_tc_ao_beta, (ao_num, ao_num)]
implicit none
- Fock_matrix_tc_ao_beta = ao_one_e_integrals_tc_tot + two_e_tc_non_hermit_integral_beta
+ Fock_matrix_tc_ao_beta = ao_one_e_integrals_tc_tot + two_e_tc_integral_beta
END_PROVIDER
! ---
-BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_alpha, (mo_num, mo_num) ]
+BEGIN_PROVIDER [double precision, Fock_matrix_tc_mo_alpha, (mo_num, mo_num)]
BEGIN_DOC
! Total alpha TC Fock matrix : h_c + Two-e^TC terms on the MO basis
@@ -185,31 +110,16 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_alpha, (mo_num, mo_num) ]
double precision :: t0, t1, tt0, tt1
double precision, allocatable :: tmp(:,:)
- !print*, ' Providing Fock_matrix_tc_mo_alpha ...'
- !call wall_time(t0)
+ PROVIDE mo_l_coef mo_r_coef
- if(bi_ortho) then
-
- PROVIDE mo_l_coef mo_r_coef
-
- call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_alpha, size(Fock_matrix_tc_ao_alpha, 1) &
- , Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1) )
-
- if(three_body_h_tc) then
- PROVIDE fock_3e_uhf_mo_a
- Fock_matrix_tc_mo_alpha += fock_3e_uhf_mo_a
- endif
-
- else
-
- call ao_to_mo( Fock_matrix_tc_ao_alpha, size(Fock_matrix_tc_ao_alpha, 1) &
- , Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1) )
+ call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_alpha, size(Fock_matrix_tc_ao_alpha, 1) &
+ , Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1) )
+ if(three_body_h_tc) then
+ PROVIDE fock_3e_mo_a
+ Fock_matrix_tc_mo_alpha += fock_3e_mo_a
endif
- !call wall_time(t1)
- !print*, ' Wall time for Fock_matrix_tc_mo_alpha =', t1-t0
-
END_PROVIDER
! ---
@@ -223,21 +133,12 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_beta, (mo_num,mo_num) ]
implicit none
double precision, allocatable :: tmp(:,:)
- if(bi_ortho) then
-
- call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_beta, size(Fock_matrix_tc_ao_beta, 1) &
- , Fock_matrix_tc_mo_beta, size(Fock_matrix_tc_mo_beta, 1) )
-
- if(three_body_h_tc) then
- PROVIDE fock_3e_uhf_mo_b
- Fock_matrix_tc_mo_beta += fock_3e_uhf_mo_b
- endif
-
- else
-
- call ao_to_mo( Fock_matrix_tc_ao_beta, size(Fock_matrix_tc_ao_beta, 1) &
- , Fock_matrix_tc_mo_beta, size(Fock_matrix_tc_mo_beta, 1) )
+ call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_beta, size(Fock_matrix_tc_ao_beta, 1) &
+ , Fock_matrix_tc_mo_beta, size(Fock_matrix_tc_mo_beta, 1) )
+ if(three_body_h_tc) then
+ PROVIDE fock_3e_mo_b
+ Fock_matrix_tc_mo_beta += fock_3e_mo_b
endif
END_PROVIDER
@@ -286,20 +187,895 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_tc_ao_tot, (ao_num, ao_num) ]
implicit none
double precision :: t0, t1
- !print*, ' Providing Fock_matrix_tc_ao_tot ...'
- !call wall_time(t0)
-
PROVIDE mo_l_coef mo_r_coef
PROVIDE Fock_matrix_tc_mo_tot
call mo_to_ao_bi_ortho( Fock_matrix_tc_mo_tot, size(Fock_matrix_tc_mo_tot, 1) &
, Fock_matrix_tc_ao_tot, size(Fock_matrix_tc_ao_tot, 1) )
- !call wall_time(t1)
- !print*, ' Wall time for Fock_matrix_tc_ao_tot =', t1-t0
-
END_PROVIDER
! ---
+
+! ---
+
+BEGIN_PROVIDER [double precision, fock_3e_mo_a, (mo_num, mo_num)]
+
+ BEGIN_DOC
+ !
+ ! Fock matrix alpha from three-electron terms
+ !
+ ! WARNING :: non hermitian if bi-ortho MOS used
+ !
+ END_DOC
+
+ implicit none
+ double precision :: ti, tf
+
+ PROVIDE mo_l_coef mo_r_coef
+
+ ! CLOSED-SHELL PART
+ PROVIDE fock_3e_mo_cs
+ fock_3e_mo_a = fock_3e_mo_cs
+
+ if(elec_alpha_num .ne. elec_beta_num) then
+
+ ! OPEN-SHELL PART
+ PROVIDE fock_3e_mo_a_os
+
+ fock_3e_mo_a += fock_3e_mo_a_os
+ endif
+
+END_PROVIDER
+
+! ---
+
+BEGIN_PROVIDER [double precision, fock_3e_mo_b, (mo_num, mo_num)]
+
+ BEGIN_DOC
+ !
+ ! Fock matrix beta from three-electron terms
+ !
+ ! WARNING :: non hermitian if bi-ortho MOS used
+ !
+ END_DOC
+
+ implicit none
+ double precision :: ti, tf
+
+ PROVIDE mo_l_coef mo_r_coef
+
+ ! CLOSED-SHELL PART
+ PROVIDE fock_3e_mo_cs
+ fock_3e_mo_b = fock_3e_mo_cs
+
+ if(elec_alpha_num .ne. elec_beta_num) then
+
+ ! OPEN-SHELL PART
+ PROVIDE fock_3e_mo_b_os
+
+ fock_3e_mo_b += fock_3e_mo_b_os
+ endif
+
+END_PROVIDER
+
+! ---
+
+
+! ---
+
+ BEGIN_PROVIDER [double precision, fock_3e_mo_a_os, (mo_num, mo_num)]
+&BEGIN_PROVIDER [double precision, fock_3e_mo_b_os, (mo_num, mo_num)]
+
+ BEGIN_DOC
+ !
+ ! Open Shell part of the Fock matrix from three-electron terms
+ !
+ ! WARNING :: non hermitian if bi-ortho MOS used
+ !
+ END_DOC
+
+ implicit none
+ integer :: a, b, i, j, ipoint
+ double precision :: loc_1, loc_2, loc_3, loc_4
+ double precision :: ti, tf
+ double precision, allocatable :: Okappa(:), Jkappa(:,:), Obarkappa(:), Jbarkappa(:,:)
+ double precision, allocatable :: tmp_omp_d1(:), tmp_omp_d2(:,:)
+ double precision, allocatable :: tmp_1(:,:), tmp_2(:,:,:,:)
+ double precision, allocatable :: tmp_3(:,:,:), tmp_4(:,:,:)
+
+ PROVIDE mo_l_coef mo_r_coef
+
+ ! ---
+
+ allocate(Jkappa(n_points_final_grid,3), Okappa(n_points_final_grid))
+ allocate(Jbarkappa(n_points_final_grid,3), Obarkappa(n_points_final_grid))
+ Jkappa = 0.d0
+ Okappa = 0.d0
+ Jbarkappa = 0.d0
+ Obarkappa = 0.d0
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, i, tmp_omp_d1, tmp_omp_d2) &
+ !$OMP SHARED (n_points_final_grid, elec_beta_num, elec_alpha_num, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP int2_grad1_u12_bimo_t, Okappa, Jkappa, Obarkappa, Jbarkappa)
+
+ allocate(tmp_omp_d2(n_points_final_grid,3), tmp_omp_d1(n_points_final_grid))
+
+ tmp_omp_d2 = 0.d0
+ tmp_omp_d1 = 0.d0
+ !$OMP DO
+ do i = 1, elec_beta_num
+ do ipoint = 1, n_points_final_grid
+ tmp_omp_d2(ipoint,1) += int2_grad1_u12_bimo_t(ipoint,1,i,i)
+ tmp_omp_d2(ipoint,2) += int2_grad1_u12_bimo_t(ipoint,2,i,i)
+ tmp_omp_d2(ipoint,3) += int2_grad1_u12_bimo_t(ipoint,3,i,i)
+ tmp_omp_d1(ipoint) += mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
+ enddo
+ enddo
+ !$OMP END DO NOWAIT
+ !$OMP CRITICAL
+ do ipoint = 1, n_points_final_grid
+ Jkappa(ipoint,1) += tmp_omp_d2(ipoint,1)
+ Jkappa(ipoint,2) += tmp_omp_d2(ipoint,2)
+ Jkappa(ipoint,3) += tmp_omp_d2(ipoint,3)
+ Okappa(ipoint) += tmp_omp_d1(ipoint)
+ enddo
+ !$OMP END CRITICAL
+
+ tmp_omp_d2 = 0.d0
+ tmp_omp_d1 = 0.d0
+ !$OMP DO
+ do i = elec_beta_num+1, elec_alpha_num
+ do ipoint = 1, n_points_final_grid
+ tmp_omp_d2(ipoint,1) += int2_grad1_u12_bimo_t(ipoint,1,i,i)
+ tmp_omp_d2(ipoint,2) += int2_grad1_u12_bimo_t(ipoint,2,i,i)
+ tmp_omp_d2(ipoint,3) += int2_grad1_u12_bimo_t(ipoint,3,i,i)
+ tmp_omp_d1(ipoint) += mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
+ enddo
+ enddo
+ !$OMP END DO NOWAIT
+ !$OMP CRITICAL
+ do ipoint = 1, n_points_final_grid
+ Jbarkappa(ipoint,1) += tmp_omp_d2(ipoint,1)
+ Jbarkappa(ipoint,2) += tmp_omp_d2(ipoint,2)
+ Jbarkappa(ipoint,3) += tmp_omp_d2(ipoint,3)
+ Obarkappa(ipoint) += tmp_omp_d1(ipoint)
+ enddo
+ !$OMP END CRITICAL
+
+ deallocate(tmp_omp_d2, tmp_omp_d1)
+ !$OMP END PARALLEL
+
+ ! ---
+
+ allocate(tmp_1(n_points_final_grid,4))
+
+ do ipoint = 1, n_points_final_grid
+
+ loc_1 = -2.d0 * Okappa (ipoint)
+ loc_2 = -2.d0 * Obarkappa(ipoint)
+ loc_3 = Obarkappa(ipoint)
+
+ tmp_1(ipoint,1) = (loc_1 - loc_3) * Jbarkappa(ipoint,1) + loc_2 * Jkappa(ipoint,1)
+ tmp_1(ipoint,2) = (loc_1 - loc_3) * Jbarkappa(ipoint,2) + loc_2 * Jkappa(ipoint,2)
+ tmp_1(ipoint,3) = (loc_1 - loc_3) * Jbarkappa(ipoint,3) + loc_2 * Jkappa(ipoint,3)
+
+ tmp_1(ipoint,4) = Obarkappa(ipoint)
+ enddo
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, i, j, loc_1, loc_2, tmp_omp_d2) &
+ !$OMP SHARED (n_points_final_grid, elec_beta_num, elec_alpha_num, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP int2_grad1_u12_bimo_t, tmp_1)
+
+ allocate(tmp_omp_d2(n_points_final_grid,3))
+
+ tmp_omp_d2 = 0.d0
+ !$OMP DO COLLAPSE(2)
+ do i = 1, elec_beta_num
+ do j = elec_beta_num+1, elec_alpha_num
+ do ipoint = 1, n_points_final_grid
+
+ loc_1 = mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
+ loc_2 = mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
+
+ tmp_omp_d2(ipoint,1) += loc_1 * int2_grad1_u12_bimo_t(ipoint,1,i,j) + loc_2 * int2_grad1_u12_bimo_t(ipoint,1,j,i)
+ tmp_omp_d2(ipoint,2) += loc_1 * int2_grad1_u12_bimo_t(ipoint,2,i,j) + loc_2 * int2_grad1_u12_bimo_t(ipoint,2,j,i)
+ tmp_omp_d2(ipoint,3) += loc_1 * int2_grad1_u12_bimo_t(ipoint,3,i,j) + loc_2 * int2_grad1_u12_bimo_t(ipoint,3,j,i)
+ enddo
+ enddo
+ enddo
+ !$OMP END DO NOWAIT
+ !$OMP CRITICAL
+ do ipoint = 1, n_points_final_grid
+ tmp_1(ipoint,1) += tmp_omp_d2(ipoint,1)
+ tmp_1(ipoint,2) += tmp_omp_d2(ipoint,2)
+ tmp_1(ipoint,3) += tmp_omp_d2(ipoint,3)
+ enddo
+ !$OMP END CRITICAL
+
+ tmp_omp_d2 = 0.d0
+ !$OMP DO COLLAPSE(2)
+ do i = elec_beta_num+1, elec_alpha_num
+ do j = elec_beta_num+1, elec_alpha_num
+ do ipoint = 1, n_points_final_grid
+
+ loc_1 = mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
+
+ tmp_omp_d2(ipoint,1) += loc_1 * int2_grad1_u12_bimo_t(ipoint,1,i,j)
+ tmp_omp_d2(ipoint,2) += loc_1 * int2_grad1_u12_bimo_t(ipoint,2,i,j)
+ tmp_omp_d2(ipoint,3) += loc_1 * int2_grad1_u12_bimo_t(ipoint,3,i,j)
+ enddo
+ enddo
+ enddo
+ !$OMP END DO NOWAIT
+ !$OMP CRITICAL
+ do ipoint = 1, n_points_final_grid
+ tmp_1(ipoint,1) += tmp_omp_d2(ipoint,1)
+ tmp_1(ipoint,2) += tmp_omp_d2(ipoint,2)
+ tmp_1(ipoint,3) += tmp_omp_d2(ipoint,3)
+ enddo
+ !$OMP END CRITICAL
+
+ deallocate(tmp_omp_d2)
+ !$OMP END PARALLEL
+
+ ! ---
+
+ allocate(tmp_2(n_points_final_grid,4,mo_num,mo_num))
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, a, b) &
+ !$OMP SHARED (n_points_final_grid, mo_num, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, &
+ !$OMP tmp_2)
+ !$OMP DO COLLAPSE(2)
+ do a = 1, mo_num
+ do b = 1, mo_num
+ do ipoint = 1, n_points_final_grid
+ tmp_2(ipoint,1,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,b,a)
+ tmp_2(ipoint,2,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,b,a)
+ tmp_2(ipoint,3,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,b,a)
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, a, b, i) &
+ !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
+ !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
+ !$OMP tmp_2)
+ !$OMP DO COLLAPSE(2)
+ do a = 1, mo_num
+ do b = 1, mo_num
+
+ tmp_2(:,4,b,a) = 0.d0
+ do i = 1, elec_beta_num
+ do ipoint = 1, n_points_final_grid
+ tmp_2(ipoint,4,b,a) += final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,a) &
+ + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,a) &
+ + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,a) )
+ enddo
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ ! ---
+
+ call dgemv( 'T', 4*n_points_final_grid, mo_num*mo_num, 1.d0 &
+ , tmp_2(1,1,1,1), size(tmp_2, 1) * size(tmp_2, 2) &
+ , tmp_1(1,1), 1 &
+ , 0.d0, fock_3e_mo_b_os(1,1), 1)
+
+ deallocate(tmp_1, tmp_2)
+
+ ! ---
+
+ allocate(tmp_3(n_points_final_grid,2,mo_num), tmp_4(n_points_final_grid,2,mo_num))
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, b, loc_1, loc_2) &
+ !$OMP SHARED (n_points_final_grid, mo_num, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP final_weight_at_r_vector, Jkappa, Jbarkappa, tmp_3, tmp_4)
+ !$OMP DO
+ do b = 1, mo_num
+ tmp_3(:,:,b) = 0.d0
+ tmp_4(:,:,b) = 0.d0
+ do ipoint = 1, n_points_final_grid
+
+ tmp_3(ipoint,1,b) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,b)
+
+ loc_1 = -2.0d0 * mos_r_in_r_array_transp(ipoint,b)
+
+ tmp_4(ipoint,1,b) = loc_1 * ( Jbarkappa(ipoint,1) * (Jkappa(ipoint,1) + 0.25d0 * Jbarkappa(ipoint,1)) &
+ + Jbarkappa(ipoint,2) * (Jkappa(ipoint,2) + 0.25d0 * Jbarkappa(ipoint,2)) &
+ + Jbarkappa(ipoint,3) * (Jkappa(ipoint,3) + 0.25d0 * Jbarkappa(ipoint,3)) )
+
+ tmp_4(ipoint,2,b) = mos_r_in_r_array_transp(ipoint,b)
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, b, i, loc_1, loc_2, loc_3, loc_4) &
+ !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
+ !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP Jkappa, Jbarkappa, tmp_3, tmp_4)
+ !$OMP DO
+ do b = 1, mo_num
+
+ do i = 1, elec_beta_num
+ do ipoint = 1, n_points_final_grid
+
+ loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
+ loc_2 = mos_r_in_r_array_transp(ipoint,i)
+
+ tmp_3(ipoint,2,b) += loc_1 * ( Jbarkappa(ipoint,1) * int2_grad1_u12_bimo_t(ipoint,1,b,i) &
+ + Jbarkappa(ipoint,2) * int2_grad1_u12_bimo_t(ipoint,2,b,i) &
+ + Jbarkappa(ipoint,3) * int2_grad1_u12_bimo_t(ipoint,3,b,i) )
+
+ tmp_4(ipoint,1,b) += loc_2 * ( Jbarkappa(ipoint,1) * int2_grad1_u12_bimo_t(ipoint,1,i,b) &
+ + Jbarkappa(ipoint,2) * int2_grad1_u12_bimo_t(ipoint,2,i,b) &
+ + Jbarkappa(ipoint,3) * int2_grad1_u12_bimo_t(ipoint,3,i,b) )
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, b, i, j, loc_1, loc_2, loc_3) &
+ !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
+ !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP tmp_3, tmp_4)
+ !$OMP DO
+ do b = 1, mo_num
+ do i = 1, elec_beta_num
+ do j = elec_beta_num+1, elec_alpha_num
+ do ipoint = 1, n_points_final_grid
+
+ loc_2 = mos_r_in_r_array_transp(ipoint,b)
+
+ tmp_4(ipoint,1,b) += loc_2 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
+ + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
+ + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) )
+ enddo
+ enddo
+ enddo
+
+ do i = elec_beta_num+1, elec_alpha_num
+ do j = elec_beta_num+1, elec_alpha_num
+ do ipoint = 1, n_points_final_grid
+
+ loc_2 = 0.5d0 * mos_r_in_r_array_transp(ipoint,b)
+
+ tmp_4(ipoint,1,b) += loc_2 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
+ + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
+ + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) )
+ enddo
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ ! ---
+
+ call dgemm( 'T', 'N', mo_num, mo_num, 2*n_points_final_grid, 1.d0 &
+ , tmp_3(1,1,1), 2*n_points_final_grid &
+ , tmp_4(1,1,1), 2*n_points_final_grid &
+ , 1.d0, fock_3e_mo_b_os(1,1), mo_num)
+
+ deallocate(tmp_3, tmp_4)
+
+ ! ---
+
+ fock_3e_mo_a_os = fock_3e_mo_b_os
+
+ allocate(tmp_1(n_points_final_grid,1))
+
+ do ipoint = 1, n_points_final_grid
+ tmp_1(ipoint,1) = Obarkappa(ipoint) + 2.d0 * Okappa(ipoint)
+ enddo
+
+ allocate(tmp_2(n_points_final_grid,1,mo_num,mo_num))
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, a, b, i) &
+ !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
+ !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
+ !$OMP tmp_2)
+ !$OMP DO COLLAPSE(2)
+ do a = 1, mo_num
+ do b = 1, mo_num
+
+ tmp_2(:,1,b,a) = 0.d0
+ do i = elec_beta_num+1, elec_alpha_num
+ do ipoint = 1, n_points_final_grid
+ tmp_2(ipoint,1,b,a) += final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,a) &
+ + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,a) &
+ + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,a) )
+ enddo
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ call dgemv( 'T', n_points_final_grid, mo_num*mo_num, 1.d0 &
+ , tmp_2(1,1,1,1), size(tmp_2, 1) * size(tmp_2, 2) &
+ , tmp_1(1,1), 1 &
+ , 1.d0, fock_3e_mo_a_os(1,1), 1)
+
+ deallocate(tmp_1, tmp_2)
+
+ ! ---
+
+ allocate(tmp_3(n_points_final_grid,8,mo_num), tmp_4(n_points_final_grid,8,mo_num))
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, b) &
+ !$OMP SHARED (n_points_final_grid, mo_num, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP final_weight_at_r_vector, Jkappa, Jbarkappa, tmp_3, tmp_4)
+ !$OMP DO
+ do b = 1, mo_num
+ tmp_3(:,:,b) = 0.d0
+ tmp_4(:,:,b) = 0.d0
+ do ipoint = 1, n_points_final_grid
+
+ tmp_3(ipoint,1,b) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,b)
+
+ tmp_4(ipoint,8,b) = mos_r_in_r_array_transp(ipoint,b)
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, b, i, loc_1, loc_2, loc_3, loc_4) &
+ !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
+ !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP Jkappa, Jbarkappa, tmp_3, tmp_4)
+ !$OMP DO
+ do b = 1, mo_num
+ do i = 1, elec_beta_num
+ do ipoint = 1, n_points_final_grid
+
+ loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
+ loc_2 = mos_r_in_r_array_transp(ipoint,i)
+
+ tmp_3(ipoint,2,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,1,b,i)
+ tmp_3(ipoint,3,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,2,b,i)
+ tmp_3(ipoint,4,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,3,b,i)
+
+ tmp_4(ipoint,5,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,1,i,b)
+ tmp_4(ipoint,6,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,2,i,b)
+ tmp_4(ipoint,7,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,3,i,b)
+ enddo
+ enddo
+
+ do i = elec_beta_num+1, elec_alpha_num
+ do ipoint = 1, n_points_final_grid
+
+ loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
+ loc_3 = 2.d0 * loc_1
+ loc_2 = mos_r_in_r_array_transp(ipoint,i)
+ loc_4 = 2.d0 * loc_2
+
+ tmp_3(ipoint,5,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,1,b,i)
+ tmp_3(ipoint,6,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,2,b,i)
+ tmp_3(ipoint,7,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,3,b,i)
+
+ tmp_3(ipoint,8,b) += loc_3 * ( (Jkappa(ipoint,1) + 0.5d0 * Jbarkappa(ipoint,1)) * int2_grad1_u12_bimo_t(ipoint,1,b,i) &
+ + (Jkappa(ipoint,2) + 0.5d0 * Jbarkappa(ipoint,2)) * int2_grad1_u12_bimo_t(ipoint,2,b,i) &
+ + (Jkappa(ipoint,3) + 0.5d0 * Jbarkappa(ipoint,3)) * int2_grad1_u12_bimo_t(ipoint,3,b,i) )
+
+ tmp_4(ipoint,1,b) += loc_4 * ( (Jkappa(ipoint,1) + 0.5d0 * Jbarkappa(ipoint,1)) * int2_grad1_u12_bimo_t(ipoint,1,i,b) &
+ + (Jkappa(ipoint,2) + 0.5d0 * Jbarkappa(ipoint,2)) * int2_grad1_u12_bimo_t(ipoint,2,i,b) &
+ + (Jkappa(ipoint,3) + 0.5d0 * Jbarkappa(ipoint,3)) * int2_grad1_u12_bimo_t(ipoint,3,i,b) )
+
+ tmp_4(ipoint,2,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,1,i,b)
+ tmp_4(ipoint,3,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,2,i,b)
+ tmp_4(ipoint,4,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,3,i,b)
+
+ tmp_4(ipoint,5,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,1,i,b)
+ tmp_4(ipoint,6,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,2,i,b)
+ tmp_4(ipoint,7,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,3,i,b)
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, b, i, j, loc_1, loc_2, loc_3) &
+ !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
+ !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP tmp_3, tmp_4)
+ !$OMP DO
+ do b = 1, mo_num
+
+ do i = 1, elec_beta_num
+ do j = elec_beta_num+1, elec_alpha_num
+ do ipoint = 1, n_points_final_grid
+
+ loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,j)
+ loc_2 = mos_r_in_r_array_transp(ipoint,b)
+ loc_3 = mos_r_in_r_array_transp(ipoint,i)
+
+ tmp_3(ipoint,8,b) -= loc_1 * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,j) &
+ + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,j) &
+ + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,j) )
+
+ tmp_4(ipoint,1,b) -= loc_3 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,b) &
+ + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,b) &
+ + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,b) )
+
+ loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
+ loc_3 = mos_r_in_r_array_transp(ipoint,j)
+
+ tmp_3(ipoint,8,b) -= loc_1 * ( int2_grad1_u12_bimo_t(ipoint,1,b,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
+ + int2_grad1_u12_bimo_t(ipoint,2,b,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
+ + int2_grad1_u12_bimo_t(ipoint,3,b,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) )
+
+ tmp_4(ipoint,1,b) -= loc_3 * ( int2_grad1_u12_bimo_t(ipoint,1,j,i) * int2_grad1_u12_bimo_t(ipoint,1,i,b) &
+ + int2_grad1_u12_bimo_t(ipoint,2,j,i) * int2_grad1_u12_bimo_t(ipoint,2,i,b) &
+ + int2_grad1_u12_bimo_t(ipoint,3,j,i) * int2_grad1_u12_bimo_t(ipoint,3,i,b) )
+ enddo
+ enddo
+ enddo
+
+ do i = elec_beta_num+1, elec_alpha_num
+ do j = elec_beta_num+1, elec_alpha_num
+ do ipoint = 1, n_points_final_grid
+
+ loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,j)
+ loc_2 = 0.5d0 * mos_r_in_r_array_transp(ipoint,b)
+ loc_3 = mos_r_in_r_array_transp(ipoint,i)
+
+ tmp_3(ipoint,8,b) -= loc_1 * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,j) &
+ + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,j) &
+ + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,j) )
+
+ tmp_4(ipoint,1,b) -= loc_3 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,b) &
+ + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,b) &
+ + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,b) )
+ enddo
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ ! ---
+
+ call dgemm( 'T', 'N', mo_num, mo_num, 8*n_points_final_grid, 1.d0 &
+ , tmp_3(1,1,1), 8*n_points_final_grid &
+ , tmp_4(1,1,1), 8*n_points_final_grid &
+ , 1.d0, fock_3e_mo_a_os(1,1), mo_num)
+
+ deallocate(tmp_3, tmp_4)
+ deallocate(Jkappa, Okappa)
+
+END_PROVIDER
+
+! ---
+
+BEGIN_PROVIDER [double precision, fock_3e_mo_cs, (mo_num, mo_num)]
+
+ implicit none
+ integer :: a, b, i, j, ipoint
+ double precision :: ti, tf
+ double precision :: loc_1, loc_2, loc_3
+ double precision, allocatable :: Okappa(:), Jkappa(:,:)
+ double precision, allocatable :: tmp_omp_d1(:), tmp_omp_d2(:,:)
+ double precision, allocatable :: tmp_1(:,:), tmp_2(:,:,:,:), tmp_22(:,:,:)
+ double precision, allocatable :: tmp_3(:,:,:), tmp_4(:,:,:)
+
+ PROVIDE mo_l_coef mo_r_coef
+
+ ! ---
+
+ allocate(Jkappa(n_points_final_grid,3), Okappa(n_points_final_grid))
+ Jkappa = 0.d0
+ Okappa = 0.d0
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, i, tmp_omp_d1, tmp_omp_d2) &
+ !$OMP SHARED (n_points_final_grid, elec_beta_num, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP int2_grad1_u12_bimo_t, Okappa, Jkappa)
+
+ allocate(tmp_omp_d2(n_points_final_grid,3), tmp_omp_d1(n_points_final_grid))
+ tmp_omp_d2 = 0.d0
+ tmp_omp_d1 = 0.d0
+
+ !$OMP DO
+ do i = 1, elec_beta_num
+ do ipoint = 1, n_points_final_grid
+ tmp_omp_d2(ipoint,1) += int2_grad1_u12_bimo_t(ipoint,1,i,i)
+ tmp_omp_d2(ipoint,2) += int2_grad1_u12_bimo_t(ipoint,2,i,i)
+ tmp_omp_d2(ipoint,3) += int2_grad1_u12_bimo_t(ipoint,3,i,i)
+ tmp_omp_d1(ipoint) += mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
+ enddo
+ enddo
+ !$OMP END DO NOWAIT
+
+ !$OMP CRITICAL
+ do ipoint = 1, n_points_final_grid
+ Jkappa(ipoint,1) += tmp_omp_d2(ipoint,1)
+ Jkappa(ipoint,2) += tmp_omp_d2(ipoint,2)
+ Jkappa(ipoint,3) += tmp_omp_d2(ipoint,3)
+ Okappa(ipoint) += tmp_omp_d1(ipoint)
+ enddo
+ !$OMP END CRITICAL
+
+ deallocate(tmp_omp_d2, tmp_omp_d1)
+
+ !$OMP END PARALLEL
+
+ ! ---
+
+ allocate(tmp_1(n_points_final_grid,4))
+
+ do ipoint = 1, n_points_final_grid
+ loc_1 = 2.d0 * Okappa(ipoint)
+ tmp_1(ipoint,1) = loc_1 * Jkappa(ipoint,1)
+ tmp_1(ipoint,2) = loc_1 * Jkappa(ipoint,2)
+ tmp_1(ipoint,3) = loc_1 * Jkappa(ipoint,3)
+ tmp_1(ipoint,4) = Okappa(ipoint)
+ enddo
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, i, j, loc_1, tmp_omp_d2) &
+ !$OMP SHARED (n_points_final_grid, elec_beta_num, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP int2_grad1_u12_bimo_t, tmp_1)
+
+ allocate(tmp_omp_d2(n_points_final_grid,3))
+ tmp_omp_d2 = 0.d0
+
+ !$OMP DO COLLAPSE(2)
+ do i = 1, elec_beta_num
+ do j = 1, elec_beta_num
+ do ipoint = 1, n_points_final_grid
+
+ loc_1 = mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
+
+ tmp_omp_d2(ipoint,1) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,1,i,j)
+ tmp_omp_d2(ipoint,2) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,2,i,j)
+ tmp_omp_d2(ipoint,3) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,3,i,j)
+ enddo
+ enddo
+ enddo
+ !$OMP END DO NOWAIT
+
+ !$OMP CRITICAL
+ do ipoint = 1, n_points_final_grid
+ tmp_1(ipoint,1) += tmp_omp_d2(ipoint,1)
+ tmp_1(ipoint,2) += tmp_omp_d2(ipoint,2)
+ tmp_1(ipoint,3) += tmp_omp_d2(ipoint,3)
+ enddo
+ !$OMP END CRITICAL
+
+ deallocate(tmp_omp_d2)
+ !$OMP END PARALLEL
+
+ ! ---
+
+ if(tc_save_mem) then
+
+ allocate(tmp_22(n_points_final_grid,4,mo_num))
+ do a = 1, mo_num
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, b, i) &
+ !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, a, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, &
+ !$OMP tmp_22)
+ !$OMP DO
+ do b = 1, mo_num
+ do ipoint = 1, n_points_final_grid
+ tmp_22(ipoint,1,b) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,b,a)
+ tmp_22(ipoint,2,b) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,b,a)
+ tmp_22(ipoint,3,b) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,b,a)
+ enddo
+ tmp_22(:,4,b) = 0.d0
+ do i = 1, elec_beta_num
+ do ipoint = 1, n_points_final_grid
+ tmp_22(ipoint,4,b) -= final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,a) &
+ + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,a) &
+ + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,a) )
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+ call dgemv( 'T', 4*n_points_final_grid, mo_num, -2.d0 &
+ , tmp_22(1,1,1), size(tmp_22, 1) * size(tmp_22, 2) &
+ , tmp_1(1,1), 1 &
+ , 0.d0, fock_3e_mo_cs(1,a), 1)
+ enddo
+ deallocate(tmp_22)
+
+ else
+
+ allocate(tmp_2(n_points_final_grid,4,mo_num,mo_num))
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, a, b, i) &
+ !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, &
+ !$OMP tmp_2)
+ !$OMP DO COLLAPSE(2)
+ do a = 1, mo_num
+ do b = 1, mo_num
+ do ipoint = 1, n_points_final_grid
+ tmp_2(ipoint,1,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,b,a)
+ tmp_2(ipoint,2,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,b,a)
+ tmp_2(ipoint,3,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,b,a)
+ enddo
+ tmp_2(:,4,b,a) = 0.d0
+ do i = 1, elec_beta_num
+ do ipoint = 1, n_points_final_grid
+ tmp_2(ipoint,4,b,a) -= final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,a) &
+ + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,a) &
+ + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,a) )
+ enddo
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+ call dgemv( 'T', 4*n_points_final_grid, mo_num*mo_num, -2.d0 &
+ , tmp_2(1,1,1,1), size(tmp_2, 1) * size(tmp_2, 2) &
+ , tmp_1(1,1), 1 &
+ , 0.d0, fock_3e_mo_cs(1,1), 1)
+ deallocate(tmp_2)
+
+ endif
+
+ deallocate(tmp_1)
+
+ ! ---
+
+ allocate(tmp_3(n_points_final_grid,5,mo_num), tmp_4(n_points_final_grid,5,mo_num))
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, b, loc_1, loc_2) &
+ !$OMP SHARED (n_points_final_grid, mo_num, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP final_weight_at_r_vector, Jkappa, tmp_3, tmp_4)
+ !$OMP DO
+ do b = 1, mo_num
+ tmp_3(:,:,b) = 0.d0
+ tmp_4(:,:,b) = 0.d0
+ do ipoint = 1, n_points_final_grid
+ tmp_3(ipoint,1,b) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,b)
+
+ tmp_4(ipoint,1,b) = -2.d0 * mos_r_in_r_array_transp(ipoint,b) * ( Jkappa(ipoint,1) * Jkappa(ipoint,1) &
+ + Jkappa(ipoint,2) * Jkappa(ipoint,2) &
+ + Jkappa(ipoint,3) * Jkappa(ipoint,3) )
+ tmp_4(ipoint,5,b) = mos_r_in_r_array_transp(ipoint,b)
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, b, i, loc_1, loc_2) &
+ !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, &
+ !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP Jkappa, tmp_3, tmp_4)
+ !$OMP DO
+ do b = 1, mo_num
+ do i = 1, elec_beta_num
+ do ipoint = 1, n_points_final_grid
+
+ loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
+ loc_2 = mos_r_in_r_array_transp(ipoint,i)
+
+ tmp_3(ipoint,2,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,1,b,i)
+ tmp_3(ipoint,3,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,2,b,i)
+ tmp_3(ipoint,4,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,3,b,i)
+ tmp_3(ipoint,5,b) += 2.d0 * loc_1 * ( Jkappa(ipoint,1) * int2_grad1_u12_bimo_t(ipoint,1,b,i) &
+ + Jkappa(ipoint,2) * int2_grad1_u12_bimo_t(ipoint,2,b,i) &
+ + Jkappa(ipoint,3) * int2_grad1_u12_bimo_t(ipoint,3,b,i) )
+
+ tmp_4(ipoint,2,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,1,i,b)
+ tmp_4(ipoint,3,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,2,i,b)
+ tmp_4(ipoint,4,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,3,i,b)
+ tmp_4(ipoint,1,b) += 2.d0 * loc_2 * ( Jkappa(ipoint,1) * int2_grad1_u12_bimo_t(ipoint,1,i,b) &
+ + Jkappa(ipoint,2) * int2_grad1_u12_bimo_t(ipoint,2,i,b) &
+ + Jkappa(ipoint,3) * int2_grad1_u12_bimo_t(ipoint,3,i,b) )
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, b, i, j, loc_1, loc_2, loc_3) &
+ !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, &
+ !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP tmp_3, tmp_4)
+ !$OMP DO
+ do b = 1, mo_num
+ do i = 1, elec_beta_num
+ do j = 1, elec_beta_num
+ do ipoint = 1, n_points_final_grid
+
+ loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,j)
+ loc_2 = mos_r_in_r_array_transp(ipoint,b)
+ loc_3 = mos_r_in_r_array_transp(ipoint,i)
+
+ tmp_3(ipoint,5,b) -= loc_1 * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,j) &
+ + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,j) &
+ + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,j) )
+
+ tmp_4(ipoint,1,b) += ( loc_2 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
+ + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
+ + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) ) &
+ - loc_3 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,b) &
+ + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,b) &
+ + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,b) ) )
+ enddo
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ ! ---
+
+ call dgemm( 'T', 'N', mo_num, mo_num, 5*n_points_final_grid, 1.d0 &
+ , tmp_3(1,1,1), 5*n_points_final_grid &
+ , tmp_4(1,1,1), 5*n_points_final_grid &
+ , 1.d0, fock_3e_mo_cs(1,1), mo_num)
+
+ deallocate(tmp_3, tmp_4)
+ deallocate(Jkappa, Okappa)
+
+ ! ---
+
+END_PROVIDER
+
+! ---
+
diff --git a/plugins/local/tc_scf/fock_tc_mo_tot.irp.f b/plugins/local/tc_scf/fock_tc_mo_tot.irp.f
index eb8973ff..fd490af6 100644
--- a/plugins/local/tc_scf/fock_tc_mo_tot.irp.f
+++ b/plugins/local/tc_scf/fock_tc_mo_tot.irp.f
@@ -1,4 +1,6 @@
+! ---
+
BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_tot, (mo_num,mo_num) ]
&BEGIN_PROVIDER [ double precision, Fock_matrix_tc_diag_mo_tot, (mo_num)]
@@ -23,9 +25,6 @@
integer :: i, j, n
double precision :: t0, t1
- !print*, ' Providing Fock_matrix_tc_mo_tot ...'
- !call wall_time(t0)
-
if(elec_alpha_num == elec_beta_num) then
PROVIDE Fock_matrix_tc_mo_alpha
@@ -133,7 +132,7 @@
enddo
endif
- if(no_oa_or_av_opt)then
+ if(no_oa_or_av_opt) then
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_inact_orb
@@ -154,12 +153,25 @@
enddo
endif
- if(.not.bi_ortho .and. three_body_h_tc)then
- Fock_matrix_tc_mo_tot += fock_3_mat
- endif
+ if(tc_Brillouin_Right) then
- !call wall_time(t1)
- !print*, ' Wall time for Fock_matrix_tc_mo_tot =', t1-t0
+ double precision, allocatable :: tmp(:,:)
+ allocate(tmp(mo_num,mo_num))
+
+ tmp = Fock_matrix_tc_mo_tot
+ do j = 1, mo_num
+ do i = 1, j-1
+ tmp(i,j) = Fock_matrix_tc_mo_tot(j,i)
+ enddo
+ enddo
+
+ Fock_matrix_tc_mo_tot = tmp
+ deallocate(tmp)
+
+ endif
END_PROVIDER
+! ---
+
+
diff --git a/plugins/local/tc_scf/fock_three_hermit.irp.f b/plugins/local/tc_scf/fock_three_hermit.irp.f
deleted file mode 100644
index 00d47fae..00000000
--- a/plugins/local/tc_scf/fock_three_hermit.irp.f
+++ /dev/null
@@ -1,771 +0,0 @@
-
-! ---
-
-BEGIN_PROVIDER [ double precision, fock_3_mat, (mo_num, mo_num)]
-
- implicit none
- integer :: i,j
- double precision :: contrib
-
- fock_3_mat = 0.d0
- if(.not.bi_ortho .and. three_body_h_tc) then
-
- call give_fock_ia_three_e_total(1, 1, contrib)
- !! !$OMP PARALLEL &
- !! !$OMP DEFAULT (NONE) &
- !! !$OMP PRIVATE (i,j,m,integral) &
- !! !$OMP SHARED (mo_num,three_body_3_index)
- !! !$OMP DO SCHEDULE (guided) COLLAPSE(3)
- do i = 1, mo_num
- do j = 1, mo_num
- call give_fock_ia_three_e_total(j,i,contrib)
- fock_3_mat(j,i) = -contrib
- enddo
- enddo
- !else if(bi_ortho.and.three_body_h_tc) then
- !! !$OMP END DO
- !! !$OMP END PARALLEL
- !! do i = 1, mo_num
- !! do j = 1, i-1
- !! mat_three(j,i) = mat_three(i,j)
- !! enddo
- !! enddo
- endif
-
-END_PROVIDER
-
-
-subroutine give_fock_ia_three_e_total(i,a,contrib)
- implicit none
- BEGIN_DOC
-! contrib is the TOTAL (same spins / opposite spins) contribution from the three body term to the Fock operator
-!
- END_DOC
- integer, intent(in) :: i,a
- double precision, intent(out) :: contrib
- double precision :: int_1, int_2, int_3
- double precision :: mos_i, mos_a, w_ia
- double precision :: mos_ia, weight
-
- integer :: mm, ipoint,k,l
-
- int_1 = 0.d0
- int_2 = 0.d0
- int_3 = 0.d0
- do mm = 1, 3
- do ipoint = 1, n_points_final_grid
- weight = final_weight_at_r_vector(ipoint)
- mos_i = mos_in_r_array_transp(ipoint,i)
- mos_a = mos_in_r_array_transp(ipoint,a)
- mos_ia = mos_a * mos_i
- w_ia = x_W_ij_erf_rk(ipoint,mm,i,a)
-
- int_1 += weight * fock_3_w_kk_sum(ipoint,mm) * (4.d0 * fock_3_rho_beta(ipoint) * w_ia &
- + 2.0d0 * mos_ia * fock_3_w_kk_sum(ipoint,mm) &
- - 2.0d0 * fock_3_w_ki_mos_k(ipoint,mm,i) * mos_a &
- - 2.0d0 * fock_3_w_ki_mos_k(ipoint,mm,a) * mos_i )
- int_2 += weight * (-1.d0) * ( 2.0d0 * fock_3_w_kl_mo_k_mo_l(ipoint,mm) * w_ia &
- + 2.0d0 * fock_3_rho_beta(ipoint) * fock_3_w_ki_wk_a(ipoint,mm,i,a) &
- + 1.0d0 * mos_ia * fock_3_trace_w_tilde(ipoint,mm) )
-
- int_3 += weight * 1.d0 * (fock_3_w_kl_wla_phi_k(ipoint,mm,i) * mos_a + fock_3_w_kl_wla_phi_k(ipoint,mm,a) * mos_i &
- +fock_3_w_ki_mos_k(ipoint,mm,i) * fock_3_w_ki_mos_k(ipoint,mm,a) )
- enddo
- enddo
- contrib = int_1 + int_2 + int_3
-
-end
-
-! ---
-
-BEGIN_PROVIDER [double precision, diag_three_elem_hf]
-
- implicit none
- integer :: i, j, k, ipoint, mm
- double precision :: contrib, weight, four_third, one_third, two_third, exchange_int_231
- double precision :: integral_aaa, hthree, integral_aab, integral_abb, integral_bbb
- double precision, allocatable :: tmp(:)
- double precision, allocatable :: tmp_L(:,:), tmp_R(:,:)
- double precision, allocatable :: tmp_M(:,:), tmp_S(:), tmp_O(:), tmp_J(:,:)
- double precision, allocatable :: tmp_M_priv(:,:), tmp_S_priv(:), tmp_O_priv(:), tmp_J_priv(:,:)
-
- PROVIDE mo_l_coef mo_r_coef
-
- !print *, ' providing diag_three_elem_hf'
-
- if(.not. three_body_h_tc) then
-
- if(noL_standard) then
- PROVIDE noL_0e
- diag_three_elem_hf = noL_0e
- else
- diag_three_elem_hf = 0.d0
- endif
-
- else
-
- if(.not. bi_ortho) then
-
- ! ---
-
- one_third = 1.d0/3.d0
- two_third = 2.d0/3.d0
- four_third = 4.d0/3.d0
- diag_three_elem_hf = 0.d0
- do i = 1, elec_beta_num
- do j = 1, elec_beta_num
- do k = 1, elec_beta_num
- call give_integrals_3_body(k, j, i, j, i, k, exchange_int_231)
- diag_three_elem_hf += two_third * exchange_int_231
- enddo
- enddo
- enddo
- do mm = 1, 3
- do ipoint = 1, n_points_final_grid
- weight = final_weight_at_r_vector(ipoint)
- contrib = 3.d0 * fock_3_w_kk_sum(ipoint,mm) * fock_3_rho_beta(ipoint) * fock_3_w_kk_sum(ipoint,mm) &
- - 2.d0 * fock_3_w_kl_mo_k_mo_l(ipoint,mm) * fock_3_w_kk_sum(ipoint,mm) &
- - 1.d0 * fock_3_rho_beta(ipoint) * fock_3_w_kl_w_kl(ipoint,mm)
- contrib *= four_third
- contrib += -two_third * fock_3_rho_beta(ipoint) * fock_3_w_kl_w_kl(ipoint,mm) &
- -four_third * fock_3_w_kk_sum(ipoint,mm) * fock_3_w_kl_mo_k_mo_l(ipoint,mm)
- diag_three_elem_hf += weight * contrib
- enddo
- enddo
-
- diag_three_elem_hf = - diag_three_elem_hf
-
- ! ---
-
- else
-
- ! ------------
- ! SLOW VERSION
- ! ------------
-
- !call give_aaa_contrib(integral_aaa)
- !call give_aab_contrib(integral_aab)
- !call give_abb_contrib(integral_abb)
- !call give_bbb_contrib(integral_bbb)
- !diag_three_elem_hf = integral_aaa + integral_aab + integral_abb + integral_bbb
-
- ! ------------
- ! ------------
-
- PROVIDE int2_grad1_u12_bimo_t
- PROVIDE mos_l_in_r_array_transp
- PROVIDE mos_r_in_r_array_transp
-
- if(elec_alpha_num .eq. elec_beta_num) then
-
- allocate(tmp(elec_beta_num))
- allocate(tmp_L(n_points_final_grid,3), tmp_R(n_points_final_grid,3))
-
- !$OMP PARALLEL &
- !$OMP DEFAULT(NONE) &
- !$OMP PRIVATE(j, i, ipoint, tmp_L, tmp_R) &
- !$OMP SHARED(elec_beta_num, n_points_final_grid, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, tmp, final_weight_at_r_vector)
-
- !$OMP DO
- do j = 1, elec_beta_num
-
- tmp_L = 0.d0
- tmp_R = 0.d0
- do i = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
-
- tmp_L(ipoint,1) = tmp_L(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i)
- tmp_L(ipoint,2) = tmp_L(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i)
- tmp_L(ipoint,3) = tmp_L(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i)
-
- tmp_R(ipoint,1) = tmp_R(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_R(ipoint,2) = tmp_R(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_R(ipoint,3) = tmp_R(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i)
- enddo
- enddo
-
- tmp(j) = 0.d0
- do ipoint = 1, n_points_final_grid
- tmp(j) = tmp(j) + final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3))
- enddo
- enddo ! j
- !$OMP END DO
- !$OMP END PARALLEL
-
- diag_three_elem_hf = -2.d0 * sum(tmp)
-
- deallocate(tmp)
- deallocate(tmp_L, tmp_R)
-
- ! ---
-
- allocate(tmp_O(n_points_final_grid), tmp_J(n_points_final_grid,3))
- tmp_O = 0.d0
- tmp_J = 0.d0
-
- !$OMP PARALLEL &
- !$OMP DEFAULT(NONE) &
- !$OMP PRIVATE(i, ipoint, tmp_O_priv, tmp_J_priv) &
- !$OMP SHARED(elec_beta_num, n_points_final_grid, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, tmp_O, tmp_J)
-
- allocate(tmp_O_priv(n_points_final_grid), tmp_J_priv(n_points_final_grid,3))
- tmp_O_priv = 0.d0
- tmp_J_priv = 0.d0
-
- !$OMP DO
- do i = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
- tmp_O_priv(ipoint) = tmp_O_priv(ipoint) + mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
- tmp_J_priv(ipoint,1) = tmp_J_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,i)
- tmp_J_priv(ipoint,2) = tmp_J_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,i)
- tmp_J_priv(ipoint,3) = tmp_J_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,i)
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
- tmp_O = tmp_O + tmp_O_priv
- tmp_J = tmp_J + tmp_J_priv
- !$OMP END CRITICAL
-
- deallocate(tmp_O_priv, tmp_J_priv)
- !$OMP END PARALLEL
-
- allocate(tmp_M(n_points_final_grid,3), tmp_S(n_points_final_grid))
- tmp_M = 0.d0
- tmp_S = 0.d0
-
- !$OMP PARALLEL &
- !$OMP DEFAULT(NONE) &
- !$OMP PRIVATE(i, j, ipoint, tmp_M_priv, tmp_S_priv) &
- !$OMP SHARED(elec_beta_num, n_points_final_grid, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, tmp_M, tmp_S)
-
- allocate(tmp_M_priv(n_points_final_grid,3), tmp_S_priv(n_points_final_grid))
- tmp_M_priv = 0.d0
- tmp_S_priv = 0.d0
-
- !$OMP DO COLLAPSE(2)
- do i = 1, elec_beta_num
- do j = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
-
- tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
- tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
- tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
-
- tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i)
- enddo
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
- tmp_M = tmp_M + tmp_M_priv
- tmp_S = tmp_S + tmp_S_priv
- !$OMP END CRITICAL
-
- deallocate(tmp_M_priv, tmp_S_priv)
- !$OMP END PARALLEL
-
- allocate(tmp(n_points_final_grid))
-
- do ipoint = 1, n_points_final_grid
-
- tmp_S(ipoint) = 2.d0 * (tmp_J(ipoint,1)*tmp_J(ipoint,1) + tmp_J(ipoint,2)*tmp_J(ipoint,2) + tmp_J(ipoint,3)*tmp_J(ipoint,3)) - tmp_S(ipoint)
-
- tmp(ipoint) = final_weight_at_r_vector(ipoint) * ( tmp_O(ipoint) * tmp_S(ipoint) &
- - 2.d0 * ( tmp_J(ipoint,1) * tmp_M(ipoint,1) &
- + tmp_J(ipoint,2) * tmp_M(ipoint,2) &
- + tmp_J(ipoint,3) * tmp_M(ipoint,3)))
- enddo
-
- diag_three_elem_hf = diag_three_elem_hf -2.d0 * (sum(tmp))
-
- deallocate(tmp)
-
- else
-
- allocate(tmp(elec_alpha_num))
- allocate(tmp_L(n_points_final_grid,3), tmp_R(n_points_final_grid,3))
-
- !$OMP PARALLEL &
- !$OMP DEFAULT(NONE) &
- !$OMP PRIVATE(j, i, ipoint, tmp_L, tmp_R) &
- !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, tmp, final_weight_at_r_vector)
-
- !$OMP DO
- do j = 1, elec_beta_num
-
- tmp_L = 0.d0
- tmp_R = 0.d0
- do i = elec_beta_num+1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
-
- tmp_L(ipoint,1) = tmp_L(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i)
- tmp_L(ipoint,2) = tmp_L(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i)
- tmp_L(ipoint,3) = tmp_L(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i)
-
- tmp_R(ipoint,1) = tmp_R(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_R(ipoint,2) = tmp_R(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_R(ipoint,3) = tmp_R(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i)
- enddo
- enddo
-
- tmp(j) = 0.d0
- do ipoint = 1, n_points_final_grid
- tmp(j) = tmp(j) + final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3))
- enddo
-
- do i = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
-
- tmp_L(ipoint,1) = tmp_L(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i)
- tmp_L(ipoint,2) = tmp_L(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i)
- tmp_L(ipoint,3) = tmp_L(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i)
-
- tmp_R(ipoint,1) = tmp_R(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_R(ipoint,2) = tmp_R(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_R(ipoint,3) = tmp_R(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i)
- enddo
- enddo
-
- do ipoint = 1, n_points_final_grid
- tmp(j) = tmp(j) + final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3))
- enddo
- enddo ! j
- !$OMP END DO
- !$OMP END PARALLEL
-
- ! ---
-
- !$OMP PARALLEL &
- !$OMP DEFAULT(NONE) &
- !$OMP PRIVATE(j, i, ipoint, tmp_L, tmp_R) &
- !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, tmp, final_weight_at_r_vector)
-
- !$OMP DO
- do j = elec_beta_num+1, elec_alpha_num
-
- tmp_L = 0.d0
- tmp_R = 0.d0
- do i = 1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
- tmp_L(ipoint,1) = tmp_L(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i)
- tmp_L(ipoint,2) = tmp_L(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i)
- tmp_L(ipoint,3) = tmp_L(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i)
-
- tmp_R(ipoint,1) = tmp_R(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_R(ipoint,2) = tmp_R(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_R(ipoint,3) = tmp_R(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i)
- enddo
- enddo
-
- tmp(j) = 0.d0
- do ipoint = 1, n_points_final_grid
- tmp(j) = tmp(j) + 0.5d0 * final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3))
- enddo
- enddo ! j
- !$OMP END DO
- !$OMP END PARALLEL
-
- diag_three_elem_hf = -2.d0 * sum(tmp)
-
- deallocate(tmp)
- deallocate(tmp_L, tmp_R)
-
- ! ---
-
- allocate(tmp_O(n_points_final_grid), tmp_J(n_points_final_grid,3))
- tmp_O = 0.d0
- tmp_J = 0.d0
-
- !$OMP PARALLEL &
- !$OMP DEFAULT(NONE) &
- !$OMP PRIVATE(i, ipoint, tmp_O_priv, tmp_J_priv) &
- !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, tmp_O, tmp_J)
-
- allocate(tmp_O_priv(n_points_final_grid), tmp_J_priv(n_points_final_grid,3))
- tmp_O_priv = 0.d0
- tmp_J_priv = 0.d0
-
- !$OMP DO
- do i = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
- tmp_O_priv(ipoint) = tmp_O_priv(ipoint) + mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
- tmp_J_priv(ipoint,1) = tmp_J_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,i)
- tmp_J_priv(ipoint,2) = tmp_J_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,i)
- tmp_J_priv(ipoint,3) = tmp_J_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,i)
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP DO
- do i = elec_beta_num+1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
- tmp_O_priv(ipoint) = tmp_O_priv(ipoint) + 0.5d0 * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
- tmp_J_priv(ipoint,1) = tmp_J_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,i)
- tmp_J_priv(ipoint,2) = tmp_J_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,i)
- tmp_J_priv(ipoint,3) = tmp_J_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,i)
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
- tmp_O = tmp_O + tmp_O_priv
- tmp_J = tmp_J + tmp_J_priv
- !$OMP END CRITICAL
-
- deallocate(tmp_O_priv, tmp_J_priv)
- !$OMP END PARALLEL
-
- ! ---
-
- allocate(tmp_M(n_points_final_grid,3), tmp_S(n_points_final_grid))
- tmp_M = 0.d0
- tmp_S = 0.d0
-
- !$OMP PARALLEL &
- !$OMP DEFAULT(NONE) &
- !$OMP PRIVATE(i, j, ipoint, tmp_M_priv, tmp_S_priv) &
- !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, tmp_M, tmp_S)
-
- allocate(tmp_M_priv(n_points_final_grid,3), tmp_S_priv(n_points_final_grid))
- tmp_M_priv = 0.d0
- tmp_S_priv = 0.d0
-
- !$OMP DO COLLAPSE(2)
- do i = 1, elec_beta_num
- do j = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
-
- tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
- tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
- tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
-
- tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i)
- enddo
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP DO COLLAPSE(2)
- do i = elec_beta_num+1, elec_alpha_num
- do j = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
-
- tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
- tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
- tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
-
- tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
-
- tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i)
- enddo
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP DO COLLAPSE(2)
- do i = elec_beta_num+1, elec_alpha_num
- do j = elec_beta_num+1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
-
- tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
- tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
- tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
-
- tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
- + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
- + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i)
- enddo
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
- tmp_M = tmp_M + tmp_M_priv
- tmp_S = tmp_S + tmp_S_priv
- !$OMP END CRITICAL
-
- deallocate(tmp_M_priv, tmp_S_priv)
- !$OMP END PARALLEL
-
- allocate(tmp(n_points_final_grid))
-
- do ipoint = 1, n_points_final_grid
-
- tmp_S(ipoint) = 2.d0 * (tmp_J(ipoint,1)*tmp_J(ipoint,1) + tmp_J(ipoint,2)*tmp_J(ipoint,2) + tmp_J(ipoint,3)*tmp_J(ipoint,3)) - tmp_S(ipoint)
-
- tmp(ipoint) = final_weight_at_r_vector(ipoint) * ( tmp_O(ipoint) * tmp_S(ipoint) &
- - 2.d0 * ( tmp_J(ipoint,1) * tmp_M(ipoint,1) &
- + tmp_J(ipoint,2) * tmp_M(ipoint,2) &
- + tmp_J(ipoint,3) * tmp_M(ipoint,3)))
- enddo
-
- diag_three_elem_hf = diag_three_elem_hf - 2.d0 * (sum(tmp))
-
- deallocate(tmp)
-
- endif
-
-
- endif
-
- endif
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [ double precision, fock_3_mat_a_op_sh, (mo_num, mo_num)]
- implicit none
- integer :: h,p,i,j
- double precision :: direct_int, exch_int, exchange_int_231, exchange_int_312
- double precision :: exchange_int_23, exchange_int_12, exchange_int_13
-
- fock_3_mat_a_op_sh = 0.d0
- do h = 1, mo_num
- do p = 1, mo_num
- !F_a^{ab}(h,p)
- do i = 1, elec_beta_num ! beta
- do j = elec_beta_num+1, elec_alpha_num ! alpha
- call give_integrals_3_body(h,j,i,p,j,i,direct_int) !
- call give_integrals_3_body(h,j,i,j,p,i,exch_int)
- fock_3_mat_a_op_sh(h,p) -= direct_int - exch_int
- enddo
- enddo
- !F_a^{aa}(h,p)
- do i = 1, elec_beta_num ! alpha
- do j = elec_beta_num+1, elec_alpha_num ! alpha
- call give_integrals_3_body(h,j,i,p,j,i,direct_int)
- call give_integrals_3_body(h,j,i,i,p,j,exchange_int_231)
- call give_integrals_3_body(h,j,i,j,i,p,exchange_int_312)
- call give_integrals_3_body(h,j,i,p,i,j,exchange_int_23)
- call give_integrals_3_body(h,j,i,i,j,p,exchange_int_12)
- call give_integrals_3_body(h,j,i,j,p,i,exchange_int_13)
- fock_3_mat_a_op_sh(h,p) -= ( direct_int + exchange_int_231 + exchange_int_312 &
- - exchange_int_23 & ! i <-> j
- - exchange_int_12 & ! p <-> j
- - exchange_int_13 )! p <-> i
- enddo
- enddo
- enddo
- enddo
-! symmetrized
-! do p = 1, elec_beta_num
-! do h = elec_alpha_num +1, mo_num
-! fock_3_mat_a_op_sh(h,p) = fock_3_mat_a_op_sh(p,h)
-! enddo
-! enddo
-
-! do h = elec_beta_num+1, elec_alpha_num
-! do p = elec_alpha_num +1, mo_num
-! !F_a^{bb}(h,p)
-! do i = 1, elec_beta_num
-! do j = i+1, elec_beta_num
-! call give_integrals_3_body(h,j,i,p,j,i,direct_int)
-! call give_integrals_3_body(h,j,i,p,i,j,exch_int)
-! fock_3_mat_a_op_sh(h,p) -= direct_int - exch_int
-! enddo
-! enddo
-! enddo
-! enddo
-
-END_PROVIDER
-
-BEGIN_PROVIDER [ double precision, fock_3_mat_b_op_sh, (mo_num, mo_num)]
- implicit none
- integer :: h,p,i,j
- double precision :: direct_int, exch_int
- fock_3_mat_b_op_sh = 0.d0
- do h = 1, elec_beta_num
- do p = elec_alpha_num +1, mo_num
- !F_b^{aa}(h,p)
- do i = 1, elec_beta_num
- do j = elec_beta_num+1, elec_alpha_num
- call give_integrals_3_body(h,j,i,p,j,i,direct_int)
- call give_integrals_3_body(h,j,i,p,i,j,exch_int)
- fock_3_mat_b_op_sh(h,p) += direct_int - exch_int
- enddo
- enddo
-
- !F_b^{ab}(h,p)
- do i = elec_beta_num+1, elec_beta_num
- do j = 1, elec_beta_num
- call give_integrals_3_body(h,j,i,p,j,i,direct_int)
- call give_integrals_3_body(h,j,i,j,p,i,exch_int)
- fock_3_mat_b_op_sh(h,p) += direct_int - exch_int
- enddo
- enddo
-
- enddo
- enddo
-
-END_PROVIDER
-
-
-BEGIN_PROVIDER [ double precision, fock_3_w_kk_sum, (n_points_final_grid,3)]
- implicit none
- integer :: mm, ipoint,k
- double precision :: w_kk
- fock_3_w_kk_sum = 0.d0
- do k = 1, elec_beta_num
- do mm = 1, 3
- do ipoint = 1, n_points_final_grid
- w_kk = x_W_ij_erf_rk(ipoint,mm,k,k)
- fock_3_w_kk_sum(ipoint,mm) += w_kk
- enddo
- enddo
- enddo
-END_PROVIDER
-
-BEGIN_PROVIDER [ double precision, fock_3_w_ki_mos_k, (n_points_final_grid,3,mo_num)]
- implicit none
- integer :: mm, ipoint,k,i
- double precision :: w_ki, mo_k
- fock_3_w_ki_mos_k = 0.d0
- do i = 1, mo_num
- do k = 1, elec_beta_num
- do mm = 1, 3
- do ipoint = 1, n_points_final_grid
- w_ki = x_W_ij_erf_rk(ipoint,mm,k,i)
- mo_k = mos_in_r_array(k,ipoint)
- fock_3_w_ki_mos_k(ipoint,mm,i) += w_ki * mo_k
- enddo
- enddo
- enddo
- enddo
-
-END_PROVIDER
-
-BEGIN_PROVIDER [ double precision, fock_3_w_kl_w_kl, (n_points_final_grid,3)]
- implicit none
- integer :: k,j,ipoint,mm
- double precision :: w_kj
- fock_3_w_kl_w_kl = 0.d0
- do j = 1, elec_beta_num
- do k = 1, elec_beta_num
- do mm = 1, 3
- do ipoint = 1, n_points_final_grid
- w_kj = x_W_ij_erf_rk(ipoint,mm,k,j)
- fock_3_w_kl_w_kl(ipoint,mm) += w_kj * w_kj
- enddo
- enddo
- enddo
- enddo
-
-
-END_PROVIDER
-
-BEGIN_PROVIDER [ double precision, fock_3_rho_beta, (n_points_final_grid)]
- implicit none
- integer :: ipoint,k
- fock_3_rho_beta = 0.d0
- do ipoint = 1, n_points_final_grid
- do k = 1, elec_beta_num
- fock_3_rho_beta(ipoint) += mos_in_r_array(k,ipoint) * mos_in_r_array(k,ipoint)
- enddo
- enddo
-END_PROVIDER
-
-BEGIN_PROVIDER [ double precision, fock_3_w_kl_mo_k_mo_l, (n_points_final_grid,3)]
- implicit none
- integer :: ipoint,k,l,mm
- double precision :: mos_k, mos_l, w_kl
- fock_3_w_kl_mo_k_mo_l = 0.d0
- do k = 1, elec_beta_num
- do l = 1, elec_beta_num
- do mm = 1, 3
- do ipoint = 1, n_points_final_grid
- mos_k = mos_in_r_array_transp(ipoint,k)
- mos_l = mos_in_r_array_transp(ipoint,l)
- w_kl = x_W_ij_erf_rk(ipoint,mm,l,k)
- fock_3_w_kl_mo_k_mo_l(ipoint,mm) += w_kl * mos_k * mos_l
- enddo
- enddo
- enddo
- enddo
-
-END_PROVIDER
-
-BEGIN_PROVIDER [ double precision, fock_3_w_ki_wk_a, (n_points_final_grid,3,mo_num, mo_num)]
- implicit none
- integer :: ipoint,i,a,k,mm
- double precision :: w_ki,w_ka
- fock_3_w_ki_wk_a = 0.d0
- do i = 1, mo_num
- do a = 1, mo_num
- do mm = 1, 3
- do ipoint = 1, n_points_final_grid
- do k = 1, elec_beta_num
- w_ki = x_W_ij_erf_rk(ipoint,mm,k,i)
- w_ka = x_W_ij_erf_rk(ipoint,mm,k,a)
- fock_3_w_ki_wk_a(ipoint,mm,a,i) += w_ki * w_ka
- enddo
- enddo
- enddo
- enddo
- enddo
-END_PROVIDER
-
-BEGIN_PROVIDER [ double precision, fock_3_trace_w_tilde, (n_points_final_grid,3)]
- implicit none
- integer :: ipoint,k,mm
- fock_3_trace_w_tilde = 0.d0
- do k = 1, elec_beta_num
- do mm = 1, 3
- do ipoint = 1, n_points_final_grid
- fock_3_trace_w_tilde(ipoint,mm) += fock_3_w_ki_wk_a(ipoint,mm,k,k)
- enddo
- enddo
- enddo
-
-END_PROVIDER
-
-BEGIN_PROVIDER [ double precision, fock_3_w_kl_wla_phi_k, (n_points_final_grid,3,mo_num)]
- implicit none
- integer :: ipoint,a,k,mm,l
- double precision :: w_kl,w_la, mo_k
- fock_3_w_kl_wla_phi_k = 0.d0
- do a = 1, mo_num
- do k = 1, elec_beta_num
- do l = 1, elec_beta_num
- do mm = 1, 3
- do ipoint = 1, n_points_final_grid
- w_kl = x_W_ij_erf_rk(ipoint,mm,l,k)
- w_la = x_W_ij_erf_rk(ipoint,mm,l,a)
- mo_k = mos_in_r_array_transp(ipoint,k)
- fock_3_w_kl_wla_phi_k(ipoint,mm,a) += w_kl * w_la * mo_k
- enddo
- enddo
- enddo
- enddo
- enddo
-END_PROVIDER
-
-
-
-
-
diff --git a/plugins/local/tc_scf/fock_vartc.irp.f b/plugins/local/tc_scf/fock_vartc.irp.f
deleted file mode 100644
index 2b4a57e5..00000000
--- a/plugins/local/tc_scf/fock_vartc.irp.f
+++ /dev/null
@@ -1,287 +0,0 @@
-
-! ---
-
- BEGIN_PROVIDER [ double precision, two_e_vartc_integral_alpha, (ao_num, ao_num)]
-&BEGIN_PROVIDER [ double precision, two_e_vartc_integral_beta , (ao_num, ao_num)]
-
- implicit none
- integer :: i, j, k, l
- double precision :: density, density_a, density_b, I_coul, I_kjli
- double precision :: t0, t1
- double precision, allocatable :: tmp_a(:,:), tmp_b(:,:)
-
- two_e_vartc_integral_alpha = 0.d0
- two_e_vartc_integral_beta = 0.d0
-
- !$OMP PARALLEL DEFAULT (NONE) &
- !$OMP PRIVATE (i, j, k, l, density_a, density_b, density, tmp_a, tmp_b, I_coul, I_kjli) &
- !$OMP SHARED (ao_num, TCSCF_density_matrix_ao_alpha, TCSCF_density_matrix_ao_beta, ao_two_e_tc_tot, &
- !$OMP two_e_vartc_integral_alpha, two_e_vartc_integral_beta)
-
- allocate(tmp_a(ao_num,ao_num), tmp_b(ao_num,ao_num))
- tmp_a = 0.d0
- tmp_b = 0.d0
-
- !$OMP DO
- do j = 1, ao_num
- do l = 1, ao_num
- density_a = TCSCF_density_matrix_ao_alpha(l,j)
- density_b = TCSCF_density_matrix_ao_beta (l,j)
- density = density_a + density_b
- do i = 1, ao_num
- do k = 1, ao_num
-
- I_coul = density * ao_two_e_tc_tot(k,i,l,j)
- I_kjli = ao_two_e_tc_tot(k,j,l,i)
-
- tmp_a(k,i) += I_coul - density_a * I_kjli
- tmp_b(k,i) += I_coul - density_b * I_kjli
- enddo
- enddo
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
- do i = 1, ao_num
- do j = 1, ao_num
- two_e_vartc_integral_alpha(j,i) += tmp_a(j,i)
- two_e_vartc_integral_beta (j,i) += tmp_b(j,i)
- enddo
- enddo
- !$OMP END CRITICAL
-
- deallocate(tmp_a, tmp_b)
- !$OMP END PARALLEL
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [ double precision, Fock_matrix_vartc_ao_alpha, (ao_num, ao_num)]
-
- implicit none
-
- Fock_matrix_vartc_ao_alpha = ao_one_e_integrals_tc_tot + two_e_vartc_integral_alpha
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [ double precision, Fock_matrix_vartc_ao_beta, (ao_num, ao_num)]
-
- implicit none
-
- Fock_matrix_vartc_ao_beta = ao_one_e_integrals_tc_tot + two_e_vartc_integral_beta
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [ double precision, Fock_matrix_vartc_mo_alpha, (mo_num, mo_num) ]
-
- implicit none
-
- call ao_to_mo_bi_ortho( Fock_matrix_vartc_ao_alpha, size(Fock_matrix_vartc_ao_alpha, 1) &
- , Fock_matrix_vartc_mo_alpha, size(Fock_matrix_vartc_mo_alpha, 1) )
- if(three_body_h_tc) then
- Fock_matrix_vartc_mo_alpha += fock_3e_uhf_mo_a
- endif
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [ double precision, Fock_matrix_vartc_mo_beta, (mo_num,mo_num) ]
-
- implicit none
-
- call ao_to_mo_bi_ortho( Fock_matrix_vartc_ao_beta, size(Fock_matrix_vartc_ao_beta, 1) &
- , Fock_matrix_vartc_mo_beta, size(Fock_matrix_vartc_mo_beta, 1) )
- if(three_body_h_tc) then
- Fock_matrix_vartc_mo_beta += fock_3e_uhf_mo_b
- endif
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [ double precision, grad_vartc]
-
- implicit none
- integer :: i, k
- double precision :: grad_left, grad_right
-
- grad_left = 0.d0
- grad_right = 0.d0
-
- do i = 1, elec_beta_num ! doc --> SOMO
- do k = elec_beta_num+1, elec_alpha_num
- grad_left = max(grad_left , dabs(Fock_matrix_vartc_mo_tot(k,i)))
- grad_right = max(grad_right, dabs(Fock_matrix_vartc_mo_tot(i,k)))
- enddo
- enddo
-
- do i = 1, elec_beta_num ! doc --> virt
- do k = elec_alpha_num+1, mo_num
- grad_left = max(grad_left , dabs(Fock_matrix_vartc_mo_tot(k,i)))
- grad_right = max(grad_right, dabs(Fock_matrix_vartc_mo_tot(i,k)))
- enddo
- enddo
-
- do i = elec_beta_num+1, elec_alpha_num ! SOMO --> virt
- do k = elec_alpha_num+1, mo_num
- grad_left = max(grad_left , dabs(Fock_matrix_vartc_mo_tot(k,i)))
- grad_right = max(grad_right, dabs(Fock_matrix_vartc_mo_tot(i,k)))
- enddo
- enddo
-
- grad_vartc = grad_left + grad_right
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [ double precision, Fock_matrix_vartc_ao_tot, (ao_num, ao_num) ]
-
- implicit none
-
- call mo_to_ao_bi_ortho( Fock_matrix_vartc_mo_tot, size(Fock_matrix_vartc_mo_tot, 1) &
- , Fock_matrix_vartc_ao_tot, size(Fock_matrix_vartc_ao_tot, 1) )
-
-END_PROVIDER
-
-! ---
-
- BEGIN_PROVIDER [ double precision, Fock_matrix_vartc_mo_tot, (mo_num,mo_num) ]
-&BEGIN_PROVIDER [ double precision, Fock_matrix_vartc_diag_mo_tot, (mo_num)]
-
- implicit none
- integer :: i, j, n
-
- if(elec_alpha_num == elec_beta_num) then
- Fock_matrix_vartc_mo_tot = Fock_matrix_vartc_mo_alpha
- else
-
- do j = 1, elec_beta_num
- ! F-K
- do i = 1, elec_beta_num !CC
- Fock_matrix_vartc_mo_tot(i,j) = 0.5d0*(Fock_matrix_vartc_mo_alpha(i,j)+Fock_matrix_vartc_mo_beta(i,j))&
- - (Fock_matrix_vartc_mo_beta(i,j) - Fock_matrix_vartc_mo_alpha(i,j))
- enddo
- ! F+K/2
- do i = elec_beta_num+1, elec_alpha_num !CA
- Fock_matrix_vartc_mo_tot(i,j) = 0.5d0*(Fock_matrix_vartc_mo_alpha(i,j)+Fock_matrix_vartc_mo_beta(i,j))&
- + 0.5d0*(Fock_matrix_vartc_mo_beta(i,j) - Fock_matrix_vartc_mo_alpha(i,j))
- enddo
- ! F
- do i = elec_alpha_num+1, mo_num !CV
- Fock_matrix_vartc_mo_tot(i,j) = 0.5d0*(Fock_matrix_vartc_mo_alpha(i,j)+Fock_matrix_vartc_mo_beta(i,j))
- enddo
- enddo
-
- do j = elec_beta_num+1, elec_alpha_num
- ! F+K/2
- do i = 1, elec_beta_num !AC
- Fock_matrix_vartc_mo_tot(i,j) = 0.5d0*(Fock_matrix_vartc_mo_alpha(i,j)+Fock_matrix_vartc_mo_beta(i,j))&
- + 0.5d0*(Fock_matrix_vartc_mo_beta(i,j) - Fock_matrix_vartc_mo_alpha(i,j))
- enddo
- ! F
- do i = elec_beta_num+1, elec_alpha_num !AA
- Fock_matrix_vartc_mo_tot(i,j) = 0.5d0*(Fock_matrix_vartc_mo_alpha(i,j)+Fock_matrix_vartc_mo_beta(i,j))
- enddo
- ! F-K/2
- do i = elec_alpha_num+1, mo_num !AV
- Fock_matrix_vartc_mo_tot(i,j) = 0.5d0*(Fock_matrix_vartc_mo_alpha(i,j)+Fock_matrix_vartc_mo_beta(i,j))&
- - 0.5d0*(Fock_matrix_vartc_mo_beta(i,j) - Fock_matrix_vartc_mo_alpha(i,j))
- enddo
- enddo
-
- do j = elec_alpha_num+1, mo_num
- ! F
- do i = 1, elec_beta_num !VC
- Fock_matrix_vartc_mo_tot(i,j) = 0.5d0*(Fock_matrix_vartc_mo_alpha(i,j)+Fock_matrix_vartc_mo_beta(i,j))
- enddo
- ! F-K/2
- do i = elec_beta_num+1, elec_alpha_num !VA
- Fock_matrix_vartc_mo_tot(i,j) = 0.5d0*(Fock_matrix_vartc_mo_alpha(i,j)+Fock_matrix_vartc_mo_beta(i,j))&
- - 0.5d0*(Fock_matrix_vartc_mo_beta(i,j) - Fock_matrix_vartc_mo_alpha(i,j))
- enddo
- ! F+K
- do i = elec_alpha_num+1, mo_num !VV
- Fock_matrix_vartc_mo_tot(i,j) = 0.5d0*(Fock_matrix_vartc_mo_alpha(i,j)+Fock_matrix_vartc_mo_beta(i,j)) &
- + (Fock_matrix_vartc_mo_beta(i,j) - Fock_matrix_vartc_mo_alpha(i,j))
- enddo
- enddo
- if(three_body_h_tc)then
- ! C-O
- do j = 1, elec_beta_num
- do i = elec_beta_num+1, elec_alpha_num
- Fock_matrix_vartc_mo_tot(i,j) += 0.5d0*(fock_a_tot_3e_bi_orth(i,j) + fock_b_tot_3e_bi_orth(i,j))
- Fock_matrix_vartc_mo_tot(j,i) += 0.5d0*(fock_a_tot_3e_bi_orth(j,i) + fock_b_tot_3e_bi_orth(j,i))
- enddo
- enddo
- ! C-V
- do j = 1, elec_beta_num
- do i = elec_alpha_num+1, mo_num
- Fock_matrix_vartc_mo_tot(i,j) += 0.5d0*(fock_a_tot_3e_bi_orth(i,j) + fock_b_tot_3e_bi_orth(i,j))
- Fock_matrix_vartc_mo_tot(j,i) += 0.5d0*(fock_a_tot_3e_bi_orth(j,i) + fock_b_tot_3e_bi_orth(j,i))
- enddo
- enddo
- ! O-V
- do j = elec_beta_num+1, elec_alpha_num
- do i = elec_alpha_num+1, mo_num
- Fock_matrix_vartc_mo_tot(i,j) += 0.5d0*(fock_a_tot_3e_bi_orth(i,j) + fock_b_tot_3e_bi_orth(i,j))
- Fock_matrix_vartc_mo_tot(j,i) += 0.5d0*(fock_a_tot_3e_bi_orth(j,i) + fock_b_tot_3e_bi_orth(j,i))
- enddo
- enddo
- endif
-
- endif
-
- do i = 1, mo_num
- Fock_matrix_vartc_diag_mo_tot(i) = Fock_matrix_vartc_mo_tot(i,i)
- enddo
-
- if(frozen_orb_scf)then
- integer :: iorb, jorb
- do i = 1, n_core_orb
- iorb = list_core(i)
- do j = 1, n_act_orb
- jorb = list_act(j)
- Fock_matrix_vartc_mo_tot(iorb,jorb) = 0.d0
- Fock_matrix_vartc_mo_tot(jorb,iorb) = 0.d0
- enddo
- enddo
- endif
-
- if(no_oa_or_av_opt)then
- do i = 1, n_act_orb
- iorb = list_act(i)
- do j = 1, n_inact_orb
- jorb = list_inact(j)
- Fock_matrix_vartc_mo_tot(iorb,jorb) = 0.d0
- Fock_matrix_vartc_mo_tot(jorb,iorb) = 0.d0
- enddo
- do j = 1, n_virt_orb
- jorb = list_virt(j)
- Fock_matrix_vartc_mo_tot(iorb,jorb) = 0.d0
- Fock_matrix_vartc_mo_tot(jorb,iorb) = 0.d0
- enddo
- do j = 1, n_core_orb
- jorb = list_core(j)
- Fock_matrix_vartc_mo_tot(iorb,jorb) = 0.d0
- Fock_matrix_vartc_mo_tot(jorb,iorb) = 0.d0
- enddo
- enddo
- endif
-
- !call check_sym(Fock_matrix_vartc_mo_tot, mo_num)
- !do i = 1, mo_num
- ! write(*,'(100(F15.8, I4))') Fock_matrix_vartc_mo_tot(i,:)
- !enddo
-
-END_PROVIDER
-
-! ---
-
diff --git a/plugins/local/tc_scf/integrals_in_r_stuff.irp.f b/plugins/local/tc_scf/integrals_in_r_stuff.irp.f
deleted file mode 100644
index 3ce85a97..00000000
--- a/plugins/local/tc_scf/integrals_in_r_stuff.irp.f
+++ /dev/null
@@ -1,391 +0,0 @@
-
-! ---
-
-BEGIN_PROVIDER [ double precision, tc_scf_dm_in_r, (n_points_final_grid) ]
-
- implicit none
- integer :: i, j
-
- tc_scf_dm_in_r = 0.d0
- do i = 1, n_points_final_grid
- do j = 1, elec_beta_num
- tc_scf_dm_in_r(i) += mos_r_in_r_array(j,i) * mos_l_in_r_array(j,i)
- enddo
- enddo
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [ double precision, w_sum_in_r, (n_points_final_grid, 3)]
-
- implicit none
- integer :: ipoint, j, xi
-
- w_sum_in_r = 0.d0
- do j = 1, elec_beta_num
- do xi = 1, 3
- do ipoint = 1, n_points_final_grid
- !w_sum_in_r(ipoint,xi) += x_W_ki_bi_ortho_erf_rk(ipoint,xi,j,j)
- w_sum_in_r(ipoint,xi) += x_W_ki_bi_ortho_erf_rk_diag(ipoint,xi,j)
- enddo
- enddo
- enddo
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [ double precision, ww_sum_in_r, (n_points_final_grid, 3)]
-
- implicit none
- integer :: ipoint, j, xi
- double precision :: tmp
-
- ww_sum_in_r = 0.d0
- do j = 1, elec_beta_num
- do xi = 1, 3
- do ipoint = 1, n_points_final_grid
- tmp = x_W_ki_bi_ortho_erf_rk_diag(ipoint,xi,j)
- ww_sum_in_r(ipoint,xi) += tmp * tmp
- enddo
- enddo
- enddo
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [ double precision, W1_r_in_r, (n_points_final_grid, 3, mo_num)]
-
- implicit none
- integer :: i, j, xi, ipoint
-
- ! TODO: call lapack
-
- W1_r_in_r = 0.d0
- do i = 1, mo_num
- do j = 1, elec_beta_num
- do xi = 1, 3
- do ipoint = 1, n_points_final_grid
- W1_r_in_r(ipoint,xi,i) += mos_r_in_r_array_transp(ipoint,j) * x_W_ki_bi_ortho_erf_rk(ipoint,xi,j,i)
- enddo
- enddo
- enddo
- enddo
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [ double precision, W1_l_in_r, (n_points_final_grid, 3, mo_num)]
-
- implicit none
- integer :: i, j, xi, ipoint
-
- ! TODO: call lapack
-
- W1_l_in_r = 0.d0
- do i = 1, mo_num
- do j = 1, elec_beta_num
- do xi = 1, 3
- do ipoint = 1, n_points_final_grid
- W1_l_in_r(ipoint,xi,i) += mos_l_in_r_array_transp(ipoint,j) * x_W_ki_bi_ortho_erf_rk(ipoint,xi,i,j)
- enddo
- enddo
- enddo
- enddo
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [ double precision, W1_in_r, (n_points_final_grid, 3)]
-
- implicit none
- integer :: j, xi, ipoint
-
- ! TODO: call lapack
-
- W1_in_r = 0.d0
- do j = 1, elec_beta_num
- do xi = 1, 3
- do ipoint = 1, n_points_final_grid
- W1_in_r(ipoint,xi) += W1_l_in_r(ipoint,xi,j) * mos_r_in_r_array_transp(ipoint,j)
- enddo
- enddo
- enddo
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [ double precision, W1_diag_in_r, (n_points_final_grid, 3)]
-
- implicit none
- integer :: j, xi, ipoint
-
- ! TODO: call lapack
-
- W1_diag_in_r = 0.d0
- do j = 1, elec_beta_num
- do xi = 1, 3
- do ipoint = 1, n_points_final_grid
- W1_diag_in_r(ipoint,xi) += mos_r_in_r_array_transp(ipoint,j) * mos_l_in_r_array_transp(ipoint,j) * x_W_ki_bi_ortho_erf_rk_diag(ipoint,xi,j)
- enddo
- enddo
- enddo
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [ double precision, v_sum_in_r, (n_points_final_grid, 3)]
-
- implicit none
- integer :: i, j, xi, ipoint
-
- ! TODO: call lapack
- v_sum_in_r = 0.d0
- do i = 1, elec_beta_num
- do j = 1, elec_beta_num
- do xi = 1, 3
- do ipoint = 1, n_points_final_grid
- v_sum_in_r(ipoint,xi) += x_W_ki_bi_ortho_erf_rk(ipoint,xi,i,j) * x_W_ki_bi_ortho_erf_rk(ipoint,xi,j,i)
- enddo
- enddo
- enddo
- enddo
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [ double precision, W1_W1_r_in_r, (n_points_final_grid, 3, mo_num)]
-
- implicit none
- integer :: i, m, xi, ipoint
-
- ! TODO: call lapack
-
- W1_W1_r_in_r = 0.d0
- do i = 1, mo_num
- do m = 1, elec_beta_num
- do xi = 1, 3
- do ipoint = 1, n_points_final_grid
- W1_W1_r_in_r(ipoint,xi,i) += x_W_ki_bi_ortho_erf_rk(ipoint,xi,m,i) * W1_r_in_r(ipoint,xi,m)
- enddo
- enddo
- enddo
- enddo
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [ double precision, W1_W1_l_in_r, (n_points_final_grid, 3, mo_num)]
-
- implicit none
- integer :: i, j, xi, ipoint
-
- ! TODO: call lapack
-
- W1_W1_l_in_r = 0.d0
- do i = 1, mo_num
- do j = 1, elec_beta_num
- do xi = 1, 3
- do ipoint = 1, n_points_final_grid
- W1_W1_l_in_r(ipoint,xi,i) += x_W_ki_bi_ortho_erf_rk(ipoint,xi,i,j) * W1_l_in_r(ipoint,xi,j)
- enddo
- enddo
- enddo
- enddo
-
-END_PROVIDER
-
-! ---
-
-subroutine direct_term_imj_bi_ortho(a, i, integral)
-
- BEGIN_DOC
- ! computes sum_(j,m = 1, elec_beta_num) < a m j | i m j > with bi ortho mos
- END_DOC
-
- implicit none
- integer, intent(in) :: i, a
- double precision, intent(out) :: integral
-
- integer :: ipoint, xi
- double precision :: weight, tmp
-
- integral = 0.d0
- do xi = 1, 3
- do ipoint = 1, n_points_final_grid
- weight = final_weight_at_r_vector(ipoint)
- !integral += ( mos_l_in_r_array(a,ipoint) * mos_r_in_r_array(i,ipoint) * w_sum_in_r(ipoint,xi) * w_sum_in_r(ipoint,xi) &
- ! + 2.d0 * tc_scf_dm_in_r(ipoint) * w_sum_in_r(ipoint,xi) * x_W_ki_bi_ortho_erf_rk(ipoint,xi,a,i) ) * weight
-
- tmp = w_sum_in_r(ipoint,xi)
-
- integral += ( mos_l_in_r_array_transp(ipoint,a) * mos_r_in_r_array_transp(ipoint,i) * tmp * tmp &
- + 2.d0 * tc_scf_dm_in_r(ipoint) * tmp * x_W_ki_bi_ortho_erf_rk(ipoint,xi,a,i) &
- ) * weight
- enddo
- enddo
-
-end
-
-! ---
-
-subroutine exch_term_jmi_bi_ortho(a, i, integral)
-
- BEGIN_DOC
- ! computes sum_(j,m = 1, elec_beta_num) < a m j | j m i > with bi ortho mos
- END_DOC
-
- implicit none
- integer, intent(in) :: i, a
- double precision, intent(out) :: integral
-
- integer :: ipoint, xi, j
- double precision :: weight, tmp
-
- integral = 0.d0
- do xi = 1, 3
- do ipoint = 1, n_points_final_grid
- weight = final_weight_at_r_vector(ipoint)
-
- tmp = 0.d0
- do j = 1, elec_beta_num
- tmp = tmp + x_W_ki_bi_ortho_erf_rk(ipoint,xi,a,j) * x_W_ki_bi_ortho_erf_rk(ipoint,xi,j,i)
- enddo
-
- integral += ( mos_l_in_r_array_transp(ipoint,a) * W1_r_in_r(ipoint,xi,i) * w_sum_in_r(ipoint,xi) &
- + tc_scf_dm_in_r(ipoint) * tmp &
- + mos_r_in_r_array_transp(ipoint,i) * W1_l_in_r(ipoint,xi,a) * w_sum_in_r(ipoint,xi) &
- ) * weight
-
- enddo
- enddo
-
-end
-
-! ---
-
-subroutine exch_term_ijm_bi_ortho(a, i, integral)
-
- BEGIN_DOC
- ! computes sum_(j,m = 1, elec_beta_num) < a m j | i j m > with bi ortho mos
- END_DOC
-
- implicit none
- integer, intent(in) :: i, a
- double precision, intent(out) :: integral
-
- integer :: ipoint, xi
- double precision :: weight
-
- integral = 0.d0
- do xi = 1, 3
- do ipoint = 1, n_points_final_grid
- weight = final_weight_at_r_vector(ipoint)
-
- integral += ( mos_l_in_r_array_transp(ipoint,a) * mos_r_in_r_array_transp(ipoint,i) * v_sum_in_r(ipoint,xi) &
- + 2.d0 * x_W_ki_bi_ortho_erf_rk(ipoint,xi,a,i) * W1_in_r(ipoint,xi) &
- ) * weight
-
- enddo
- enddo
-
-end
-
-! ---
-
-subroutine direct_term_ijj_bi_ortho(a, i, integral)
-
- BEGIN_DOC
- ! computes sum_(j = 1, elec_beta_num) < a j j | i j j > with bi ortho mos
- END_DOC
-
- implicit none
- integer, intent(in) :: i, a
- double precision, intent(out) :: integral
-
- integer :: ipoint, xi
- double precision :: weight
-
- integral = 0.d0
- do xi = 1, 3
- do ipoint = 1, n_points_final_grid
- weight = final_weight_at_r_vector(ipoint)
-
- integral += ( mos_l_in_r_array_transp(ipoint,a) * mos_r_in_r_array_transp(ipoint,i) * ww_sum_in_r(ipoint,xi) &
- + 2.d0 * W1_diag_in_r(ipoint, xi) * x_W_ki_bi_ortho_erf_rk(ipoint,xi,a,i) &
- ) * weight
- enddo
- enddo
-
-end
-
-! ---
-
-subroutine cyclic_term_jim_bi_ortho(a, i, integral)
-
- BEGIN_DOC
- ! computes sum_(j,m = 1, elec_beta_num) < a m j | j i m > with bi ortho mos
- END_DOC
-
- implicit none
- integer, intent(in) :: i, a
- double precision, intent(out) :: integral
-
- integer :: ipoint, xi
- double precision :: weight
-
- integral = 0.d0
- do xi = 1, 3
- do ipoint = 1, n_points_final_grid
- weight = final_weight_at_r_vector(ipoint)
-
- integral += ( mos_l_in_r_array_transp(ipoint,a) * W1_W1_r_in_r(ipoint,xi,i) &
- + W1_W1_l_in_r(ipoint,xi,a) * mos_r_in_r_array_transp(ipoint,i) &
- + W1_l_in_r(ipoint,xi,a) * W1_r_in_r(ipoint,xi,i) &
- ) * weight
-
- enddo
- enddo
-
-end
-
-! ---
-
-subroutine cyclic_term_mji_bi_ortho(a, i, integral)
-
- BEGIN_DOC
- ! computes sum_(j,m = 1, elec_beta_num) < a m j | m j i > with bi ortho mos
- END_DOC
-
- implicit none
- integer, intent(in) :: i, a
- double precision, intent(out) :: integral
-
- integer :: ipoint, xi
- double precision :: weight
-
- integral = 0.d0
- do xi = 1, 3
- do ipoint = 1, n_points_final_grid
- weight = final_weight_at_r_vector(ipoint)
-
- integral += ( mos_l_in_r_array_transp(ipoint,a) * W1_W1_r_in_r(ipoint,xi,i) &
- + W1_l_in_r(ipoint,xi,a) * W1_r_in_r(ipoint,xi,i) &
- + W1_W1_l_in_r(ipoint,xi,a) * mos_r_in_r_array_transp(ipoint,i) &
- ) * weight
-
- enddo
- enddo
-
-end
-
-! ---
-
diff --git a/plugins/local/tc_scf/jast_schmos_90.irp.f b/plugins/local/tc_scf/jast_schmos_90.irp.f
deleted file mode 100644
index 5c5e625f..00000000
--- a/plugins/local/tc_scf/jast_schmos_90.irp.f
+++ /dev/null
@@ -1,318 +0,0 @@
- BEGIN_PROVIDER [integer , m_max_sm_7]
-&BEGIN_PROVIDER [integer , n_max_sm_7]
-&BEGIN_PROVIDER [integer , o_max_sm_7]
- implicit none
- BEGIN_DOC
-! maximum value of the "m", "n" and "o" integer in the Jastrow function as in Eq. (4)
-! of Schmidt,Moskowitz, JCP, 93, 4172 (1990) for the SM_7 version of Table IV
- END_DOC
- m_max_sm_7 = 4
- n_max_sm_7 = 0
- o_max_sm_7 = 4
-END_PROVIDER
-
- BEGIN_PROVIDER [integer , m_max_sm_9]
-&BEGIN_PROVIDER [integer , n_max_sm_9]
-&BEGIN_PROVIDER [integer , o_max_sm_9]
- implicit none
- BEGIN_DOC
-! maximum value of the "m", "n" and "o" integer in the Jastrow function as in Eq. (4)
-! of Schmidt,Moskowitz, JCP, 93, 4172 (1990) for the SM_9 version of Table IV
- END_DOC
- m_max_sm_9 = 4
- n_max_sm_9 = 2
- o_max_sm_9 = 4
-END_PROVIDER
-
-
- BEGIN_PROVIDER [integer , m_max_sm_17]
-&BEGIN_PROVIDER [integer , n_max_sm_17]
-&BEGIN_PROVIDER [integer , o_max_sm_17]
- implicit none
- BEGIN_DOC
-! maximum value of the "m", "n" and "o" integer in the Jastrow function as in Eq. (4)
-! of Schmidt,Moskowitz, JCP, 93, 4172 (1990) for the SM_17 version of Table IV
- END_DOC
- m_max_sm_17 = 6
- n_max_sm_17 = 2
- o_max_sm_17 = 6
-END_PROVIDER
-
-
-BEGIN_PROVIDER [ double precision, c_mn_o_sm_7, (0:m_max_sm_7,0:n_max_sm_7,0:o_max_sm_7,2:10)]
- implicit none
- BEGIN_DOC
- !
- !c_mn_o_7(0:4,0:4,2:10) = coefficient for the SM_7 correlation factor as given is Table IV of
- ! Schmidt,Moskowitz, JCP, 93, 4172 (1990)
- ! the first index (0:4) is the "m" integer for the 1e part
- ! the second index(0:0) is the "n" integer for the 1e part WHICH IS ALWAYS SET TO 0 FOR SM_7
- ! the third index (0:4) is the "o" integer for the 2e part
- ! the fourth index (2:10) is the nuclear charge of the atom
- END_DOC
- c_mn_o_sm_7 = 0.d0
- integer :: i
- do i = 2, 10 ! loop over nuclear charge
- c_mn_o_sm_7(0,0,1,i) = 0.5d0 ! all the linear terms are set to 1/2 to satisfy the anti-parallel spin condition
- enddo
- ! He atom
- ! two electron terms
- c_mn_o_sm_7(0,0,2,2) = 0.50516d0
- c_mn_o_sm_7(0,0,3,2) = -0.19313d0
- c_mn_o_sm_7(0,0,4,2) = 0.30276d0
- ! one-electron terms
- c_mn_o_sm_7(2,0,0,2) = -0.16995d0
- c_mn_o_sm_7(3,0,0,2) = -0.34505d0
- c_mn_o_sm_7(4,0,0,2) = -0.54777d0
- ! Ne atom
- ! two electron terms
- c_mn_o_sm_7(0,0,2,10) = -0.792d0
- c_mn_o_sm_7(0,0,3,10) = 1.05232d0
- c_mn_o_sm_7(0,0,4,10) = -0.65615d0
- ! one-electron terms
- c_mn_o_sm_7(2,0,0,10) = -0.13312d0
- c_mn_o_sm_7(3,0,0,10) = -0.00131d0
- c_mn_o_sm_7(4,0,0,10) = 0.09083d0
-
-END_PROVIDER
-
-BEGIN_PROVIDER [ double precision, c_mn_o_sm_9, (0:m_max_sm_9,0:n_max_sm_9,0:o_max_sm_9,2:10)]
- implicit none
- BEGIN_DOC
- !
- !c_mn_o_9(0:4,0:4,2:10) = coefficient for the SM_9 correlation factor as given is Table IV of
- ! Schmidt,Moskowitz, JCP, 93, 4172 (1990)
- ! the first index (0:4) is the "m" integer for the 1e part
- ! the second index(0:0) is the "n" integer for the 1e part WHICH IS ALWAYS SET TO 0 FOR SM_9
- ! the third index (0:4) is the "o" integer for the 2e part
- ! the fourth index (2:10) is the nuclear charge of the atom
- END_DOC
- c_mn_o_sm_9 = 0.d0
- integer :: i
- do i = 2, 10 ! loop over nuclear charge
- c_mn_o_sm_9(0,0,1,i) = 0.5d0 ! all the linear terms are set to 1/2 to satisfy the anti-parallel spin condition
- enddo
- ! He atom
- ! two electron terms
- c_mn_o_sm_9(0,0,2,2) = 0.50516d0
- c_mn_o_sm_9(0,0,3,2) = -0.19313d0
- c_mn_o_sm_9(0,0,4,2) = 0.30276d0
- ! one-electron terms
- c_mn_o_sm_9(2,0,0,2) = -0.16995d0
- c_mn_o_sm_9(3,0,0,2) = -0.34505d0
- c_mn_o_sm_9(4,0,0,2) = -0.54777d0
- ! Ne atom
- ! two electron terms
- c_mn_o_sm_9(0,0,2,10) = -0.792d0
- c_mn_o_sm_9(0,0,3,10) = 1.05232d0
- c_mn_o_sm_9(0,0,4,10) = -0.65615d0
- ! one-electron terms
- c_mn_o_sm_9(2,0,0,10) = -0.13312d0
- c_mn_o_sm_9(3,0,0,10) = -0.00131d0
- c_mn_o_sm_9(4,0,0,10) = 0.09083d0
-
-END_PROVIDER
-
-BEGIN_PROVIDER [ double precision, c_mn_o_sm_17, (0:m_max_sm_17,0:n_max_sm_17,0:o_max_sm_17,2:10)]
- implicit none
- BEGIN_DOC
- !
- !c_mn_o_17(0:4,0:4,2:10) = coefficient for the SM_17 correlation factor as given is Table IV of
- ! Schmidt,Moskowitz, JCP, 93, 4172 (1990)
- ! the first index (0:4) is the "m" integer for the 1e part
- ! the second index(0:0) is the "n" integer for the 1e part WHICH IS ALWAYS SET TO 0 FOR SM_17
- ! the third index (0:4) is the "o" integer for the 2e part
- ! the fourth index (2:10) is the nuclear charge of the atom
- END_DOC
- c_mn_o_sm_17 = 0.d0
- integer :: i
- do i = 2, 10 ! loop over nuclear charge
- c_mn_o_sm_17(0,0,1,i) = 0.5d0 ! all the linear terms are set to 1/2 to satisfy the anti-parallel spin condition
- enddo
- ! He atom
- ! two electron terms
- c_mn_o_sm_17(0,0,2,2) = 0.09239d0
- c_mn_o_sm_17(0,0,3,2) = -0.38664d0
- c_mn_o_sm_17(0,0,4,2) = 0.95764d0
- ! one-electron terms
- c_mn_o_sm_17(2,0,0,2) = 0.23208d0
- c_mn_o_sm_17(3,0,0,2) = -0.45032d0
- c_mn_o_sm_17(4,0,0,2) = 0.82777d0
- c_mn_o_sm_17(2,2,0,2) = -4.15388d0
- ! ee-n terms
- c_mn_o_sm_17(2,0,2,2) = 0.80622d0
- c_mn_o_sm_17(2,2,2,2) = 10.19704d0
- c_mn_o_sm_17(4,0,2,2) = -4.96259d0
- c_mn_o_sm_17(2,0,4,2) = -1.35647d0
- c_mn_o_sm_17(4,2,2,2) = -5.90907d0
- c_mn_o_sm_17(6,0,2,2) = 0.90343d0
- c_mn_o_sm_17(4,0,4,2) = 5.50739d0
- c_mn_o_sm_17(2,2,4,2) = -0.03154d0
- c_mn_o_sm_17(2,0,6,2) = -1.1051860
-
-
- ! Ne atom
- ! two electron terms
- c_mn_o_sm_17(0,0,2,10) = -0.80909d0
- c_mn_o_sm_17(0,0,3,10) = -0.00219d0
- c_mn_o_sm_17(0,0,4,10) = 0.59188d0
- ! one-electron terms
- c_mn_o_sm_17(2,0,0,10) = -0.00567d0
- c_mn_o_sm_17(3,0,0,10) = 0.14011d0
- c_mn_o_sm_17(4,0,0,10) = -0.05671d0
- c_mn_o_sm_17(2,2,0,10) = -3.33767d0
- ! ee-n terms
- c_mn_o_sm_17(2,0,2,10) = 1.95067d0
- c_mn_o_sm_17(2,2,2,10) = 6.83340d0
- c_mn_o_sm_17(4,0,2,10) = -3.29231d0
- c_mn_o_sm_17(2,0,4,10) = -2.44998d0
- c_mn_o_sm_17(4,2,2,10) = -2.13029d0
- c_mn_o_sm_17(6,0,2,10) = 2.25768d0
- c_mn_o_sm_17(4,0,4,10) = 1.97951d0
- c_mn_o_sm_17(2,2,4,10) = -2.0924160
- c_mn_o_sm_17(2,0,6,10) = 0.35493d0
-
-END_PROVIDER
-
- BEGIN_PROVIDER [ double precision, b_I_sm_90,(2:10)]
-&BEGIN_PROVIDER [ double precision, d_I_sm_90,(2:10)]
- implicit none
- BEGIN_DOC
-! "b_I" and "d_I" parameters of Eqs. (4) and (5) of Schmidt,Moskowitz, JCP, 93, 4172 (1990)
- END_DOC
- b_I_sm_90 = 1.d0
- d_I_sm_90 = 1.d0
-
-END_PROVIDER
-
-subroutine get_full_sm_90_jastrow(r1,r2,rI,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
- implicit none
- double precision, intent(in) :: r1(3),r2(3),rI(3)
- integer, intent(in) :: sm_j, i_charge
- double precision, intent(out):: j_1e,j_2e,j_een,j_tot
- BEGIN_DOC
- ! Jastrow function as in Eq. (4) of Schmidt,Moskowitz, JCP, 93, 4172 (1990)
- ! the i_charge variable is the integer specifying the charge of the atom for the Jastrow
- ! the sm_j integer variable represents the "quality" of the jastrow : sm_j = 7, 9, 17
- END_DOC
- double precision :: r_inucl,r_jnucl,r_ij,b_I, d_I
- b_I = b_I_sm_90(i_charge)
- d_I = d_I_sm_90(i_charge)
- call get_rescaled_variables_j_sm_90(r1,r2,rI,b_I,d_I,r_inucl,r_jnucl,r_ij)
- call jastrow_func_sm_90(r_inucl,r_jnucl,r_ij,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
-end
-
-subroutine get_rescaled_variables_j_sm_90(r1,r2,rI,b_I,d_I,r_inucl,r_jnucl,r_ij)
- implicit none
- BEGIN_DOC
- ! rescaled variables of Eq. (5) and (6) of Schmidt,Moskowitz, JCP, 93, 4172 (1990)
- ! the "b_I" and "d_I" parameters are the same as in Eqs. (5) and (6)
- END_DOC
- double precision, intent(in) :: r1(3),r2(3),rI(3)
- double precision, intent(in) :: b_I, d_I
- double precision, intent(out):: r_inucl,r_jnucl,r_ij
- double precision :: rin, rjn, rij
- integer :: i
- rin = 0.d0
- rjn = 0.d0
- rij = 0.d0
- do i = 1,3
- rin += (r1(i) - rI(i)) * (r1(i) - rI(i))
- rjn += (r2(i) - rI(i)) * (r2(i) - rI(i))
- rij += (r2(i) - r1(i)) * (r2(i) - r1(i))
- enddo
- rin = dsqrt(rin)
- rjn = dsqrt(rjn)
- rij = dsqrt(rij)
- r_inucl = b_I * rin/(1.d0 + b_I * rin)
- r_jnucl = b_I * rjn/(1.d0 + b_I * rjn)
- r_ij = d_I * rij/(1.d0 + b_I * rij)
-end
-
-subroutine jastrow_func_sm_90(r_inucl,r_jnucl,r_ij,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
- implicit none
- BEGIN_DOC
- ! Jastrow function as in Eq. (4) of Schmidt,Moskowitz, JCP, 93, 4172 (1990)
- ! Here the r_inucl, r_jnucl are the rescaled variables as defined in Eq. (5) with "b_I"
- ! r_ij is the rescaled variable as defined in Eq. (6) with "d_I"
- ! the i_charge variable is the integer specifying the charge of the atom for the Jastrow
- ! the sm_j integer variable represents the "quality" of the jastrow : sm_j = 7, 9, 17
- !
- ! it returns the j_1e : sum of terms with "o" = "n" = 0, "m" /= 0,
- ! j_2e : sum of terms with "m" = "n" = 0, "o" /= 0,
- ! j_een : sum of terms with "m" /=0, "n" /= 0, "o" /= 0,
- ! j_tot : the total sum
- END_DOC
- double precision, intent(in) :: r_inucl,r_jnucl,r_ij
- integer, intent(in) :: sm_j,i_charge
- double precision, intent(out):: j_1e,j_2e,j_een,j_tot
- j_1e = 0.D0
- j_2e = 0.D0
- j_een = 0.D0
- double precision :: delta_mn,jastrow_sm_90_atomic
- integer :: m,n,o
-BEGIN_TEMPLATE
- ! pure 2e part
- n = 0
- m = 0
- if(sm_j == $X )then
- do o = 1, o_max_sm_$X
- if(dabs(c_mn_o_sm_$X(m,n,o,i_charge)).lt.1.d-10)cycle
- j_2e += c_mn_o_sm_$X(m,n,o,i_charge) * jastrow_sm_90_atomic(m,n,o,i_charge,r_inucl,r_jnucl,r_ij)
- enddo
-! else
-! print*,'sm_j = ',sm_j
-! print*,'not implemented, stop'
-! stop
- endif
- ! pure one-e part
- o = 0
- if(sm_j == $X)then
- do n = 2, n_max_sm_$X
- do m = 2, m_max_sm_$X
- j_1e += c_mn_o_sm_$X(m,n,o,i_charge) * jastrow_sm_90_atomic(m,n,o,i_charge,r_inucl,r_jnucl,r_ij)
- enddo
- enddo
-! else
-! print*,'sm_j = ',sm_j
-! print*,'not implemented, stop'
-! stop
- endif
- ! e-e-n part
- if(sm_j == $X)then
- do o = 1, o_max_sm_$X
- do m = 2, m_max_sm_$X
- do n = 2, n_max_sm_$X
- j_een += c_mn_o_sm_$X(m,n,o,i_charge) * jastrow_sm_90_atomic(m,n,o,i_charge,r_inucl,r_jnucl,r_ij)
- enddo
- enddo
- enddo
- else
-! print*,'sm_j = ',sm_j
-! print*,'not implemented, stop'
-! stop
- endif
- j_tot = j_1e + j_2e + j_een
-SUBST [ X]
- 7 ;;
- 9 ;;
- 17 ;;
-END_TEMPLATE
-end
-
-double precision function jastrow_sm_90_atomic(m,n,o,i_charge,r_inucl,r_jnucl,r_ij)
- implicit none
- BEGIN_DOC
-! contribution to the function of Eq. (4) of Schmidt,Moskowitz, JCP, 93, 4172 (1990)
-! for a given m,n,o and atom
- END_DOC
- double precision, intent(in) :: r_inucl,r_jnucl,r_ij
- integer , intent(in) :: m,n,o,i_charge
- double precision :: delta_mn
- if(m==n)then
- delta_mn = 0.5d0
- else
- delta_mn = 1.D0
- endif
- jastrow_sm_90_atomic = delta_mn * (r_inucl**m * r_jnucl**n + r_jnucl**m * r_inucl**n)*r_ij**o
-end
diff --git a/plugins/local/tc_scf/minimize_tc_angles.irp.f b/plugins/local/tc_scf/minimize_tc_angles.irp.f
index c7752930..e5f6cf87 100644
--- a/plugins/local/tc_scf/minimize_tc_angles.irp.f
+++ b/plugins/local/tc_scf/minimize_tc_angles.irp.f
@@ -20,7 +20,7 @@ program minimize_tc_angles
! TODO
! check if rotations of orbitals affect the TC energy
! and refuse the step
- call minimize_tc_orb_angles
+ call minimize_tc_orb_angles()
end
diff --git a/plugins/local/tc_scf/plot_j_schMos.irp.f b/plugins/local/tc_scf/plot_j_schMos.irp.f
deleted file mode 100644
index eda0dd25..00000000
--- a/plugins/local/tc_scf/plot_j_schMos.irp.f
+++ /dev/null
@@ -1,69 +0,0 @@
-program plot_j
- implicit none
- double precision :: r1(3),rI(3),r2(3)
- double precision :: r12,dx,xmax, j_1e,j_2e,j_een,j_tot
- double precision :: j_mu_F_x_j
- integer :: i,nx,m,i_charge,sm_j
-
- character*(128) :: output
- integer :: i_unit_output_He_sm_7,i_unit_output_Ne_sm_7
- integer :: i_unit_output_He_sm_17,i_unit_output_Ne_sm_17
- integer :: getUnitAndOpen
- output='J_SM_7_He'
- i_unit_output_He_sm_7 = getUnitAndOpen(output,'w')
- output='J_SM_7_Ne'
- i_unit_output_Ne_sm_7 = getUnitAndOpen(output,'w')
-
- output='J_SM_17_He'
- i_unit_output_He_sm_17 = getUnitAndOpen(output,'w')
- output='J_SM_17_Ne'
- i_unit_output_Ne_sm_17 = getUnitAndOpen(output,'w')
-
- rI = 0.d0
- r1 = 0.d0
- r2 = 0.d0
- r1(1) = 1.5d0
- xmax = 20.d0
- r2(1) = -xmax*0.5d0
- nx = 1000
- dx = xmax/dble(nx)
- do i = 1, nx
- r12 = 0.d0
- do m = 1, 3
- r12 += (r1(m) - r2(m))*(r1(m) - r2(m))
- enddo
- r12 = dsqrt(r12)
- double precision :: jmu,env_nucl,jmu_env,jmu_scaled, jmu_scaled_env
- double precision :: b_I,d_I,r_inucl,r_jnucl,r_ij
- b_I = 1.D0
- d_I = 1.D0
- call get_rescaled_variables_j_sm_90(r1,r2,rI,b_I,d_I,r_inucl,r_jnucl,r_ij)
- jmu=j_mu_F_x_j(r12)
- jmu_scaled=j_mu_F_x_j(r_ij)
- jmu_env = jmu * env_nucl(r1) * env_nucl(r2)
-! jmu_scaled_env= jmu_scaled * (1.d0 - env_coef(1) * dexp(-env_expo(1)*r_inucl**2)) * (1.d0 - env_coef(1) * dexp(-env_expo(1)*r_jnucl**2))
- jmu_scaled_env= jmu_scaled * env_nucl(r1) * env_nucl(r2)
- ! He
- i_charge = 2
- ! SM 7 Jastrow
- sm_j = 7
- call get_full_sm_90_jastrow(r1,r2,rI,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
- write(i_unit_output_He_sm_7,'(100(F16.10,X))')r2(1),r12,j_mu_F_x_j(r12), j_1e,j_2e,j_een,j_tot,jmu_env,jmu_scaled,jmu_scaled_env
- ! SM 17 Jastrow
- sm_j = 17
- call get_full_sm_90_jastrow(r1,r2,rI,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
- write(i_unit_output_He_sm_17,'(100(F16.10,X))')r2(1),r12,j_mu_F_x_j(r12), j_1e,j_2e,j_een,j_tot,jmu_env,jmu_scaled,jmu_scaled_env
- ! Ne
- i_charge = 10
- ! SM 7 Jastrow
- sm_j = 7
- call get_full_sm_90_jastrow(r1,r2,rI,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
- write(i_unit_output_Ne_sm_7,'(100(F16.10,X))')r2(1),r12,j_mu_F_x_j(r12), j_1e,j_2e,j_een,j_tot,jmu_env,jmu_scaled,jmu_scaled_env
- ! SM 17 Jastrow
- sm_j = 17
- call get_full_sm_90_jastrow(r1,r2,rI,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
- write(i_unit_output_Ne_sm_17,'(100(F16.10,X))')r2(1),r12,j_mu_F_x_j(r12), j_1e,j_2e,j_een,j_tot,jmu_env,jmu_scaled,jmu_scaled_env
- r2(1) += dx
- enddo
-
-end
diff --git a/plugins/local/tc_scf/print_fit_param.irp.f b/plugins/local/tc_scf/print_fit_param.irp.f
deleted file mode 100644
index e62f0dde..00000000
--- a/plugins/local/tc_scf/print_fit_param.irp.f
+++ /dev/null
@@ -1,59 +0,0 @@
-program print_fit_param
-
- BEGIN_DOC
-! TODO : Put the documentation of the program here
- END_DOC
-
- implicit none
-
- my_grid_becke = .True.
- PROVIDE tc_grid1_a tc_grid1_r
- my_n_pt_r_grid = tc_grid1_r
- my_n_pt_a_grid = tc_grid1_a
- touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
-
- !call create_guess
- !call orthonormalize_mos
-
- call main()
-
-end
-
-! ---
-
-subroutine main()
-
- implicit none
- integer :: i
-
- mu_erf = 1.d0
- touch mu_erf
-
- print *, ' fit for (1 - erf(x))^2'
- do i = 1, n_max_fit_slat
- print*, expo_gauss_1_erf_x_2(i), coef_gauss_1_erf_x_2(i)
- enddo
-
- print *, ''
- print *, ' fit for [x * (1 - erf(x)) - 1/sqrt(pi) * exp(-x**2)]'
- do i = 1, n_max_fit_slat
- print *, expo_gauss_j_mu_x(i), 2.d0 * coef_gauss_j_mu_x(i)
- enddo
-
- print *, ''
- print *, ' fit for [x * (1 - erf(x)) - 1/sqrt(pi) * exp(-x**2)]^2'
- do i = 1, n_max_fit_slat
- print *, expo_gauss_j_mu_x_2(i), 4.d0 * coef_gauss_j_mu_x_2(i)
- enddo
-
- print *, ''
- print *, ' fit for [x * (1 - erf(x)) - 1/sqrt(pi) * exp(-x**2)] x [1 - erf(mu * r12)]'
- do i = 1, n_max_fit_slat
- print *, expo_gauss_j_mu_1_erf(i), 4.d0 * coef_gauss_j_mu_1_erf(i)
- enddo
-
- return
-end subroutine main
-
-! ---
-
diff --git a/plugins/local/tc_scf/print_tcscf_energy.irp.f b/plugins/local/tc_scf/print_tcscf_energy.irp.f
deleted file mode 100644
index 6f9afd9a..00000000
--- a/plugins/local/tc_scf/print_tcscf_energy.irp.f
+++ /dev/null
@@ -1,55 +0,0 @@
-program print_tcscf_energy
-
- BEGIN_DOC
- ! TODO : Put the documentation of the program here
- END_DOC
-
- implicit none
-
- print *, 'Hello world'
- my_grid_becke = .True.
- PROVIDE tc_grid1_a tc_grid1_r
- my_n_pt_r_grid = tc_grid1_r
- my_n_pt_a_grid = tc_grid1_a
- touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
-
- call main()
-
-end
-
-! ---
-
-subroutine main()
-
- implicit none
- double precision :: etc_tot, etc_1e, etc_2e, etc_3e
-
- PROVIDE j2e_type mu_erf
- PROVIDE j1e_type j1e_coef j1e_expo
- PROVIDE env_type env_coef env_expo
-
- print*, ' j2e_type = ', j2e_type
- print*, ' j1e_type = ', j1e_type
- print*, ' env_type = ', env_type
-
- print*, ' mu_erf = ', mu_erf
-
- etc_tot = TC_HF_energy
- etc_1e = TC_HF_one_e_energy
- etc_2e = TC_HF_two_e_energy
- etc_3e = 0.d0
- if(three_body_h_tc) then
- !etc_3e = diag_three_elem_hf
- etc_3e = tcscf_energy_3e_naive
- endif
-
- print *, " E_TC = ", etc_tot
- print *, " E_1e = ", etc_1e
- print *, " E_2e = ", etc_2e
- print *, " E_3e = ", etc_3e
-
- return
-end subroutine main
-
-! ---
-
diff --git a/plugins/local/tc_scf/rh_tcscf_diis.irp.f b/plugins/local/tc_scf/rh_tcscf_diis.irp.f
index 431b6e08..1cade02a 100644
--- a/plugins/local/tc_scf/rh_tcscf_diis.irp.f
+++ b/plugins/local/tc_scf/rh_tcscf_diis.irp.f
@@ -61,7 +61,7 @@ subroutine rh_tcscf_diis()
etc_tot = TC_HF_energy
etc_1e = TC_HF_one_e_energy
etc_2e = TC_HF_two_e_energy
- etc_3e = diag_three_elem_hf
+ etc_3e = TC_HF_three_e_energy
!tc_grad = grad_non_hermit
er_DIIS = maxval(abs(FQS_SQF_mo))
e_delta = dabs(etc_tot - e_save)
@@ -189,7 +189,7 @@ subroutine rh_tcscf_diis()
etc_tot = TC_HF_energy
etc_1e = TC_HF_one_e_energy
etc_2e = TC_HF_two_e_energy
- etc_3e = diag_three_elem_hf
+ etc_3e = TC_HF_three_e_energy
!tc_grad = grad_non_hermit
er_DIIS = maxval(abs(FQS_SQF_mo))
e_delta = dabs(etc_tot - e_save)
@@ -234,7 +234,7 @@ subroutine rh_tcscf_diis()
call unlock_io
if(er_delta .lt. 0.d0) then
- call ezfio_set_tc_scf_bitc_energy(etc_tot)
+ call ezfio_set_tc_scf_tcscf_energy(etc_tot)
call ezfio_set_bi_ortho_mos_mo_l_coef(mo_l_coef)
call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef)
write(json_unit, json_true_fmt) 'saved'
@@ -263,7 +263,7 @@ subroutine rh_tcscf_diis()
deallocate(mo_r_coef_save, mo_l_coef_save, F_DIIS, E_DIIS)
- call ezfio_set_tc_scf_bitc_energy(TC_HF_energy)
+ call ezfio_set_tc_scf_tcscf_energy(TC_HF_energy)
call ezfio_set_bi_ortho_mos_mo_l_coef(mo_l_coef)
call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef)
diff --git a/plugins/local/tc_scf/rh_tcscf_simple.irp.f b/plugins/local/tc_scf/rh_tcscf_simple.irp.f
deleted file mode 100644
index 0b79e8ea..00000000
--- a/plugins/local/tc_scf/rh_tcscf_simple.irp.f
+++ /dev/null
@@ -1,129 +0,0 @@
-! ---
-
-subroutine rh_tcscf_simple()
-
- implicit none
- integer :: i, j, it, dim_DIIS
- double precision :: t0, t1
- double precision :: e_save, e_delta, rho_delta
- double precision :: etc_tot, etc_1e, etc_2e, etc_3e, tc_grad
- double precision :: er_DIIS
- double precision, allocatable :: rho_old(:,:), rho_new(:,:)
-
- allocate(rho_old(ao_num,ao_num), rho_new(ao_num,ao_num))
-
- it = 0
- e_save = 0.d0
- dim_DIIS = 0
-
- ! ---
-
- if(.not. bi_ortho) then
- print *, ' grad_hermit = ', grad_hermit
- call save_good_hermit_tc_eigvectors
- TOUCH mo_coef
- call save_mos
- endif
-
- ! ---
-
- if(bi_ortho) then
-
- PROVIDE level_shift_tcscf
- PROVIDE mo_l_coef mo_r_coef
-
- write(6, '(A4,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A4, 1X, A8)') &
- '====', '================', '================', '================', '================', '================' &
- , '================', '================', '================', '====', '========'
-
- write(6, '(A4,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A4, 1X, A8)') &
- ' it ', ' SCF TC Energy ', ' E(1e) ', ' E(2e) ', ' E(3e) ', ' energy diff ' &
- , ' gradient ', ' DIIS error ', ' level shift ', 'DIIS', ' WT (m)'
-
- write(6, '(A4,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A4, 1X, A8)') &
- '====', '================', '================', '================', '================', '================' &
- , '================', '================', '================', '====', '========'
-
-
- ! first iteration (HF orbitals)
- call wall_time(t0)
-
- etc_tot = TC_HF_energy
- etc_1e = TC_HF_one_e_energy
- etc_2e = TC_HF_two_e_energy
- etc_3e = 0.d0
- if(three_body_h_tc) then
- etc_3e = diag_three_elem_hf
- endif
- tc_grad = grad_non_hermit
- er_DIIS = maxval(abs(FQS_SQF_mo))
- e_delta = dabs(etc_tot - e_save)
- e_save = etc_tot
-
- call wall_time(t1)
- write(6, '(I4,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, I4,1X, F8.2)') &
- it, etc_tot, etc_1e, etc_2e, etc_3e, e_delta, tc_grad, er_DIIS, level_shift_tcscf, dim_DIIS, (t1-t0)/60.d0
-
- do while(tc_grad .gt. dsqrt(thresh_tcscf))
- call wall_time(t0)
-
- it += 1
- if(it > n_it_tcscf_max) then
- print *, ' max of TCSCF iterations is reached ', n_it_TCSCF_max
- stop
- endif
-
- mo_l_coef = fock_tc_leigvec_ao
- mo_r_coef = fock_tc_reigvec_ao
- call ezfio_set_bi_ortho_mos_mo_l_coef(mo_l_coef)
- call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef)
- TOUCH mo_l_coef mo_r_coef
-
- etc_tot = TC_HF_energy
- etc_1e = TC_HF_one_e_energy
- etc_2e = TC_HF_two_e_energy
- etc_3e = 0.d0
- if(three_body_h_tc) then
- etc_3e = diag_three_elem_hf
- endif
- tc_grad = grad_non_hermit
- er_DIIS = maxval(abs(FQS_SQF_mo))
- e_delta = dabs(etc_tot - e_save)
- e_save = etc_tot
-
- call ezfio_set_tc_scf_bitc_energy(etc_tot)
-
- call wall_time(t1)
- write(6, '(I4,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, I4,1X, F8.2)') &
- it, etc_tot, etc_1e, etc_2e, etc_3e, e_delta, tc_grad, er_DIIS, level_shift_tcscf, dim_DIIS, (t1-t0)/60.d0
- enddo
-
- else
-
- do while( (grad_hermit.gt.dsqrt(thresh_tcscf)) .and. (it.lt.n_it_tcscf_max) )
- print*,'grad_hermit = ',grad_hermit
- it += 1
- print *, 'iteration = ', it
- print *, '***'
- print *, 'TC HF total energy = ', TC_HF_energy
- print *, 'TC HF 1 e energy = ', TC_HF_one_e_energy
- print *, 'TC HF 2 e energy = ', TC_HF_two_e_energy
- print *, 'TC HF 3 body = ', diag_three_elem_hf
- print *, '***'
- print *, ''
- call save_good_hermit_tc_eigvectors
- TOUCH mo_coef
- call save_mos
- enddo
-
- endif
-
- print *, ' TCSCF Simple converged !'
- !call print_energy_and_mos(good_angles)
-
- deallocate(rho_old, rho_new)
-
-end
-
-! ---
-
diff --git a/plugins/local/tc_scf/rh_vartcscf_simple.irp.f b/plugins/local/tc_scf/rh_vartcscf_simple.irp.f
deleted file mode 100644
index ecb0709e..00000000
--- a/plugins/local/tc_scf/rh_vartcscf_simple.irp.f
+++ /dev/null
@@ -1,89 +0,0 @@
-! ---
-
-subroutine rh_vartcscf_simple()
-
- implicit none
- integer :: i, j, it, dim_DIIS
- double precision :: t0, t1
- double precision :: e_save, e_delta, rho_delta
- double precision :: etc_tot, etc_1e, etc_2e, etc_3e
- double precision :: er_DIIS
-
-
- it = 0
- e_save = 0.d0
- dim_DIIS = 0
-
- ! ---
-
- PROVIDE level_shift_tcscf
- PROVIDE mo_r_coef
-
- write(6, '(A4,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A4, 1X, A8)') &
- '====', '================', '================', '================', '================', '================' &
- , '================', '================', '====', '========'
- write(6, '(A4,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A4, 1X, A8)') &
- ' it ', ' SCF TC Energy ', ' E(1e) ', ' E(2e) ', ' E(3e) ', ' energy diff ' &
- , ' DIIS error ', ' level shift ', 'DIIS', ' WT (m)'
- write(6, '(A4,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A4, 1X, A8)') &
- '====', '================', '================', '================', '================', '================' &
- , '================', '================', '====', '========'
-
-
- ! first iteration (HF orbitals)
- call wall_time(t0)
-
- etc_tot = VARTC_HF_energy
- etc_1e = VARTC_HF_one_e_energy
- etc_2e = VARTC_HF_two_e_energy
- etc_3e = 0.d0
- if(three_body_h_tc) then
- etc_3e = diag_three_elem_hf
- endif
- er_DIIS = maxval(abs(FQS_SQF_mo))
- e_delta = dabs(etc_tot - e_save)
- e_save = etc_tot
-
- call wall_time(t1)
- write(6, '(I4,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, I4,1X, F8.2)') &
- it, etc_tot, etc_1e, etc_2e, etc_3e, e_delta, er_DIIS, level_shift_tcscf, dim_DIIS, (t1-t0)/60.d0
-
- do while(er_DIIS .gt. dsqrt(thresh_tcscf))
- call wall_time(t0)
-
- it += 1
- if(it > n_it_tcscf_max) then
- print *, ' max of TCSCF iterations is reached ', n_it_TCSCF_max
- stop
- endif
-
- mo_r_coef = fock_vartc_eigvec_ao
- mo_l_coef = mo_r_coef
- call ezfio_set_bi_ortho_mos_mo_l_coef(mo_l_coef)
- call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef)
- TOUCH mo_l_coef mo_r_coef
-
- etc_tot = VARTC_HF_energy
- etc_1e = VARTC_HF_one_e_energy
- etc_2e = VARTC_HF_two_e_energy
- etc_3e = 0.d0
- if(three_body_h_tc) then
- etc_3e = diag_three_elem_hf
- endif
- er_DIIS = maxval(abs(FQS_SQF_mo))
- e_delta = dabs(etc_tot - e_save)
- e_save = etc_tot
-
- call ezfio_set_tc_scf_bitc_energy(etc_tot)
-
- call wall_time(t1)
- write(6, '(I4,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, I4,1X, F8.2)') &
- it, etc_tot, etc_1e, etc_2e, etc_3e, e_delta, er_DIIS, level_shift_tcscf, dim_DIIS, (t1-t0)/60.d0
- enddo
-
- print *, ' VAR-TCSCF Simple converged !'
-
-end
-
-! ---
-
diff --git a/plugins/local/tc_scf/rotate_tcscf_orbitals.irp.f b/plugins/local/tc_scf/rotate_tcscf_orbitals.irp.f
deleted file mode 100644
index 0f2663e5..00000000
--- a/plugins/local/tc_scf/rotate_tcscf_orbitals.irp.f
+++ /dev/null
@@ -1,369 +0,0 @@
-
-! ---
-
-program rotate_tcscf_orbitals
-
- BEGIN_DOC
- ! TODO : Rotate the bi-orthonormal orbitals in order to minimize left-right angles when degenerate
- END_DOC
-
- implicit none
-
- my_grid_becke = .True.
- PROVIDE tc_grid1_a tc_grid1_r
- my_n_pt_r_grid = tc_grid1_r
- my_n_pt_a_grid = tc_grid1_a
- touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
-
- bi_ortho = .True.
- touch bi_ortho
-
- call minimize_tc_orb_angles()
- !call maximize_overlap()
-
-end
-
-! ---
-
-subroutine maximize_overlap()
-
- implicit none
- integer :: i, m, n
- double precision :: accu_d, accu_nd
- double precision, allocatable :: C(:,:), R(:,:), L(:,:), W(:,:), e(:)
- double precision, allocatable :: S(:,:)
-
- n = ao_num
- m = mo_num
-
- allocate(L(n,m), R(n,m), C(n,m), W(n,n), e(m))
- L = mo_l_coef
- R = mo_r_coef
- C = mo_coef
- W = ao_overlap
-
- print*, ' fock matrix diag elements'
- do i = 1, m
- e(i) = Fock_matrix_tc_mo_tot(i,i)
- print*, e(i)
- enddo
-
- ! ---
-
- print *, ' overlap before :'
- print *, ' '
-
- allocate(S(m,m))
-
- call LTxSxR(n, m, L, W, R, S)
- !print*, " L.T x R"
- !do i = 1, m
- ! write(*, '(100(F16.10,X))') S(i,i)
- !enddo
- call LTxSxR(n, m, L, W, C, S)
- print*, " L.T x C"
- do i = 1, m
- write(*, '(100(F16.10,X))') S(i,:)
- enddo
- call LTxSxR(n, m, C, W, R, S)
- print*, " C.T x R"
- do i = 1, m
- write(*, '(100(F16.10,X))') S(i,:)
- enddo
-
- deallocate(S)
-
- ! ---
-
- call rotate_degen_eigvec_to_maximize_overlap(n, m, e, C, W, L, R)
-
- ! ---
-
- print *, ' overlap after :'
- print *, ' '
-
- allocate(S(m,m))
-
- call LTxSxR(n, m, L, W, R, S)
- !print*, " L.T x R"
- !do i = 1, m
- ! write(*, '(100(F16.10,X))') S(i,i)
- !enddo
- call LTxSxR(n, m, L, W, C, S)
- print*, " L.T x C"
- do i = 1, m
- write(*, '(100(F16.10,X))') S(i,:)
- enddo
- call LTxSxR(n, m, C, W, R, S)
- print*, " C.T x R"
- do i = 1, m
- write(*, '(100(F16.10,X))') S(i,:)
- enddo
-
- deallocate(S)
-
- ! ---
-
- mo_l_coef = L
- mo_r_coef = R
- call ezfio_set_bi_ortho_mos_mo_l_coef(mo_l_coef)
- call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef)
-
- ! ---
-
- deallocate(L, R, C, W, e)
-
-end subroutine maximize_overlap
-
-! ---
-
-subroutine rotate_degen_eigvec_to_maximize_overlap(n, m, e0, C0, W0, L0, R0)
-
- implicit none
-
- integer, intent(in) :: n, m
- double precision, intent(in) :: e0(m), W0(n,n), C0(n,m)
- double precision, intent(inout) :: L0(n,m), R0(n,m)
-
-
- integer :: i, j, k, kk, mm, id1, tot_deg
- double precision :: ei, ej, de, de_thr
- integer, allocatable :: deg_num(:)
- double precision, allocatable :: L(:,:), R(:,:), C(:,:), Lnew(:,:), Rnew(:,:), tmp(:,:)
- !double precision, allocatable :: S(:,:), Snew(:,:), T(:,:), Ttmp(:,:), Stmp(:,:)
- double precision, allocatable :: S(:,:), Snew(:,:), T(:,:), Ttmp(:,:), Stmp(:,:)
- !real*8 :: S(m,m), Snew(m,m), T(m,m)
-
- id1 = 700
- allocate(S(id1,id1), Snew(id1,id1), T(id1,id1))
-
- ! ---
-
- allocate( deg_num(m) )
- do i = 1, m
- deg_num(i) = 1
- enddo
-
- de_thr = thr_degen_tc
-
- do i = 1, m-1
- ei = e0(i)
-
- ! already considered in degen vectors
- if(deg_num(i).eq.0) cycle
-
- do j = i+1, m
- ej = e0(j)
- de = dabs(ei - ej)
-
- if(de .lt. de_thr) then
- deg_num(i) = deg_num(i) + 1
- deg_num(j) = 0
- endif
-
- enddo
- enddo
-
- tot_deg = 0
- do i = 1, m
- if(deg_num(i).gt.1) then
- print *, ' degen on', i, deg_num(i)
- tot_deg = tot_deg + 1
- endif
- enddo
-
- if(tot_deg .eq. 0) then
- print *, ' no degen'
- return
- endif
-
- ! ---
-
- do i = 1, m
- mm = deg_num(i)
-
- if(mm .gt. 1) then
-
- allocate(L(n,mm), R(n,mm), C(n,mm))
- do j = 1, mm
- L(1:n,j) = L0(1:n,i+j-1)
- R(1:n,j) = R0(1:n,i+j-1)
- C(1:n,j) = C0(1:n,i+j-1)
- enddo
-
- ! ---
-
- ! C.T x W0 x R
- allocate(tmp(mm,n), Stmp(mm,mm))
- call dgemm( 'T', 'N', mm, n, n, 1.d0 &
- , C, size(C, 1), W0, size(W0, 1) &
- , 0.d0, tmp, size(tmp, 1) )
- call dgemm( 'N', 'N', mm, mm, n, 1.d0 &
- , tmp, size(tmp, 1), R, size(R, 1) &
- , 0.d0, Stmp, size(Stmp, 1) )
- deallocate(C, tmp)
-
- S = 0.d0
- do k = 1, mm
- do kk = 1, mm
- S(kk,k) = Stmp(kk,k)
- enddo
- enddo
- deallocate(Stmp)
-
- !print*, " overlap bef"
- !do k = 1, mm
- ! write(*, '(100(F16.10,X))') (S(k,kk), kk=1, mm)
- !enddo
-
- T = 0.d0
- Snew = 0.d0
- call maxovl(mm, mm, S, T, Snew)
-
- !print*, " overlap aft"
- !do k = 1, mm
- ! write(*, '(100(F16.10,X))') (Snew(k,kk), kk=1, mm)
- !enddo
-
- allocate(Ttmp(mm,mm))
- Ttmp(1:mm,1:mm) = T(1:mm,1:mm)
-
- allocate(Lnew(n,mm), Rnew(n,mm))
- call dgemm( 'N', 'N', n, mm, mm, 1.d0 &
- , R, size(R, 1), Ttmp(1,1), size(Ttmp, 1) &
- , 0.d0, Rnew, size(Rnew, 1) )
- call dgemm( 'N', 'N', n, mm, mm, 1.d0 &
- , L, size(L, 1), Ttmp(1,1), size(Ttmp, 1) &
- , 0.d0, Lnew, size(Lnew, 1) )
-
- deallocate(L, R)
- deallocate(Ttmp)
-
- ! ---
-
- do j = 1, mm
- L0(1:n,i+j-1) = Lnew(1:n,j)
- R0(1:n,i+j-1) = Rnew(1:n,j)
- enddo
- deallocate(Lnew, Rnew)
-
- endif
- enddo
-
- deallocate(S, Snew, T)
-
-end subroutine rotate_degen_eigvec_to_maximize_overlap
-
-! ---
-
-subroutine fix_right_to_one()
-
- implicit none
- integer :: i, j, m, n, mm, tot_deg
- double precision :: accu_d, accu_nd
- double precision :: de_thr, ei, ej, de
- integer, allocatable :: deg_num(:)
- double precision, allocatable :: R0(:,:), L0(:,:), W(:,:), e0(:)
- double precision, allocatable :: R(:,:), L(:,:), S(:,:), Stmp(:,:), tmp(:,:)
-
- n = ao_num
- m = mo_num
-
- allocate(L0(n,m), R0(n,m), W(n,n), e0(m))
- L0 = mo_l_coef
- R0 = mo_r_coef
- W = ao_overlap
-
- print*, ' fock matrix diag elements'
- do i = 1, m
- e0(i) = Fock_matrix_tc_mo_tot(i,i)
- print*, e0(i)
- enddo
-
- ! ---
-
- allocate( deg_num(m) )
- do i = 1, m
- deg_num(i) = 1
- enddo
-
- de_thr = 1d-6
-
- do i = 1, m-1
- ei = e0(i)
-
- ! already considered in degen vectors
- if(deg_num(i).eq.0) cycle
-
- do j = i+1, m
- ej = e0(j)
- de = dabs(ei - ej)
-
- if(de .lt. de_thr) then
- deg_num(i) = deg_num(i) + 1
- deg_num(j) = 0
- endif
-
- enddo
- enddo
-
- deallocate(e0)
-
- tot_deg = 0
- do i = 1, m
- if(deg_num(i).gt.1) then
- print *, ' degen on', i, deg_num(i)
- tot_deg = tot_deg + 1
- endif
- enddo
-
- if(tot_deg .eq. 0) then
- print *, ' no degen'
- return
- endif
-
- ! ---
-
- do i = 1, m
- mm = deg_num(i)
-
- if(mm .gt. 1) then
-
- allocate(L(n,mm), R(n,mm))
- do j = 1, mm
- L(1:n,j) = L0(1:n,i+j-1)
- R(1:n,j) = R0(1:n,i+j-1)
- enddo
-
- ! ---
-
- call impose_weighted_orthog_svd(n, mm, W, R)
- call impose_weighted_biorthog_qr(n, mm, thresh_biorthog_diag, thresh_biorthog_nondiag, R, W, L)
-
- ! ---
-
- do j = 1, mm
- L0(1:n,i+j-1) = L(1:n,j)
- R0(1:n,i+j-1) = R(1:n,j)
- enddo
- deallocate(L, R)
-
- endif
- enddo
-
- call check_weighted_biorthog_binormalize(n, m, L0, W, R0, thresh_biorthog_diag, thresh_biorthog_nondiag, .true.)
-
- deallocate(W, deg_num)
-
- mo_l_coef = L0
- mo_r_coef = R0
- deallocate(L0, R0)
-
- call ezfio_set_bi_ortho_mos_mo_l_coef(mo_l_coef)
- call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef)
- print *, ' orbitals are rotated '
-
- return
-end subroutine fix_right_to_one
-
-! ---
diff --git a/plugins/local/tc_scf/routines_rotates.irp.f b/plugins/local/tc_scf/routines_rotates.irp.f
index 5780431b..64a81e8e 100644
--- a/plugins/local/tc_scf/routines_rotates.irp.f
+++ b/plugins/local/tc_scf/routines_rotates.irp.f
@@ -40,9 +40,6 @@ subroutine LTxSxR(n, m, L, S, R, C)
end subroutine LTxR
-! ---
-
-
! ---
subroutine minimize_tc_orb_angles()
@@ -103,7 +100,10 @@ subroutine routine_save_rotated_mos(thr_deg, good_angles)
double precision, allocatable :: stmp(:,:), T(:,:), Snew(:,:), smat2(:,:)
double precision, allocatable :: mo_l_coef_tmp(:,:), mo_r_coef_tmp(:,:), mo_l_coef_new(:,:)
- E_thr = 1d-04
+ PROVIDE TC_HF_energy
+ PROVIDE mo_r_coef mo_l_coef
+
+ E_thr = 1d-07
E_old = TC_HF_energy
allocate(mo_l_coef_old(ao_num,mo_num), mo_r_coef_old(ao_num,mo_num))
mo_r_coef_old = mo_r_coef
@@ -111,7 +111,7 @@ subroutine routine_save_rotated_mos(thr_deg, good_angles)
good_angles = .False.
- allocate(mo_l_coef_good(ao_num, mo_num), mo_r_coef_good(ao_num,mo_num))
+ allocate(mo_l_coef_good(ao_num,mo_num), mo_r_coef_good(ao_num,mo_num))
print *, ' ***************************************'
print *, ' ***************************************'
@@ -123,7 +123,7 @@ subroutine routine_save_rotated_mos(thr_deg, good_angles)
mo_r_coef_good = mo_r_coef
mo_l_coef_good = mo_l_coef
- allocate(mo_r_coef_new(ao_num, mo_num))
+ allocate(mo_r_coef_new(ao_num,mo_num))
mo_r_coef_new = mo_r_coef
do i = 1, mo_num
norm = 1.d0/dsqrt(overlap_mo_r(i,i))
@@ -141,10 +141,11 @@ subroutine routine_save_rotated_mos(thr_deg, good_angles)
call build_s_matrix(ao_num, mo_num, mo_r_coef_new, mo_r_coef_new, ao_overlap, s_mat)
! call give_degen(fock_diag,mo_num,thr_deg,list_degen,n_degen_list)
if(n_core_orb.ne.0)then
- call give_degen_full_listcore(fock_diag, mo_num, list_core, n_core_orb, thr_deg, list_degen, n_degen_list)
+ call give_degen_full_listcore(fock_diag, mo_num, list_core, n_core_orb, thr_deg, list_degen, n_degen_list)
else
- call give_degen_full_list(fock_diag, mo_num, thr_deg, list_degen, n_degen_list)
+ call give_degen_full_list(fock_diag, mo_num, thr_deg, list_degen, n_degen_list)
endif
+
print *, ' fock_matrix_mo'
do i = 1, mo_num
print *, i, fock_diag(i), angle_left_right(i)
@@ -156,50 +157,52 @@ subroutine routine_save_rotated_mos(thr_deg, good_angles)
! n_degen = ilast - ifirst +1
n_degen = list_degen(i,0)
- if(n_degen .ge. 1000)n_degen = 1 ! convention for core orbitals
+ if(n_degen .ge. 1000) n_degen = 1 ! convention for core orbitals
if(n_degen .eq. 1) cycle
+ print*, ' working on orbital', i
+ print*, ' multiplicity =', n_degen
allocate(stmp(n_degen,n_degen), smat2(n_degen,n_degen))
allocate(mo_r_coef_tmp(ao_num,n_degen), mo_l_coef_tmp(ao_num,n_degen), mo_l_coef_new(ao_num,n_degen))
allocate(T(n_degen,n_degen), Snew(n_degen,n_degen))
print*,'Right orbitals before'
- do j = 1, n_degen
- write(*,'(100(F16.10,X))') mo_r_coef_new(1:ao_num,list_degen(i,j))
- enddo
+ do j = 1, n_degen
+ write(*,'(1000(F16.10,X))') mo_r_coef_new(1:ao_num,list_degen(i,j))
+ enddo
print*,'Left orbitals before'
- do j = 1, n_degen
- write(*,'(100(F16.10,X))')mo_l_coef(1:ao_num,list_degen(i,j))
- enddo
+ do j = 1, n_degen
+ write(*,'(1000(F16.10,X))') mo_l_coef(1:ao_num,list_degen(i,j))
+ enddo
if(angle_left_right(list_degen(i,1)).gt.80.d0.and.n_degen==2)then
- integer :: i_list, j_list
- i_list = list_degen(i,1)
- j_list = list_degen(i,2)
- print*,'Huge angle !!! == ',angle_left_right(list_degen(i,1)),angle_left_right(list_degen(i,2))
- print*,'i_list = ',i_list
- print*,'i_list = ',j_list
- print*,'Swapping left/right orbitals'
- call print_strong_overlap(i_list, j_list)
- mo_r_coef_tmp(1:ao_num,1) = mo_r_coef_new(1:ao_num,i_list)
- mo_r_coef_tmp(1:ao_num,2) = mo_l_coef(1:ao_num,i_list)
- mo_l_coef_tmp(1:ao_num,1) = mo_l_coef(1:ao_num,j_list)
- mo_l_coef_tmp(1:ao_num,2) = mo_r_coef_new(1:ao_num,j_list)
+ integer :: i_list, j_list
+ i_list = list_degen(i,1)
+ j_list = list_degen(i,2)
+ print*,'Huge angle !!! == ',angle_left_right(list_degen(i,1)),angle_left_right(list_degen(i,2))
+ print*,'i_list = ',i_list
+ print*,'i_list = ',j_list
+ print*,'Swapping left/right orbitals'
+ call print_strong_overlap(i_list, j_list)
+ mo_r_coef_tmp(1:ao_num,1) = mo_r_coef_new(1:ao_num,i_list)
+ mo_r_coef_tmp(1:ao_num,2) = mo_l_coef(1:ao_num,i_list)
+ mo_l_coef_tmp(1:ao_num,1) = mo_l_coef(1:ao_num,j_list)
+ mo_l_coef_tmp(1:ao_num,2) = mo_r_coef_new(1:ao_num,j_list)
else
- do j = 1, n_degen
- print*,'i_list = ',list_degen(i,j)
- mo_r_coef_tmp(1:ao_num,j) = mo_r_coef_new(1:ao_num,list_degen(i,j))
- mo_l_coef_tmp(1:ao_num,j) = mo_l_coef(1:ao_num,list_degen(i,j))
- enddo
+ do j = 1, n_degen
+ print*,'i_list = ',list_degen(i,j)
+ mo_r_coef_tmp(1:ao_num,j) = mo_r_coef_new(1:ao_num,list_degen(i,j))
+ mo_l_coef_tmp(1:ao_num,j) = mo_l_coef(1:ao_num,list_degen(i,j))
+ enddo
endif
print*,'Right orbitals '
- do j = 1, n_degen
- write(*,'(100(F16.10,X))')mo_r_coef_tmp(1:ao_num,j)
- enddo
+ do j = 1, n_degen
+ write(*,'(1000(F16.10,X))') mo_r_coef_tmp(1:ao_num,j)
+ enddo
print*,'Left orbitals '
- do j = 1, n_degen
- write(*,'(100(F16.10,X))')mo_l_coef_tmp(1:ao_num,j)
- enddo
+ do j = 1, n_degen
+ write(*,'(100(F16.10,X))') mo_l_coef_tmp(1:ao_num,j)
+ enddo
! Orthogonalization of right functions
print *, ' Orthogonalization of RIGHT functions'
print *, ' ------------------------------------'
diff --git a/plugins/local/tc_scf/tc_petermann_factor.irp.f b/plugins/local/tc_scf/tc_petermann_factor.irp.f
deleted file mode 100644
index 14fff898..00000000
--- a/plugins/local/tc_scf/tc_petermann_factor.irp.f
+++ /dev/null
@@ -1,91 +0,0 @@
-
-! ---
-
-program tc_petermann_factor
-
- BEGIN_DOC
- ! TODO : Put the documentation of the program here
- END_DOC
-
- implicit none
-
- my_grid_becke = .True.
- PROVIDE tc_grid1_a tc_grid1_r
- my_n_pt_r_grid = tc_grid1_r
- my_n_pt_a_grid = tc_grid1_a
- touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
-
- call main()
-
-end
-
-! ---
-
-subroutine main()
-
- implicit none
- integer :: i, j
- double precision :: Pf_diag_av
- double precision, allocatable :: Sl(:,:), Sr(:,:), Pf(:,:)
-
- allocate(Sl(mo_num,mo_num), Sr(mo_num,mo_num), Pf(mo_num,mo_num))
-
-
- call LTxSxR(ao_num, mo_num, mo_l_coef, ao_overlap, mo_r_coef, Sl)
- !call dgemm( "T", "N", mo_num, mo_num, ao_num, 1.d0 &
- ! , mo_l_coef, size(mo_l_coef, 1), mo_l_coef, size(mo_l_coef, 1) &
- ! , 0.d0, Sl, size(Sl, 1) )
-
- print *, ''
- print *, ' left-right orthog matrix:'
- do i = 1, mo_num
- write(*,'(100(F8.4,X))') Sl(:,i)
- enddo
-
- call LTxSxR(ao_num, mo_num, mo_l_coef, ao_overlap, mo_l_coef, Sl)
- !call dgemm( "T", "N", mo_num, mo_num, ao_num, 1.d0 &
- ! , mo_l_coef, size(mo_l_coef, 1), mo_l_coef, size(mo_l_coef, 1) &
- ! , 0.d0, Sl, size(Sl, 1) )
-
- print *, ''
- print *, ' left-orthog matrix:'
- do i = 1, mo_num
- write(*,'(100(F8.4,X))') Sl(:,i)
- enddo
-
- call LTxSxR(ao_num, mo_num, mo_r_coef, ao_overlap, mo_r_coef, Sr)
-! call dgemm( "T", "N", mo_num, mo_num, ao_num, 1.d0 &
-! , mo_r_coef, size(mo_r_coef, 1), mo_r_coef, size(mo_r_coef, 1) &
-! , 0.d0, Sr, size(Sr, 1) )
-
- print *, ''
- print *, ' right-orthog matrix:'
- do i = 1, mo_num
- write(*,'(100(F8.4,X))') Sr(:,i)
- enddo
-
- print *, ''
- print *, ' Petermann matrix:'
- do i = 1, mo_num
- do j = 1, mo_num
- Pf(j,i) = Sl(j,i) * Sr(j,i)
- enddo
- write(*,'(100(F8.4,X))') Pf(:,i)
- enddo
-
- Pf_diag_av = 0.d0
- do i = 1, mo_num
- Pf_diag_av = Pf_diag_av + Pf(i,i)
- enddo
- Pf_diag_av = Pf_diag_av / dble(mo_num)
-
- print *, ''
- print *, ' mean of the diagonal Petermann factor = ', Pf_diag_av
-
- deallocate(Sl, Sr, Pf)
-
- return
-end subroutine
-
-! ---
-
diff --git a/plugins/local/tc_scf/tc_scf.irp.f b/plugins/local/tc_scf/tc_scf.irp.f
index d8c5ab66..83da03ec 100644
--- a/plugins/local/tc_scf/tc_scf.irp.f
+++ b/plugins/local/tc_scf/tc_scf.irp.f
@@ -7,19 +7,6 @@ program tc_scf
END_DOC
implicit none
- integer :: i
- logical :: good_angles
-
- PROVIDE j1e_type
- PROVIDE j2e_type
- PROVIDE tcscf_algorithm
- PROVIDE var_tc
-
- print *, ' TC-SCF with:'
- print *, ' j1e_type = ', j1e_type
- print *, ' j2e_type = ', j2e_type
-
- write(json_unit,json_array_open_fmt) 'tc-scf'
my_grid_becke = .True.
PROVIDE tc_grid1_a tc_grid1_r
@@ -30,7 +17,6 @@ program tc_scf
call write_int(6, my_n_pt_r_grid, 'radial external grid over')
call write_int(6, my_n_pt_a_grid, 'angular external grid over')
-
if(tc_integ_type .eq. "numeric") then
my_extra_grid_becke = .True.
PROVIDE tc_grid2_a tc_grid2_r
@@ -42,46 +28,38 @@ program tc_scf
call write_int(6, my_n_pt_a_extra_grid, 'angular internal grid over')
endif
- !call create_guess()
- !call orthonormalize_mos()
+ call main()
+end
- if(var_tc) then
+! ---
- print *, ' VAR-TC'
+subroutine main()
- if(tcscf_algorithm == 'DIIS') then
- print*, ' NOT implemented yet'
- elseif(tcscf_algorithm == 'Simple') then
- call rh_vartcscf_simple()
- else
- print *, ' not implemented yet', tcscf_algorithm
- stop
- endif
+ implicit none
- else
+ integer :: i
+ logical :: good_angles
- if(tcscf_algorithm == 'DIIS') then
- call rh_tcscf_diis()
- elseif(tcscf_algorithm == 'Simple') then
- call rh_tcscf_simple()
- else
- print *, ' not implemented yet', tcscf_algorithm
- stop
- endif
+ print *, ' TC-SCF with:'
+ print *, ' j2e_type = ', j2e_type
+ print *, ' j1e_type = ', j1e_type
+ print *, ' env_type = ', env_type
- PROVIDE Fock_matrix_tc_diag_mo_tot
- print*, ' Eigenvalues:'
- do i = 1, mo_num
- print*, i, Fock_matrix_tc_diag_mo_tot(i)
- enddo
+ write(json_unit,json_array_open_fmt) 'tc-scf'
- ! TODO
- ! rotate angles in separate code only if necessary
- !call minimize_tc_orb_angles()
- call print_energy_and_mos(good_angles)
+ call rh_tcscf_diis()
+ PROVIDE Fock_matrix_tc_diag_mo_tot
+ print*, ' Eigenvalues:'
+ do i = 1, mo_num
+ print*, i, Fock_matrix_tc_diag_mo_tot(i)
+ enddo
+
+ if(minimize_lr_angles) then
+ call minimize_tc_orb_angles()
endif
+ call print_energy_and_mos(good_angles)
write(json_unit,json_array_close_fmtx)
call json_close
@@ -117,7 +95,7 @@ subroutine create_guess()
SOFT_TOUCH mo_label
endif
-end subroutine create_guess
+end
! ---
diff --git a/plugins/local/tc_scf/tc_scf_dm.irp.f b/plugins/local/tc_scf/tc_scf_dm.irp.f
index bf31a4a1..5d25fce2 100644
--- a/plugins/local/tc_scf/tc_scf_dm.irp.f
+++ b/plugins/local/tc_scf/tc_scf_dm.irp.f
@@ -10,16 +10,8 @@ BEGIN_PROVIDER [double precision, TCSCF_density_matrix_ao_beta, (ao_num, ao_num)
implicit none
- if(bi_ortho) then
-
- PROVIDE mo_l_coef mo_r_coef
- TCSCF_density_matrix_ao_beta = TCSCF_bi_ort_dm_ao_beta
-
- else
-
- TCSCF_density_matrix_ao_beta = SCF_density_matrix_ao_beta
-
- endif
+ PROVIDE mo_l_coef mo_r_coef
+ TCSCF_density_matrix_ao_beta = TCSCF_bi_ort_dm_ao_beta
END_PROVIDER
@@ -35,16 +27,8 @@ BEGIN_PROVIDER [double precision, TCSCF_density_matrix_ao_alpha, (ao_num, ao_num
implicit none
- if(bi_ortho) then
-
- PROVIDE mo_l_coef mo_r_coef
- TCSCF_density_matrix_ao_alpha = TCSCF_bi_ort_dm_ao_alpha
-
- else
-
- TCSCF_density_matrix_ao_alpha = SCF_density_matrix_ao_alpha
-
- endif
+ PROVIDE mo_l_coef mo_r_coef
+ TCSCF_density_matrix_ao_alpha = TCSCF_bi_ort_dm_ao_alpha
END_PROVIDER
diff --git a/plugins/local/tc_scf/tc_scf_energy.irp.f b/plugins/local/tc_scf/tc_scf_energy.irp.f
index 833b48aa..74ab9d05 100644
--- a/plugins/local/tc_scf/tc_scf_energy.irp.f
+++ b/plugins/local/tc_scf/tc_scf_energy.irp.f
@@ -1,7 +1,8 @@
- BEGIN_PROVIDER [ double precision, TC_HF_energy ]
-&BEGIN_PROVIDER [ double precision, TC_HF_one_e_energy]
-&BEGIN_PROVIDER [ double precision, TC_HF_two_e_energy]
+ BEGIN_PROVIDER [double precision, TC_HF_energy ]
+&BEGIN_PROVIDER [double precision, TC_HF_one_e_energy ]
+&BEGIN_PROVIDER [double precision, TC_HF_two_e_energy ]
+&BEGIN_PROVIDER [double precision, TC_HF_three_e_energy]
BEGIN_DOC
! TC Hartree-Fock energy containing the nuclear repulsion, and its one- and two-body components.
@@ -11,11 +12,8 @@
integer :: i, j
double precision :: t0, t1
- !print*, ' Providing TC energy ...'
- !call wall_time(t0)
-
PROVIDE mo_l_coef mo_r_coef
- PROVIDE two_e_tc_non_hermit_integral_alpha two_e_tc_non_hermit_integral_beta
+ PROVIDE two_e_tc_integral_alpha two_e_tc_integral_beta
TC_HF_energy = nuclear_repulsion
TC_HF_one_e_energy = 0.d0
@@ -23,47 +21,20 @@
do j = 1, ao_num
do i = 1, ao_num
- TC_HF_two_e_energy += 0.5d0 * ( two_e_tc_non_hermit_integral_alpha(i,j) * TCSCF_density_matrix_ao_alpha(i,j) &
- + two_e_tc_non_hermit_integral_beta (i,j) * TCSCF_density_matrix_ao_beta (i,j) )
+ TC_HF_two_e_energy += 0.5d0 * ( two_e_tc_integral_alpha(i,j) * TCSCF_density_matrix_ao_alpha(i,j) &
+ + two_e_tc_integral_beta (i,j) * TCSCF_density_matrix_ao_beta (i,j) )
TC_HF_one_e_energy += ao_one_e_integrals_tc_tot(i,j) &
* (TCSCF_density_matrix_ao_alpha(i,j) + TCSCF_density_matrix_ao_beta (i,j) )
enddo
enddo
- TC_HF_energy += TC_HF_one_e_energy + TC_HF_two_e_energy
- TC_HF_energy += diag_three_elem_hf
+ if((three_body_h_tc .eq. .False.) .and. (.not. noL_standard)) then
+ TC_HF_three_e_energy = 0.d0
+ else
+ TC_HF_three_e_energy = noL_0e
+ endif
- !call wall_time(t1)
- !print*, ' Wall time for TC energy=', t1-t0
-
-END_PROVIDER
-
-! ---
-
- BEGIN_PROVIDER [ double precision, VARTC_HF_energy]
-&BEGIN_PROVIDER [ double precision, VARTC_HF_one_e_energy]
-&BEGIN_PROVIDER [ double precision, VARTC_HF_two_e_energy]
-
- implicit none
- integer :: i, j
-
- PROVIDE mo_r_coef
-
- VARTC_HF_energy = nuclear_repulsion
- VARTC_HF_one_e_energy = 0.d0
- VARTC_HF_two_e_energy = 0.d0
-
- do j = 1, ao_num
- do i = 1, ao_num
- VARTC_HF_two_e_energy += 0.5d0 * ( two_e_vartc_integral_alpha(i,j) * TCSCF_density_matrix_ao_alpha(i,j) &
- + two_e_vartc_integral_beta (i,j) * TCSCF_density_matrix_ao_beta (i,j) )
- VARTC_HF_one_e_energy += ao_one_e_integrals_tc_tot(i,j) &
- * (TCSCF_density_matrix_ao_alpha(i,j) + TCSCF_density_matrix_ao_beta (i,j) )
- enddo
- enddo
-
- VARTC_HF_energy += VARTC_HF_one_e_energy + VARTC_HF_two_e_energy
- VARTC_HF_energy += diag_three_elem_hf
+ TC_HF_energy += TC_HF_one_e_energy + TC_HF_two_e_energy + TC_HF_three_e_energy
END_PROVIDER
diff --git a/plugins/local/tc_scf/tcscf_energy_naive.irp.f b/plugins/local/tc_scf/tcscf_energy_naive.irp.f
deleted file mode 100644
index 82bb8799..00000000
--- a/plugins/local/tc_scf/tcscf_energy_naive.irp.f
+++ /dev/null
@@ -1,80 +0,0 @@
-
-! ---
-
-BEGIN_PROVIDER [double precision, tcscf_energy_3e_naive]
-
- implicit none
- integer :: i, j, k
- integer :: neu, ned, D(elec_num)
- integer :: ii, jj, kk
- integer :: si, sj, sk
- double precision :: I_ijk, I_jki, I_kij, I_jik, I_ikj, I_kji
- double precision :: I_tot
-
- PROVIDE mo_l_coef mo_r_coef
-
- neu = elec_alpha_num
- ned = elec_beta_num
- if (neu > 0) D(1:neu) = [(2*i-1, i = 1, neu)]
- if (ned > 0) D(neu+1:neu+ned) = [(2*i, i = 1, ned)]
-
- !print*, "D = "
- !do i = 1, elec_num
- ! ii = (D(i) - 1) / 2 + 1
- ! si = mod(D(i), 2)
- ! print*, i, D(i), ii, si
- !enddo
-
- tcscf_energy_3e_naive = 0.d0
-
- do i = 1, elec_num - 2
- ii = (D(i) - 1) / 2 + 1
- si = mod(D(i), 2)
-
- do j = i + 1, elec_num - 1
- jj = (D(j) - 1) / 2 + 1
- sj = mod(D(j), 2)
-
- do k = j + 1, elec_num
- kk = (D(k) - 1) / 2 + 1
- sk = mod(D(k), 2)
-
- call give_integrals_3_body_bi_ort(ii, jj, kk, ii, jj, kk, I_ijk)
- I_tot = I_ijk
-
- if(sj==si .and. sk==sj) then
- call give_integrals_3_body_bi_ort(ii, jj, kk, jj, kk, ii, I_jki)
- I_tot += I_jki
- endif
-
- if(sk==si .and. si==sj) then
- call give_integrals_3_body_bi_ort(ii, jj, kk, kk, ii, jj, I_kij)
- I_tot += I_kij
- endif
-
- if(sj==si) then
- call give_integrals_3_body_bi_ort(ii, jj, kk, jj, ii, kk, I_jik)
- I_tot -= I_jik
- endif
-
- if(sk==sj) then
- call give_integrals_3_body_bi_ort(ii, jj, kk, ii, kk, jj, I_ikj)
- I_tot -= I_ikj
- endif
-
- if(sk==si) then
- call give_integrals_3_body_bi_ort(ii, jj, kk, kk, jj, ii, I_kji)
- I_tot -= I_kji
- endif
-
- tcscf_energy_3e_naive += I_tot
- enddo
- enddo
- enddo
-
- tcscf_energy_3e_naive = -tcscf_energy_3e_naive
-
-END_PROVIDER
-
-! ---
-
diff --git a/plugins/local/tc_scf/test_int.irp.f b/plugins/local/tc_scf/test_int.irp.f
deleted file mode 100644
index e135fcd8..00000000
--- a/plugins/local/tc_scf/test_int.irp.f
+++ /dev/null
@@ -1,970 +0,0 @@
-program test_ints
-
- BEGIN_DOC
- ! TODO : Put the documentation of the program here
- END_DOC
-
- implicit none
-
- print *, ' starting test_ints ...'
-
- my_grid_becke = .True.
- PROVIDE tc_grid1_a tc_grid1_r
- my_n_pt_r_grid = tc_grid1_r
- my_n_pt_a_grid = tc_grid1_a
- touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
-
- my_extra_grid_becke = .True.
- my_n_pt_r_extra_grid = 30
- my_n_pt_a_extra_grid = 50 ! small extra_grid for quick debug
- touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid
-
-!! OK
-! call routine_int2_u_grad1u_env2
-! OK
-! call routine_v_ij_erf_rk_cst_mu_env
-! OK
-! call routine_x_v_ij_erf_rk_cst_mu_env
-! OK
-! call routine_int2_u2_env2
-! OK
-! call routine_int2_u_grad1u_x_env2
-! OK
-! call routine_int2_grad1u2_grad2u2_env2
-! call routine_int2_u_grad1u_env2
-! call test_int2_grad1_u12_ao_test
-! call routine_v_ij_u_cst_mu_env_test
-! call test_grid_points_ao
- !call test_int_gauss
-
- !call test_fock_3e_uhf_ao()
- !call test_fock_3e_uhf_mo()
-
- !call test_two_e_tc_non_hermit_integral()
-
-!!PROVIDE TC_HF_energy VARTC_HF_energy
-!!print *, ' TC_HF_energy = ', TC_HF_energy
-!!print *, ' VARTC_HF_energy = ', VARTC_HF_energy
-
- call test_fock_3e_uhf_mo_cs()
- call test_fock_3e_uhf_mo_a()
- call test_fock_3e_uhf_mo_b()
-
-end
-
-! ---
-
-subroutine routine_test_env
- implicit none
- integer :: i,icount,j
- icount = 0
- do i = 1, List_env1s_square_size
- if(dabs(List_env1s_square_coef(i)).gt.1.d-10)then
- print*,''
- print*,List_env1s_square_expo(i),List_env1s_square_coef(i)
- print*,List_env1s_square_cent(1:3,i)
- print*,''
- icount += 1
- endif
-
- enddo
- print*,'List_env1s_square_coef,icount = ',List_env1s_square_size,icount
- do i = 1, ao_num
- do j = 1, ao_num
- do icount = 1, List_comb_thr_b3_size(j,i)
- print*,'',j,i
- print*,List_comb_thr_b3_expo(icount,j,i),List_comb_thr_b3_coef(icount,j,i)
- print*,List_comb_thr_b3_cent(1:3,icount,j,i)
- print*,''
- enddo
-! enddo
- enddo
- enddo
- print*,'max_List_comb_thr_b3_size = ',max_List_comb_thr_b3_size,List_env1s_square_size
-
-end
-
-subroutine routine_int2_u_grad1u_env2
- implicit none
- integer :: i,j,ipoint,k,l
- double precision :: weight,accu_relat, accu_abs, contrib
- double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:)
-
- allocate(array(ao_num, ao_num, ao_num, ao_num))
- array = 0.d0
- allocate(array_ref(ao_num, ao_num, ao_num, ao_num))
- array_ref = 0.d0
- do ipoint = 1, n_points_final_grid
- weight = final_weight_at_r_vector(ipoint)
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- array(j,i,l,k) += int2_u_grad1u_env2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
- array_ref(j,i,l,k) += int2_u_grad1u_env2(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
- enddo
- enddo
- enddo
- enddo
- enddo
- accu_relat = 0.d0
- accu_abs = 0.d0
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k))
- accu_abs += contrib
- if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then
- accu_relat += contrib/dabs(array_ref(j,i,l,k))
- endif
- enddo
- enddo
- enddo
- enddo
- print*,'******'
- print*,'******'
- print*,'routine_int2_u_grad1u_env2'
- print*,'accu_abs = ',accu_abs/dble(ao_num)**4
- print*,'accu_relat = ',accu_relat/dble(ao_num)**4
-
-
-
-end
-
-subroutine routine_v_ij_erf_rk_cst_mu_env
- implicit none
- integer :: i,j,ipoint,k,l
- double precision :: weight,accu_relat, accu_abs, contrib
- double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:)
- allocate(array(ao_num, ao_num, ao_num, ao_num))
- array = 0.d0
- allocate(array_ref(ao_num, ao_num, ao_num, ao_num))
- array_ref = 0.d0
- do ipoint = 1, n_points_final_grid
- weight = final_weight_at_r_vector(ipoint)
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- array(j,i,l,k) += v_ij_erf_rk_cst_mu_env_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
- array_ref(j,i,l,k) += v_ij_erf_rk_cst_mu_env(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
- enddo
- enddo
- enddo
- enddo
- enddo
- accu_relat = 0.d0
- accu_abs = 0.d0
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k))
- accu_abs += contrib
- if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then
- accu_relat += contrib/dabs(array_ref(j,i,l,k))
- endif
- enddo
- enddo
- enddo
- enddo
- print*,'******'
- print*,'******'
- print*,'routine_v_ij_erf_rk_cst_mu_env'
- print*,'accu_abs = ',accu_abs/dble(ao_num)**4
- print*,'accu_relat = ',accu_relat/dble(ao_num)**4
-
-
-
-end
-
-
-subroutine routine_x_v_ij_erf_rk_cst_mu_env
- implicit none
- integer :: i,j,ipoint,k,l,m
- double precision :: weight,accu_relat, accu_abs, contrib
- double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:)
- allocate(array(ao_num, ao_num, ao_num, ao_num))
- array = 0.d0
- allocate(array_ref(ao_num, ao_num, ao_num, ao_num))
- array_ref = 0.d0
- do ipoint = 1, n_points_final_grid
- weight = final_weight_at_r_vector(ipoint)
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- do m = 1, 3
- array(j,i,l,k) += x_v_ij_erf_rk_cst_mu_env_test(j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight
- array_ref(j,i,l,k) += x_v_ij_erf_rk_cst_mu_env (j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight
- enddo
- enddo
- enddo
- enddo
- enddo
- enddo
- accu_relat = 0.d0
- accu_abs = 0.d0
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k))
- accu_abs += contrib
- if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then
- accu_relat += contrib/dabs(array_ref(j,i,l,k))
- endif
- enddo
- enddo
- enddo
- enddo
-
- print*,'******'
- print*,'******'
- print*,'routine_x_v_ij_erf_rk_cst_mu_env'
- print*,'accu_abs = ',accu_abs/dble(ao_num)**4
- print*,'accu_relat = ',accu_relat/dble(ao_num)**4
-
-
-
-end
-
-
-
-subroutine routine_v_ij_u_cst_mu_env_test
- implicit none
- integer :: i,j,ipoint,k,l
- double precision :: weight,accu_relat, accu_abs, contrib
- double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:)
- allocate(array(ao_num, ao_num, ao_num, ao_num))
- array = 0.d0
- allocate(array_ref(ao_num, ao_num, ao_num, ao_num))
- array_ref = 0.d0
- do ipoint = 1, n_points_final_grid
- weight = final_weight_at_r_vector(ipoint)
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- array(j,i,l,k) += v_ij_u_cst_mu_env_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
- array_ref(j,i,l,k) += v_ij_u_cst_mu_env_fit (j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
- enddo
- enddo
- enddo
- enddo
- enddo
- accu_relat = 0.d0
- accu_abs = 0.d0
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k))
- accu_abs += contrib
- if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then
- accu_relat += contrib/dabs(array_ref(j,i,l,k))
- endif
- enddo
- enddo
- enddo
- enddo
- print*,'******'
- print*,'******'
- print*,'routine_v_ij_u_cst_mu_env_test'
- print*,'accu_abs = ',accu_abs/dble(ao_num)**4
- print*,'accu_relat = ',accu_relat/dble(ao_num)**4
-
-end
-
-subroutine routine_int2_grad1u2_grad2u2_env2
- implicit none
- integer :: i,j,ipoint,k,l
- integer :: ii , jj
- double precision :: weight,accu_relat, accu_abs, contrib
- double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:)
- double precision, allocatable :: ints(:,:,:)
- allocate(ints(ao_num, ao_num, n_points_final_grid))
-! do ipoint = 1, n_points_final_grid
-! do i = 1, ao_num
-! do j = 1, ao_num
-! read(33,*)ints(j,i,ipoint)
-! enddo
-! enddo
-! enddo
-
- allocate(array(ao_num, ao_num, ao_num, ao_num))
- array = 0.d0
- allocate(array_ref(ao_num, ao_num, ao_num, ao_num))
- array_ref = 0.d0
- do ipoint = 1, n_points_final_grid
- weight = final_weight_at_r_vector(ipoint)
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- array(j,i,l,k) += int2_grad1u2_grad2u2_env2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
-! !array(j,i,l,k) += int2_grad1u2_grad2u2_env2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
-! array_ref(j,i,l,k) += int2_grad1u2_grad2u2_env2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
-! !array(j,i,l,k) += ints(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
-! array_ref(j,i,l,k) += int2_grad1u2_grad2u2_env2(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
- array_ref(j,i,l,k) += ints(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
-! if(dabs(int2_grad1u2_grad2u2_env2_test(j,i,ipoint)).gt.1.d-6)then
-! if(dabs(int2_grad1u2_grad2u2_env2_test(j,i,ipoint) - int2_grad1u2_grad2u2_env2_test(j,i,ipoint)).gt.1.d-6)then
-! print*,j,i,ipoint
-! print*,int2_grad1u2_grad2u2_env2_test(j,i,ipoint) , int2_grad1u2_grad2u2_env2_test(j,i,ipoint), dabs(int2_grad1u2_grad2u2_env2_test(j,i,ipoint) - int2_grad1u2_grad2u2_env2_test(j,i,ipoint))
-! print*,int2_grad1u2_grad2u2_env2_test(i,j,ipoint) , int2_grad1u2_grad2u2_env2_test(i,j,ipoint), dabs(int2_grad1u2_grad2u2_env2_test(i,j,ipoint) - int2_grad1u2_grad2u2_env2_test(i,j,ipoint))
-! stop
-! endif
-! endif
- enddo
- enddo
- enddo
- enddo
- enddo
- double precision :: e_ref, e_new
- accu_relat = 0.d0
- accu_abs = 0.d0
- e_ref = 0.d0
- e_new = 0.d0
- do ii = 1, elec_alpha_num
- do jj = ii, elec_alpha_num
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- e_ref += mo_coef(j,ii) * mo_coef(i,ii) * array_ref(j,i,l,k) * mo_coef(l,jj) * mo_coef(k,jj)
- e_new += mo_coef(j,ii) * mo_coef(i,ii) * array(j,i,l,k) * mo_coef(l,jj) * mo_coef(k,jj)
- contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k))
- accu_abs += contrib
-! if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then
-! accu_relat += contrib/dabs(array_ref(j,i,l,k))
-! endif
- enddo
- enddo
- enddo
- enddo
-
- enddo
- enddo
- print*,'e_ref = ',e_ref
- print*,'e_new = ',e_new
-! print*,'accu_abs = ',accu_abs/dble(ao_num)**4
-! print*,'accu_relat = ',accu_relat/dble(ao_num)**4
-
-
-
-end
-
-subroutine routine_int2_u2_env2
- implicit none
- integer :: i,j,ipoint,k,l
- double precision :: weight,accu_relat, accu_abs, contrib
- double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:)
-
- allocate(array(ao_num, ao_num, ao_num, ao_num))
- array = 0.d0
- allocate(array_ref(ao_num, ao_num, ao_num, ao_num))
- array_ref = 0.d0
- do ipoint = 1, n_points_final_grid
- weight = final_weight_at_r_vector(ipoint)
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- array(j,i,l,k) += int2_u2_env2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
- array_ref(j,i,l,k) += int2_u2_env2(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
- enddo
- enddo
- enddo
- enddo
- enddo
- accu_relat = 0.d0
- accu_abs = 0.d0
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k))
- accu_abs += contrib
- if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then
- accu_relat += contrib/dabs(array_ref(j,i,l,k))
- endif
- enddo
- enddo
- enddo
- enddo
- print*,'******'
- print*,'******'
- print*,'routine_int2_u2_env2'
- print*,'accu_abs = ',accu_abs/dble(ao_num)**4
- print*,'accu_relat = ',accu_relat/dble(ao_num)**4
-
-
-
-end
-
-
-subroutine routine_int2_u_grad1u_x_env2
- implicit none
- integer :: i,j,ipoint,k,l,m
- double precision :: weight,accu_relat, accu_abs, contrib
- double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:)
-
- allocate(array(ao_num, ao_num, ao_num, ao_num))
- array = 0.d0
- allocate(array_ref(ao_num, ao_num, ao_num, ao_num))
- array_ref = 0.d0
- do ipoint = 1, n_points_final_grid
- weight = final_weight_at_r_vector(ipoint)
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- do m = 1, 3
- array(j,i,l,k) += int2_u_grad1u_x_env2_test(j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight
- array_ref(j,i,l,k) += int2_u_grad1u_x_env2 (j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight
- enddo
- enddo
- enddo
- enddo
- enddo
- enddo
- accu_relat = 0.d0
- accu_abs = 0.d0
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k))
- accu_abs += contrib
- if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then
- accu_relat += contrib/dabs(array_ref(j,i,l,k))
- endif
- enddo
- enddo
- enddo
- enddo
- print*,'******'
- print*,'******'
- print*,'routine_int2_u_grad1u_x_env2'
- print*,'accu_abs = ',accu_abs/dble(ao_num)**4
- print*,'accu_relat = ',accu_relat/dble(ao_num)**4
-
-
-
-end
-
-subroutine routine_v_ij_u_cst_mu_env
- implicit none
- integer :: i,j,ipoint,k,l
- double precision :: weight,accu_relat, accu_abs, contrib
- double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:)
-
- allocate(array(ao_num, ao_num, ao_num, ao_num))
- array = 0.d0
- allocate(array_ref(ao_num, ao_num, ao_num, ao_num))
- array_ref = 0.d0
- do ipoint = 1, n_points_final_grid
- weight = final_weight_at_r_vector(ipoint)
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- array(j,i,l,k) += v_ij_u_cst_mu_env_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
- array_ref(j,i,l,k) += v_ij_u_cst_mu_env_fit (j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
- enddo
- enddo
- enddo
- enddo
- enddo
- accu_relat = 0.d0
- accu_abs = 0.d0
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k))
- accu_abs += contrib
- if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then
- accu_relat += contrib/dabs(array_ref(j,i,l,k))
- endif
- enddo
- enddo
- enddo
- enddo
- print*,'******'
- print*,'******'
- print*,'routine_v_ij_u_cst_mu_env'
- print*,'accu_abs = ',accu_abs/dble(ao_num)**4
- print*,'accu_relat = ',accu_relat/dble(ao_num)**4
-
-end
-
-! ---
-
-subroutine test_fock_3e_uhf_ao()
-
- implicit none
- integer :: i, j
- double precision :: diff_tot, diff_ij, thr_ih, norm
- double precision, allocatable :: fock_3e_uhf_ao_a_mo(:,:), fock_3e_uhf_ao_b_mo(:,:)
-
- thr_ih = 1d-7
-
- PROVIDE fock_a_tot_3e_bi_orth fock_b_tot_3e_bi_orth
- PROVIDE fock_3e_uhf_ao_a fock_3e_uhf_ao_b
-
- ! ---
-
- allocate(fock_3e_uhf_ao_a_mo(mo_num,mo_num))
- call ao_to_mo_bi_ortho( fock_3e_uhf_ao_a , size(fock_3e_uhf_ao_a , 1) &
- , fock_3e_uhf_ao_a_mo, size(fock_3e_uhf_ao_a_mo, 1) )
-
- norm = 0.d0
- diff_tot = 0.d0
- do i = 1, mo_num
- do j = 1, mo_num
-
- diff_ij = dabs(fock_3e_uhf_ao_a_mo(j,i) - fock_a_tot_3e_bi_orth(j,i))
- if(diff_ij .gt. thr_ih) then
- print *, ' difference on ', j, i
- print *, ' MANU : ', fock_a_tot_3e_bi_orth(j,i)
- print *, ' UHF : ', fock_3e_uhf_ao_a_mo (j,i)
- !stop
- endif
-
- norm += dabs(fock_a_tot_3e_bi_orth(j,i))
- diff_tot += diff_ij
- enddo
- enddo
- print *, ' diff on F_a = ', diff_tot / norm
- print *, ' '
-
- deallocate(fock_3e_uhf_ao_a_mo)
-
- ! ---
-
- allocate(fock_3e_uhf_ao_b_mo(mo_num,mo_num))
- call ao_to_mo_bi_ortho( fock_3e_uhf_ao_b , size(fock_3e_uhf_ao_b , 1) &
- , fock_3e_uhf_ao_b_mo, size(fock_3e_uhf_ao_b_mo, 1) )
-
- norm = 0.d0
- diff_tot = 0.d0
- do i = 1, mo_num
- do j = 1, mo_num
-
- diff_ij = dabs(fock_3e_uhf_ao_b_mo(j,i) - fock_b_tot_3e_bi_orth(j,i))
- if(diff_ij .gt. thr_ih) then
- print *, ' difference on ', j, i
- print *, ' MANU : ', fock_b_tot_3e_bi_orth(j,i)
- print *, ' UHF : ', fock_3e_uhf_ao_b_mo (j,i)
- !stop
- endif
-
- norm += dabs(fock_b_tot_3e_bi_orth(j,i))
- diff_tot += diff_ij
- enddo
- enddo
- print *, ' diff on F_b = ', diff_tot/norm
- print *, ' '
-
- deallocate(fock_3e_uhf_ao_b_mo)
-
- ! ---
-
-end subroutine test_fock_3e_uhf_ao()
-
-! ---
-
-subroutine test_fock_3e_uhf_mo()
-
- implicit none
- integer :: i, j
- double precision :: diff_tot, diff_ij, thr_ih, norm
-
- thr_ih = 1d-12
-
- PROVIDE fock_a_tot_3e_bi_orth fock_b_tot_3e_bi_orth
- PROVIDE fock_3e_uhf_mo_a fock_3e_uhf_mo_b
-
- ! ---
-
- norm = 0.d0
- diff_tot = 0.d0
- do i = 1, mo_num
- do j = 1, mo_num
-
- diff_ij = dabs(fock_3e_uhf_mo_a(j,i) - fock_a_tot_3e_bi_orth(j,i))
- if(diff_ij .gt. thr_ih) then
- print *, ' difference on ', j, i
- print *, ' MANU : ', fock_a_tot_3e_bi_orth(j,i)
- print *, ' UHF : ', fock_3e_uhf_mo_a (j,i)
- !stop
- endif
-
- norm += dabs(fock_a_tot_3e_bi_orth(j,i))
- diff_tot += diff_ij
- enddo
- enddo
- print *, ' diff on F_a = ', diff_tot / norm
- print *, ' norm_a = ', norm
- print *, ' '
-
- ! ---
-
- norm = 0.d0
- diff_tot = 0.d0
- do i = 1, mo_num
- do j = 1, mo_num
-
- diff_ij = dabs(fock_3e_uhf_mo_b(j,i) - fock_b_tot_3e_bi_orth(j,i))
- if(diff_ij .gt. thr_ih) then
- print *, ' difference on ', j, i
- print *, ' MANU : ', fock_b_tot_3e_bi_orth(j,i)
- print *, ' UHF : ', fock_3e_uhf_mo_b (j,i)
- !stop
- endif
-
- norm += dabs(fock_b_tot_3e_bi_orth(j,i))
- diff_tot += diff_ij
- enddo
- enddo
- print *, ' diff on F_b = ', diff_tot/norm
- print *, ' norm_b = ', norm
- print *, ' '
-
- ! ---
-
-end
-
-! ---
-
-subroutine test_grid_points_ao
- implicit none
- integer :: i,j,ipoint,icount,icount_good, icount_bad,icount_full
- double precision :: thr
- thr = 1.d-10
-! print*,'max_n_pts_grid_ao_prod = ',max_n_pts_grid_ao_prod
-! print*,'n_pts_grid_ao_prod'
- do i = 1, ao_num
- do j = i, ao_num
- icount = 0
- icount_good = 0
- icount_bad = 0
- icount_full = 0
- do ipoint = 1, n_points_final_grid
-! if(dabs(int2_u_grad1u_x_env2_test(j,i,ipoint,1)) &
-! + dabs(int2_u_grad1u_x_env2_test(j,i,ipoint,2)) &
-! + dabs(int2_u_grad1u_x_env2_test(j,i,ipoint,3)) )
-! if(dabs(int2_u2_env2_test(j,i,ipoint)).gt.thr)then
-! icount += 1
-! endif
- if(dabs(v_ij_u_cst_mu_env_ng_1_test(j,i,ipoint)).gt.thr*0.1d0)then
- icount_full += 1
- endif
- if(dabs(v_ij_u_cst_mu_env_test(j,i,ipoint)).gt.thr)then
- icount += 1
- if(dabs(v_ij_u_cst_mu_env_ng_1_test(j,i,ipoint)).gt.thr*0.1d0)then
- icount_good += 1
- else
- print*,j,i,ipoint
- print*,dabs(v_ij_u_cst_mu_env_test(j,i,ipoint)), dabs(v_ij_u_cst_mu_env_ng_1_test(j,i,ipoint)),dabs(v_ij_u_cst_mu_env_ng_1_test(j,i,ipoint))/dabs(v_ij_u_cst_mu_env_test(j,i,ipoint))
- icount_bad += 1
- endif
- endif
-! if(dabs(v_ij_u_cst_mu_env_ng_1_test(j,i,ipoint)).gt.thr)then
-! endif
- enddo
- print*,''
- print*,j,i
- print*,icount,icount_full, icount_bad!,n_pts_grid_ao_prod(j,i)
- print*,dble(icount)/dble(n_points_final_grid),dble(icount_full)/dble(n_points_final_grid)
-! dble(n_pts_grid_ao_prod(j,i))/dble(n_points_final_grid)
-! if(icount.gt.n_pts_grid_ao_prod(j,i))then
-! print*,'pb !!'
-! endif
- enddo
- enddo
-end
-
-subroutine test_int_gauss
- implicit none
- integer :: i,j
- print*,'center'
- do i = 1, ao_num
- do j = i, ao_num
- print*,j,i
- print*,ao_prod_sigma(j,i),ao_overlap_abs_grid(j,i)
- print*,ao_prod_center(1:3,j,i)
- enddo
- enddo
- print*,''
- double precision :: weight, r(3),integral_1,pi,center(3),f_r,alpha,distance,integral_2
- center = 0.d0
- pi = dacos(-1.d0)
- integral_1 = 0.d0
- integral_2 = 0.d0
- alpha = 0.75d0
- do i = 1, n_points_final_grid
- ! you get x, y and z of the ith grid point
- r(1) = final_grid_points(1,i)
- r(2) = final_grid_points(2,i)
- r(3) = final_grid_points(3,i)
- weight = final_weight_at_r_vector(i)
- distance = dsqrt( (r(1) - center(1))**2 + (r(2) - center(2))**2 + (r(3) - center(3))**2 )
- f_r = dexp(-alpha * distance*distance)
- ! you add the contribution of the grid point to the integral
- integral_1 += f_r * weight
- integral_2 += f_r * distance * weight
- enddo
- print*,'integral_1 =',integral_1
- print*,'(pi/alpha)**1.5 =',(pi / alpha)**1.5
- print*,'integral_2 =',integral_2
- print*,'(pi/alpha)**1.5 =',2.d0*pi / (alpha)**2
-
-
-end
-
-! ---
-
-subroutine test_two_e_tc_non_hermit_integral()
-
- implicit none
- integer :: i, j
- double precision :: diff_tot, diff, thr_ih, norm
-
- thr_ih = 1d-10
-
- PROVIDE two_e_tc_non_hermit_integral_beta two_e_tc_non_hermit_integral_alpha
- PROVIDE two_e_tc_non_hermit_integral_seq_beta two_e_tc_non_hermit_integral_seq_alpha
-
- ! ---
-
- norm = 0.d0
- diff_tot = 0.d0
- do i = 1, ao_num
- do j = 1, ao_num
-
- diff = dabs(two_e_tc_non_hermit_integral_seq_alpha(j,i) - two_e_tc_non_hermit_integral_alpha(j,i))
- if(diff .gt. thr_ih) then
- print *, ' difference on ', j, i
- print *, ' seq : ', two_e_tc_non_hermit_integral_seq_alpha(j,i)
- print *, ' // : ', two_e_tc_non_hermit_integral_alpha (j,i)
- !stop
- endif
-
- norm += dabs(two_e_tc_non_hermit_integral_seq_alpha(j,i))
- diff_tot += diff
- enddo
- enddo
-
- print *, ' diff tot a = ', diff_tot / norm
- print *, ' norm a = ', norm
- print *, ' '
-
- ! ---
-
- norm = 0.d0
- diff_tot = 0.d0
- do i = 1, ao_num
- do j = 1, ao_num
-
- diff = dabs(two_e_tc_non_hermit_integral_seq_beta(j,i) - two_e_tc_non_hermit_integral_beta(j,i))
- if(diff .gt. thr_ih) then
- print *, ' difference on ', j, i
- print *, ' seq : ', two_e_tc_non_hermit_integral_seq_beta(j,i)
- print *, ' // : ', two_e_tc_non_hermit_integral_beta (j,i)
- !stop
- endif
-
- norm += dabs(two_e_tc_non_hermit_integral_seq_beta(j,i))
- diff_tot += diff
- enddo
- enddo
-
- print *, ' diff tot b = ', diff_tot / norm
- print *, ' norm b = ', norm
- print *, ' '
-
- ! ---
-
- return
-
-end
-
-! ---
-
-subroutine test_int2_grad1_u12_ao_test
- implicit none
- integer :: i,j,ipoint,m,k,l
- double precision :: weight,accu_relat, accu_abs, contrib
- double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:)
- allocate(array(ao_num, ao_num, ao_num, ao_num))
- array = 0.d0
- allocate(array_ref(ao_num, ao_num, ao_num, ao_num))
- array_ref = 0.d0
- do m = 1, 3
- do ipoint = 1, n_points_final_grid
- weight = final_weight_at_r_vector(ipoint)
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- array(j,i,l,k) += int2_grad1_u12_ao_test(j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight
- array_ref(j,i,l,k) += int2_grad1_u12_ao(j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight
- enddo
- enddo
- enddo
- enddo
- enddo
- enddo
-
- accu_relat = 0.d0
- accu_abs = 0.d0
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k))
- accu_abs += contrib
- if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then
- accu_relat += contrib/dabs(array_ref(j,i,l,k))
- endif
- enddo
- enddo
- enddo
- enddo
- print*,'******'
- print*,'******'
- print*,'test_int2_grad1_u12_ao_test'
- print*,'accu_abs = ',accu_abs/dble(ao_num)**4
- print*,'accu_relat = ',accu_relat/dble(ao_num)**4
-end
-
-! ---
-
-subroutine test_fock_3e_uhf_mo_cs()
-
- implicit none
- integer :: i, j
- double precision :: I_old, I_new
- double precision :: diff_tot, diff, thr_ih, norm
-
-! double precision :: t0, t1
-! print*, ' Providing fock_a_tot_3e_bi_orth ...'
-! call wall_time(t0)
-! PROVIDE fock_a_tot_3e_bi_orth
-! call wall_time(t1)
-! print*, ' Wall time for fock_a_tot_3e_bi_orth =', t1 - t0
-
- PROVIDE fock_3e_uhf_mo_cs fock_3e_uhf_mo_cs_old
-
- thr_ih = 1d-8
- norm = 0.d0
- diff_tot = 0.d0
-
- do i = 1, mo_num
- do j = 1, mo_num
-
- I_old = fock_3e_uhf_mo_cs_old(j,i)
- I_new = fock_3e_uhf_mo_cs (j,i)
-
- diff = dabs(I_old - I_new)
- if(diff .gt. thr_ih) then
- print *, ' problem in fock_3e_uhf_mo_cs on ', j, i
- print *, ' old value = ', I_old
- print *, ' new value = ', I_new
- !stop
- endif
-
- norm += dabs(I_old)
- diff_tot += diff
- enddo
- enddo
-
- print *, ' diff tot (%) = ', 100.d0 * diff_tot / norm
-
- return
-end
-
-! ---
-
-subroutine test_fock_3e_uhf_mo_a()
-
- implicit none
- integer :: i, j
- double precision :: I_old, I_new
- double precision :: diff_tot, diff, thr_ih, norm
-
- PROVIDE fock_3e_uhf_mo_a fock_3e_uhf_mo_a_old
-
- thr_ih = 1d-8
- norm = 0.d0
- diff_tot = 0.d0
-
- do i = 1, mo_num
- do j = 1, mo_num
-
- I_old = fock_3e_uhf_mo_a_old(j,i)
- I_new = fock_3e_uhf_mo_a (j,i)
-
- diff = dabs(I_old - I_new)
- if(diff .gt. thr_ih) then
- print *, ' problem in fock_3e_uhf_mo_a on ', j, i
- print *, ' old value = ', I_old
- print *, ' new value = ', I_new
- !stop
- endif
-
- norm += dabs(I_old)
- diff_tot += diff
- enddo
- enddo
-
- print *, ' diff tot (%) = ', 100.d0 * diff_tot / norm
-
- return
-end
-
-! ---
-
-subroutine test_fock_3e_uhf_mo_b()
-
- implicit none
- integer :: i, j
- double precision :: I_old, I_new
- double precision :: diff_tot, diff, thr_ih, norm
-
- PROVIDE fock_3e_uhf_mo_b fock_3e_uhf_mo_b_old
-
- thr_ih = 1d-8
- norm = 0.d0
- diff_tot = 0.d0
-
- do i = 1, mo_num
- do j = 1, mo_num
-
- I_old = fock_3e_uhf_mo_b_old(j,i)
- I_new = fock_3e_uhf_mo_b (j,i)
-
- diff = dabs(I_old - I_new)
- if(diff .gt. thr_ih) then
- print *, ' problem in fock_3e_uhf_mo_b on ', j, i
- print *, ' old value = ', I_old
- print *, ' new value = ', I_new
- !stop
- endif
-
- norm += dabs(I_old)
- diff_tot += diff
- enddo
- enddo
-
- print *, ' diff tot (%) = ', 100.d0 * diff_tot / norm
-
- return
-end
-
-! ---
-
diff --git a/plugins/local/tc_scf/three_e_energy_bi_ortho.irp.f b/plugins/local/tc_scf/three_e_energy_bi_ortho.irp.f
deleted file mode 100644
index 0c9ebbd7..00000000
--- a/plugins/local/tc_scf/three_e_energy_bi_ortho.irp.f
+++ /dev/null
@@ -1,189 +0,0 @@
-
-subroutine contrib_3e_diag_sss(i, j, k, integral)
-
- BEGIN_DOC
- ! returns the pure same spin contribution to diagonal matrix element of 3e term
- END_DOC
-
- implicit none
- integer, intent(in) :: i, j, k
- double precision, intent(out) :: integral
- double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int, c_3_int, c_minus_3_int
-
- call give_integrals_3_body_bi_ort(i, k, j, i, k, j, direct_int )!!! < i k j | i k j >
- call give_integrals_3_body_bi_ort(i, k, j, j, i, k, c_3_int) ! < i k j | j i k >
- call give_integrals_3_body_bi_ort(i, k, j, k, j, i, c_minus_3_int)! < i k j | k j i >
- integral = direct_int + c_3_int + c_minus_3_int
-
- ! negative terms :: exchange contrib
- call give_integrals_3_body_bi_ort(i, k, j, j, k, i, exch_13_int)!!! < i k j | j k i > : E_13
- call give_integrals_3_body_bi_ort(i, k, j, i, j, k, exch_23_int)!!! < i k j | i j k > : E_23
- call give_integrals_3_body_bi_ort(i, k, j, k, i, j, exch_12_int)!!! < i k j | k i j > : E_12
-
- integral += - exch_13_int - exch_23_int - exch_12_int
- integral = -integral
-
-end
-
-! ---
-
-subroutine contrib_3e_diag_soo(i,j,k,integral)
- implicit none
- integer, intent(in) :: i,j,k
- BEGIN_DOC
- ! returns the pure same spin contribution to diagonal matrix element of 3e term
- END_DOC
- double precision, intent(out) :: integral
- double precision :: direct_int, exch_23_int
- call give_integrals_3_body_bi_ort(i, k, j, i, k, j, direct_int) ! < i k j | i k j >
- call give_integrals_3_body_bi_ort(i, k, j, i, j, k, exch_23_int)! < i k j | i j k > : E_23
- integral = direct_int - exch_23_int
- integral = -integral
-end
-
-
-subroutine give_aaa_contrib_bis(integral_aaa)
- implicit none
- double precision, intent(out) :: integral_aaa
- double precision :: integral
- integer :: i,j,k
- integral_aaa = 0.d0
- do i = 1, elec_alpha_num
- do j = i+1, elec_alpha_num
- do k = j+1, elec_alpha_num
- call contrib_3e_diag_sss(i,j,k,integral)
- integral_aaa += integral
- enddo
- enddo
- enddo
-
-end
-
-! ---
-
-subroutine give_aaa_contrib(integral_aaa)
-
- implicit none
- integer :: i, j, k
- double precision :: integral
- double precision, intent(out) :: integral_aaa
-
- integral_aaa = 0.d0
- do i = 1, elec_alpha_num
- do j = 1, elec_alpha_num
- do k = 1, elec_alpha_num
- call contrib_3e_diag_sss(i, j, k, integral)
- integral_aaa += integral
- enddo
- enddo
- enddo
- integral_aaa *= 1.d0/6.d0
-
- return
-end
-
-! ---
-
-subroutine give_aab_contrib(integral_aab)
- implicit none
- double precision, intent(out) :: integral_aab
- double precision :: integral
- integer :: i,j,k
- integral_aab = 0.d0
- do i = 1, elec_beta_num
- do j = 1, elec_alpha_num
- do k = 1, elec_alpha_num
- call contrib_3e_diag_soo(i,j,k,integral)
- integral_aab += integral
- enddo
- enddo
- enddo
- integral_aab *= 0.5d0
-end
-
-
-subroutine give_aab_contrib_bis(integral_aab)
- implicit none
- double precision, intent(out) :: integral_aab
- double precision :: integral
- integer :: i,j,k
- integral_aab = 0.d0
- do i = 1, elec_beta_num
- do j = 1, elec_alpha_num
- do k = j+1, elec_alpha_num
- call contrib_3e_diag_soo(i,j,k,integral)
- integral_aab += integral
- enddo
- enddo
- enddo
-end
-
-
-subroutine give_abb_contrib(integral_abb)
- implicit none
- double precision, intent(out) :: integral_abb
- double precision :: integral
- integer :: i,j,k
- integral_abb = 0.d0
- do i = 1, elec_alpha_num
- do j = 1, elec_beta_num
- do k = 1, elec_beta_num
- call contrib_3e_diag_soo(i,j,k,integral)
- integral_abb += integral
- enddo
- enddo
- enddo
- integral_abb *= 0.5d0
-end
-
-subroutine give_abb_contrib_bis(integral_abb)
- implicit none
- double precision, intent(out) :: integral_abb
- double precision :: integral
- integer :: i,j,k
- integral_abb = 0.d0
- do i = 1, elec_alpha_num
- do j = 1, elec_beta_num
- do k = j+1, elec_beta_num
- call contrib_3e_diag_soo(i,j,k,integral)
- integral_abb += integral
- enddo
- enddo
- enddo
-end
-
-subroutine give_bbb_contrib_bis(integral_bbb)
- implicit none
- double precision, intent(out) :: integral_bbb
- double precision :: integral
- integer :: i,j,k
- integral_bbb = 0.d0
- do i = 1, elec_beta_num
- do j = i+1, elec_beta_num
- do k = j+1, elec_beta_num
- call contrib_3e_diag_sss(i,j,k,integral)
- integral_bbb += integral
- enddo
- enddo
- enddo
-
-end
-
-subroutine give_bbb_contrib(integral_bbb)
- implicit none
- double precision, intent(out) :: integral_bbb
- double precision :: integral
- integer :: i,j,k
- integral_bbb = 0.d0
- do i = 1, elec_beta_num
- do j = 1, elec_beta_num
- do k = 1, elec_beta_num
- call contrib_3e_diag_sss(i,j,k,integral)
- integral_bbb += integral
- enddo
- enddo
- enddo
- integral_bbb *= 1.d0/6.d0
-end
-
-
diff --git a/plugins/local/tc_scf/write_ao_2e_tc_integ.irp.f b/plugins/local/tc_scf/write_ao_2e_tc_integ.irp.f
new file mode 100644
index 00000000..ec5167d1
--- /dev/null
+++ b/plugins/local/tc_scf/write_ao_2e_tc_integ.irp.f
@@ -0,0 +1,56 @@
+! ---
+
+program write_ao_2e_tc_integ
+
+ implicit none
+
+ print *, ' j2e_type = ', j2e_type
+ print *, ' j1e_type = ', j1e_type
+ print *, ' env_type = ', env_type
+
+ my_grid_becke = .True.
+ PROVIDE tc_grid1_a tc_grid1_r
+ my_n_pt_r_grid = tc_grid1_r
+ my_n_pt_a_grid = tc_grid1_a
+ touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
+
+ call write_int(6, my_n_pt_r_grid, 'radial external grid over')
+ call write_int(6, my_n_pt_a_grid, 'angular external grid over')
+
+ if(tc_integ_type .eq. "numeric") then
+ my_extra_grid_becke = .True.
+ PROVIDE tc_grid2_a tc_grid2_r
+ my_n_pt_r_extra_grid = tc_grid2_r
+ my_n_pt_a_extra_grid = tc_grid2_a
+ touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid
+
+ call write_int(6, my_n_pt_r_extra_grid, 'radial internal grid over')
+ call write_int(6, my_n_pt_a_extra_grid, 'angular internal grid over')
+ endif
+
+ call main()
+
+end
+
+! ---
+
+subroutine main()
+
+ implicit none
+
+ PROVIDE io_tc_integ
+
+ print*, 'io_tc_integ = ', io_tc_integ
+
+ if(io_tc_integ .ne. "Write") then
+ print*, 'io_tc_integ != Write'
+ print*, io_tc_integ
+ stop
+ endif
+
+ PROVIDE ao_two_e_tc_tot
+
+end
+
+! ---
+
diff --git a/plugins/local/tuto_plugins/H2.xyz b/plugins/local/tuto_plugins/H2.xyz
new file mode 100644
index 00000000..7af12291
--- /dev/null
+++ b/plugins/local/tuto_plugins/H2.xyz
@@ -0,0 +1,6 @@
+2
+H2, equilibrium geometry
+H 0.0 0.0 0.
+H 0.0 0.0 0.74
+
+
diff --git a/plugins/local/tuto_plugins/n2.xyz b/plugins/local/tuto_plugins/n2.xyz
new file mode 100644
index 00000000..016732d8
--- /dev/null
+++ b/plugins/local/tuto_plugins/n2.xyz
@@ -0,0 +1,4 @@
+2
+N2 Geo: Experiment Mult: 1 symmetry: 14
+N 0.0 0.0 0.5488
+N 0.0 0.0 -0.5488
diff --git a/plugins/local/tuto_plugins/tuto_I/print_one_e_h.irp.f b/plugins/local/tuto_plugins/tuto_I/print_one_e_h.irp.f
new file mode 100644
index 00000000..5d8dc1e7
--- /dev/null
+++ b/plugins/local/tuto_plugins/tuto_I/print_one_e_h.irp.f
@@ -0,0 +1,20 @@
+program my_program_to_print_stuffs
+ implicit none
+ BEGIN_DOC
+! TODO : Put the documentation of the program here
+ END_DOC
+ integer :: i,j
+ print*,'AO integrals '
+ do i = 1, ao_num
+ do j = 1, ao_num
+ print*,j,i,ao_one_e_integrals(j,i)
+ enddo
+ enddo
+
+ print*,'MO integrals '
+ do i = 1, mo_num
+ do j = 1, mo_num
+ print*,j,i,mo_one_e_integrals(j,i)
+ enddo
+ enddo
+end
diff --git a/plugins/local/tuto_plugins/tuto_I/print_traces_on_e.irp.f b/plugins/local/tuto_plugins/tuto_I/print_traces_on_e.irp.f
new file mode 100644
index 00000000..2bf3b86b
--- /dev/null
+++ b/plugins/local/tuto_plugins/tuto_I/print_traces_on_e.irp.f
@@ -0,0 +1,24 @@
+program my_program
+ implicit none
+ BEGIN_DOC
+! This program is there essentially to show how one can use providers in programs
+ END_DOC
+ integer :: i,j
+ double precision :: accu
+ print*,'Trace on the AO basis '
+ print*,trace_ao_one_e_ints
+ print*,'Trace on the AO basis after projection on the MO basis'
+ print*,trace_ao_one_e_ints_from_mo
+ print*,'Trace of MO integrals '
+ print*,trace_mo_one_e_ints
+ print*,'ao_num = ',ao_num
+ print*,'mo_num = ',mo_num
+ if(ao_num .ne. mo_num)then
+ print*,'The AO basis and MO basis are different ...'
+ print*,'Trace on the AO basis should not be the same as Trace of MO integrals'
+ print*,'Only the second one must be equal to the trace on the MO integrals'
+ else
+ print*,'The AO basis and MO basis are the same !'
+ print*,'All traces should coincide '
+ endif
+end
diff --git a/plugins/local/tuto_plugins/tuto_I/print_two_e_h.irp.f b/plugins/local/tuto_plugins/tuto_I/print_two_e_h.irp.f
new file mode 100644
index 00000000..eaeb6c98
--- /dev/null
+++ b/plugins/local/tuto_plugins/tuto_I/print_two_e_h.irp.f
@@ -0,0 +1,32 @@
+program my_program_to_print_stuffs
+ implicit none
+ BEGIN_DOC
+! TODO : Put the documentation of the program here
+ END_DOC
+ integer :: i,j,k,l
+ double precision :: integral
+ double precision :: get_ao_two_e_integral, get_two_e_integral ! declaration of the functions
+ print*,'AO integrals, physicist notations : '
+ do i = 1, ao_num
+ do j = 1, ao_num
+ do k = 1, ao_num
+ do l = 1, ao_num
+ integral = get_ao_two_e_integral(i, j, k, l, ao_integrals_map)
+ print*,i,j,k,l,integral
+ enddo
+ enddo
+ enddo
+ enddo
+
+ print*,'MO integrals, physicist notations : '
+ do i = 1, mo_num
+ do j = 1, mo_num
+ do k = 1, mo_num
+ do l = 1, mo_num
+ integral = get_two_e_integral(i, j, k, l, mo_integrals_map)
+ print*,i,j,k,l,integral
+ enddo
+ enddo
+ enddo
+ enddo
+end
diff --git a/plugins/local/tuto_plugins/tuto_I/test_cholesky.irp.f b/plugins/local/tuto_plugins/tuto_I/test_cholesky.irp.f
new file mode 100644
index 00000000..d09d100a
--- /dev/null
+++ b/plugins/local/tuto_plugins/tuto_I/test_cholesky.irp.f
@@ -0,0 +1,53 @@
+program my_program_to_print_stuffs
+ implicit none
+ BEGIN_DOC
+! TODO : Put the documentation of the program here
+ END_DOC
+ integer :: i,j,k,l,m
+ double precision :: integral, accu, accu_tot, integral_cholesky
+ double precision :: get_ao_two_e_integral, get_two_e_integral ! declaration of the functions
+ print*,'AO integrals, physicist notations : '
+ accu_tot = 0.D0
+ do i = 1, ao_num
+ do j = 1, ao_num
+ do k = 1, ao_num
+ do l = 1, ao_num
+ integral = get_ao_two_e_integral(i, j, k, l, ao_integrals_map)
+ integral_cholesky = 0.D0
+ do m = 1, cholesky_ao_num
+ integral_cholesky += cholesky_ao_transp(m,i,k) * cholesky_ao_transp(m,j,l)
+ enddo
+ accu = dabs(integral_cholesky-integral)
+ accu_tot += accu
+ if(accu.gt.1.d-10)then
+ print*,i,j,k,l
+ print*,accu, integral, integral_cholesky
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ print*,'accu_tot',accu_tot
+
+ print*,'MO integrals, physicist notations : '
+ do i = 1, mo_num
+ do j = 1, mo_num
+ do k = 1, mo_num
+ do l = 1, mo_num
+ integral = get_two_e_integral(i, j, k, l, mo_integrals_map)
+ accu = 0.D0
+ integral_cholesky = 0.D0
+ do m = 1, cholesky_mo_num
+ integral_cholesky += cholesky_mo_transp(m,i,k) * cholesky_mo_transp(m,j,l)
+ enddo
+ accu = dabs(integral_cholesky-integral)
+ accu_tot += accu
+ if(accu.gt.1.d-10)then
+ print*,i,j,k,l
+ print*,accu, integral, integral_cholesky
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+end
diff --git a/plugins/local/tuto_plugins/tuto_I/traces_one_e.irp.f b/plugins/local/tuto_plugins/tuto_I/traces_one_e.irp.f
new file mode 100644
index 00000000..e71d49fc
--- /dev/null
+++ b/plugins/local/tuto_plugins/tuto_I/traces_one_e.irp.f
@@ -0,0 +1,111 @@
+
+! This file is an example of the kind of manipulations that you can do with providers
+!
+
+!!!!!!!!!!!!!!!!!!!!!!!!!! Main providers useful for the program !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!!! type name
+BEGIN_PROVIDER [ double precision, trace_mo_one_e_ints]
+ implicit none
+ BEGIN_DOC
+! trace_mo_one_e_ints = Trace of the one-electron integrals on the MO basis
+!
+! = sum_i mo_one_e_integrals(i,i)
+ END_DOC
+ integer :: i
+ trace_mo_one_e_ints = 0.d0
+ do i = 1, mo_num
+ trace_mo_one_e_ints += mo_one_e_integrals(i,i)
+ enddo
+END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, trace_ao_one_e_ints]
+ implicit none
+ BEGIN_DOC
+! trace_ao_one_e_ints = Trace of the one-electron integrals on the AO basis taking into account the non orthogonality
+!
+! Be aware that the trace of an operator in a non orthonormal basis is Tr(A S^{-1}) = \sum_{m,n}(A_mn S^{-1}_mn)
+!
+! WARNING: it is equal to the trace on the MO basis if and only if the AO basis and MO basis
+! have the same number of functions
+ END_DOC
+ integer :: i,j
+ double precision, allocatable :: inv_overlap_times_integrals(:,:) ! = h S^{-1}
+ allocate(inv_overlap_times_integrals(ao_num,ao_num))
+ ! routine that computes the product of two matrices, you can check it with
+ ! irpman get_AB_prod
+ call get_AB_prod(ao_one_e_integrals,ao_num,ao_num,s_inv,ao_num,inv_overlap_times_integrals)
+ ! Tr(inv_overlap_times_integrals) = Tr(h S^{-1})
+ trace_ao_one_e_ints = 0.d0
+ do i = 1, ao_num
+ trace_ao_one_e_ints += inv_overlap_times_integrals(i,i)
+ enddo
+ !
+ ! testing the formula Tr(A S^{-1}) = \sum_{m,n}(A_mn S^{-1}_mn)
+ double precision :: test
+ test = 0.d0
+ do i = 1, ao_num
+ do j = 1, ao_num
+ test += ao_one_e_integrals(j,i) * s_inv(i,j)
+ enddo
+ enddo
+ if(dabs(accu - trace_ao_one_e_ints).gt.1.d-12)then
+ print*,'Warning ! '
+ print*,'Something is wrong because Tr(AB) \ne sum_{mn}A_mn B_nm'
+ endif
+END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, trace_ao_one_e_ints_from_mo]
+ implicit none
+ BEGIN_DOC
+! trace_ao_one_e_ints_from_mo = Trace of the one-electron integrals on the AO basis after projection on the MO basis
+!
+! = Tr([SC h {SC}^+] S^{-1})
+!
+! = Be aware that the trace of an operator in a non orthonormal basis is = Tr(A S^{-1}) where S is the metric
+! Must be equal to the trace_mo_one_e_ints
+ END_DOC
+ integer :: i
+ double precision, allocatable :: inv_overlap_times_integrals(:,:)
+ allocate(inv_overlap_times_integrals(ao_num,ao_num))
+ ! Using the provider ao_one_e_integrals_from_mo = [SC h {SC}^+]
+ call get_AB_prod(ao_one_e_integrals_from_mo,ao_num,ao_num,s_inv,ao_num,inv_overlap_times_integrals)
+ ! inv_overlap_times_integrals = [SC h {SC}^+] S^{-1}
+ trace_ao_one_e_ints_from_mo = 0.d0
+ ! Computing the trace
+ do i = 1, ao_num
+ trace_ao_one_e_ints_from_mo += inv_overlap_times_integrals(i,i)
+ enddo
+END_PROVIDER
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!! Additional providers to check some stuffs !!!!!!!!!!!!!!!!!!!!!!!!!
+
+BEGIN_PROVIDER [ double precision, ao_one_e_int_no_ov_from_mo, (ao_num, ao_num) ]
+ BEGIN_DOC
+ ! ao_one_e_int_no_ov_from_mo = C mo_one_e_integrals C^T
+ !
+ ! WARNING : NON EQUAL TO ao_one_e_integrals due to the non orthogonality
+ END_DOC
+ call mo_to_ao_no_overlap(mo_one_e_integrals,mo_num,ao_one_e_int_no_ov_from_mo,ao_num)
+END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, ao_one_e_int_no_ov_from_mo_ov_ov, (ao_num, ao_num)]
+ BEGIN_DOC
+ ! ao_one_e_int_no_ov_from_mo_ov_ov = S ao_one_e_int_no_ov_from_mo S = SC mo_one_e_integrals (SC)^T
+ !
+ ! EQUAL TO ao_one_e_integrals ONLY IF ao_num = mo_num
+ END_DOC
+ double precision, allocatable :: tmp(:,:)
+ allocate(tmp(ao_num, ao_num))
+ call get_AB_prod(ao_overlap,ao_num,ao_num,ao_one_e_int_no_ov_from_mo,ao_num,tmp)
+ call get_AB_prod(tmp,ao_num,ao_num,ao_overlap,ao_num,ao_one_e_int_no_ov_from_mo_ov_ov)
+END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, c_t_s_c, (mo_num, mo_num)]
+ implicit none
+ BEGIN_DOC
+! C^T S C = should be the identity
+ END_DOC
+ call get_AB_prod(mo_coef_transp,mo_num,ao_num,S_mo_coef,mo_num,c_t_s_c)
+END_PROVIDER
+
diff --git a/plugins/local/tuto_plugins/tuto_I/tuto_I.rst b/plugins/local/tuto_plugins/tuto_I/tuto_I.rst
new file mode 100644
index 00000000..43b4af0b
--- /dev/null
+++ b/plugins/local/tuto_plugins/tuto_I/tuto_I.rst
@@ -0,0 +1,218 @@
+=============================================
+Tuto I: One- and two-e integrals (20 minutes)
+=============================================
+
+Requirements
+------------
+1) You know how to create an |EZFIO| file and run calculations with |QP| (check the tuto: ``_),
+
+2) You have an |EZFIO| file with MOs created (with the :ref:`scf` executable for instance). As we are going to print out some integrals, don't take a too large system/basis (Ex: H2, cc-pVDZ is ok :)
+
+3) You made an qp set_file YOUR_EZFIO_FILE_FOR_H2 in order to work on that ezfio folder.
+
+4) You have READ the :file:`qp2/plugins/README.rst` file to HAVE THE **VOCABULARY**.
+
+Our goals:
+----------
+We want to create a plugin to do the following things:
+ 1) print out one- and two-electron integrals on the AO/MO basis,
+
+ 2) creates two providers which manipulate these objects,
+
+ 3) print out these providers.
+
+I) Getting started: creating the plugin
+---------------------------------------
+We will go step-by-step through these plugins.
+
+We will create a plugin named "plugin_I", and its location will be in "tuto_plugins".
+Therefore to create the plugin, we do:
+
+.. code:: bash
+
+ qp plugins create -n plugin_I -r tuto_plugins
+
+Then do an "ls" in qp2/plugins/tuto_plugins/ and you will find a directory called "plugin_I".
+
+In that directory you will find:
+
+1) a :file:`NEED` file that will eventually contain all the other modules/plugins needed by our "plugin_I",
+
+2) a :file:`README.rst` file that you can and **SHOULD** modify in order to **DOCUMENT** what is doing the plugin,
+
+3) a :file:`plugin_I.irp.f` file that is a program to be compiled and just printing "Hello world"
+
+II) Specifying the dependencies
+-------------------------------
+The next step is to know what are the other modules/plugins that we need to do what we want.
+We need here
+
+a) the one-electron integrals on the AO basis, which are computed in :file:`qp2/src/ao_one_e_ints/`
+
+b) the one-electron integrals on the MO basis, which are computed in :file:`qp2/src/mo_one_e_ints/`
+
+c) the two-electron integrals on the AO basis, which are computed in :file:`qp2/src/ao_two_e_ints/`
+
+d) the two-electron integrals on the MO basis, which are computed in :file:`qp2/src/mo_two_e_ints/`
+
+Therefore, we will need the following four modules:
+
+ a) ao_one_e_ints
+ b) mo_one_e_ints
+ c) ao_two_e_ints
+ d) mo_two_e_ints
+
+You can then create the following "NEED" file by executing the following command
+
+.. code:: bash
+
+ cat < NEED
+ ao_one_e_ints
+ mo_one_e_ints
+ ao_two_e_ints
+ mo_two_e_ints
+ EOF
+
+II) Installing the plugin
+-------------------------
+Now that we have specified the various depenencies we need now to INSTALL the plugin, which means to create the equivalent of a Makefile for the compilation.
+
+To do it we simply do
+
+.. code:: bash
+
+ qp plugins install plugin_I
+
+
+III) Compiling the void plugin
+------------------------------
+It is customary to compile first your "void" plugin, void in the sense that it does not contain anything else than the program printing "Hello world".
+
+To do so, just go in the plugin and execute the following command
+
+.. code:: bash
+
+ ninja
+
+It does a lot of stuffs, but it must conclude with something like
+
+.. code:: bash
+
+ make: Leaving directory 'SOME_PATH_TOWARD_YOUR_QP2_DIRECTORY/qp2/ocaml'
+
+
+Since that it has compiled, an executable "plugin_I" has been created.
+
+Also, if you make "ls" in the "plugin_I" you will notice that many symbolink links have been created, and among which the four modules that you included in the NEED file.
+
+All the other modules (Ex::ref:`module_ao_basis`, :ref:`module_utils`) are here because they are need by some of the four modules that you need.
+The variables that we need are
+
+:data:`ao_one_e_integrals`
+
+:data:`mo_one_e_integrals`
+
+You can check them with
+
+.. code:: bash
+
+ irpman ao_one_e_integrals
+
+
+.. code:: bash
+
+ irpman mo_one_e_integrals
+
+in order to get some information on where they are created, and many more information.
+We will now create an executable such that it prints out the integrals.
+
+
+IV) Printing out the one-electron integrals
+--------------------------------------------
+We will now create a program that will print out the one-electron integrals on the AO and MO basis.
+
+You can then copy the file :file:`qp2/plugins/tuto_plugins/tuto_I/print_one_e_h.irp.f` in your plugin.
+
+In this file you will see that we simply browse the two arrays :data:`ao_one_e_integrals` and :data:`mo_one_e_integrals`, which are the providers and we browse them until either :data:`ao_num` or :data:`mo_num` which are also providers representing the number of AOs or MOs.
+
+
+.. seealso::
+
+ You can check these variables with :command:`irpman` !
+
+If you recompile using |ninja| as before, and another executable has been created "print_one_e_h".
+Then, you can run the program on the ezfio file by doing
+
+.. code:: bash
+
+ qp run print_one_e_h
+
+and will print out the data you need :)
+
+By the way, as the file :file:`plugin_I.irp.f` contains nothing but a "Hello world" print, you can simply remove it if you want.
+
+V) Printing out the two-electron integrals
+------------------------------------------
+We will now create a file that prints out the two-electron integrals in the AO and MO basis.
+These can be accessed with the following subroutines :
+
+1- :c:func:`get_ao_two_e_integral` for the AO basis
+
+2- :c:func:`get_two_e_integral` for the MO basis
+
+
+.. seealso::
+
+ check them with irpman !
+
+To print the two-electron integrals, you can copy the file :file:`qp2/plugins/tuto_plugins/tuto_I/print_two_e_h.irp.f` in your plugin and recompile with |ninja|.
+Then just run the program
+
+.. code:: bash
+
+ qp run print_two_e_h
+
+and it will print all the things you want :)
+
+VI) Creating new providers and a program to print them
+------------------------------------------------------
+We will now create new providers that manipulates the objects that we just printed.
+As an example, we will compute the trace of the one electron integrals in the AO and MO basis.
+In the file :file:`qp2/plugins/tuto_plugins/tuto_I/traces_one_e.irp.f` you will find the several new providers among which
+
+ 1- :c:data:`trace_mo_one_e_ints` : simply the sum of the diagonal matrix element of the one-electron integrals
+
+ 2- :c:data:`trace_ao_one_e_ints` : the corresponding trace on the AO basis
+ .. math::
+
+ \text{Tr}({\bf h}{\bf S}^{-1}) = \sum_{m,n} S^{-1}_{mn} h_{mn}
+
+
+ 3- :c:data:`trace_ao_one_e_ints_from_mo` : the trace on the AO basis with the integrals obtained first from the MO basis
+ .. math::
+
+ \text{Tr}({\bf \tilde{h}}{\bf S}^{-1}) = \text{Tr}\big({\bf SC h}({\bf SC }^T){\bf S}^{-1}\big)
+
+Just copy the :file:`qp2/plugins/tuto_plugins/tuto_I/traces_one_e.irp.f` in your plugin and recompile.
+
+.. seealso::
+
+ Once it has compiled, check your new providers with :command:`irpman` !
+
+As explained in the files :file:`qp2/plugins/tuto_plugins/tuto_I/traces_one_e.irp.f` and :file:`qp2/plugins/tuto_plugins/tuto_I/print_traces_on_e.irp.f`, :c:data:`trace_mo_one_e_ints` is equal to :c:data:`trace_ao_one_e_ints` only if the number of AO basis functions is equal to the number of MO basis functions, which means if you work with cartesian functions.
+
+
+.. seealso::
+
+ You can check with :command:`qp create_ezfio -h` for the option to create an |EZFIO| with cartesian basis functions
+
+In the file :file:`qp2/plugins/tuto_plugins/tuto_I/print_traces_on_e.irp.f` you will find an example of executable that prints out the various providers.
+Copy these two files in your plugin and recompile to execute it.
+
+Execute the program print_traces_on_e and check for the results with
+
+.. code:: bash
+
+ qp run print_traces_on_e
+
+The code in :file:`qp2/plugins/tuto_plugins/tuto_I/print_traces_on_e.irp.f` should be easy to read, I let the reader interpret it.
diff --git a/scripts/compilation/qp_create_ninja b/scripts/compilation/qp_create_ninja
index e67d896b..75b50c82 100755
--- a/scripts/compilation/qp_create_ninja
+++ b/scripts/compilation/qp_create_ninja
@@ -802,8 +802,12 @@ if __name__ == "__main__":
pickle_path = os.path.join(QP_ROOT, "config", "qp_create_ninja.pickle")
if arguments["update"]:
+ try:
with open(pickle_path, 'rb') as handle:
arguments = pickle.load(handle)
+ except FileNotFoundError:
+ print("\n-----\nError: Please run 'configure -c config/'\n-----\n")
+ raise
elif arguments["create"]:
diff --git a/scripts/ezfio_interface/qp_edit_template b/scripts/ezfio_interface/qp_edit_template
index fe718a50..2380660e 100644
--- a/scripts/ezfio_interface/qp_edit_template
+++ b/scripts/ezfio_interface/qp_edit_template
@@ -8,14 +8,14 @@ open Sexplib.Std
(** Interactive editing of the input.
-WARNING
+WARNING
This file is automatically generated by
`${{QP_ROOT}}/scripts/ezfio_interface/ei_handler.py`
*)
(** Keywords used to define input sections *)
-type keyword =
+type keyword =
| Ao_basis
| Determinants_by_hand
| Electrons
@@ -37,7 +37,7 @@ let keyword_to_string = function
(** Create the header of the temporary file *)
-let file_header filename =
+let file_header filename =
Printf.sprintf "
==================================================================
Quantum Package
@@ -47,7 +47,7 @@ Editing file `%s`
" filename
-
+
(** Creates the header of a section *)
let make_header kw =
@@ -58,14 +58,14 @@ let make_header kw =
(** Returns the rst string of section [s] *)
-let get s =
+let get s =
let header = (make_header s) in
- let f (read,to_rst) =
+ let f (read,to_rst) =
match read () with
| Some text -> header ^ (Rst_string.to_string (to_rst text))
| None -> ""
in
- let rst =
+ let rst =
try
begin
let open Input in
@@ -84,27 +84,27 @@ let get s =
end
with
| Sys_error msg -> (Printf.eprintf "Info: %s\n%!" msg ; "")
- in
+ in
rst
(** Applies the changes from the string [str] corresponding to section [s] *)
-let set str s =
+let set str s =
let header = (make_header s) in
match String_ext.substr_index ~pos:0 ~pattern:header str with
| None -> ()
- | Some idx ->
+ | Some idx ->
begin
let index_begin = idx + (String.length header) in
- let index_end =
+ let index_end =
match ( String_ext.substr_index ~pos:(index_begin+(String.length header)+1)
~pattern:"==" str) with
| Some i -> i
| None -> String.length str
in
let l = index_end - index_begin in
- let str = String.sub str index_begin l
+ let str = String.sub str index_begin l
|> Rst_string.of_string
in
let write (of_rst,w) s =
@@ -129,29 +129,37 @@ let set str s =
(** Creates the temporary file for interactive editing *)
-let create_temp_file ezfio_filename fields =
- let temp_filename = Filename.temp_file "qp_edit_" ".rst" in
+let create_temp_file ?filename ezfio_filename fields =
+ let temp_filename =
+ match filename with
+ | None -> Filename.temp_file "qp_edit_" ".rst"
+ | Some f -> f
+ in
+ let () =
+ match filename with
+ | None -> at_exit (fun () -> Sys.remove temp_filename)
+ | _ -> ()
+ in
begin
let oc = open_out temp_filename in
- (file_header ezfio_filename) :: (List.map get fields)
- |> String.concat "\n"
+ (file_header ezfio_filename) :: (List.map get fields)
+ |> String.concat "\n"
|> Printf.fprintf oc "%s";
close_out oc;
- at_exit (fun () -> Sys.remove temp_filename);
temp_filename
end
-
-let run check_only ?ndet ?state ezfio_filename =
+
+let run check_only ?ndet ?state ?read ?write ezfio_filename =
(* Set check_only if the arguments are not empty *)
- let check_only =
- match ndet, state with
- | None, None -> check_only
- | _ -> true
+ let open_editor =
+ match ndet, state, read, write with
+ | None, None, None, None -> not check_only
+ | _ -> false
in
(* Open EZFIO *)
@@ -163,7 +171,7 @@ let run check_only ?ndet ?state ezfio_filename =
(* Clean qp_stop status *)
[ "qpstop" ; "qpkill" ]
|> List.iter (fun f ->
- let stopfile =
+ let stopfile =
Filename.concat (Qpackage.ezfio_work ezfio_filename) f
in
if Sys.file_exists stopfile then
@@ -173,7 +181,7 @@ let run check_only ?ndet ?state ezfio_filename =
(* Reorder basis set *)
begin
match Input.Ao_basis.read() with
- | Some aos ->
+ | Some aos ->
let ordering = Input.Ao_basis.ordering aos in
let test = Array.copy ordering in
Array.sort compare test ;
@@ -184,7 +192,7 @@ let run check_only ?ndet ?state ezfio_filename =
Input.Ao_basis.write new_aos;
match Input.Mo_basis.read() with
| None -> ()
- | Some mos ->
+ | Some mos ->
let new_mos = Input.Mo_basis.reorder mos ordering in
Input.Mo_basis.write new_mos
end
@@ -200,7 +208,7 @@ let run check_only ?ndet ?state ezfio_filename =
begin
match state with
| None -> ()
- | Some range ->
+ | Some range ->
begin
Input.Determinants_by_hand.extract_states range
end
@@ -210,14 +218,14 @@ let run check_only ?ndet ?state ezfio_filename =
(*
let output = (file_header ezfio_filename) :: (
List.map get [
- Ao_basis ;
- Mo_basis ;
+ Ao_basis ;
+ Mo_basis ;
])
in
String.concat output
|> print_string
*)
-
+
let tasks = [
Nuclei_by_hand ;
Ao_basis;
@@ -230,33 +238,37 @@ let run check_only ?ndet ?state ezfio_filename =
(* Create the temp file *)
let temp_filename =
- create_temp_file ezfio_filename tasks
+ match read, write with
+ | None, None -> create_temp_file ezfio_filename tasks
+ | Some filename, None -> filename
+ | None, filename -> create_temp_file ?filename ezfio_filename tasks
+ | x, y -> failwith "read and write options are incompatible"
in
- (* Open the temp file with external editor *)
- let editor =
- try Sys.getenv "EDITOR"
- with Not_found -> "vi"
- in
- match check_only with
- | true -> ()
- | false ->
- Printf.sprintf "%s %s" editor temp_filename
- |> Sys.command |> ignore
- ;
+ if open_editor then
+ begin
+ (* Open the temp file with external editor *)
+ let editor =
+ try Sys.getenv "EDITOR"
+ with Not_found -> "vi"
+ in
+ Printf.sprintf "%s %s" editor temp_filename
+ |> Sys.command |> ignore
+ end;
- (* Re-read the temp file *)
- let temp_string =
- let ic = open_in temp_filename in
- let result =
- input_lines ic
- |> String.concat "\n"
+ if write = None then
+ (* Re-read the temp file *)
+ let temp_string =
+ let ic = open_in temp_filename in
+ let result =
+ input_lines ic
+ |> String.concat "\n"
+ in
+ close_in ic;
+ result
in
- close_in ic;
- result
- in
- List.iter (fun x -> set temp_string x) tasks
+ List.iter (fun x -> set temp_string x) tasks
@@ -264,7 +276,7 @@ let run check_only ?ndet ?state ezfio_filename =
(** Remove the backup file *)
let remove_backup ezfio_filename =
- let backup_filename =
+ let backup_filename =
Printf.sprintf "%s/work/backup.tar" ezfio_filename
in
try Sys.remove backup_filename
@@ -273,7 +285,7 @@ let remove_backup ezfio_filename =
(** Create a backup file in case of an exception *)
let create_backup ezfio_filename =
remove_backup ezfio_filename;
- let backup_filename =
+ let backup_filename =
Printf.sprintf "%s/work/backup.tar" ezfio_filename
in
try
@@ -289,7 +301,7 @@ let create_backup ezfio_filename =
(** Restore the backup file when an exception occuprs *)
let restore_backup ezfio_filename =
- let filename =
+ let filename =
Printf.sprintf "%s/work/backup.tar" ezfio_filename
in
if Sys.file_exists filename then
@@ -312,6 +324,16 @@ let () =
doc="Checks the input data";
arg=Without_arg; }};
+ {{
+ short='w'; long="write"; opt=Optional;
+ doc="Writes the qp_edit file to a file\"";
+ arg=With_arg ""; }};
+
+ {{
+ short='r'; long="read"; opt=Optional;
+ doc="Reads the file and applies it to the EZFIO\"";
+ arg=With_arg ""; }};
+
{{ short='n'; long="ndet"; opt=Optional;
doc="Truncates the wavefunction to the target number of determinants";
arg=With_arg ""; }};
@@ -328,6 +350,12 @@ let () =
end;
(* Handle options *)
+ let write =
+ Command_line.get "write"
+ in
+ let read =
+ Command_line.get "read"
+ in
let ndet =
match Command_line.get "ndet" with
| None -> None
@@ -353,7 +381,7 @@ let () =
(* Run the program *)
try
if (not c) then create_backup ezfio_filename;
- run c ?ndet ?state ezfio_filename
+ run c ?ndet ?state ?read ?write ezfio_filename
with
| Failure exc
| Invalid_argument exc ->
diff --git a/src/ao_basis/aos_in_r.irp.f b/src/ao_basis/aos_in_r.irp.f
index 1b1595a3..053c86a2 100644
--- a/src/ao_basis/aos_in_r.irp.f
+++ b/src/ao_basis/aos_in_r.irp.f
@@ -1,67 +1,76 @@
-double precision function ao_value(i,r)
- implicit none
- BEGIN_DOC
-! Returns the value of the i-th ao at point $\textbf{r}$
- END_DOC
- double precision, intent(in) :: r(3)
- integer, intent(in) :: i
- integer :: m,num_ao
- double precision :: center_ao(3)
- double precision :: beta
- integer :: power_ao(3)
- double precision :: accu,dx,dy,dz,r2
- num_ao = ao_nucl(i)
- power_ao(1:3)= ao_power(i,1:3)
- center_ao(1:3) = nucl_coord(num_ao,1:3)
- dx = (r(1) - center_ao(1))
- dy = (r(2) - center_ao(2))
- dz = (r(3) - center_ao(3))
- r2 = dx*dx + dy*dy + dz*dz
- dx = dx**power_ao(1)
- dy = dy**power_ao(2)
- dz = dz**power_ao(3)
+! ---
- accu = 0.d0
- do m=1,ao_prim_num(i)
- beta = ao_expo_ordered_transp(m,i)
- accu += ao_coef_normalized_ordered_transp(m,i) * dexp(-beta*r2)
- enddo
- ao_value = accu * dx * dy * dz
+double precision function ao_value(i, r)
+
+ BEGIN_DOC
+ ! Returns the value of the i-th ao at point $\textbf{r}$
+ END_DOC
+
+ implicit none
+ integer, intent(in) :: i
+ double precision, intent(in) :: r(3)
+
+ integer :: m, num_ao
+ integer :: power_ao(3)
+ double precision :: center_ao(3)
+ double precision :: beta
+ double precision :: accu, dx, dy, dz, r2
+
+ num_ao = ao_nucl(i)
+ power_ao(1:3) = ao_power(i,1:3)
+ center_ao(1:3) = nucl_coord(num_ao,1:3)
+ dx = r(1) - center_ao(1)
+ dy = r(2) - center_ao(2)
+ dz = r(3) - center_ao(3)
+ r2 = dx*dx + dy*dy + dz*dz
+ dx = dx**power_ao(1)
+ dy = dy**power_ao(2)
+ dz = dz**power_ao(3)
+
+ accu = 0.d0
+ do m = 1, ao_prim_num(i)
+ beta = ao_expo_ordered_transp(m,i)
+ accu += ao_coef_normalized_ordered_transp(m,i) * dexp(-beta*r2)
+ enddo
+ ao_value = accu * dx * dy * dz
end
-double precision function primitive_value(i,j,r)
- implicit none
- BEGIN_DOC
-! Returns the value of the j-th primitive of the i-th |AO| at point $\textbf{r}
-! **without the coefficient**
- END_DOC
- double precision, intent(in) :: r(3)
- integer, intent(in) :: i,j
+double precision function primitive_value(i, j, r)
- integer :: m,num_ao
- double precision :: center_ao(3)
- double precision :: beta
- integer :: power_ao(3)
- double precision :: accu,dx,dy,dz,r2
- num_ao = ao_nucl(i)
- power_ao(1:3)= ao_power(i,1:3)
- center_ao(1:3) = nucl_coord(num_ao,1:3)
- dx = (r(1) - center_ao(1))
- dy = (r(2) - center_ao(2))
- dz = (r(3) - center_ao(3))
- r2 = dx*dx + dy*dy + dz*dz
- dx = dx**power_ao(1)
- dy = dy**power_ao(2)
- dz = dz**power_ao(3)
+ BEGIN_DOC
+ ! Returns the value of the j-th primitive of the i-th |AO| at point $\textbf{r}
+ ! **without the coefficient**
+ END_DOC
- accu = 0.d0
- m=j
- beta = ao_expo_ordered_transp(m,i)
- accu += dexp(-beta*r2)
- primitive_value = accu * dx * dy * dz
+ implicit none
+ integer, intent(in) :: i, j
+ double precision, intent(in) :: r(3)
+
+ integer :: m, num_ao
+ integer :: power_ao(3)
+ double precision :: center_ao(3)
+ double precision :: beta
+ double precision :: accu, dx, dy, dz, r2
+
+ num_ao = ao_nucl(i)
+ power_ao(1:3)= ao_power(i,1:3)
+ center_ao(1:3) = nucl_coord(num_ao,1:3)
+ dx = r(1) - center_ao(1)
+ dy = r(2) - center_ao(2)
+ dz = r(3) - center_ao(3)
+ r2 = dx*dx + dy*dy + dz*dz
+ dx = dx**power_ao(1)
+ dy = dy**power_ao(2)
+ dz = dz**power_ao(3)
+
+ accu = 0.d0
+ m = j
+ beta = ao_expo_ordered_transp(m,i)
+ accu += dexp(-beta*r2)
+ primitive_value = accu * dx * dy * dz
end
@@ -104,9 +113,9 @@ subroutine give_all_aos_at_r(r, tmp_array)
dz2 = dz**p_ao(3)
tmp_array(k) = 0.d0
- do l = 1,ao_prim_num(k)
+ do l = 1, ao_prim_num(k)
beta = ao_expo_ordered_transp_per_nucl(l,j,i)
- if(dabs(beta*r2).gt.40.d0) cycle
+ if(beta*r2.gt.50.d0) cycle
tmp_array(k) += ao_coef_normalized_ordered_transp_per_nucl(l,j,i) * dexp(-beta*r2)
enddo
@@ -120,207 +129,232 @@ end
! ---
-subroutine give_all_aos_and_grad_at_r(r,aos_array,aos_grad_array)
- implicit none
- BEGIN_DOC
-! input : r(1) ==> r(1) = x, r(2) = y, r(3) = z
-!
-! output :
-!
-! * aos_array(i) = ao(i) evaluated at ro
-! * aos_grad_array(1,i) = gradient X of the ao(i) evaluated at $\textbf{r}$
-!
- END_DOC
- double precision, intent(in) :: r(3)
- double precision, intent(out) :: aos_array(ao_num)
- double precision, intent(out) :: aos_grad_array(3,ao_num)
+subroutine give_all_aos_and_grad_at_r(r, aos_array, aos_grad_array)
- integer :: power_ao(3)
- integer :: i,j,k,l,m
- double precision :: dx,dy,dz,r2
- double precision :: dx2,dy2,dz2
- double precision :: dx1,dy1,dz1
- double precision :: center_ao(3)
- double precision :: beta,accu_1,accu_2,contrib
- do i = 1, nucl_num
- center_ao(1:3) = nucl_coord(i,1:3)
- dx = (r(1) - center_ao(1))
- dy = (r(2) - center_ao(2))
- dz = (r(3) - center_ao(3))
- r2 = dx*dx + dy*dy + dz*dz
- do j = 1,Nucl_N_Aos(i)
- k = Nucl_Aos_transposed(j,i) ! index of the ao in the ordered format
- aos_array(k) = 0.d0
- aos_grad_array(1,k) = 0.d0
- aos_grad_array(2,k) = 0.d0
- aos_grad_array(3,k) = 0.d0
- power_ao(1:3)= ao_power_ordered_transp_per_nucl(1:3,j,i)
- dx2 = dx**power_ao(1)
- dy2 = dy**power_ao(2)
- dz2 = dz**power_ao(3)
- if(power_ao(1) .ne. 0)then
- dx1 = dble(power_ao(1)) * dx**(power_ao(1)-1)
- else
- dx1 = 0.d0
- endif
- if(power_ao(2) .ne. 0)then
- dy1 = dble(power_ao(2)) * dy**(power_ao(2)-1)
- else
- dy1 = 0.d0
- endif
- if(power_ao(3) .ne. 0)then
- dz1 = dble(power_ao(3)) * dz**(power_ao(3)-1)
- else
- dz1 = 0.d0
- endif
- accu_1 = 0.d0
- accu_2 = 0.d0
- do l = 1,ao_prim_num(k)
- beta = ao_expo_ordered_transp_per_nucl(l,j,i)
- contrib = 0.d0
- if(beta*r2.gt.50.d0)cycle
- contrib = ao_coef_normalized_ordered_transp_per_nucl(l,j,i) * dexp(-beta*r2)
- accu_1 += contrib
- accu_2 += contrib * beta
- enddo
- aos_array(k) = accu_1 * dx2 * dy2 * dz2
- aos_grad_array(1,k) = accu_1 * dx1 * dy2 * dz2- 2.d0 * dx2 * dx * dy2 * dz2 * accu_2
- aos_grad_array(2,k) = accu_1 * dx2 * dy1 * dz2- 2.d0 * dx2 * dy2 * dy * dz2 * accu_2
- aos_grad_array(3,k) = accu_1 * dx2 * dy2 * dz1- 2.d0 * dx2 * dy2 * dz2 * dz * accu_2
+ BEGIN_DOC
+ !
+ ! input : r(1) ==> r(1) = x, r(2) = y, r(3) = z
+ !
+ ! output :
+ !
+ ! * aos_array(i) = ao(i) evaluated at ro
+ ! * aos_grad_array(1,i) = gradient X of the ao(i) evaluated at $\textbf{r}$
+ !
+ END_DOC
+
+ implicit none
+ double precision, intent(in) :: r(3)
+ double precision, intent(out) :: aos_array(ao_num)
+ double precision, intent(out) :: aos_grad_array(3,ao_num)
+
+ integer :: power_ao(3)
+ integer :: i, j, k, l, m
+ double precision :: dx, dy, dz, r2
+ double precision :: dx1, dy1, dz1
+ double precision :: dx2, dy2, dz2
+ double precision :: center_ao(3)
+ double precision :: beta, accu_1, accu_2, contrib
+
+ do i = 1, nucl_num
+
+ center_ao(1:3) = nucl_coord(i,1:3)
+
+ dx = r(1) - center_ao(1)
+ dy = r(2) - center_ao(2)
+ dz = r(3) - center_ao(3)
+ r2 = dx*dx + dy*dy + dz*dz
+
+ do j = 1, Nucl_N_Aos(i)
+
+ k = Nucl_Aos_transposed(j,i) ! index of the ao in the ordered format
+
+ aos_array(k) = 0.d0
+ aos_grad_array(1,k) = 0.d0
+ aos_grad_array(2,k) = 0.d0
+ aos_grad_array(3,k) = 0.d0
+
+ power_ao(1:3) = ao_power_ordered_transp_per_nucl(1:3,j,i)
+ dx2 = dx**power_ao(1)
+ dy2 = dy**power_ao(2)
+ dz2 = dz**power_ao(3)
+
+ dx1 = 0.d0
+ if(power_ao(1) .ne. 0) then
+ dx1 = dble(power_ao(1)) * dx**(power_ao(1)-1)
+ endif
+
+ dy1 = 0.d0
+ if(power_ao(2) .ne. 0) then
+ dy1 = dble(power_ao(2)) * dy**(power_ao(2)-1)
+ endif
+
+ dz1 = 0.d0
+ if(power_ao(3) .ne. 0) then
+ dz1 = dble(power_ao(3)) * dz**(power_ao(3)-1)
+ endif
+
+ accu_1 = 0.d0
+ accu_2 = 0.d0
+ do l = 1, ao_prim_num(k)
+ beta = ao_expo_ordered_transp_per_nucl(l,j,i)
+ if(beta*r2.gt.50.d0) cycle
+ contrib = ao_coef_normalized_ordered_transp_per_nucl(l,j,i) * dexp(-beta*r2)
+ accu_1 += contrib
+ accu_2 += contrib * beta
+ enddo
+
+ aos_array(k) = accu_1 * dx2 * dy2 * dz2
+ aos_grad_array(1,k) = accu_1 * dx1 * dy2 * dz2 - 2.d0 * dx2 * dx * dy2 * dz2 * accu_2
+ aos_grad_array(2,k) = accu_1 * dx2 * dy1 * dz2 - 2.d0 * dx2 * dy2 * dy * dz2 * accu_2
+ aos_grad_array(3,k) = accu_1 * dx2 * dy2 * dz1 - 2.d0 * dx2 * dy2 * dz2 * dz * accu_2
+ enddo
enddo
- enddo
+
end
+! ---
-subroutine give_all_aos_and_grad_and_lapl_at_r(r,aos_array,aos_grad_array,aos_lapl_array)
- implicit none
- BEGIN_DOC
-! input : r(1) ==> r(1) = x, r(2) = y, r(3) = z
-!
-! output :
-!
-! * aos_array(i) = ao(i) evaluated at $\textbf{r}$
-! * aos_grad_array(1,i) = $\nabla_x$ of the ao(i) evaluated at $\textbf{r}$
- END_DOC
- double precision, intent(in) :: r(3)
- double precision, intent(out) :: aos_array(ao_num)
- double precision, intent(out) :: aos_grad_array(3,ao_num)
- double precision, intent(out) :: aos_lapl_array(3,ao_num)
+subroutine give_all_aos_and_grad_and_lapl_at_r(r, aos_array, aos_grad_array, aos_lapl_array)
- integer :: power_ao(3)
- integer :: i,j,k,l,m
- double precision :: dx,dy,dz,r2
- double precision :: dx2,dy2,dz2
- double precision :: dx1,dy1,dz1
- double precision :: dx3,dy3,dz3
- double precision :: dx4,dy4,dz4
- double precision :: dx5,dy5,dz5
- double precision :: center_ao(3)
- double precision :: beta,accu_1,accu_2,accu_3,contrib
- do i = 1, nucl_num
- center_ao(1:3) = nucl_coord(i,1:3)
- dx = (r(1) - center_ao(1))
- dy = (r(2) - center_ao(2))
- dz = (r(3) - center_ao(3))
- r2 = dx*dx + dy*dy + dz*dz
- do j = 1,Nucl_N_Aos(i)
- k = Nucl_Aos_transposed(j,i) ! index of the ao in the ordered format
- aos_array(k) = 0.d0
- aos_grad_array(1,k) = 0.d0
- aos_grad_array(2,k) = 0.d0
- aos_grad_array(3,k) = 0.d0
+ BEGIN_DOC
+ !
+ ! input : r(1) ==> r(1) = x, r(2) = y, r(3) = z
+ !
+ ! output :
+ !
+ ! * aos_array(i) = ao(i) evaluated at $\textbf{r}$
+ ! * aos_grad_array(1,i) = $\nabla_x$ of the ao(i) evaluated at $\textbf{r}$
+ !
+ END_DOC
- aos_lapl_array(1,k) = 0.d0
- aos_lapl_array(2,k) = 0.d0
- aos_lapl_array(3,k) = 0.d0
+ implicit none
+ double precision, intent(in) :: r(3)
+ double precision, intent(out) :: aos_array(ao_num)
+ double precision, intent(out) :: aos_grad_array(3,ao_num)
+ double precision, intent(out) :: aos_lapl_array(3,ao_num)
- power_ao(1:3)= ao_power_ordered_transp_per_nucl(1:3,j,i)
- dx2 = dx**power_ao(1)
- dy2 = dy**power_ao(2)
- dz2 = dz**power_ao(3)
- if(power_ao(1) .ne. 0)then
- dx1 = dble(power_ao(1)) * dx**(power_ao(1)-1)
- else
- dx1 = 0.d0
- endif
- ! For the Laplacian
- if(power_ao(1) .ge. 2)then
- dx3 = dble(power_ao(1)) * dble((power_ao(1)-1)) * dx**(power_ao(1)-2)
- else
- dx3 = 0.d0
- endif
- if(power_ao(1) .ge. 1)then
- dx4 = dble((2 * power_ao(1) + 1)) * dx**(power_ao(1))
- else
- dx4 = dble((power_ao(1) + 1)) * dx**(power_ao(1))
- endif
+ integer :: power_ao(3)
+ integer :: i, j, k, l, m
+ double precision :: dx, dy, dz, r2
+ double precision :: dx1, dy1, dz1
+ double precision :: dx2, dy2, dz2
+ double precision :: dx3, dy3, dz3
+ double precision :: dx4, dy4, dz4
+ double precision :: dx5, dy5, dz5
+ double precision :: center_ao(3)
+ double precision :: beta, accu_1, accu_2, accu_3, contrib
- dx5 = dx**(power_ao(1)+2)
+ do i = 1, nucl_num
- if(power_ao(2) .ne. 0)then
- dy1 = dble(power_ao(2)) * dy**(power_ao(2)-1)
- else
- dy1 = 0.d0
- endif
- ! For the Laplacian
- if(power_ao(2) .ge. 2)then
- dy3 = dble(power_ao(2)) * dble((power_ao(2)-1)) * dy**(power_ao(2)-2)
- else
- dy3 = 0.d0
- endif
+ center_ao(1:3) = nucl_coord(i,1:3)
- if(power_ao(2) .ge. 1)then
- dy4 = dble((2 * power_ao(2) + 1)) * dy**(power_ao(2))
- else
- dy4 = dble((power_ao(2) + 1)) * dy**(power_ao(2))
- endif
+ dx = r(1) - center_ao(1)
+ dy = r(2) - center_ao(2)
+ dz = r(3) - center_ao(3)
+ r2 = dx*dx + dy*dy + dz*dz
+
+ do j = 1, Nucl_N_Aos(i)
- dy5 = dy**(power_ao(2)+2)
+ k = Nucl_Aos_transposed(j,i) ! index of the ao in the ordered format
+ aos_array(k) = 0.d0
+ aos_grad_array(1,k) = 0.d0
+ aos_grad_array(2,k) = 0.d0
+ aos_grad_array(3,k) = 0.d0
+ aos_lapl_array(1,k) = 0.d0
+ aos_lapl_array(2,k) = 0.d0
+ aos_lapl_array(3,k) = 0.d0
+
+ power_ao(1:3)= ao_power_ordered_transp_per_nucl(1:3,j,i)
+ dx2 = dx**power_ao(1)
+ dy2 = dy**power_ao(2)
+ dz2 = dz**power_ao(3)
- if(power_ao(3) .ne. 0)then
- dz1 = dble(power_ao(3)) * dz**(power_ao(3)-1)
- else
- dz1 = 0.d0
- endif
- ! For the Laplacian
- if(power_ao(3) .ge. 2)then
- dz3 = dble(power_ao(3)) * dble((power_ao(3)-1)) * dz**(power_ao(3)-2)
- else
- dz3 = 0.d0
- endif
+ ! ---
- if(power_ao(3) .ge. 1)then
- dz4 = dble((2 * power_ao(3) + 1)) * dz**(power_ao(3))
- else
- dz4 = dble((power_ao(3) + 1)) * dz**(power_ao(3))
- endif
+ dx1 = 0.d0
+ if(power_ao(1) .ne. 0) then
+ dx1 = dble(power_ao(1)) * dx**(power_ao(1)-1)
+ endif
- dz5 = dz**(power_ao(3)+2)
+ dx3 = 0.d0
+ if(power_ao(1) .ge. 2) then
+ dx3 = dble(power_ao(1)) * dble((power_ao(1)-1)) * dx**(power_ao(1)-2)
+ endif
+ if(power_ao(1) .ge. 1) then
+ dx4 = dble((2 * power_ao(1) + 1)) * dx**(power_ao(1))
+ else
+ dx4 = dble((power_ao(1) + 1)) * dx**(power_ao(1))
+ endif
+
+ dx5 = dx**(power_ao(1)+2)
+
+ ! ---
+
+ dy1 = 0.d0
+ if(power_ao(2) .ne. 0) then
+ dy1 = dble(power_ao(2)) * dy**(power_ao(2)-1)
+ endif
- accu_1 = 0.d0
- accu_2 = 0.d0
- accu_3 = 0.d0
- do l = 1,ao_prim_num(k)
- beta = ao_expo_ordered_transp_per_nucl(l,j,i)
- contrib = ao_coef_normalized_ordered_transp_per_nucl(l,j,i) * dexp(-beta*r2)
- accu_1 += contrib
- accu_2 += contrib * beta
- accu_3 += contrib * beta**2
- enddo
- aos_array(k) = accu_1 * dx2 * dy2 * dz2
+ dy3 = 0.d0
+ if(power_ao(2) .ge. 2) then
+ dy3 = dble(power_ao(2)) * dble((power_ao(2)-1)) * dy**(power_ao(2)-2)
+ endif
+
+ if(power_ao(2) .ge. 1) then
+ dy4 = dble((2 * power_ao(2) + 1)) * dy**(power_ao(2))
+ else
+ dy4 = dble((power_ao(2) + 1)) * dy**(power_ao(2))
+ endif
+
+ dy5 = dy**(power_ao(2)+2)
- aos_grad_array(1,k) = accu_1 * dx1 * dy2 * dz2- 2.d0 * dx2 * dx * dy2 * dz2 * accu_2
- aos_grad_array(2,k) = accu_1 * dx2 * dy1 * dz2- 2.d0 * dx2 * dy2 * dy * dz2 * accu_2
- aos_grad_array(3,k) = accu_1 * dx2 * dy2 * dz1- 2.d0 * dx2 * dy2 * dz2 * dz * accu_2
+ ! ---
+
+ dz1 = 0.d0
+ if(power_ao(3) .ne. 0) then
+ dz1 = dble(power_ao(3)) * dz**(power_ao(3)-1)
+ endif
- aos_lapl_array(1,k) = accu_1 * dx3 * dy2 * dz2- 2.d0 * dx4 * dy2 * dz2* accu_2 +4.d0 * dx5 *dy2 * dz2* accu_3
- aos_lapl_array(2,k) = accu_1 * dx2 * dy3 * dz2- 2.d0 * dx2 * dy4 * dz2* accu_2 +4.d0 * dx2 *dy5 * dz2* accu_3
- aos_lapl_array(3,k) = accu_1 * dx2 * dy2 * dz3- 2.d0 * dx2 * dy2 * dz4* accu_2 +4.d0 * dx2 *dy2 * dz5* accu_3
+ dz3 = 0.d0
+ if(power_ao(3) .ge. 2) then
+ dz3 = dble(power_ao(3)) * dble((power_ao(3)-1)) * dz**(power_ao(3)-2)
+ endif
+
+ if(power_ao(3) .ge. 1) then
+ dz4 = dble((2 * power_ao(3) + 1)) * dz**(power_ao(3))
+ else
+ dz4 = dble((power_ao(3) + 1)) * dz**(power_ao(3))
+ endif
+
+ dz5 = dz**(power_ao(3)+2)
+
+ ! ---
+
+ accu_1 = 0.d0
+ accu_2 = 0.d0
+ accu_3 = 0.d0
+ do l = 1,ao_prim_num(k)
+ beta = ao_expo_ordered_transp_per_nucl(l,j,i)
+ if(beta*r2.gt.50.d0) cycle
+ contrib = ao_coef_normalized_ordered_transp_per_nucl(l,j,i) * dexp(-beta*r2)
+ accu_1 += contrib
+ accu_2 += contrib * beta
+ accu_3 += contrib * beta**2
+ enddo
+ aos_array(k) = accu_1 * dx2 * dy2 * dz2
+ aos_grad_array(1,k) = accu_1 * dx1 * dy2 * dz2 - 2.d0 * dx2 * dx * dy2 * dz2 * accu_2
+ aos_grad_array(2,k) = accu_1 * dx2 * dy1 * dz2 - 2.d0 * dx2 * dy2 * dy * dz2 * accu_2
+ aos_grad_array(3,k) = accu_1 * dx2 * dy2 * dz1 - 2.d0 * dx2 * dy2 * dz2 * dz * accu_2
+ aos_lapl_array(1,k) = accu_1 * dx3 * dy2 * dz2 - 2.d0 * dx4 * dy2 * dz2 * accu_2 + 4.d0 * dx5 * dy2 * dz2 * accu_3
+ aos_lapl_array(2,k) = accu_1 * dx2 * dy3 * dz2 - 2.d0 * dx2 * dy4 * dz2 * accu_2 + 4.d0 * dx2 * dy5 * dz2 * accu_3
+ aos_lapl_array(3,k) = accu_1 * dx2 * dy2 * dz3 - 2.d0 * dx2 * dy2 * dz4 * accu_2 + 4.d0 * dx2 * dy2 * dz5 * accu_3
+ enddo
enddo
- enddo
+
end
+! ---
diff --git a/src/ao_one_e_ints/ao_one_e_ints.irp.f b/src/ao_one_e_ints/ao_one_e_ints.irp.f
index 65981dc9..9b914dee 100644
--- a/src/ao_one_e_ints/ao_one_e_ints.irp.f
+++ b/src/ao_one_e_ints/ao_one_e_ints.irp.f
@@ -45,3 +45,13 @@ BEGIN_PROVIDER [ double precision, ao_one_e_integrals_imag,(ao_num,ao_num)]
END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, ao_one_e_integrals_from_mo, (ao_num, ao_num)]
+ implicit none
+ BEGIN_DOC
+! Integrals of the one e hamiltonian obtained from the integrals on the MO basis
+!
+! WARNING : this is equal to ao_one_e_integrals only if the AO and MO basis have the same number of functions
+ END_DOC
+ call mo_to_ao(mo_one_e_integrals,mo_num,ao_one_e_integrals_from_mo,ao_num)
+END_PROVIDER
diff --git a/src/ao_one_e_ints/ao_ortho_canonical.irp.f b/src/ao_one_e_ints/ao_ortho_canonical.irp.f
index 668b920d..eff7e7be 100644
--- a/src/ao_one_e_ints/ao_ortho_canonical.irp.f
+++ b/src/ao_one_e_ints/ao_ortho_canonical.irp.f
@@ -138,6 +138,8 @@ END_PROVIDER
deallocate(S)
endif
+ FREE ao_overlap
+
END_PROVIDER
BEGIN_PROVIDER [double precision, ao_ortho_canonical_overlap, (ao_ortho_canonical_num,ao_ortho_canonical_num)]
diff --git a/src/ao_two_e_ints/cholesky.irp.f b/src/ao_two_e_ints/cholesky.irp.f
index 2977f0f4..5fbd166c 100644
--- a/src/ao_two_e_ints/cholesky.irp.f
+++ b/src/ao_two_e_ints/cholesky.irp.f
@@ -6,7 +6,7 @@ BEGIN_PROVIDER [ double precision, cholesky_ao_transp, (cholesky_ao_num, ao_num,
integer :: i,j,k
do j=1,ao_num
do i=1,ao_num
- do k=1,ao_num
+ do k=1,cholesky_ao_num
cholesky_ao_transp(k,i,j) = cholesky_ao(i,j,k)
enddo
enddo
@@ -66,7 +66,8 @@ END_PROVIDER
else
- PROVIDE nucl_coord
+ PROVIDE nucl_coord ao_two_e_integral_schwartz
+ call set_multiple_levels_omp(.False.)
if (do_direct_integrals) then
if (ao_two_e_integral(1,1,1,1) < huge(1.d0)) then
diff --git a/src/becke_numerical_grid/extra_grid_vector.irp.f b/src/becke_numerical_grid/extra_grid_vector.irp.f
index ae167282..e054e22c 100644
--- a/src/becke_numerical_grid/extra_grid_vector.irp.f
+++ b/src/becke_numerical_grid/extra_grid_vector.irp.f
@@ -47,8 +47,12 @@ END_PROVIDER
END_DOC
implicit none
- integer :: i,j,k,l,i_count
- double precision :: r(3)
+ integer :: i, j, k, l, i_count
+ double precision :: r(3)
+ double precision :: wall0, wall1
+
+ call wall_time(wall0)
+ print *, ' Providing extra_final_grid_points ...'
i_count = 0
do j = 1, nucl_num
@@ -70,6 +74,10 @@ END_PROVIDER
enddo
enddo
+ call wall_time(wall1)
+ print *, ' wall time for extra_final_grid_points,', wall1 - wall0
+ call print_memory_usage()
+
END_PROVIDER
diff --git a/src/becke_numerical_grid/grid_becke_vector.irp.f b/src/becke_numerical_grid/grid_becke_vector.irp.f
index 473096d0..9da8a099 100644
--- a/src/becke_numerical_grid/grid_becke_vector.irp.f
+++ b/src/becke_numerical_grid/grid_becke_vector.irp.f
@@ -67,13 +67,6 @@ END_PROVIDER
index_final_points(2,i_count) = i
index_final_points(3,i_count) = j
index_final_points_reverse(k,i,j) = i_count
-
- if(final_weight_at_r_vector(i_count) .lt. 0.d0) then
- print *, ' !!! WARNING !!!'
- print *, ' negative weight !!!!'
- print *, i_count, final_weight_at_r_vector(i_count)
- stop
- endif
enddo
enddo
enddo
diff --git a/src/bitmask/EZFIO.cfg b/src/bitmask/EZFIO.cfg
index 9d713304..13007509 100644
--- a/src/bitmask/EZFIO.cfg
+++ b/src/bitmask/EZFIO.cfg
@@ -3,3 +3,36 @@ type: integer
doc: Number of active |MOs|
interface: ezfio
+[do_ormas]
+type: logical
+doc: if |true| restrict selection based on ORMAS rules
+interface: ezfio, provider, ocaml
+default: false
+
+[ormas_n_space]
+type: integer
+doc: Number of active spaces
+interface: ezfio, provider, ocaml
+default: 1
+
+[ormas_mstart]
+type: integer
+doc: starting orb for each ORMAS space
+size: (bitmask.ormas_n_space)
+interface: ezfio
+#default: (1)
+
+[ormas_min_e]
+type: integer
+doc: min number of electrons in each ORMAS space
+size: (bitmask.ormas_n_space)
+interface: ezfio
+#default: (0)
+
+[ormas_max_e]
+type: integer
+doc: max number of electrons in each ORMAS space
+size: (bitmask.ormas_n_space)
+interface: ezfio
+#default: (electrons.elec_num)
+
diff --git a/src/bitmask/bitmasks_ormas.irp.f b/src/bitmask/bitmasks_ormas.irp.f
new file mode 100644
index 00000000..336022e5
--- /dev/null
+++ b/src/bitmask/bitmasks_ormas.irp.f
@@ -0,0 +1,206 @@
+use bitmasks
+
+BEGIN_PROVIDER [integer, ormas_mstart, (ormas_n_space) ]
+ implicit none
+ BEGIN_DOC
+! first orbital idx in each active space
+ END_DOC
+
+ logical :: has
+ PROVIDE ezfio_filename
+ if (mpi_master) then
+
+ call ezfio_has_bitmask_ormas_mstart(has)
+ if (has) then
+! write(6,'(A)') '.. >>>>> [ IO READ: ormas_mstart ] <<<<< ..'
+ call ezfio_get_bitmask_ormas_mstart(ormas_mstart)
+ ASSERT (ormas_mstart(1).eq.1)
+ else if (ormas_n_space.eq.1) then
+ ormas_mstart = 1
+ else
+ print *, 'bitmask/ormas_mstart not found in EZFIO file'
+ stop 1
+ endif
+ endif
+ IRP_IF MPI_DEBUG
+ print *, irp_here, mpi_rank
+ call MPI_BARRIER(MPI_COMM_WORLD, ierr)
+ IRP_ENDIF
+ IRP_IF MPI
+ include 'mpif.h'
+ integer :: ierr
+ call MPI_BCAST( ormas_mstart, ormas_n_space, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
+ if (ierr /= MPI_SUCCESS) then
+ stop 'Unable to read ormas_mstart with MPI'
+ endif
+ IRP_ENDIF
+
+! call write_time(6)
+
+
+END_PROVIDER
+
+BEGIN_PROVIDER [integer, ormas_min_e, (ormas_n_space) ]
+ implicit none
+ BEGIN_DOC
+! min nelec in each active space
+ END_DOC
+
+ logical :: has
+ PROVIDE ezfio_filename
+ if (mpi_master) then
+
+ call ezfio_has_bitmask_ormas_min_e(has)
+ if (has) then
+! write(6,'(A)') '.. >>>>> [ IO READ: ormas_min_e ] <<<<< ..'
+ call ezfio_get_bitmask_ormas_min_e(ormas_min_e)
+ else if (ormas_n_space.eq.1) then
+ ormas_min_e = 0
+ else
+ print *, 'bitmask/ormas_min_e not found in EZFIO file'
+ stop 1
+ endif
+ endif
+ IRP_IF MPI_DEBUG
+ print *, irp_here, mpi_rank
+ call MPI_BARRIER(MPI_COMM_WORLD, ierr)
+ IRP_ENDIF
+ IRP_IF MPI
+ include 'mpif.h'
+ integer :: ierr
+ call MPI_BCAST( ormas_min_e, ormas_n_space, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
+ if (ierr /= MPI_SUCCESS) then
+ stop 'Unable to read ormas_min_e with MPI'
+ endif
+ IRP_ENDIF
+
+! call write_time(6)
+
+END_PROVIDER
+
+BEGIN_PROVIDER [integer, ormas_max_e, (ormas_n_space) ]
+ implicit none
+ BEGIN_DOC
+! max nelec in each active space
+ END_DOC
+
+ logical :: has
+ PROVIDE ezfio_filename
+ if (mpi_master) then
+
+ call ezfio_has_bitmask_ormas_max_e(has)
+ if (has) then
+! write(6,'(A)') '.. >>>>> [ IO READ: ormas_max_e ] <<<<< ..'
+ call ezfio_get_bitmask_ormas_max_e(ormas_max_e)
+ else if (ormas_n_space.eq.1) then
+ ormas_max_e = elec_num
+ else
+ print *, 'bitmask/ormas_max_e not found in EZFIO file'
+ stop 1
+ endif
+ endif
+ IRP_IF MPI_DEBUG
+ print *, irp_here, mpi_rank
+ call MPI_BARRIER(MPI_COMM_WORLD, ierr)
+ IRP_ENDIF
+ IRP_IF MPI
+ include 'mpif.h'
+ integer :: ierr
+ call MPI_BCAST( ormas_max_e, ormas_n_space, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
+ if (ierr /= MPI_SUCCESS) then
+ stop 'Unable to read ormas_max_e with MPI'
+ endif
+ IRP_ENDIF
+
+! call write_time(6)
+
+END_PROVIDER
+
+ BEGIN_PROVIDER [ integer, ormas_n_orb, (ormas_n_space) ]
+&BEGIN_PROVIDER [ integer, ormas_max_n_orb ]
+ implicit none
+ BEGIN_DOC
+ ! number of orbitals in each ormas space
+ END_DOC
+ integer :: i
+ ormas_n_orb = 0
+ ormas_n_orb(ormas_n_space) = mo_num + 1 - ormas_mstart(ormas_n_space)
+ do i = ormas_n_space-1, 1, -1
+ ormas_n_orb(i) = ormas_mstart(i+1) - ormas_mstart(i)
+ ASSERT (ormas_n_orb(i).ge.1)
+ enddo
+ ormas_max_n_orb = maxval(ormas_n_orb)
+END_PROVIDER
+
+BEGIN_PROVIDER [ integer, ormas_list_orb, (ormas_max_n_orb, ormas_n_space) ]
+ implicit none
+ BEGIN_DOC
+ ! list of orbitals in each ormas space
+ END_DOC
+ integer :: i,j,k
+ ormas_list_orb = 0
+ i = 1
+ do j = 1, ormas_n_space
+ do k = 1, ormas_n_orb(j)
+ ormas_list_orb(k,j) = i
+ i += 1
+ enddo
+ enddo
+END_PROVIDER
+
+BEGIN_PROVIDER [ integer(bit_kind), ormas_bitmask, (N_int, ormas_n_space) ]
+ implicit none
+ BEGIN_DOC
+ ! bitmask for each ormas space
+ END_DOC
+ integer :: j
+ ormas_bitmask = 0_bit_kind
+ do j = 1, ormas_n_space
+ call list_to_bitstring(ormas_bitmask(1,j), ormas_list_orb(:,j), ormas_n_orb(j), N_int)
+ enddo
+END_PROVIDER
+
+subroutine ormas_occ(key_in, occupancies)
+ implicit none
+ BEGIN_DOC
+ ! number of electrons in each ormas space
+ END_DOC
+ integer(bit_kind), intent(in) :: key_in(N_int,2)
+ integer, intent(out) :: occupancies(ormas_n_space)
+ integer :: i,ispin,ispace
+
+ occupancies = 0
+ ! TODO: get start/end of each space within N_int
+ do ispace=1,ormas_n_space
+ do ispin=1,2
+ do i=1,N_int
+ occupancies(ispace) += popcnt(iand(ormas_bitmask(i,ispace),key_in(i,ispin)))
+ enddo
+ enddo
+ enddo
+end
+
+logical function det_allowed_ormas(key_in)
+ implicit none
+ BEGIN_DOC
+ ! return true if det has allowable ormas occupations
+ END_DOC
+ integer(bit_kind), intent(in) :: key_in(N_int,2)
+ integer :: i,ispin,ispace,occ
+
+ det_allowed_ormas = .True.
+ if (ormas_n_space.eq.1) return
+ det_allowed_ormas = .False.
+ ! TODO: get start/end of each space within N_int
+ do ispace=1,ormas_n_space
+ occ = 0
+ do ispin=1,2
+ do i=1,N_int
+ occ += popcnt(iand(ormas_bitmask(i,ispace),key_in(i,ispin)))
+ enddo
+ enddo
+ if ((occ.lt.ormas_min_e(ispace)).or.(occ.gt.ormas_max_e(ispace))) return
+ enddo
+ det_allowed_ormas = .True.
+end
+
diff --git a/src/ccsd/ccsd_t_space_orb_stoch.irp.f b/src/ccsd/ccsd_t_space_orb_stoch.irp.f
index 13fa4f1a..1093c59d 100644
--- a/src/ccsd/ccsd_t_space_orb_stoch.irp.f
+++ b/src/ccsd/ccsd_t_space_orb_stoch.irp.f
@@ -110,6 +110,7 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
double precision :: eocc
double precision :: norm
integer :: isample
+ PROVIDE nthreads_pt2
! Prepare table of triplets (a,b,c)
@@ -124,7 +125,7 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
do b = a+1, nV
do c = b+1, nV
Nabc = Nabc + 1_8
- Pabc(Nabc) = -1.d0/(f_v(a) + f_v(b) + f_v(c))
+ Pabc(Nabc) = f_v(a) + f_v(b) + f_v(c)
abc(1,Nabc) = int(a,2)
abc(2,Nabc) = int(b,2)
abc(3,Nabc) = int(c,2)
@@ -134,13 +135,13 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
abc(1,Nabc) = int(a,2)
abc(2,Nabc) = int(b,2)
abc(3,Nabc) = int(a,2)
- Pabc(Nabc) = -1.d0/(2.d0*f_v(a) + f_v(b))
+ Pabc(Nabc) = 2.d0*f_v(a) + f_v(b)
Nabc = Nabc + 1_8
abc(1,Nabc) = int(b,2)
abc(2,Nabc) = int(a,2)
abc(3,Nabc) = int(b,2)
- Pabc(Nabc) = -1.d0/(f_v(a) + 2.d0*f_v(b))
+ Pabc(Nabc) = f_v(a) + 2.d0*f_v(b)
enddo
enddo
@@ -149,6 +150,7 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
enddo
! Sort triplets in decreasing Pabc
+ Pabc(:) = -1.d0/max(0.2d0,Pabc(:))
call dsort_big(Pabc, iorder, Nabc)
! Normalize
@@ -163,7 +165,6 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
call i8set_order_big(abc, iorder, Nabc)
-
! Cumulative distribution for sampling
waccu(Nabc) = 0.d0
do i8=Nabc-1,1,-1
@@ -181,8 +182,8 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
integer :: nbuckets
nbuckets = 100
+ double precision, allocatable :: ED(:)
double precision, allocatable :: wsum(:)
- allocate(wsum(nbuckets))
converged = .False.
Ncomputed = 0_8
@@ -197,7 +198,8 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
iright = Nabc
integer*8, allocatable :: bounds(:,:)
- allocate (bounds(2,nbuckets))
+ allocate(wsum(nbuckets), ED(nbuckets), bounds(2,nbuckets))
+ ED(:) = 0.d0
do isample=1,nbuckets
eta = 1.d0/dble(nbuckets) * dble(isample)
ieta = binary_search(waccu,eta,Nabc)
@@ -215,11 +217,12 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
print '(A)', ' ======================= ============== =========='
+ call set_multiple_levels_omp(.False.)
call wall_time(t00)
imin = 1_8
!$OMP PARALLEL &
!$OMP PRIVATE(ieta,eta,a,b,c,kiter,isample) &
- !$OMP DEFAULT(SHARED)
+ !$OMP DEFAULT(SHARED) NUM_THREADS(nthreads_pt2)
do kiter=1,Nabc
@@ -233,7 +236,7 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
enddo
! Deterministic part
- if (imin < Nabc) then
+ if (imin <= Nabc) then
ieta=imin
sampled(ieta) = 0_8
a = abc(1,ieta)
@@ -254,7 +257,7 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
! Stochastic part
call random_number(eta)
do isample=1,nbuckets
- if (imin >= bounds(2,isample)) then
+ if (imin > bounds(2,isample)) then
cycle
endif
ieta = binary_search(waccu,(eta + dble(isample-1))/dble(nbuckets),Nabc)+1
@@ -280,7 +283,7 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
enddo
call wall_time(t01)
- if ((t01-t00 > 1.0d0).or.(imin >= Nabc)) then
+ if ((t01-t00 > 1.0d0).or.(imin > Nabc)) then
!$OMP TASKWAIT
call wall_time(t01)
@@ -300,8 +303,11 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
do isample=1,nbuckets
- if (imin >= bounds(2,isample)) then
- energy_det = energy_det + sum(memo(bounds(1,isample):bounds(2,isample)))
+ if (imin > bounds(2,isample)) then
+ if (ED(isample) == 0.d0) then
+ ED(isample) = sum(memo(bounds(1,isample):bounds(2,isample)))
+ endif
+ energy_det = energy_det + ED(isample)
scale = scale - wsum(isample)
else
exit
@@ -310,12 +316,14 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
isample = min(isample,nbuckets)
do ieta=bounds(1,isample), Nabc
- w = dble(max(sampled(ieta),0_8))
- tmp = w * memo(ieta) * Pabc(ieta)
- ET = ET + tmp
- ET2 = ET2 + tmp * memo(ieta) * Pabc(ieta)
- norm = norm + w
+ if (sampled(ieta) < 0_8) cycle
+ w = dble(sampled(ieta))
+ tmp = w * memo(ieta) * Pabc(ieta)
+ ET = ET + tmp
+ ET2 = ET2 + tmp * memo(ieta) * Pabc(ieta)
+ norm = norm + w
enddo
+
norm = norm/scale
if (norm > 0.d0) then
energy_stoch = ET / norm
@@ -327,7 +335,7 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
print '('' '',F20.8, '' '', ES12.4,'' '', F8.2,'' '')', eccsd+energy, dsqrt(variance/(norm-1.d0)), 100.*real(Ncomputed)/real(Nabc)
endif
!$OMP END MASTER
- if (imin >= Nabc) exit
+ if (imin > Nabc) exit
enddo
!$OMP END PARALLEL
diff --git a/src/cipsi/README.rst b/src/cipsi/README.rst
index 054f938f..7385de5b 100644
--- a/src/cipsi/README.rst
+++ b/src/cipsi/README.rst
@@ -15,18 +15,18 @@ The :c:func:`run_cipsi` subroutine iteratively:
* If :option:`determinants s2_eig` is |true|, it adds all the necessary
determinants to allow the eigenstates of |H| to be eigenstates of |S^2|
* Diagonalizes |H| in the enlarged internal space
-* Computes the |PT2| contribution to the energy stochastically :cite:`Garniron_2017.2`
+* Computes the |PT2| contribution to the energy stochastically :cite:`Garniron_2017b`
or deterministically, depending on :option:`perturbation do_pt2`
* Extrapolates the variational energy by fitting
:math:`E=E_\text{FCI} - \alpha\, E_\text{PT2}`
The difference between :c:func:`run_stochastic_cipsi` and :c:func:`run_cipsi` is that
:c:func:`run_stochastic_cipsi` selects the determinants on the fly with the computation
-of the stochastic |PT2| :cite:`Garniron_2017.2`. Hence, it is a semi-stochastic selection. It
+of the stochastic |PT2| :cite:`Garniron_2017b`. Hence, it is a semi-stochastic selection. It
* Selects the most important determinants from the external space and adds them to the
internal space, on the fly with the computation of the PT2 with the stochastic algorithm
- presented in :cite:`Garniron_2017.2`.
+ presented in :cite:`Garniron_2017b`.
* If :option:`determinants s2_eig` is |true|, it adds all the necessary
determinants to allow the eigenstates of |H| to be eigenstates of |S^2|
* Extrapolates the variational energy by fitting
diff --git a/src/cipsi/selection.irp.f b/src/cipsi/selection.irp.f
index 50749272..0281a1d4 100644
--- a/src/cipsi/selection.irp.f
+++ b/src/cipsi/selection.irp.f
@@ -627,6 +627,11 @@ subroutine fill_buffer_$DOUBLE(i_generator, sp, h1, h2, bannedOrb, banned, fock_
call apply_particle(mask, s1, p1, det, ok, N_int)
endif
+ if (do_ormas) then
+ logical, external :: det_allowed_ormas
+ if (.not.det_allowed_ormas(det)) cycle
+ endif
+
if (do_only_cas) then
integer, external :: number_of_holes, number_of_particles
if (number_of_particles(det)>0) then
diff --git a/src/cipsi_utils/pt2_stoch_routines.irp.f b/src/cipsi_utils/pt2_stoch_routines.irp.f
index f067d0be..100335f6 100644
--- a/src/cipsi_utils/pt2_stoch_routines.irp.f
+++ b/src/cipsi_utils/pt2_stoch_routines.irp.f
@@ -117,6 +117,9 @@ subroutine ZMQ_pt2(E, pt2_data, pt2_data_err, relative_error, N_in)
use selection_types
implicit none
+ BEGIN_DOC
+! Computes the PT2 energy using ZMQ
+ END_DOC
integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull
integer, intent(in) :: N_in
@@ -540,27 +543,59 @@ subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2_data, pt2_data_
! 1/(N-1.5) : see Brugger, The American Statistician (23) 4 p. 32 (1969)
if(c > 2) then
eqt = dabs((pt2_data_S2(t) % pt2(pt2_stoch_istate) / c) - (pt2_data_S(t) % pt2(pt2_stoch_istate)/c)**2) ! dabs for numerical stability
- eqt = sqrt(eqt / (dble(c) - 1.5d0))
+ eqt = dsqrt(eqt / (dble(c) - 1.5d0))
pt2_data_err % pt2(pt2_stoch_istate) = eqt
eqt = dabs((pt2_data_S2(t) % variance(pt2_stoch_istate) / c) - (pt2_data_S(t) % variance(pt2_stoch_istate)/c)**2) ! dabs for numerical stability
- eqt = sqrt(eqt / (dble(c) - 1.5d0))
+ eqt = dsqrt(eqt / (dble(c) - 1.5d0))
pt2_data_err % variance(pt2_stoch_istate) = eqt
eqta(:) = dabs((pt2_data_S2(t) % overlap(:,pt2_stoch_istate) / c) - (pt2_data_S(t) % overlap(:,pt2_stoch_istate)/c)**2) ! dabs for numerical stability
- eqta(:) = sqrt(eqta(:) / (dble(c) - 1.5d0))
+ eqta(:) = dsqrt(eqta(:) / (dble(c) - 1.5d0))
pt2_data_err % overlap(:,pt2_stoch_istate) = eqta(:)
if ((time - time1 > 1.d0) .or. (n==N_det_generators)) then
time1 = time
- print '(I10, X, F12.6, X, G10.3, X, F10.6, X, G10.3, X, F10.6, X, G10.3, X, F10.4)', c, &
- pt2_data % pt2(pt2_stoch_istate) +E, &
- pt2_data_err % pt2(pt2_stoch_istate), &
- pt2_data % variance(pt2_stoch_istate), &
- pt2_data_err % variance(pt2_stoch_istate), &
- pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate), &
- pt2_data_err % overlap(pt2_stoch_istate,pt2_stoch_istate), &
+
+ value1 = pt2_data % pt2(pt2_stoch_istate) + E
+ error1 = pt2_data_err % pt2(pt2_stoch_istate)
+ value2 = pt2_data % pt2(pt2_stoch_istate)
+ error2 = pt2_data_err % pt2(pt2_stoch_istate)
+ value3 = pt2_data % variance(pt2_stoch_istate)
+ error3 = pt2_data_err % variance(pt2_stoch_istate)
+ value4 = pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate)
+ error4 = pt2_data_err % overlap(pt2_stoch_istate,pt2_stoch_istate)
+
+ ! Max size of the values (FX.Y) with X=size
+ size1 = 15
+ size2 = 12
+ size3 = 12
+ size4 = 12
+
+ ! To generate the format: number(error)
+ call format_w_error(value1,error1,size1,8,format_value1,str_error1)
+ call format_w_error(value2,error2,size2,8,format_value2,str_error2)
+ call format_w_error(value3,error3,size3,8,format_value3,str_error3)
+ call format_w_error(value4,error4,size4,8,format_value4,str_error4)
+
+ ! value > string with the right format
+ write(str_value1,'('//format_value1//')') value1
+ write(str_value2,'('//format_value2//')') value2
+ write(str_value3,'('//format_value3//')') value3
+ write(str_value4,'('//format_value4//')') value4
+
+ ! Convergence criterion
+ conv_crit = dabs(pt2_data_err % pt2(pt2_stoch_istate)) / &
+ (1.d-20 + dabs(pt2_data % pt2(pt2_stoch_istate)) )
+ write(str_conv,'(G10.3)') conv_crit
+
+ write(*,'(I10,X,X,A20,X,A16,X,A16,X,A16,X,A12,X,F10.1)') c,&
+ adjustl(adjustr(str_value1)//'('//str_error1(1:1)//')'),&
+ adjustl(adjustr(str_value2)//'('//str_error2(1:1)//')'),&
+ adjustl(adjustr(str_value3)//'('//str_error3(1:1)//')'),&
+ adjustl(adjustr(str_value4)//'('//str_error4(1:1)//')'),&
+ adjustl(str_conv),&
time-time0
if (stop_now .or. ( &
(do_exit .and. (dabs(pt2_data_err % pt2(pt2_stoch_istate)) / &
diff --git a/src/cipsi_utils/zmq_selection.irp.f b/src/cipsi_utils/zmq_selection.irp.f
index 1bfe87c0..5c2f8fc8 100644
--- a/src/cipsi_utils/zmq_selection.irp.f
+++ b/src/cipsi_utils/zmq_selection.irp.f
@@ -3,6 +3,9 @@ subroutine ZMQ_selection(N_in, pt2_data)
use selection_types
implicit none
+ BEGIN_DOC
+! Performs the determinant selection using ZeroMQ
+ END_DOC
integer(ZMQ_PTR) :: zmq_to_qp_run_socket , zmq_socket_pull
integer, intent(in) :: N_in
diff --git a/src/davidson/diagonalization_hs2_dressed.irp.f b/src/davidson/diagonalization_hs2_dressed.irp.f
index 1ead9d78..fd967ecc 100644
--- a/src/davidson/diagonalization_hs2_dressed.irp.f
+++ b/src/davidson/diagonalization_hs2_dressed.irp.f
@@ -139,7 +139,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_
integer :: iter2, itertot
double precision, allocatable :: y(:,:), h(:,:), h_p(:,:), lambda(:), s2(:)
real, allocatable :: y_s(:,:)
- double precision, allocatable :: s_(:,:), s_tmp(:,:)
+ double precision, allocatable :: s_(:,:), s_tmp(:,:), prev_y(:,:)
double precision :: diag_h_mat_elem
double precision, allocatable :: residual_norm(:)
character*(16384) :: write_buffer
@@ -288,6 +288,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_
h(N_st_diag*itermax,N_st_diag*itermax), &
! h_p(N_st_diag*itermax,N_st_diag*itermax), &
y(N_st_diag*itermax,N_st_diag*itermax), &
+ prev_y(N_st_diag*itermax,N_st_diag*itermax), &
s_(N_st_diag*itermax,N_st_diag*itermax), &
s_tmp(N_st_diag*itermax,N_st_diag*itermax), &
residual_norm(N_st_diag), &
@@ -301,6 +302,10 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_
s_ = 0.d0
s_tmp = 0.d0
+ prev_y = 0.d0
+ do i = 1, N_st_diag*itermax
+ prev_y(i,i) = 1d0
+ enddo
ASSERT (N_st > 0)
ASSERT (N_st_diag >= N_st)
@@ -479,6 +484,10 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_
if (info > 0) then
! Numerical errors propagate. We need to reduce the number of iterations
itermax = iter-1
+
+ ! eigenvectors of the previous iteration
+ y = prev_y
+ shift2 = shift2 - N_st_diag
exit
endif
@@ -522,6 +531,84 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_
enddo
endif
+ if (state_following) then
+ if (.not. only_expected_s2) then
+ print*,''
+ print*,'!!! State following only available with only_expected_s2 = .True. !!!'
+ STOP
+ endif
+ endif
+
+ if (state_following) then
+
+ integer :: state(N_st), idx
+ double precision :: omax
+ logical :: used
+ logical, allocatable :: ok(:)
+ double precision, allocatable :: overlp(:,:)
+
+ allocate(overlp(shift2,N_st),ok(shift2))
+
+ overlp = 0d0
+ do j = 1, shift2-1, N_st_diag
+
+ ! Computes some states from the guess vectors
+ ! Psi(:,j:j+N_st_diag) = U y(:,j:j+N_st_diag) and put them
+ ! in U(1,shift2+1:shift2+1+N_st_diag) as temporary array
+ call dgemm('N','N', sze, N_st_diag, shift2, &
+ 1.d0, U, size(U,1), y(1,j), size(y,1), 0.d0, U(1,shift2+1), size(U,1))
+
+ ! Overlap
+ do l = 1, N_st
+ do k = 1, N_st_diag
+ do i = 1, sze
+ overlp(k+j-1,l) += u_in(i,l) * U(i,shift2+k)
+ enddo
+ enddo
+ enddo
+
+ enddo
+
+ state = 0
+ do l = 1, N_st
+
+ omax = 0d0
+ idx = 0
+ do k = 1, shift2
+
+ ! Already used ?
+ used = .False.
+ do i = 1, N_st
+ if (state(i) == k) then
+ used = .True.
+ endif
+ enddo
+
+ ! Maximum overlap
+ if ((dabs(overlp(k,l)) > omax) .and. (.not. used) .and. state_ok(k)) then
+ omax = dabs(overlp(k,l))
+ idx = k
+ endif
+ enddo
+
+ state(l) = idx
+ enddo
+
+ ! tmp array before setting state_ok
+ ok = .False.
+ do l = 1, N_st
+ ok(state(l)) = .True.
+ enddo
+
+ do k = 1, shift2
+ if (.not. ok(k)) then
+ state_ok(k) = .False.
+ endif
+ enddo
+
+ deallocate(overlp,ok)
+ endif
+
do k=1,shift2
if (.not. state_ok(k)) then
do l=k+1,shift2
@@ -537,46 +624,49 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_
endif
enddo
- if (state_following) then
+ ! Swapped eigenvectors
+ prev_y = y
- overlap = -1.d0
- do k=1,shift2
- do i=1,shift2
- overlap(k,i) = dabs(y(k,i))
- enddo
- enddo
- do k=1,N_st
- cmax = -1.d0
- do i=1,N_st
- if (overlap(i,k) > cmax) then
- cmax = overlap(i,k)
- order(k) = i
- endif
- enddo
- do i=1,N_st_diag
- overlap(order(k),i) = -1.d0
- enddo
- enddo
- overlap = y
- do k=1,N_st
- l = order(k)
- if (k /= l) then
- y(1:shift2,k) = overlap(1:shift2,l)
- endif
- enddo
- do k=1,N_st
- overlap(k,1) = lambda(k)
- overlap(k,2) = s2(k)
- enddo
- do k=1,N_st
- l = order(k)
- if (k /= l) then
- lambda(k) = overlap(l,1)
- s2(k) = overlap(l,2)
- endif
- enddo
-
- endif
+! if (state_following) then
+!
+! overlap = -1.d0
+! do k=1,shift2
+! do i=1,shift2
+! overlap(k,i) = dabs(y(k,i))
+! enddo
+! enddo
+! do k=1,N_st
+! cmax = -1.d0
+! do i=1,N_st
+! if (overlap(i,k) > cmax) then
+! cmax = overlap(i,k)
+! order(k) = i
+! endif
+! enddo
+! do i=1,N_st_diag
+! overlap(order(k),i) = -1.d0
+! enddo
+! enddo
+! overlap = y
+! do k=1,N_st
+! l = order(k)
+! if (k /= l) then
+! y(1:shift2,k) = overlap(1:shift2,l)
+! endif
+! enddo
+! do k=1,N_st
+! overlap(k,1) = lambda(k)
+! overlap(k,2) = s2(k)
+! enddo
+! do k=1,N_st
+! l = order(k)
+! if (k /= l) then
+! lambda(k) = overlap(l,1)
+! s2(k) = overlap(l,2)
+! endif
+! enddo
+!
+! endif
! Express eigenvectors of h in the determinant basis
@@ -599,7 +689,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_
do i=1,sze
U(i,shift2+k) = &
(lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) &
- /max(H_jj(i) - lambda (k),1.d-2)
+ /max(dabs(H_jj(i) - lambda (k)),1.d-2) * dsign(1d0,H_jj(i) - lambda (k))
enddo
if (k <= N_st) then
@@ -714,7 +804,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_
residual_norm, &
U, overlap, &
h, y_s, S_d, &
- y, s_, s_tmp, &
+ y, s_, s_tmp, prev_y, &
lambda &
)
FREE nthreads_davidson
diff --git a/src/davidson/diagonalize_ci.irp.f b/src/davidson/diagonalize_ci.irp.f
index 46ad8f78..59c8313a 100644
--- a/src/davidson/diagonalize_ci.irp.f
+++ b/src/davidson/diagonalize_ci.irp.f
@@ -123,6 +123,7 @@ END_PROVIDER
endif
enddo
+
if (N_states_diag > N_states_diag_save) then
N_states_diag = N_states_diag_save
TOUCH N_states_diag
@@ -133,24 +134,101 @@ END_PROVIDER
print *, 'Diagonalization of H using Lapack'
allocate (eigenvectors(size(H_matrix_all_dets,1),N_det))
allocate (eigenvalues(N_det))
+
if (s2_eig) then
+
double precision, parameter :: alpha = 0.1d0
allocate (H_prime(N_det,N_det) )
+
H_prime(1:N_det,1:N_det) = H_matrix_all_dets(1:N_det,1:N_det) + &
alpha * S2_matrix_all_dets(1:N_det,1:N_det)
+
do j=1,N_det
H_prime(j,j) = H_prime(j,j) - alpha*expected_s2
enddo
+
call lapack_diag(eigenvalues,eigenvectors,H_prime,size(H_prime,1),N_det)
call nullify_small_elements(N_det,N_det,eigenvectors,size(eigenvectors,1),1.d-12)
+
CI_electronic_energy(:) = 0.d0
i_state = 0
+
allocate (s2_eigvalues(N_det))
allocate(index_good_state_array(N_det),good_state_array(N_det))
+
good_state_array = .False.
call u_0_S2_u_0(s2_eigvalues,eigenvectors,N_det,psi_det,N_int,&
N_det,size(eigenvectors,1))
- if (only_expected_s2) then
+
+ if (state_following) then
+ if (.not. only_expected_s2) then
+ print*,''
+ print*,'!!! State following only available with only_expected_s2 = .True. !!!'
+ STOP
+ endif
+ if (N_det < N_states) then
+ print*,''
+ print*,'!!! State following requires at least N_states determinants to be activated !!!'
+ STOP
+ endif
+ endif
+
+ if (state_following .and. only_expected_s2) then
+
+ integer :: state(N_states), idx,l
+ double precision :: omax
+ double precision, allocatable :: overlp(:)
+ logical :: used
+ logical, allocatable :: ok(:)
+
+ allocate(overlp(N_det), ok(N_det))
+
+ i_state = 0
+ state = 0
+ do l = 1, N_states
+
+ ! Overlap wrt each state
+ overlp = 0d0
+ do k = 1, N_det
+ do i = 1, N_det
+ overlp(k) = overlp(k) + psi_coef(i,l) * eigenvectors(i,k)
+ enddo
+ enddo
+
+ ! Idx of the state with the maximum overlap not already "used"
+ omax = 0d0
+ idx = 0
+ do k = 1, N_det
+
+ ! Already used ?
+ used = .False.
+ do i = 1, N_states
+ if (state(i) == k) then
+ used = .True.
+ endif
+ enddo
+
+ ! Maximum overlap
+ if (dabs(overlp(k)) > omax .and. .not. used) then
+ if (dabs(s2_eigvalues(k)-expected_s2) > 0.5d0) cycle
+ omax = dabs(overlp(k))
+ idx = k
+ endif
+ enddo
+
+ state(l) = idx
+ i_state +=1
+ enddo
+
+ deallocate(overlp, ok)
+
+ do i = 1, i_state
+ index_good_state_array(i) = state(i)
+ good_state_array(i) = .True.
+ enddo
+
+ else if (only_expected_s2) then
+
do j=1,N_det
! Select at least n_states states with S^2 values closed to "expected_s2"
if(dabs(s2_eigvalues(j)-expected_s2).le.0.5d0)then
@@ -158,17 +236,23 @@ END_PROVIDER
index_good_state_array(i_state) = j
good_state_array(j) = .True.
endif
+
if(i_state.eq.N_states) then
exit
endif
enddo
+
else
+
do j=1,N_det
index_good_state_array(j) = j
good_state_array(j) = .True.
enddo
+
endif
+
if(i_state .ne.0)then
+
! Fill the first "i_state" states that have a correct S^2 value
do j = 1, i_state
do i=1,N_det
@@ -177,6 +261,7 @@ END_PROVIDER
CI_electronic_energy(j) = eigenvalues(index_good_state_array(j))
CI_s2(j) = s2_eigvalues(index_good_state_array(j))
enddo
+
i_other_state = 0
do j = 1, N_det
if(good_state_array(j))cycle
@@ -201,6 +286,7 @@ END_PROVIDER
print*,' as the CI_eigenvectors'
print*,' You should consider more states and maybe ask for s2_eig to be .True. or just enlarge the CI space'
print*,''
+
do j=1,min(N_states_diag,N_det)
do i=1,N_det
CI_eigenvectors(i,j) = eigenvectors(i,j)
@@ -209,14 +295,18 @@ END_PROVIDER
CI_s2(j) = s2_eigvalues(j)
enddo
endif
+
deallocate(index_good_state_array,good_state_array)
deallocate(s2_eigvalues)
+
else
+
call lapack_diag(eigenvalues,eigenvectors, &
H_matrix_all_dets,size(H_matrix_all_dets,1),N_det)
CI_electronic_energy(:) = 0.d0
call u_0_S2_u_0(CI_s2,eigenvectors,N_det,psi_det,N_int, &
min(N_det,N_states_diag),size(eigenvectors,1))
+
! Select the "N_states_diag" states of lowest energy
do j=1,min(N_det,N_states_diag)
do i=1,N_det
@@ -224,7 +314,9 @@ END_PROVIDER
enddo
CI_electronic_energy(j) = eigenvalues(j)
enddo
+
endif
+
do k=1,N_states_diag
CI_electronic_energy(k) = 0.d0
do j=1,N_det
@@ -235,6 +327,7 @@ END_PROVIDER
enddo
enddo
enddo
+
deallocate(eigenvectors,eigenvalues)
endif
diff --git a/src/determinants/slater_rules_general.irp.f b/src/determinants/slater_rules_general.irp.f
new file mode 100644
index 00000000..e987c846
--- /dev/null
+++ b/src/determinants/slater_rules_general.irp.f
@@ -0,0 +1,192 @@
+subroutine get_excitation_general(key_i,key_j, Nint,degree_array,holes_array, particles_array,phase)
+ use bitmasks
+ BEGIN_DOC
+! returns the array, for each spin, of holes/particles between key_i and key_j
+!
+! with the following convention: a^+_{particle} a_{hole}|key_i> = |key_j>
+ END_DOC
+ include 'utils/constants.include.F'
+ implicit none
+ integer, intent(in) :: Nint
+ integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2)
+ integer, intent(out) :: holes_array(100,2),particles_array(100,2),degree_array(2)
+ double precision, intent(out) :: phase
+ integer :: ispin,k,i,pos
+ integer(bit_kind) :: key_hole, key_particle
+ integer(bit_kind) :: xorvec(N_int_max,2)
+ holes_array = -1
+ particles_array = -1
+ degree_array = 0
+ do i = 1, N_int
+ xorvec(i,1) = xor( key_i(i,1), key_j(i,1))
+ xorvec(i,2) = xor( key_i(i,2), key_j(i,2))
+ degree_array(1) += popcnt(xorvec(i,1))
+ degree_array(2) += popcnt(xorvec(i,2))
+ enddo
+ degree_array(1) = shiftr(degree_array(1),1)
+ degree_array(2) = shiftr(degree_array(2),1)
+
+ do ispin = 1, 2
+ k = 1
+ !!! GETTING THE HOLES
+ do i = 1, N_int
+ key_hole = iand(xorvec(i,ispin),key_i(i,ispin))
+ do while(key_hole .ne.0_bit_kind)
+ pos = trailz(key_hole)
+ holes_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos
+ key_hole = ibclr(key_hole,pos)
+ k += 1
+ if(k .gt.100)then
+ print*,'WARNING in get_excitation_general'
+ print*,'More than a 100-th excitation for spin ',ispin
+ print*,'stoping ...'
+ stop
+ endif
+ enddo
+ enddo
+ enddo
+ do ispin = 1, 2
+ k = 1
+ !!! GETTING THE PARTICLES
+ do i = 1, N_int
+ key_particle = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_j(i,ispin))
+ do while(key_particle .ne.0_bit_kind)
+ pos = trailz(key_particle)
+ particles_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos
+ key_particle = ibclr(key_particle,pos)
+ k += 1
+ if(k .gt.100)then
+ print*,'WARNING in get_excitation_general '
+ print*,'More than a 100-th excitation for spin ',ispin
+ print*,'stoping ...'
+ stop
+ endif
+ enddo
+ enddo
+ enddo
+ integer :: h,p, i_ok
+ integer(bit_kind), allocatable :: det_i(:,:),det_ip(:,:)
+ integer :: exc(0:2,2,2)
+ double precision :: phase_tmp
+ allocate(det_i(Nint,2),det_ip(N_int,2))
+ det_i = key_i
+ phase = 1.d0
+ do ispin = 1, 2
+ do i = 1, degree_array(ispin)
+ h = holes_array(i,ispin)
+ p = particles_array(i,ispin)
+ det_ip = det_i
+ call do_single_excitation(det_ip,h,p,ispin,i_ok)
+ if(i_ok == -1)then
+ print*,'excitation was not possible '
+ stop
+ endif
+ call get_single_excitation(det_i,det_ip,exc,phase_tmp,Nint)
+ phase *= phase_tmp
+ det_i = det_ip
+ enddo
+ enddo
+
+end
+
+subroutine get_holes_general(key_i, key_j,Nint, holes_array)
+ use bitmasks
+ BEGIN_DOC
+! returns the array, per spin, of holes between key_i and key_j
+!
+! with the following convention: a_{hole}|key_i> --> |key_j>
+ END_DOC
+ implicit none
+ integer, intent(in) :: Nint
+ integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2)
+ integer, intent(out) :: holes_array(100,2)
+ integer(bit_kind) :: key_hole
+ integer :: ispin,k,i,pos
+ holes_array = -1
+ do ispin = 1, 2
+ k = 1
+ do i = 1, N_int
+ key_hole = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_i(i,ispin))
+ do while(key_hole .ne.0_bit_kind)
+ pos = trailz(key_hole)
+ holes_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos
+ key_hole = ibclr(key_hole,pos)
+ k += 1
+ if(k .gt.100)then
+ print*,'WARNING in get_holes_general'
+ print*,'More than a 100-th excitation for spin ',ispin
+ print*,'stoping ...'
+ stop
+ endif
+ enddo
+ enddo
+ enddo
+end
+
+subroutine get_particles_general(key_i, key_j,Nint,particles_array)
+ use bitmasks
+ BEGIN_DOC
+! returns the array, per spin, of particles between key_i and key_j
+!
+! with the following convention: a^dagger_{particle}|key_i> --> |key_j>
+ END_DOC
+ implicit none
+ integer, intent(in) :: Nint
+ integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2)
+ integer, intent(out) :: particles_array(100,2)
+ integer(bit_kind) :: key_particle
+ integer :: ispin,k,i,pos
+ particles_array = -1
+ do ispin = 1, 2
+ k = 1
+ do i = 1, N_int
+ key_particle = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_j(i,ispin))
+ do while(key_particle .ne.0_bit_kind)
+ pos = trailz(key_particle)
+ particles_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos
+ key_particle = ibclr(key_particle,pos)
+ k += 1
+ if(k .gt.100)then
+ print*,'WARNING in get_holes_general'
+ print*,'More than a 100-th excitation for spin ',ispin
+ print*,'Those are the two determinants'
+ call debug_det(key_i, N_int)
+ call debug_det(key_j, N_int)
+ print*,'stoping ...'
+ stop
+ endif
+ enddo
+ enddo
+ enddo
+end
+
+subroutine get_phase_general(key_i,Nint,degree, holes_array, particles_array,phase)
+ implicit none
+ integer, intent(in) :: degree(2), Nint
+ integer(bit_kind), intent(in) :: key_i(Nint,2)
+ integer, intent(in) :: holes_array(100,2),particles_array(100,2)
+ double precision, intent(out) :: phase
+ integer :: i,ispin,h,p, i_ok
+ integer(bit_kind), allocatable :: det_i(:,:),det_ip(:,:)
+ integer :: exc(0:2,2,2)
+ double precision :: phase_tmp
+ allocate(det_i(Nint,2),det_ip(N_int,2))
+ det_i = key_i
+ phase = 1.d0
+ do ispin = 1, 2
+ do i = 1, degree(ispin)
+ h = holes_array(i,ispin)
+ p = particles_array(i,ispin)
+ det_ip = det_i
+ call do_single_excitation(det_ip,h,p,ispin,i_ok)
+ if(i_ok == -1)then
+ print*,'excitation was not possible '
+ stop
+ endif
+ call get_single_excitation(det_i,det_ip,exc,phase_tmp,Nint)
+ phase *= phase_tmp
+ det_i = det_ip
+ enddo
+ enddo
+
+end
diff --git a/src/dft_utils_in_r/mo_in_r.irp.f b/src/dft_utils_in_r/mo_in_r.irp.f
index 192cb25a..ad931402 100644
--- a/src/dft_utils_in_r/mo_in_r.irp.f
+++ b/src/dft_utils_in_r/mo_in_r.irp.f
@@ -48,7 +48,7 @@
integer :: i,j
do i = 1, n_points_final_grid
do j = 1, mo_num
- mos_in_r_array_transp(i,j) = mos_in_r_array(j,i)
+ mos_in_r_array_transp(i,j) = mos_in_r_array_omp(j,i)
enddo
enddo
END_PROVIDER
diff --git a/src/ezfio_files/01.convert.bats b/src/ezfio_files/convert_bats_old
similarity index 100%
rename from src/ezfio_files/01.convert.bats
rename to src/ezfio_files/convert_bats_old
diff --git a/src/cipsi_utils/environment.irp.f b/src/ezfio_files/environment.irp.f
similarity index 100%
rename from src/cipsi_utils/environment.irp.f
rename to src/ezfio_files/environment.irp.f
diff --git a/src/hartree_fock/10.hf.bats b/src/hartree_fock/10.hf.bats
index b496a089..214dfa86 100644
--- a/src/hartree_fock/10.hf.bats
+++ b/src/hartree_fock/10.hf.bats
@@ -115,9 +115,6 @@ rm -rf $EZFIO
run hco.ezfio -113.1841002944744
}
-@test "HBO" { # 0.805600 1.4543s
- run hbo.ezfio -100.018582259096
-}
@test "H2S" { # 1.655600 4.21402s
run h2s.ezfio -398.6944130421982
@@ -127,9 +124,6 @@ rm -rf $EZFIO
run h3coh.ezfio -114.9865030596373
}
-@test "H2O" { # 1.811100 1.84387s
- run h2o.ezfio -0.760270218692179E+02
-}
@test "H2O2" { # 2.217000 8.50267s
run h2o2.ezfio -150.7806608469964
@@ -187,13 +181,6 @@ rm -rf $EZFIO
run oh.ezfio -75.42025413469165
}
-@test "[Cu(NH3)4]2+" { # 59.610100 4.18766m
- [[ -n $TRAVIS ]] && skip
- qp set_file cu_nh3_4_2plus.ezfio
- qp set scf_utils thresh_scf 1.e-10
- run cu_nh3_4_2plus.ezfio -1862.97590358903
-}
-
@test "SO2" { # 71.894900 3.22567m
[[ -n $TRAVIS ]] && skip
run so2.ezfio -41.55800401346361
diff --git a/src/mo_basis/utils.irp.f b/src/mo_basis/utils.irp.f
index 5f664c41..987c394a 100644
--- a/src/mo_basis/utils.irp.f
+++ b/src/mo_basis/utils.irp.f
@@ -228,7 +228,11 @@ subroutine mo_as_svd_vectors_of_mo_matrix_eig(matrix,lda,m,n,eig,label)
call dgemm('N','N',ao_num,m,m,1.d0,mo_coef_new,size(mo_coef_new,1),U,size(U,1),0.d0,mo_coef,size(mo_coef,1))
do i=1,m
- eig(i) = D(i)
+ if (eig(i) > 1.d-20) then
+ eig(i) = D(i)
+ else
+ eig(i) = 0.d0
+ endif
enddo
deallocate(A,mo_coef_new,U,Vt,D)
diff --git a/src/mo_optimization/gradient_list_opt.irp.f b/src/mo_optimization/gradient_list_opt.irp.f
index 9b7228c7..9331c80f 100644
--- a/src/mo_optimization/gradient_list_opt.irp.f
+++ b/src/mo_optimization/gradient_list_opt.irp.f
@@ -319,7 +319,7 @@ call omp_set_max_active_levels(4)
! \end{equation}
! We need a vector to use the gradient. Here the gradient is a
-! antisymetric matrix so we can transform it in a vector of length
+! antisymmetric matrix so we can transform it in a vector of length
! mo_num*(mo_num-1)/2.
! Here we do these two things at the same time.
diff --git a/src/mo_optimization/gradient_opt.irp.f b/src/mo_optimization/gradient_opt.irp.f
index 25be6b5a..10d42b35 100644
--- a/src/mo_optimization/gradient_opt.irp.f
+++ b/src/mo_optimization/gradient_opt.irp.f
@@ -284,7 +284,7 @@ call omp_set_max_active_levels(4)
! \end{equation}
! We need a vector to use the gradient. Here the gradient is a
-! antisymetric matrix so we can transform it in a vector of length
+! antisymmetric matrix so we can transform it in a vector of length
! mo_num*(mo_num-1)/2.
! Here we do these two things at the same time.
diff --git a/src/mol_properties/multi_s_dipole_moment.irp.f b/src/mol_properties/multi_s_dipole_moment.irp.f
index 913ae2f3..c7216a61 100644
--- a/src/mol_properties/multi_s_dipole_moment.irp.f
+++ b/src/mol_properties/multi_s_dipole_moment.irp.f
@@ -91,3 +91,42 @@ BEGIN_PROVIDER [double precision, multi_s_dipole_moment, (N_states, N_states)]
enddo
END_PROVIDER
+
+! ---
+
+ BEGIN_PROVIDER [double precision, multi_s_x_dipole_moment_eigenvec, (N_states, N_states)]
+&BEGIN_PROVIDER [double precision, multi_s_y_dipole_moment_eigenvec, (N_states, N_states)]
+&BEGIN_PROVIDER [double precision, multi_s_z_dipole_moment_eigenvec, (N_states, N_states)]
+&BEGIN_PROVIDER [double precision, multi_s_x_dipole_moment_eigenval, (N_states)]
+&BEGIN_PROVIDER [double precision, multi_s_y_dipole_moment_eigenval, (N_states)]
+&BEGIN_PROVIDER [double precision, multi_s_z_dipole_moment_eigenval, (N_states)]
+
+ implicit none
+ double precision, allocatable :: eigval(:), eigvec(:,:), A(:,:)
+
+ PROVIDE multi_s_x_dipole_moment multi_s_y_dipole_moment multi_s_z_dipole_moment
+
+ allocate(A(N_states,N_states), eigvec(N_states,N_states), eigval(N_states))
+
+ A = multi_s_x_dipole_moment
+ call lapack_diag(eigval(1), eigvec(1,1), A(1,1), N_states, N_states)
+ multi_s_x_dipole_moment_eigenval = eigval
+ multi_s_x_dipole_moment_eigenvec = eigvec
+
+ A = multi_s_y_dipole_moment
+ call lapack_diag(eigval(1), eigvec(1,1), A(1,1), N_states, N_states)
+ multi_s_y_dipole_moment_eigenval = eigval
+ multi_s_y_dipole_moment_eigenvec = eigvec
+
+ A = multi_s_z_dipole_moment
+ call lapack_diag(eigval(1), eigvec(1,1), A(1,1), N_states, N_states)
+ multi_s_z_dipole_moment_eigenval = eigval
+ multi_s_z_dipole_moment_eigenvec = eigvec
+
+ deallocate(A, eigvec, eigval)
+
+END_PROVIDER
+
+! ---
+
+
diff --git a/src/mp2/H_apply.irp.f b/src/mp2/H_apply.irp.f
new file mode 100644
index 00000000..471dde50
--- /dev/null
+++ b/src/mp2/H_apply.irp.f
@@ -0,0 +1,15 @@
+use bitmasks
+BEGIN_SHELL [ /usr/bin/env python3 ]
+from generate_h_apply import *
+from perturbation import perturbations
+
+s = H_apply("mp2")
+s.set_perturbation("Moller_plesset")
+#s.set_perturbation("epstein_nesbet")
+print(s)
+
+s = H_apply("mp2_selection")
+s.set_selection_pt2("Moller_Plesset")
+print(s)
+END_SHELL
+
diff --git a/src/mp2/NEED b/src/mp2/NEED
new file mode 100644
index 00000000..6eaf5b93
--- /dev/null
+++ b/src/mp2/NEED
@@ -0,0 +1,6 @@
+generators_full
+selectors_full
+determinants
+davidson
+davidson_undressed
+perturbation
diff --git a/src/mp2/README.rst b/src/mp2/README.rst
new file mode 100644
index 00000000..192a75f1
--- /dev/null
+++ b/src/mp2/README.rst
@@ -0,0 +1,4 @@
+===
+mp2
+===
+
diff --git a/src/mp2/mp2.irp.f b/src/mp2/mp2.irp.f
new file mode 100644
index 00000000..b8e0cc4a
--- /dev/null
+++ b/src/mp2/mp2.irp.f
@@ -0,0 +1,21 @@
+program mp2
+ call run
+end
+
+subroutine run
+ implicit none
+ double precision, allocatable :: pt2(:), norm_pert(:)
+ double precision :: H_pert_diag, E_old
+ integer :: N_st, iter
+ PROVIDE Fock_matrix_diag_mo H_apply_buffer_allocated
+ N_st = N_states
+ allocate (pt2(N_st), norm_pert(N_st))
+ E_old = HF_energy
+ call H_apply_mp2(pt2, norm_pert, H_pert_diag, N_st)
+ print *, 'N_det = ', N_det
+ print *, 'N_states = ', N_states
+ print *, 'MP2 = ', pt2
+ print *, 'E = ', E_old
+ print *, 'E+MP2 = ', E_old+pt2
+ deallocate(pt2,norm_pert)
+end
diff --git a/src/mu_of_r/basis_def.irp.f b/src/mu_of_r/basis_def.irp.f
index fff9f581..e433f4d8 100644
--- a/src/mu_of_r/basis_def.irp.f
+++ b/src/mu_of_r/basis_def.irp.f
@@ -114,3 +114,48 @@ BEGIN_PROVIDER [double precision, basis_mos_in_r_array, (n_basis_orb,n_points_fi
enddo
enddo
END_PROVIDER
+
+! BEGIN_PROVIDER [integer, n_docc_val_orb_for_cas]
+!&BEGIN_PROVIDER [integer, n_max_docc_val_orb_for_cas]
+! implicit none
+! BEGIN_DOC
+! ! Number of DOUBLY OCCUPIED VALENCE ORBITALS for the CAS wave function
+! !
+! ! This determines the size of the space \mathcal{A} of Eqs. (15-16) of Phys.Chem.Lett.2019, 10, 2931 2937
+! END_DOC
+! integer :: i
+! n_docc_val_orb_for_cas = 0
+! ! You browse the BETA ELECTRONS and check if its not a CORE ORBITAL
+! do i = 1, elec_beta_num
+! if( trim(mo_class(i))=="Inactive" &
+! .or. trim(mo_class(i))=="Active" &
+! .or. trim(mo_class(i))=="Virtual" )then
+! n_docc_val_orb_for_cas +=1
+! endif
+! enddo
+! n_max_docc_val_orb_for_cas = maxval(n_docc_val_orb_for_cas)
+!
+!END_PROVIDER
+!
+!BEGIN_PROVIDER [integer, list_doc_valence_orb_for_cas, (n_max_docc_val_orb_for_cas)]
+! implicit none
+! BEGIN_DOC
+! ! List of OCCUPIED valence orbitals for each spin to build the f_{HF}(r_1,r_2) function
+! !
+! ! This corresponds to ALL OCCUPIED orbitals in the HF wave function, except those defined as "core"
+! !
+! ! This determines the space \mathcal{A} of Eqs. (15-16) of Phys.Chem.Lett.2019, 10, 2931 2937
+! END_DOC
+! j = 0
+! ! You browse the BETA ELECTRONS and check if its not a CORE ORBITAL
+! do i = 1, elec_beta_num
+! if( trim(mo_class(i))=="Inactive" &
+! .or. trim(mo_class(i))=="Active" &
+! .or. trim(mo_class(i))=="Virtual" )then
+! j +=1
+! list_doc_valence_orb_for_cas(j) = i
+! endif
+! enddo
+!
+!END_PROVIDER
+
diff --git a/src/mu_of_r/f_hf_cholesky.irp.f b/src/mu_of_r/f_hf_cholesky.irp.f
new file mode 100644
index 00000000..84097f09
--- /dev/null
+++ b/src/mu_of_r/f_hf_cholesky.irp.f
@@ -0,0 +1,218 @@
+BEGIN_PROVIDER [integer, list_couple_hf_orb_r1, (2,n_couple_orb_r1)]
+ implicit none
+ integer :: ii,i,mm,m,itmp
+ itmp = 0
+ do ii = 1, n_occ_val_orb_for_hf(1)
+ i = list_valence_orb_for_hf(ii,1)
+ do mm = 1, n_basis_orb ! electron 1
+ m = list_basis(mm)
+ itmp += 1
+ list_couple_hf_orb_r1(1,itmp) = i
+ list_couple_hf_orb_r1(2,itmp) = m
+ enddo
+ enddo
+END_PROVIDER
+
+
+BEGIN_PROVIDER [integer, list_couple_hf_orb_r2, (2,n_couple_orb_r2)]
+ implicit none
+ integer :: ii,i,mm,m,itmp
+ itmp = 0
+ do ii = 1, n_occ_val_orb_for_hf(2)
+ i = list_valence_orb_for_hf(ii,2)
+ do mm = 1, n_basis_orb ! electron 1
+ m = list_basis(mm)
+ itmp += 1
+ list_couple_hf_orb_r2(1,itmp) = i
+ list_couple_hf_orb_r2(2,itmp) = m
+ enddo
+ enddo
+END_PROVIDER
+
+
+BEGIN_PROVIDER [integer, n_couple_orb_r1]
+ implicit none
+ BEGIN_DOC
+ ! number of couples of alpha occupied times any basis orbital
+ END_DOC
+ n_couple_orb_r1 = n_occ_val_orb_for_hf(1) * n_basis_orb
+END_PROVIDER
+
+BEGIN_PROVIDER [integer, n_couple_orb_r2]
+ implicit none
+ BEGIN_DOC
+ ! number of couples of beta occupied times any basis orbital
+ END_DOC
+ n_couple_orb_r2 = n_occ_val_orb_for_hf(2) * n_basis_orb
+END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, mos_times_cholesky_r1, (cholesky_mo_num,n_points_final_grid)]
+ implicit none
+ BEGIN_DOC
+ ! V1_AR = \sum_{I}V_AI Phi_IR where "R" specifies the index of the grid point and A the number of cholesky point
+ !
+ ! here Phi_IR is phi_i(R)xphi_b(R) for r1 and V_AI = (ib|A) chollesky vector
+ END_DOC
+ double precision, allocatable :: mos_ib_r1(:,:),mo_chol_r1(:,:)
+ double precision, allocatable :: test(:,:)
+ double precision :: mo_i_r1,mo_b_r1
+ integer :: ii,i,mm,m,itmp,ipoint,ll
+ allocate(mos_ib_r1(n_couple_orb_r1,n_points_final_grid))
+ allocate(mo_chol_r1(cholesky_mo_num,n_couple_orb_r1))
+
+ do ipoint = 1, n_points_final_grid
+ itmp = 0
+ do ii = 1, n_occ_val_orb_for_hf(1)
+ i = list_valence_orb_for_hf(ii,1)
+ mo_i_r1 = mos_in_r_array_omp(i,ipoint)
+ do mm = 1, n_basis_orb ! electron 1
+ m = list_basis(mm)
+ mo_b_r1 = mos_in_r_array_omp(m,ipoint)
+ itmp += 1
+ mos_ib_r1(itmp,ipoint) = mo_i_r1 * mo_b_r1
+ enddo
+ enddo
+ enddo
+
+ itmp = 0
+ do ii = 1, n_occ_val_orb_for_hf(1)
+ i = list_valence_orb_for_hf(ii,1)
+ do mm = 1, n_basis_orb ! electron 1
+ m = list_basis(mm)
+ itmp += 1
+ do ll = 1, cholesky_mo_num
+ mo_chol_r1(ll,itmp) = cholesky_mo_transp(ll,m,i)
+ enddo
+ enddo
+ enddo
+
+ call get_AB_prod(mo_chol_r1,cholesky_mo_num,n_couple_orb_r1,mos_ib_r1,n_points_final_grid,mos_times_cholesky_r1)
+
+
+END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, mos_times_cholesky_r2, (cholesky_mo_num,n_points_final_grid)]
+ implicit none
+ BEGIN_DOC
+ ! V1_AR = \sum_{I}V_AI Phi_IR where "R" specifies the index of the grid point and A the number of cholesky point
+ !
+ ! here Phi_IR is phi_i(R)xphi_b(R) for r2 and V_AI = (ib|A) chollesky vector
+ END_DOC
+ double precision, allocatable :: mos_ib_r2(:,:),mo_chol_r2(:,:)
+ double precision, allocatable :: test(:,:)
+ double precision :: mo_i_r2,mo_b_r2
+ integer :: ii,i,mm,m,itmp,ipoint,ll
+ allocate(mos_ib_r2(n_couple_orb_r2,n_points_final_grid))
+ allocate(mo_chol_r2(cholesky_mo_num,n_couple_orb_r2))
+
+ do ipoint = 1, n_points_final_grid
+ itmp = 0
+ do ii = 1, n_occ_val_orb_for_hf(2)
+ i = list_valence_orb_for_hf(ii,2)
+ mo_i_r2 = mos_in_r_array_omp(i,ipoint)
+ do mm = 1, n_basis_orb ! electron 1
+ m = list_basis(mm)
+ mo_b_r2 = mos_in_r_array_omp(m,ipoint)
+ itmp += 1
+ mos_ib_r2(itmp,ipoint) = mo_i_r2 * mo_b_r2
+ enddo
+ enddo
+ enddo
+
+ itmp = 0
+ do ii = 1, n_occ_val_orb_for_hf(2)
+ i = list_valence_orb_for_hf(ii,2)
+ do mm = 1, n_basis_orb ! electron 1
+ m = list_basis(mm)
+ itmp += 1
+ do ll = 1, cholesky_mo_num
+ mo_chol_r2(ll,itmp) = cholesky_mo_transp(ll,m,i)
+ enddo
+ enddo
+ enddo
+
+ call get_AB_prod(mo_chol_r2,cholesky_mo_num,n_couple_orb_r2,mos_ib_r2,n_points_final_grid,mos_times_cholesky_r2)
+
+END_PROVIDER
+
+
+BEGIN_PROVIDER [ double precision, f_hf_cholesky, (n_points_final_grid)]
+ implicit none
+ integer :: ipoint,m,k
+ !!f(R) = \sum_{I} \sum_{J} Phi_I(R) Phi_J(R) V_IJ
+ !! = \sum_{I}\sum_{J}\sum_A Phi_I(R) Phi_J(R) V_AI V_AJ
+ !! = \sum_A \sum_{I}Phi_I(R)V_AI \sum_{J}V_AJ Phi_J(R)
+ !! = \sum_A V_AR G_AR
+ !! V_AR = \sum_{I}Phi_IR V_AI = \sum_{I}Phi^t_RI V_AI
+ double precision :: u_dot_v,wall0,wall1
+ if(elec_alpha_num == elec_beta_num)then
+ provide mos_times_cholesky_r1
+ print*,'providing f_hf_cholesky ...'
+ call wall_time(wall0)
+ !$OMP PARALLEL DO &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint,m) &
+ !$OMP ShARED (mos_times_cholesky_r1,cholesky_mo_num,f_hf_cholesky,n_points_final_grid)
+ do ipoint = 1, n_points_final_grid
+ f_hf_cholesky(ipoint) = 0.d0
+ do m = 1, cholesky_mo_num
+ f_hf_cholesky(ipoint) = f_hf_cholesky(ipoint) + &
+ mos_times_cholesky_r1(m,ipoint) * mos_times_cholesky_r1(m,ipoint)
+ enddo
+ f_hf_cholesky(ipoint) *= 2.D0
+ enddo
+ !$OMP END PARALLEL DO
+
+ call wall_time(wall1)
+ print*,'Time to provide f_hf_cholesky = ',wall1-wall0
+ free mos_times_cholesky_r1
+ else
+ provide mos_times_cholesky_r2 mos_times_cholesky_r1
+ !$OMP PARALLEL DO &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint,m) &
+ !$OMP ShARED (mos_times_cholesky_r2,mos_times_cholesky_r1,cholesky_mo_num,f_hf_cholesky,n_points_final_grid)
+ do ipoint = 1, n_points_final_grid
+ f_hf_cholesky(ipoint) = 0.D0
+ do m = 1, cholesky_mo_num
+ f_hf_cholesky(ipoint) = f_hf_cholesky(ipoint) + &
+ mos_times_cholesky_r2(m,ipoint)*mos_times_cholesky_r1(m,ipoint)
+ enddo
+ f_hf_cholesky(ipoint) *= 2.D0
+ enddo
+ !$OMP END PARALLEL DO
+ call wall_time(wall1)
+ print*,'Time to provide f_hf_cholesky = ',wall1-wall0
+ free mos_times_cholesky_r2 mos_times_cholesky_r1
+ endif
+END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, on_top_hf_grid, (n_points_final_grid)]
+ implicit none
+ integer :: ipoint,i,ii
+ double precision :: dm_a, dm_b,wall0,wall1
+ print*,'providing on_top_hf_grid ...'
+ provide mos_in_r_array_omp
+ call wall_time(wall0)
+ !$OMP PARALLEL DO &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint,dm_a,dm_b,ii,i) &
+ !$OMP ShARED (n_points_final_grid,n_occ_val_orb_for_hf,mos_in_r_array_omp,list_valence_orb_for_hf,on_top_hf_grid)
+ do ipoint = 1, n_points_final_grid
+ dm_a = 0.d0
+ do ii = 1, n_occ_val_orb_for_hf(1)
+ i = list_valence_orb_for_hf(ii,1)
+ dm_a += mos_in_r_array_omp(i,ipoint)*mos_in_r_array_omp(i,ipoint)
+ enddo
+ dm_b = 0.d0
+ do ii = 1, n_occ_val_orb_for_hf(2)
+ i = list_valence_orb_for_hf(ii,2)
+ dm_b += mos_in_r_array_omp(i,ipoint)*mos_in_r_array_omp(i,ipoint)
+ enddo
+ on_top_hf_grid(ipoint) = 2.D0 * dm_a*dm_b
+ enddo
+ !$OMP END PARALLEL DO
+ call wall_time(wall1)
+ print*,'Time to provide on_top_hf_grid = ',wall1-wall0
+END_PROVIDER
+
diff --git a/src/mu_of_r/mu_of_r_conditions.irp.f b/src/mu_of_r/mu_of_r_conditions.irp.f
index 6b49b9df..5b4d4b83 100644
--- a/src/mu_of_r/mu_of_r_conditions.irp.f
+++ b/src/mu_of_r/mu_of_r_conditions.irp.f
@@ -61,7 +61,7 @@
END_DOC
integer :: ipoint
double precision :: wall0,wall1,f_hf,on_top,w_hf,sqpi
- PROVIDE mo_two_e_integrals_in_map mo_integrals_map big_array_exchange_integrals
+ PROVIDE f_hf_cholesky on_top_hf_grid
print*,'providing mu_of_r_hf ...'
call wall_time(wall0)
sqpi = dsqrt(dacos(-1.d0))
@@ -69,10 +69,10 @@
!$OMP PARALLEL DO &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint,f_hf,on_top,w_hf) &
- !$OMP ShARED (n_points_final_grid,mu_of_r_hf,f_psi_hf_ab,on_top_hf_mu_r,sqpi)
+ !$OMP ShARED (n_points_final_grid,mu_of_r_hf,f_hf_cholesky,on_top_hf_grid,sqpi)
do ipoint = 1, n_points_final_grid
- f_hf = f_psi_hf_ab(ipoint)
- on_top = on_top_hf_mu_r(ipoint)
+ f_hf = f_hf_cholesky(ipoint)
+ on_top = on_top_hf_grid(ipoint)
if(on_top.le.1.d-12.or.f_hf.le.0.d0.or.f_hf * on_top.lt.0.d0)then
w_hf = 1.d+10
else
@@ -85,6 +85,44 @@
print*,'Time to provide mu_of_r_hf = ',wall1-wall0
END_PROVIDER
+ BEGIN_PROVIDER [double precision, mu_of_r_hf_old, (n_points_final_grid) ]
+ implicit none
+ BEGIN_DOC
+ ! mu(r) computed with a HF wave function (assumes that HF MOs are stored in the EZFIO)
+ !
+ ! corresponds to Eq. (37) of J. Chem. Phys. 149, 194301 (2018) but for \Psi^B = HF^B
+ !
+ ! !!!!!! WARNING !!!!!! if no_core_density == .True. then all contributions from the core orbitals
+ !
+ ! in the two-body density matrix are excluded
+ END_DOC
+ integer :: ipoint
+ double precision :: wall0,wall1,f_hf,on_top,w_hf,sqpi
+ PROVIDE mo_two_e_integrals_in_map mo_integrals_map big_array_exchange_integrals
+ print*,'providing mu_of_r_hf_old ...'
+ call wall_time(wall0)
+ sqpi = dsqrt(dacos(-1.d0))
+ provide f_psi_hf_ab
+ !$OMP PARALLEL DO &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint,f_hf,on_top,w_hf) &
+ !$OMP ShARED (n_points_final_grid,mu_of_r_hf_old,f_psi_hf_ab,on_top_hf_mu_r,sqpi)
+ do ipoint = 1, n_points_final_grid
+ f_hf = f_psi_hf_ab(ipoint)
+ on_top = on_top_hf_mu_r(ipoint)
+ if(on_top.le.1.d-12.or.f_hf.le.0.d0.or.f_hf * on_top.lt.0.d0)then
+ w_hf = 1.d+10
+ else
+ w_hf = f_hf / on_top
+ endif
+ mu_of_r_hf_old(ipoint) = w_hf * sqpi * 0.5d0
+ enddo
+ !$OMP END PARALLEL DO
+ call wall_time(wall1)
+ print*,'Time to provide mu_of_r_hf_old = ',wall1-wall0
+ END_PROVIDER
+
+
BEGIN_PROVIDER [double precision, mu_of_r_psi_cas, (n_points_final_grid,N_states) ]
implicit none
BEGIN_DOC
diff --git a/src/scf_utils/diagonalize_fock.irp.f b/src/scf_utils/diagonalize_fock.irp.f
index 5188581a..b9042b29 100644
--- a/src/scf_utils/diagonalize_fock.irp.f
+++ b/src/scf_utils/diagonalize_fock.irp.f
@@ -47,7 +47,7 @@ BEGIN_PROVIDER [ double precision, eigenvectors_Fock_matrix_mo, (ao_num,mo_num)
do j = 1, n_core_orb
jorb = list_core(j)
F(iorb,jorb) = 0.d0
- F(jorb,iorb) = 0.d0
+ F(jorb,iorb) = 0.d0
enddo
enddo
endif
diff --git a/src/scf_utils/fock_matrix.irp.f b/src/scf_utils/fock_matrix.irp.f
index 1942e542..269a441b 100644
--- a/src/scf_utils/fock_matrix.irp.f
+++ b/src/scf_utils/fock_matrix.irp.f
@@ -11,13 +11,13 @@
! |-----------------------|
! | Fcv | F^a | Rvv |
!
- ! C: Core, O: Open, V: Virtual
- !
+ ! C: Core, O: Open, V: Virtual
+ !
! Rcc = Acc Fcc^a + Bcc Fcc^b
! Roo = Aoo Foo^a + Boo Foo^b
! Rvv = Avv Fvv^a + Bvv Fvv^b
! Fcv = (F^a + F^b)/2
- !
+ !
! F^a: Fock matrix alpha (MO), F^b: Fock matrix beta (MO)
! A,B: Coupling parameters
!
@@ -26,10 +26,10 @@
! cc oo vv
! A -0.5 0.5 1.5
! B 1.5 0.5 -0.5
- !
+ !
END_DOC
integer :: i,j,n
- if (elec_alpha_num == elec_beta_num) then
+ if (all_shells_closed) then
Fock_matrix_mo = Fock_matrix_mo_alpha
else
! Core
@@ -102,7 +102,7 @@
!
! END_DOC
!integer :: i,j,n
- !if (elec_alpha_num == elec_beta_num) then
+ !if (all_shells_closed) then
! Fock_matrix_mo = Fock_matrix_mo_alpha
!else
@@ -166,6 +166,10 @@
if(frozen_orb_scf)then
integer :: iorb,jorb
+ ! active|core|active
+ !active | | 0 |
+ !core | 0 | | 0
+ !active | | 0 |
do i = 1, n_core_orb
iorb = list_core(i)
do j = 1, n_act_orb
@@ -192,7 +196,7 @@
do j = 1, n_core_orb
jorb = list_core(j)
Fock_matrix_mo(iorb,jorb) = 0.d0
- Fock_matrix_mo(jorb,iorb) = 0.d0
+ Fock_matrix_mo(jorb,iorb) = 0.d0
enddo
enddo
endif
@@ -229,9 +233,7 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_ao, (ao_num, ao_num) ]
call mo_to_ao(Fock_matrix_mo,size(Fock_matrix_mo,1), &
Fock_matrix_ao,size(Fock_matrix_ao,1))
else
- if ( (elec_alpha_num == elec_beta_num).and. &
- (level_shift == 0.) ) &
- then
+ if (all_shells_closed.and. (level_shift == 0.)) then
integer :: i,j
do j=1,ao_num
do i=1,ao_num
diff --git a/src/scf_utils/roothaan_hall_scf.irp.f b/src/scf_utils/roothaan_hall_scf.irp.f
index 730cb496..e0fe5319 100644
--- a/src/scf_utils/roothaan_hall_scf.irp.f
+++ b/src/scf_utils/roothaan_hall_scf.irp.f
@@ -13,9 +13,9 @@ END_DOC
integer :: iteration_SCF,dim_DIIS,index_dim_DIIS
logical :: converged
- integer :: i,j
+ integer :: i,j,m
logical, external :: qp_stop
- double precision, allocatable :: mo_coef_save(:,:)
+ double precision, allocatable :: mo_coef_save(:,:), S(:,:)
PROVIDE ao_md5 mo_occ level_shift
@@ -208,9 +208,29 @@ END_DOC
size(Fock_matrix_mo,2),mo_label,1,.true.)
call restore_symmetry(ao_num, mo_num, mo_coef, size(mo_coef,1), 1.d-10)
call orthonormalize_mos
- call save_mos
endif
+
+ ! Identify degenerate MOs and force them on the axes
+ allocate(S(ao_num,ao_num))
+ i=1
+ do while (i1) then
+ call dgemm('N','T',ao_num,ao_num,m,1.d0,mo_coef(1,i),size(mo_coef,1),mo_coef(1,i),size(mo_coef,1),0.d0,S,size(S,1))
+ call pivoted_cholesky( S, m, -1.d0, ao_num, mo_coef(1,i))
+ endif
+ i = j+1
+ enddo
+
+
+ call save_mos
+
call write_double(6, Energy_SCF, 'SCF energy')
call write_time(6)
diff --git a/src/scf_utils/scf_density_matrix_ao.irp.f b/src/scf_utils/scf_density_matrix_ao.irp.f
index 55fa8e7c..3813aa61 100644
--- a/src/scf_utils/scf_density_matrix_ao.irp.f
+++ b/src/scf_utils/scf_density_matrix_ao.irp.f
@@ -1,3 +1,11 @@
+BEGIN_PROVIDER [ logical, all_shells_closed ]
+ implicit none
+ BEGIN_DOC
+ !
+ END_DOC
+ all_shells_closed = (elec_alpha_num == elec_beta_num)
+END_PROVIDER
+
BEGIN_PROVIDER [double precision, SCF_density_matrix_ao_alpha, (ao_num,ao_num) ]
implicit none
BEGIN_DOC
@@ -30,7 +38,7 @@ BEGIN_PROVIDER [ double precision, SCF_density_matrix_ao, (ao_num,ao_num) ]
! Sum of $\alpha$ and $\beta$ density matrices
END_DOC
ASSERT (size(SCF_density_matrix_ao,1) == size(SCF_density_matrix_ao_alpha,1))
- if (elec_alpha_num== elec_beta_num) then
+ if (all_shells_closed) then
SCF_density_matrix_ao = SCF_density_matrix_ao_alpha + SCF_density_matrix_ao_alpha
else
ASSERT (size(SCF_density_matrix_ao,1) == size(SCF_density_matrix_ao_beta ,1))
diff --git a/src/tools/print_detweights.irp.f b/src/tools/print_detweights.irp.f
new file mode 100644
index 00000000..5e5f2bb1
--- /dev/null
+++ b/src/tools/print_detweights.irp.f
@@ -0,0 +1,97 @@
+program print_detweights
+
+ implicit none
+
+ read_wf = .True.
+ touch read_wf
+
+ call print_exc()
+ !call main()
+
+end
+
+! ---
+
+subroutine main()
+
+ implicit none
+ integer :: i
+ integer :: degree
+ integer :: ios
+ integer, allocatable :: deg(:), ii(:), deg_sorted(:)
+ double precision, allocatable :: c(:)
+
+ PROVIDE N_int
+ PROVIDE N_det
+ PROVIDE psi_det
+ PROVIDe psi_coef
+
+ allocate(deg(N_det), ii(N_det), deg_sorted(N_det), c(N_det))
+
+ do i = 1, N_det
+
+ call debug_det(psi_det(1,1,i), N_int)
+ call get_excitation_degree(psi_det(1,1,i), psi_det(1,1,1), degree, N_int)
+
+ ii (i) = i
+ deg(i) = degree
+ c (i) = dabs(psi_coef(i,1))
+ enddo
+
+ call dsort(c, ii, N_det)
+
+ do i = 1, N_det
+ deg_sorted(i) = deg(ii(i))
+ print *, deg_sorted(i), c(i)
+ enddo
+
+ print *, ' saving psi'
+
+ ! Writing output in binary format
+ open(unit=10, file="coef.bin", status="replace", action="write", iostat=ios, form="unformatted")
+
+ if(ios /= 0) then
+ print *, ' Error opening file!'
+ stop
+ endif
+
+ write(10) N_det
+ write(10) deg_sorted
+ write(10) c
+
+ close(10)
+
+ deallocate(deg, ii, deg_sorted, c)
+
+end
+
+! ---
+
+subroutine print_exc()
+
+ implicit none
+
+ integer :: i
+ integer, allocatable :: deg(:)
+
+ PROVIDE N_int
+ PROVIDE N_det
+ PROVIDE psi_det
+
+ allocate(deg(N_det))
+
+ do i = 1, N_det
+ call get_excitation_degree(psi_det(1,1,1), psi_det(1,1,i), deg(i), N_int)
+ enddo
+
+ open(unit=10, file="exc.dat", action="write")
+ write(10,*) N_det
+ write(10,*) deg
+ close(10)
+
+ deallocate(deg)
+
+end
+
+
+
diff --git a/src/trexio/export_trexio_routines.irp.f b/src/trexio/export_trexio_routines.irp.f
index 034b142e..63630243 100644
--- a/src/trexio/export_trexio_routines.irp.f
+++ b/src/trexio/export_trexio_routines.irp.f
@@ -59,7 +59,59 @@ subroutine export_trexio(update,full_path)
enddo
call ezfio_set_trexio_trexio_file(trexio_filename)
-
+
+
+! ------------------------------------------------------------------------------
+
+! Metadata
+! --------
+
+ integer :: code_num, author_num
+ character*(64) :: code(100), author(100), user
+ character*(64), parameter :: qp2_code = "QuantumPackage"
+
+ call getenv("USER",user)
+ do k=1,N_states
+ rc = trexio_read_metadata_code_num(f(k), code_num)
+ if (rc == TREXIO_ATTR_MISSING) then
+ i = 1
+ code(:) = ""
+ else
+ rc = trexio_read_metadata_code(f(k), code, 64)
+ do i=1, code_num
+ if (trim(code(i)) == trim(qp2_code)) then
+ exit
+ endif
+ enddo
+ endif
+ if (i == code_num+1) then
+ code(i) = qp2_code
+ rc = trexio_write_metadata_code_num(f(k), i)
+ call trexio_assert(rc, TREXIO_SUCCESS)
+ rc = trexio_write_metadata_code(f(k), code, 64)
+ call trexio_assert(rc, TREXIO_SUCCESS)
+ endif
+
+ rc = trexio_read_metadata_author_num(f(k), author_num)
+ if (rc == TREXIO_ATTR_MISSING) then
+ i = 1
+ author(:) = ""
+ else
+ rc = trexio_read_metadata_author(f(k), author, 64)
+ do i=1, author_num
+ if (trim(author(i)) == trim(user)) then
+ exit
+ endif
+ enddo
+ endif
+ if (i == author_num+1) then
+ author(i) = user
+ rc = trexio_write_metadata_author_num(f(k), i)
+ call trexio_assert(rc, TREXIO_SUCCESS)
+ rc = trexio_write_metadata_author(f(k), author, 64)
+ call trexio_assert(rc, TREXIO_SUCCESS)
+ endif
+ enddo
! ------------------------------------------------------------------------------
diff --git a/src/trexio/import_trexio_determinants.irp.f b/src/trexio/import_trexio_determinants.irp.f
index 1759bb94..7be576c6 100644
--- a/src/trexio/import_trexio_determinants.irp.f
+++ b/src/trexio/import_trexio_determinants.irp.f
@@ -1,4 +1,4 @@
-program import_determinants_ao
+program import_trexio_determinants
call run
end
diff --git a/src/utils/block_diag_degen.irp.f b/src/utils/block_diag_degen.irp.f
index 188bfa58..1a9ca8d6 100644
--- a/src/utils/block_diag_degen.irp.f
+++ b/src/utils/block_diag_degen.irp.f
@@ -191,7 +191,7 @@ subroutine give_degen_full_list(A, n, thr, list_degen, n_degen_list)
list_degen(n_degen_list,1) = i
icount = 1
do j = i+1, n
- if(dabs(A(i)-A(j)).lt.thr.and.is_ok(j)) then
+ if(dabs(A(i)-A(j)).lt.thr .and. is_ok(j)) then
is_ok(j) = .False.
icount += 1
list_degen(n_degen_list,icount) = j
diff --git a/src/utils/constants.include.F b/src/utils/constants.include.F
index 422eff95..7b01f888 100644
--- a/src/utils/constants.include.F
+++ b/src/utils/constants.include.F
@@ -18,3 +18,30 @@ double precision, parameter :: c_4_3 = 4.d0/3.d0
double precision, parameter :: c_1_3 = 1.d0/3.d0
double precision, parameter :: sq_op5 = dsqrt(0.5d0)
double precision, parameter :: dlog_2pi = dlog(2.d0*dacos(-1.d0))
+
+! physical constants and units conversion factors
+double precision, parameter :: k_boltzman_si = 1.38066d-23 ! K k^-1
+double precision, parameter :: k_boltzman_au = 3.1667d-6 ! Hartree k^-1
+double precision, parameter :: k_boltzman_m1_au = 315795.26d0 ! Hartree^-1 k
+double precision, parameter :: bohr_radius_si = 0.529177d-10 ! m
+double precision, parameter :: bohr_radius_cm = 0.529177d-8 ! cm
+double precision, parameter :: bohr_radius_angs = 0.529177d0 ! Angstrom
+double precision, parameter :: electronmass_si = 9.10953d-31 ! Kg
+double precision, parameter :: electronmass_uma = 5.4858d-4 ! uma
+double precision, parameter :: electronvolt_si = 1.6021892d-19 ! J
+double precision, parameter :: uma_si = 1.66057d-27 ! Kg
+double precision, parameter :: debye_si = 3.33564d-30 ! coulomb meter
+double precision, parameter :: debye_au = 0.393427228d0 ! e * Bohr
+double precision, parameter :: angstrom_to_au = 1.889727d0 ! au
+double precision, parameter :: au_to_ohmcmm1 = 46000.0d0 ! (ohm cm)^-1
+double precision, parameter :: au_to_kb = 294210.0d0 ! kbar
+double precision, parameter :: au_to_eV = 27.211652d0
+double precision, parameter :: uma_to_au = 1822.89d0
+double precision, parameter :: au_to_terahertz = 2.4189d-5
+double precision, parameter :: au_to_sec = 2.4189d-17
+double precision, parameter :: au_to_fsec = 2.4189d-2
+double precision, parameter :: Wcm2 = 3.5d16
+double precision, parameter :: amconv = 1.66042d-24/9.1095d-28*0.5d0 ! mass conversion: a.m.u to a.u. (ry)
+double precision, parameter :: uakbar = 147105.d0 ! pressure conversion from ry/(a.u)^3 to k
+
+
diff --git a/src/utils/linear_algebra.irp.f b/src/utils/linear_algebra.irp.f
index 26e390b7..20386b30 100644
--- a/src/utils/linear_algebra.irp.f
+++ b/src/utils/linear_algebra.irp.f
@@ -2041,3 +2041,22 @@ subroutine get_A_squared(A,n,A2)
double precision, intent(out):: A2(n,n)
call dgemm('N','N',n,n,n,1.d0,A,size(A,1),A,size(A,1),0.d0,A2,size(A2,1))
end
+
+subroutine get_AB_prod(A,n,m,B,l,AB)
+ implicit none
+ BEGIN_DOC
+! AB = A B where A is n x m, B is m x l. Use the dgemm routine
+ END_DOC
+ double precision, intent(in) :: A(n,m),B(m,l)
+ integer, intent(in) :: n,m,l
+ double precision, intent(out):: AB(n,l)
+ if(size(A,2).ne.m.or.size(B,1).ne.m)then
+ print*,'error in get_AB_prod ! '
+ print*,'matrices do not have the good dimension '
+ print*,'size(A,2) = ',size(A,2)
+ print*,'size(B,1) = ',size(B,1)
+ print*,'m = ',m
+ stop
+ endif
+ call dgemm('N','N',n,l,m,1.d0,A,size(A,1),B,size(B,1),0.d0,AB,size(AB,1))
+end
diff --git a/src/utils/memory.irp.f b/src/utils/memory.irp.f
index ab85c21b..e69bf71e 100644
--- a/src/utils/memory.irp.f
+++ b/src/utils/memory.irp.f
@@ -107,7 +107,7 @@ subroutine check_mem(rss_in,routine)
double precision, intent(in) :: rss_in
character*(*) :: routine
double precision :: mem
- call total_memory(mem)
+ call resident_memory(mem)
mem += rss_in
if (mem > qp_max_mem) then
call print_memory_usage()
diff --git a/src/utils/util.irp.f b/src/utils/util.irp.f
index 97cbde67..29ec8ed4 100644
--- a/src/utils/util.irp.f
+++ b/src/utils/util.irp.f
@@ -327,12 +327,12 @@ subroutine wall_time(t)
end
BEGIN_PROVIDER [ integer, nproc ]
+ use omp_lib
implicit none
BEGIN_DOC
! Number of current OpenMP threads
END_DOC
- integer, external :: omp_get_num_threads
nproc = 1
!$OMP PARALLEL
!$OMP MASTER
@@ -576,7 +576,7 @@ logical function is_same_spin(sigma_1, sigma_2)
is_same_spin = .false.
endif
-end function is_same_spin
+end
! ---
@@ -596,7 +596,7 @@ function Kronecker_delta(i, j) result(delta)
delta = 0.d0
endif
-end function Kronecker_delta
+end
! ---
@@ -634,7 +634,81 @@ subroutine diagonalize_sym_matrix(N, A, e)
print*,'Problem in diagonalize_sym_matrix (dsyev)!!'
endif
-end subroutine diagonalize_sym_matrix
+end
+
+! ---
+
+
+subroutine give_degen(A, n, shift, list_degen, n_degen_list)
+
+ BEGIN_DOC
+ ! returns n_degen_list :: the number of degenerated SET of elements (i.e. with |A(i)-A(i+1)| below shift)
+ !
+ ! for each of these sets, list_degen(1,i) = first degenerate element of the set i,
+ !
+ ! list_degen(2,i) = last degenerate element of the set i.
+ END_DOC
+
+ implicit none
+
+ double precision, intent(in) :: A(n)
+ double precision, intent(in) :: shift
+ integer, intent(in) :: n
+ integer, intent(out) :: list_degen(2,n), n_degen_list
+
+ integer :: i, j, n_degen, k
+ logical :: keep_on
+ double precision, allocatable :: Aw(:)
+
+ list_degen = -1
+ allocate(Aw(n))
+ Aw = A
+ i=1
+ k = 0
+ do while(i.lt.n)
+ if(dabs(Aw(i)-Aw(i+1)).lt.shift)then
+ k+=1
+ j=1
+ list_degen(1,k) = i
+ keep_on = .True.
+ do while(keep_on)
+ if(i+j.gt.n)then
+ keep_on = .False.
+ exit
+ endif
+ if(dabs(Aw(i)-Aw(i+j)).lt.shift)then
+ j+=1
+ else
+ keep_on=.False.
+ exit
+ endif
+ enddo
+ n_degen = j
+ list_degen(2,k) = list_degen(1,k)-1 + n_degen
+ j=0
+ keep_on = .True.
+ do while(keep_on)
+ if(i+j+1.gt.n)then
+ keep_on = .False.
+ exit
+ endif
+ if(dabs(Aw(i+j)-Aw(i+j+1)).lt.shift)then
+ Aw(i+j) += (j-n_degen/2) * shift
+ j+=1
+ else
+ keep_on = .False.
+ exit
+ endif
+ enddo
+ Aw(i+n_degen-1) += (n_degen-1-n_degen/2) * shift
+ i+=n_degen
+ else
+ i+=1
+ endif
+ enddo
+ n_degen_list = k
+
+end
! ---