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 b03f2ecc..7a9503d7 100644
--- a/README.md
+++ b/README.md
@@ -1,3 +1,10 @@
+**Important**: The Intel ifx compiler is not able to produce correct
+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 0523b6a7..6f2d02d0 100755
--- a/bin/qp_convert_output_to_ezfio
+++ b/bin/qp_convert_output_to_ezfio
@@ -224,14 +224,18 @@ def write_ezfio(res, filename):
exponent += [p.expo for p in b.prim]
ang_mom.append(str.count(s, "z"))
shell_prim_num.append(len(b.prim))
- shell_index += [nshell_tot+1] * len(b.prim)
+ shell_index += [nshell_tot] * len(b.prim)
+
+ shell_num = len(ang_mom)
+ assert(shell_index[0] == 1)
+ assert(shell_index[-1] == shell_num)
# ~#~#~#~#~ #
# W r i t e #
# ~#~#~#~#~ #
ezfio.set_basis_basis("Read from ResultsFile")
- ezfio.set_basis_shell_num(len(ang_mom))
+ ezfio.set_basis_shell_num(shell_num)
ezfio.set_basis_basis_nucleus_index(nucl_index)
ezfio.set_basis_prim_num(len(coefficient))
@@ -309,10 +313,19 @@ def write_ezfio(res, filename):
MoMatrix = []
sym0 = [i.sym for i in res.mo_sets[MO_type]]
- sym = [i.sym for i in res.mo_sets[MO_type]]
+ sym = [i.sym for i in res.mo_sets[MO_type]]
for i in range(len(sym)):
sym[MOmap[i]] = sym0[i]
+ irrep = {}
+ for i in sym:
+ irrep[i] = 0
+
+ for i, j in enumerate(irrep.keys()):
+ irrep[j] = i+1
+
+ sym = [ irrep[k] for k in sym ]
+
MoMatrix = []
for i in range(len(MOs)):
m = MOs[i]
@@ -329,6 +342,7 @@ def write_ezfio(res, filename):
ezfio.set_mo_basis_mo_num(mo_num)
ezfio.set_mo_basis_mo_coef(MoMatrix)
ezfio.set_mo_basis_mo_occ(OccNum)
+ ezfio.set_mo_basis_mo_symmetry(sym)
print("OK")
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/bin/zcat b/bin/zcat
deleted file mode 100755
index 7ccecf07..00000000
--- a/bin/zcat
+++ /dev/null
@@ -1,23 +0,0 @@
-#!/bin/bash
-
-# On Darwin: try gzcat if available, otherwise use Python
-
-if [[ $(uname -s) = Darwin ]] ; then
- which gzcat &> /dev/null
- if [[ $? -eq 0 ]] ; then
- exec gzcat $@
- else
-
- exec python3 << EOF
-import sys
-import gzip
-with gzip.open("$1", "rt") as f:
- print(f.read())
-EOF
- fi
-else
- SCRIPTPATH="$( cd -- "$(dirname "$0")" >/dev/null 2>&1 ; pwd -P )"
- command=$(which -a zcat | grep -v "$SCRIPTPATH/" | head -1)
- exec $command $@
-fi
-
diff --git a/config/gfortran_mkl.cfg b/config/gfortran_mkl.cfg
new file mode 100644
index 00000000..f2787d63
--- /dev/null
+++ b/config/gfortran_mkl.cfg
@@ -0,0 +1,62 @@
+# Common flags
+##############
+#
+# -ffree-line-length-none : Needed for IRPF90 which produces long lines
+# -lblas -llapack : Link with libblas and liblapack libraries provided by the system
+# -I . : Include the curent directory (Mandatory)
+#
+# --ninja : Allow the utilisation of ninja. (Mandatory)
+# --align=32 : Align all provided arrays on a 32-byte boundary
+#
+#
+[COMMON]
+FC : gfortran -ffree-line-length-none -I . -mavx -g -fPIC -std=legacy
+LAPACK_LIB : -I${MKLROOT}/include -L${MKLROOT}/lib/intel64 -Wl,--no-as-needed -lmkl_gf_lp64 -lmkl_core -lpthread -lm -ldl -lmkl_gnu_thread -lgomp -fopenmp
+IRPF90 : irpf90
+IRPF90_FLAGS : --ninja --align=32 -DSET_NESTED
+
+# Global options
+################
+#
+# 1 : Activate
+# 0 : Deactivate
+#
+[OPTION]
+MODE : OPT ; [ OPT | PROFILE | DEBUG ] : Chooses the section below
+CACHE : 0 ; Enable cache_compile.py
+OPENMP : 1 ; Append OpenMP flags
+
+# Optimization flags
+####################
+#
+# -Ofast : Disregard strict standards compliance. Enables all -O3 optimizations.
+# It also enables optimizations that are not valid
+# for all standard-compliant programs. It turns on
+# -ffast-math and the Fortran-specific
+# -fno-protect-parens and -fstack-arrays.
+[OPT]
+FCFLAGS : -Ofast -mavx
+
+# Profiling flags
+#################
+#
+[PROFILE]
+FC : -p -g
+FCFLAGS : -Ofast
+
+# Debugging flags
+#################
+#
+# -fcheck=all : Checks uninitialized variables, array subscripts, etc...
+# -g : Extra debugging information
+#
+[DEBUG]
+FCFLAGS : -fcheck=all -g
+
+# OpenMP flags
+#################
+#
+[OPENMP]
+FC : -fopenmp
+IRPF90_FLAGS : --openmp
+
diff --git a/config/ifort_2021_avx.cfg b/config/ifort_2021_avx.cfg
index 6c34cf47..55fe0ee7 100644
--- a/config/ifort_2021_avx.cfg
+++ b/config/ifort_2021_avx.cfg
@@ -6,7 +6,7 @@
# --align=32 : Align all provided arrays on a 32-byte boundary
#
[COMMON]
-FC : ifort -fpic
+FC : ifort -fpic -diag-disable=10448
LAPACK_LIB : -mkl=parallel
IRPF90 : irpf90
IRPF90_FLAGS : --ninja --align=32 -DINTEL
diff --git a/config/ifort_2021_avx_mpi.cfg b/config/ifort_2021_avx_mpi.cfg
index 4c893c73..362f482a 100644
--- a/config/ifort_2021_avx_mpi.cfg
+++ b/config/ifort_2021_avx_mpi.cfg
@@ -6,7 +6,7 @@
# --align=32 : Align all provided arrays on a 32-byte boundary
#
[COMMON]
-FC : mpiifort -fpic
+FC : mpiifort -fpic -diag-disable=10448
LAPACK_LIB : -mkl=parallel
IRPF90 : irpf90
IRPF90_FLAGS : --ninja --align=32 -DMPI -DINTEL
diff --git a/config/ifort_2021_avx_notz.cfg b/config/ifort_2021_avx_notz.cfg
index 1fa595d7..3cd80236 100644
--- a/config/ifort_2021_avx_notz.cfg
+++ b/config/ifort_2021_avx_notz.cfg
@@ -6,7 +6,7 @@
# --align=32 : Align all provided arrays on a 32-byte boundary
#
[COMMON]
-FC : ifort -fpic
+FC : ifort -fpic -diag-disable=10448
LAPACK_LIB : -mkl=parallel
IRPF90 : irpf90
IRPF90_FLAGS : --ninja --align=32 --define=WITHOUT_TRAILZ --define=WITHOUT_SHIFTRL
diff --git a/config/ifort_2021_debug.cfg b/config/ifort_2021_debug.cfg
index 80802f33..2e30642c 100644
--- a/config/ifort_2021_debug.cfg
+++ b/config/ifort_2021_debug.cfg
@@ -6,7 +6,7 @@
# --align=32 : Align all provided arrays on a 32-byte boundary
#
[COMMON]
-FC : ifort -fpic
+FC : ifort -fpic -diag-disable=10448
LAPACK_LIB : -mkl=parallel
IRPF90 : irpf90
IRPF90_FLAGS : --ninja --align=32 --assert -DINTEL
diff --git a/config/ifort_2021_mpi_rome.cfg b/config/ifort_2021_mpi_rome.cfg
index e47a466e..b7341388 100644
--- a/config/ifort_2021_mpi_rome.cfg
+++ b/config/ifort_2021_mpi_rome.cfg
@@ -6,7 +6,7 @@
# --align=32 : Align all provided arrays on a 32-byte boundary
#
[COMMON]
-FC : mpiifort -fpic
+FC : mpiifort -fpic -diag-disable=10448
LAPACK_LIB : -mkl=parallel
IRPF90 : irpf90
IRPF90_FLAGS : --ninja --align=32 -DINTEL
diff --git a/config/ifort_2021_rome.cfg b/config/ifort_2021_rome.cfg
index 504438c9..1d2d8c77 100644
--- a/config/ifort_2021_rome.cfg
+++ b/config/ifort_2021_rome.cfg
@@ -6,7 +6,7 @@
# --align=32 : Align all provided arrays on a 32-byte boundary
#
[COMMON]
-FC : ifort -fpic
+FC : ifort -fpic -diag-disable=10448
LAPACK_LIB : -mkl=parallel
IRPF90 : irpf90
IRPF90_FLAGS : --ninja --align=32 -DINTEL
diff --git a/config/ifort_2021_sse4.cfg b/config/ifort_2021_sse4.cfg
index 07c3ebb8..e43147ba 100644
--- a/config/ifort_2021_sse4.cfg
+++ b/config/ifort_2021_sse4.cfg
@@ -6,7 +6,7 @@
# --align=32 : Align all provided arrays on a 32-byte boundary
#
[COMMON]
-FC : ifort -fpic
+FC : ifort -fpic -diag-disable=10448
LAPACK_LIB : -mkl=parallel
IRPF90 : irpf90
IRPF90_FLAGS : --ninja --align=32 -DINTEL
diff --git a/config/ifort_2021_sse4_mpi.cfg b/config/ifort_2021_sse4_mpi.cfg
index f3fa0eaa..1914988b 100644
--- a/config/ifort_2021_sse4_mpi.cfg
+++ b/config/ifort_2021_sse4_mpi.cfg
@@ -6,7 +6,7 @@
# --align=32 : Align all provided arrays on a 32-byte boundary
#
[COMMON]
-FC : mpiifort -fpic
+FC : mpiifort -fpic -diag-disable=10448
LAPACK_LIB : -mkl=parallel
IRPF90 : irpf90
IRPF90_FLAGS : --ninja --align=32 -DMPI -DINTEL
diff --git a/config/ifort_2021_xHost.cfg b/config/ifort_2021_xHost.cfg
index 9170b059..0dfce550 100644
--- a/config/ifort_2021_xHost.cfg
+++ b/config/ifort_2021_xHost.cfg
@@ -6,7 +6,7 @@
# --align=32 : Align all provided arrays on a 32-byte boundary
#
[COMMON]
-FC : ifort -fpic -diag-disable 5462
+FC : ifort -fpic -diag-disable=5462 -diag-disable=10448
LAPACK_LIB : -mkl=parallel
IRPF90 : irpf90
IRPF90_FLAGS : --ninja --align=64 -DINTEL
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/etc/qp.rc b/etc/qp.rc
index d316faf5..bd061e3e 100644
--- a/etc/qp.rc
+++ b/etc/qp.rc
@@ -120,7 +120,9 @@ function qp()
if [[ $? -eq 0 ]] ; then
COMMAND='qp_$@'
eval "$COMMAND" "${EZFIO_FILE}"
+ result=$?
unset COMMAND
+ return $result
else
_qp_usage
fi
diff --git a/external/irpf90 b/external/irpf90
index 4ab1b175..0007f72f 160000
--- a/external/irpf90
+++ b/external/irpf90
@@ -1 +1 @@
-Subproject commit 4ab1b175fc7ed0d96c1912f13dc53579b24157a6
+Subproject commit 0007f72f677fe7d61c5e1ed461882cb239517102
diff --git a/ocaml/Angmom.ml b/ocaml/Angmom.ml
index ed13e8dc..2da09340 100644
--- a/ocaml/Angmom.ml
+++ b/ocaml/Angmom.ml
@@ -26,8 +26,7 @@ let of_string = function
| "J" | "j" -> J
| "K" | "k" -> K
| "L" | "l" -> L
- | x -> raise (Failure ("Angmom should be S|P|D|F|G|H|I|J|K|L,
-not "^x^"."))
+ | x -> raise (Failure ("Angmom should be S|P|D|F|G|H|I|J|K|L, not "^x^"."))
let of_char = function
| 'S' | 's' -> S
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/Basis.ml b/ocaml/Basis.ml
index 9b0c6a38..f951a5f3 100644
--- a/ocaml/Basis.ml
+++ b/ocaml/Basis.ml
@@ -17,7 +17,7 @@ let read in_channel at_number =
(** Find an element in the basis set file *)
let find in_channel element =
seek_in in_channel 0;
- let element_read = ref Element.X in
+ let element_read = ref Element.Og in
while !element_read <> element
do
let buffer = input_line in_channel in
diff --git a/ocaml/Element.ml b/ocaml/Element.ml
index f0d4455d..a794b2bb 100644
--- a/ocaml/Element.ml
+++ b/ocaml/Element.ml
@@ -4,7 +4,7 @@ open Qptypes
exception ElementError of string
type t = X
-
+
|H |He
|Li|Be |B |C |N |O |F |Ne
|Na|Mg |Al|Si|P |S |Cl|Ar
@@ -20,7 +20,7 @@ type t = X
let of_string x =
match (String.capitalize_ascii (String.lowercase_ascii x)) with
-| "X" | "Dummy" -> X
+| "X" | "Ghost" -> X
| "H" | "Hydrogen" -> H
| "He" | "Helium" -> He
| "Li" | "Lithium" -> Li
@@ -265,7 +265,7 @@ let to_string = function
let to_long_string = function
-| X -> "Dummy"
+| X -> "Ghost"
| H -> "Hydrogen"
| He -> "Helium"
| Li -> "Lithium"
@@ -492,20 +492,20 @@ let to_charge c =
| No -> 102
| Lr -> 103
| Rf -> 104
- | Db -> 105
- | Sg -> 106
- | Bh -> 107
- | Hs -> 108
- | Mt -> 109
- | Ds -> 110
- | Rg -> 111
- | Cn -> 112
- | Nh -> 113
- | Fl -> 114
- | Mc -> 115
- | Lv -> 116
- | Ts -> 117
- | Og -> 118
+ | Db -> 105
+ | Sg -> 106
+ | Bh -> 107
+ | Hs -> 108
+ | Mt -> 109
+ | Ds -> 110
+ | Rg -> 111
+ | Cn -> 112
+ | Nh -> 113
+ | Fl -> 114
+ | Mc -> 115
+ | Lv -> 116
+ | Ts -> 117
+ | Og -> 118
in Charge.of_int result
@@ -565,7 +565,7 @@ let of_charge c = match (Charge.to_int c) with
| 52 -> Te
| 53 -> I
| 54 -> Xe
-| 55 -> Cs
+| 55 -> Cs
| 56 -> Ba
| 57 -> La
| 58 -> Ce
@@ -880,7 +880,7 @@ let vdw_radius x =
| Ts -> None
| Og -> None
in
- match result x with
+ match result x with
| Some y -> Some (Positive_float.of_float @@ Units.angstrom_to_bohr *. y )
| None -> None
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/ocaml/qp_create_ezfio.ml b/ocaml/qp_create_ezfio.ml
index 8e452762..4e17c0ad 100644
--- a/ocaml/qp_create_ezfio.ml
+++ b/ocaml/qp_create_ezfio.ml
@@ -6,8 +6,8 @@ type element =
| Element of Element.t
| Int_elem of (Nucl_number.t * Element.t)
-(** Handle dummy atoms placed on bonds *)
-let dummy_centers ~threshold ~molecule ~nuclei =
+(** Handle ghost atoms placed on bonds *)
+let ghost_centers ~threshold ~molecule ~nuclei =
let d =
Molecule.distance_matrix molecule
in
@@ -68,11 +68,11 @@ let run ?o b au c d m p cart xyz_file =
(Molecule.of_file xyz_file ~charge:(Charge.of_int c)
~multiplicity:(Multiplicity.of_int m) )
in
- let dummy =
- dummy_centers ~threshold:d ~molecule ~nuclei:molecule.Molecule.nuclei
+ let ghost =
+ ghost_centers ~threshold:d ~molecule ~nuclei:molecule.Molecule.nuclei
in
let nuclei =
- molecule.Molecule.nuclei @ dummy
+ molecule.Molecule.nuclei @ ghost
in
@@ -145,8 +145,6 @@ let run ?o b au c d m p cart xyz_file =
| i :: k :: [] -> (Nucl_number.of_int @@ int_of_string i, Element.of_string k)
| _ -> failwith "Expected format is int,Element:basis"
in Int_elem result
- and basis =
- String.lowercase_ascii basis
in
let key =
match elem with
@@ -313,7 +311,7 @@ let run ?o b au c d m p cart xyz_file =
}
in
let nuclei =
- molecule.Molecule.nuclei @ dummy
+ molecule.Molecule.nuclei @ ghost
in
@@ -491,11 +489,7 @@ let run ?o b au c d m p cart xyz_file =
|> List.rev
|> list_map (fun (x,i) ->
try
- let e =
- match x.Atom.element with
- | Element.X -> Element.H
- | e -> e
- in
+ let e = x.Atom.element in
let key =
Int_elem (i,x.Atom.element)
in
@@ -507,9 +501,15 @@ let run ?o b au c d m p cart xyz_file =
in
try
Basis.read_element (basis_channel key) i e
- with Not_found ->
- failwith (Printf.sprintf "Basis not found for atom %d (%s)" (Nucl_number.to_int i)
- (Element.to_string x.Atom.element) )
+ with _ ->
+ try
+ if e = Element.X then
+ Basis.read_element (basis_channel key) i (Element.H)
+ else
+ raise Not_found
+ with Not_found ->
+ failwith (Printf.sprintf "Basis not found for atom %d (%s)" (Nucl_number.to_int i)
+ (Element.to_string x.Atom.element) )
with
| End_of_file -> failwith
("Element "^(Element.to_string x.Atom.element)^" not found in basis set.")
@@ -710,9 +710,9 @@ If a file with the same name as the basis set exists, this file will be read. O
arg=With_arg "";
doc="Total charge of the molecule. Default is 0. For negative values, use m instead of -, for ex m1"} ;
- { opt=Optional ; short='d'; long="dummy";
+ { opt=Optional ; short='g'; long="ghost";
arg=With_arg "";
- doc="Add dummy atoms. x * (covalent radii of the atoms)."} ;
+ doc="Add ghost atoms. x * (covalent radii of the atoms)."} ;
{ opt=Optional ; short='m'; long="multiplicity";
arg=With_arg "";
@@ -756,8 +756,8 @@ If a file with the same name as the basis set exists, this file will be read. O
int_of_string x )
in
- let dummy =
- match Command_line.get "dummy" with
+ let ghost =
+ match Command_line.get "ghost" with
| None -> 0.
| Some x -> float_of_string x
in
@@ -782,7 +782,7 @@ If a file with the same name as the basis set exists, this file will be read. O
| x::_ -> x
in
- run ?o:output basis au charge dummy multiplicity pseudo cart xyz_filename
+ run ?o:output basis au charge ghost multiplicity pseudo cart xyz_filename
)
with
(* | Failure txt -> Printf.eprintf "Fatal error: %s\n%!" txt *)
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/NEED b/plugins/local/cipsi_tc_bi_ortho/NEED
index 8f05be69..d329326c 100644
--- a/plugins/local/cipsi_tc_bi_ortho/NEED
+++ b/plugins/local/cipsi_tc_bi_ortho/NEED
@@ -1,3 +1,4 @@
+cipsi_utils
json
mpi
perturbation
diff --git a/plugins/local/cipsi_tc_bi_ortho/cipsi.irp.f b/plugins/local/cipsi_tc_bi_ortho/cipsi.irp.f
index fb907cb3..65e0790a 100644
--- a/plugins/local/cipsi_tc_bi_ortho/cipsi.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/cipsi.irp.f
@@ -65,7 +65,7 @@ subroutine run_cipsi
if (N_det > N_det_max) then
psi_det(1:N_int,1:2,1:N_det) = psi_det_generators(1:N_int,1:2,1:N_det)
- psi_coef(1:N_det,1:N_states) = psi_coef_sorted_tc_gen(1:N_det,1:N_states)
+ psi_coef(1:N_det,1:N_states) = psi_coef_sorted_gen(1:N_det,1:N_states)
N_det = N_det_max
soft_touch N_det psi_det psi_coef
if (s2_eig) then
diff --git a/plugins/local/cipsi_tc_bi_ortho/energy.irp.f b/plugins/local/cipsi_tc_bi_ortho/energy.irp.f
index 16f4528e..3698e5c2 100644
--- a/plugins/local/cipsi_tc_bi_ortho/energy.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/energy.irp.f
@@ -15,37 +15,5 @@ BEGIN_PROVIDER [ double precision, pt2_E0_denominator, (N_states) ]
pt2_E0_denominator = eigval_right_tc_bi_orth
-! if (initialize_pt2_E0_denominator) then
-! if (h0_type == "EN") then
-! pt2_E0_denominator(1:N_states) = psi_energy(1:N_states)
-! else if (h0_type == "HF") then
-! do i=1,N_states
-! j = maxloc(abs(psi_coef(:,i)),1)
-! pt2_E0_denominator(i) = psi_det_hii(j)
-! enddo
-! else if (h0_type == "Barycentric") then
-! pt2_E0_denominator(1:N_states) = barycentric_electronic_energy(1:N_states)
-! else if (h0_type == "CFG") then
-! pt2_E0_denominator(1:N_states) = psi_energy(1:N_states)
-! else
-! print *, h0_type, ' not implemented'
-! stop
-! endif
-! do i=1,N_states
-! call write_double(6,pt2_E0_denominator(i)+nuclear_repulsion, 'PT2 Energy denominator')
-! enddo
-! else
-! pt2_E0_denominator = -huge(1.d0)
-! endif
-
-END_PROVIDER
-
-
-BEGIN_PROVIDER [ double precision, pt2_overlap, (N_states, N_states) ]
- implicit none
- BEGIN_DOC
- ! Overlap between the perturbed wave functions
- END_DOC
- pt2_overlap(1:N_states,1:N_states) = 0.d0
END_PROVIDER
diff --git a/plugins/local/cipsi_tc_bi_ortho/environment.irp.f b/plugins/local/cipsi_tc_bi_ortho/environment.irp.f
deleted file mode 100644
index 5c0e0820..00000000
--- a/plugins/local/cipsi_tc_bi_ortho/environment.irp.f
+++ /dev/null
@@ -1,14 +0,0 @@
-BEGIN_PROVIDER [ integer, nthreads_pt2 ]
- implicit none
- BEGIN_DOC
- ! Number of threads for Davidson
- END_DOC
- nthreads_pt2 = nproc
- character*(32) :: env
- call getenv('QP_NTHREADS_PT2',env)
- if (trim(env) /= '') then
- read(env,*) nthreads_pt2
- call write_int(6,nthreads_pt2,'Target number of threads for PT2')
- endif
-END_PROVIDER
-
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..a3d7b076
--- /dev/null
+++ b/plugins/local/cipsi_tc_bi_ortho/get_d1_transp.irp.f
@@ -0,0 +1,358 @@
+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, istate
+ 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)
+ do istate = 1,N_states
+ tmp_rowij(istate,mm) = 0.d0
+ tmp_rowji(istate,mm) = 0.d0
+ enddo
+ enddo
+ !!
+ 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)
+! 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
+ do istate = 1,N_states
+ tmp_rowij(istate,mm) = 0.d0
+ tmp_rowij2(istate,mm) = 0.d0
+ tmp_rowji(istate,mm) = 0.d0
+ tmp_rowji2(istate,mm) = 0.d0
+ enddo
+ 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)
+ do istate = 1, N_states
+ tmp_rowij(istate,mm) = 0.d0
+ tmp_rowji(istate,mm) = 0.d0
+ enddo
+ enddo
+ !!
+ 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)
+! 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)
+ do istate = 1,N_states
+ tmp_rowij (istate,mm) = 0.d0
+ tmp_rowij2(istate,mm) = 0.d0
+ tmp_rowji (istate,mm) = 0.d0
+ tmp_rowji2(istate,mm) = 0.d0
+ enddo
+ 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/lock_2rdm.irp.f b/plugins/local/cipsi_tc_bi_ortho/lock_2rdm.irp.f
deleted file mode 100644
index e69de29b..00000000
diff --git a/plugins/local/cipsi_tc_bi_ortho/pt2.irp.f b/plugins/local/cipsi_tc_bi_ortho/pt2.irp.f
index 833cc0ea..22381991 100644
--- a/plugins/local/cipsi_tc_bi_ortho/pt2.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/pt2.irp.f
@@ -65,8 +65,12 @@ subroutine tc_pt2
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 tc_2e_3idx_coulomb_integrals_transp
+ endif
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/pt2_stoch_routines.irp.f b/plugins/local/cipsi_tc_bi_ortho/pt2_stoch_routines.irp.f
index 284b2bc8..6e1a6748 100644
--- a/plugins/local/cipsi_tc_bi_ortho/pt2_stoch_routines.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/pt2_stoch_routines.irp.f
@@ -1,868 +1,3 @@
-BEGIN_PROVIDER [ integer, pt2_stoch_istate ]
- implicit none
- BEGIN_DOC
- ! State for stochatsic PT2
- END_DOC
- pt2_stoch_istate = 1
-END_PROVIDER
-
- BEGIN_PROVIDER [ integer, pt2_F, (N_det_generators) ]
-&BEGIN_PROVIDER [ integer, pt2_n_tasks_max ]
- implicit none
- logical, external :: testTeethBuilding
- integer :: i,j
- pt2_n_tasks_max = elec_alpha_num*elec_alpha_num + elec_alpha_num*elec_beta_num - n_core_orb*2
- pt2_n_tasks_max = min(pt2_n_tasks_max,1+N_det_generators/10000)
- call write_int(6,pt2_n_tasks_max,'pt2_n_tasks_max')
-
- pt2_F(:) = max(int(sqrt(float(pt2_n_tasks_max))),1)
- do i=1,pt2_n_0(1+pt2_N_teeth/4)
- pt2_F(i) = pt2_n_tasks_max*pt2_min_parallel_tasks
- enddo
- do i=1+pt2_n_0(pt2_N_teeth-pt2_N_teeth/4), pt2_n_0(pt2_N_teeth-pt2_N_teeth/10)
- pt2_F(i) = pt2_min_parallel_tasks
- enddo
- do i=1+pt2_n_0(pt2_N_teeth-pt2_N_teeth/10), N_det_generators
- pt2_F(i) = 1
- enddo
-
-END_PROVIDER
-
- BEGIN_PROVIDER [ integer, pt2_N_teeth ]
-&BEGIN_PROVIDER [ integer, pt2_minDetInFirstTeeth ]
- implicit none
- logical, external :: testTeethBuilding
-
- if(N_det_generators < 500) then
- pt2_minDetInFirstTeeth = 1
- pt2_N_teeth = 1
- else
- pt2_minDetInFirstTeeth = min(5, N_det_generators)
- do pt2_N_teeth=100,2,-1
- if(testTeethBuilding(pt2_minDetInFirstTeeth, pt2_N_teeth)) exit
- end do
- end if
- call write_int(6,pt2_N_teeth,'Number of comb teeth')
-END_PROVIDER
-
-
-logical function testTeethBuilding(minF, N)
- implicit none
- integer, intent(in) :: minF, N
- integer :: n0, i
- double precision :: u0, Wt, r
-
- double precision, allocatable :: tilde_w(:), tilde_cW(:)
- integer, external :: dress_find_sample
-
- double precision :: rss
- double precision, external :: memory_of_double, memory_of_int
-
- rss = memory_of_double(2*N_det_generators+1)
- call check_mem(rss,irp_here)
-
- allocate(tilde_w(N_det_generators), tilde_cW(0:N_det_generators))
-
- double precision :: norm2
- norm2 = 0.d0
- do i=N_det_generators,1,-1
- tilde_w(i) = psi_coef_sorted_tc_gen(i,pt2_stoch_istate) * &
- psi_coef_sorted_tc_gen(i,pt2_stoch_istate)
- norm2 = norm2 + tilde_w(i)
- enddo
-
- f = 1.d0/norm2
- tilde_w(:) = tilde_w(:) * f
-
- tilde_cW(0) = -1.d0
- do i=1,N_det_generators
- tilde_cW(i) = tilde_cW(i-1) + tilde_w(i)
- enddo
- tilde_cW(:) = tilde_cW(:) + 1.d0
- deallocate(tilde_w)
-
- n0 = 0
- testTeethBuilding = .false.
- double precision :: f
- integer :: minFN
- minFN = N_det_generators - minF * N
- f = 1.d0/dble(N)
- do
- u0 = tilde_cW(n0)
- r = tilde_cW(n0 + minF)
- Wt = (1d0 - u0) * f
- if (dabs(Wt) <= 1.d-3) then
- exit
- endif
- if(Wt >= r - u0) then
- testTeethBuilding = .true.
- exit
- end if
- n0 += 1
- if(n0 > minFN) then
- exit
- end if
- end do
- deallocate(tilde_cW)
-
-end function
-
-
-
-subroutine ZMQ_pt2(E, pt2_data, pt2_data_err, relative_error, N_in)
- use f77_zmq
- use selection_types
-
- implicit none
-
- integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull
- integer, intent(in) :: N_in
-! integer, intent(inout) :: N_in
- double precision, intent(in) :: relative_error, E(N_states)
- type(pt2_type), intent(inout) :: pt2_data, pt2_data_err
-!
- integer :: i, N
-
- double precision :: state_average_weight_save(N_states), w(N_states,4)
- integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket
- type(selection_buffer) :: b
-
- PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
- PROVIDE psi_bilinear_matrix_rows psi_det_sorted_tc_order psi_bilinear_matrix_order
- PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
- PROVIDE psi_bilinear_matrix_transp_order psi_selectors_coef_transp_tc psi_det_sorted_tc
- PROVIDE psi_det_hii selection_weight pseudo_sym
- PROVIDE n_act_orb n_inact_orb n_core_orb n_virt_orb n_del_orb seniority_max
- PROVIDE excitation_beta_max excitation_alpha_max excitation_max
-
- if (h0_type == 'CFG') then
- PROVIDE psi_configuration_hii det_to_configuration
- endif
-
- if (N_det <= max(4,N_states) .or. pt2_N_teeth < 2) then
- print*,'ZMQ_selection'
- call ZMQ_selection(N_in, pt2_data)
- else
- print*,'else ZMQ_selection'
-
- N = max(N_in,1) * N_states
- state_average_weight_save(:) = state_average_weight(:)
- if (int(N,8)*2_8 > huge(1)) then
- print *, irp_here, ': integer too large'
- stop -1
- endif
- call create_selection_buffer(N, N*2, b)
- ASSERT (associated(b%det))
- ASSERT (associated(b%val))
-
- do pt2_stoch_istate=1,N_states
- state_average_weight(:) = 0.d0
- state_average_weight(pt2_stoch_istate) = 1.d0
- TOUCH state_average_weight pt2_stoch_istate selection_weight
-
- PROVIDE nproc pt2_F mo_two_e_integrals_in_map mo_one_e_integrals pt2_w
- PROVIDE pt2_u pt2_J pt2_R
- call new_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'pt2')
-
- integer, external :: zmq_put_psi
- integer, external :: zmq_put_N_det_generators
- integer, external :: zmq_put_N_det_selectors
- integer, external :: zmq_put_dvector
- integer, external :: zmq_put_ivector
- if (zmq_put_psi(zmq_to_qp_run_socket,1) == -1) then
- stop 'Unable to put psi on ZMQ server'
- endif
- if (zmq_put_N_det_generators(zmq_to_qp_run_socket, 1) == -1) then
- stop 'Unable to put N_det_generators on ZMQ server'
- endif
- if (zmq_put_N_det_selectors(zmq_to_qp_run_socket, 1) == -1) then
- stop 'Unable to put N_det_selectors on ZMQ server'
- endif
- if (zmq_put_dvector(zmq_to_qp_run_socket,1,'energy',pt2_e0_denominator,size(pt2_e0_denominator)) == -1) then
- stop 'Unable to put energy on ZMQ server'
- endif
- if (zmq_put_dvector(zmq_to_qp_run_socket,1,'state_average_weight',state_average_weight,N_states) == -1) then
- stop 'Unable to put state_average_weight on ZMQ server'
- endif
- if (zmq_put_dvector(zmq_to_qp_run_socket,1,'selection_weight',selection_weight,N_states) == -1) then
- stop 'Unable to put selection_weight on ZMQ server'
- endif
- if (zmq_put_ivector(zmq_to_qp_run_socket,1,'pt2_stoch_istate',pt2_stoch_istate,1) == -1) then
- stop 'Unable to put pt2_stoch_istate on ZMQ server'
- endif
- if (zmq_put_dvector(zmq_to_qp_run_socket,1,'threshold_generators',(/threshold_generators/),1) == -1) then
- stop 'Unable to put threshold_generators on ZMQ server'
- endif
-
-
- integer, external :: add_task_to_taskserver
- character(300000) :: task
-
- integer :: j,k,ipos,ifirst
- ifirst=0
-
- ipos=0
- do i=1,N_det_generators
- if (pt2_F(i) > 1) then
- ipos += 1
- endif
- enddo
- call write_int(6,sum(pt2_F),'Number of tasks')
- call write_int(6,ipos,'Number of fragmented tasks')
-
- ipos=1
- do i= 1, N_det_generators
- do j=1,pt2_F(pt2_J(i))
- write(task(ipos:ipos+30),'(I9,1X,I9,1X,I9,''|'')') j, pt2_J(i), N_in
- ipos += 30
- if (ipos > 300000-30) then
- if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
- stop 'Unable to add task to task server'
- endif
- ipos=1
- if (ifirst == 0) then
- ifirst=1
- if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
- print *, irp_here, ': Failed in zmq_set_running'
- endif
- endif
- endif
- end do
- enddo
- if (ipos > 1) then
- if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
- stop 'Unable to add task to task server'
- endif
- endif
-
- integer, external :: zmq_set_running
- if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
- print *, irp_here, ': Failed in zmq_set_running'
- endif
-
-
- double precision :: mem_collector, mem, rss
-
- call resident_memory(rss)
-
- mem_collector = 8.d0 * & ! bytes
- ( 1.d0*pt2_n_tasks_max & ! task_id, index
- + 0.635d0*N_det_generators & ! f,d
- + pt2_n_tasks_max*pt2_type_size(N_states) & ! pt2_data_task
- + N_det_generators*pt2_type_size(N_states) & ! pt2_data_I
- + 4.d0*(pt2_N_teeth+1) & ! S, S2, T2, T3
- + 1.d0*(N_int*2.d0*N + N) & ! selection buffer
- + 1.d0*(N_int*2.d0*N + N) & ! sort selection buffer
- ) / 1024.d0**3
-
- integer :: nproc_target, ii
- nproc_target = nthreads_pt2
- ii = min(N_det, (elec_alpha_num*(mo_num-elec_alpha_num))**2)
-
- do
- mem = mem_collector + & !
- nproc_target * 8.d0 * & ! bytes
- ( 0.5d0*pt2_n_tasks_max & ! task_id
- + 64.d0*pt2_n_tasks_max & ! task
- + pt2_type_size(N_states)*pt2_n_tasks_max*N_states & ! pt2, variance, overlap
- + 1.d0*pt2_n_tasks_max & ! i_generator, subset
- + 1.d0*(N_int*2.d0*ii+ ii) & ! selection buffer
- + 1.d0*(N_int*2.d0*ii+ ii) & ! sort selection buffer
- + 2.0d0*(ii) & ! preinteresting, interesting,
- ! prefullinteresting, fullinteresting
- + 2.0d0*(N_int*2*ii) & ! minilist, fullminilist
- + 1.0d0*(N_states*mo_num*mo_num) & ! mat
- ) / 1024.d0**3
-
- if (nproc_target == 0) then
- call check_mem(mem,irp_here)
- nproc_target = 1
- exit
- endif
-
- if (mem+rss < qp_max_mem) then
- exit
- endif
-
- nproc_target = nproc_target - 1
-
- enddo
- call write_int(6,nproc_target,'Number of threads for PT2')
- call write_double(6,mem,'Memory (Gb)')
-
- call omp_set_max_active_levels(1)
-
-
- print '(A)', '========== ======================= ===================== ===================== ==========='
- print '(A)', ' Samples Energy Variance Norm^2 Seconds'
- print '(A)', '========== ======================= ===================== ===================== ==========='
-
- PROVIDE global_selection_buffer
-
- !$OMP PARALLEL DEFAULT(shared) NUM_THREADS(nproc_target+1) &
- !$OMP PRIVATE(i)
- i = omp_get_thread_num()
- if (i==0) then
-
- call pt2_collector(zmq_socket_pull, E(pt2_stoch_istate),relative_error, pt2_data, pt2_data_err, b, N)
- pt2_data % rpt2(pt2_stoch_istate) = &
- pt2_data % pt2(pt2_stoch_istate)/(1.d0+pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate))
-
- !TODO : We should use here the correct formula for the error of X/Y
- pt2_data_err % rpt2(pt2_stoch_istate) = &
- pt2_data_err % pt2(pt2_stoch_istate)/(1.d0 + pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate))
-
- else
- call pt2_slave_inproc(i)
- endif
- !$OMP END PARALLEL
- call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'pt2')
- call omp_set_max_active_levels(8)
-
- print '(A)', '========== ======================= ===================== ===================== ==========='
-
- do k=1,N_states
- pt2_overlap(pt2_stoch_istate,k) = pt2_data % overlap(k,pt2_stoch_istate)
- enddo
- SOFT_TOUCH pt2_overlap
-
- enddo
- FREE pt2_stoch_istate
-
- ! Symmetrize overlap
- do j=2,N_states
- do i=1,j-1
- pt2_overlap(i,j) = 0.5d0 * (pt2_overlap(i,j) + pt2_overlap(j,i))
- pt2_overlap(j,i) = pt2_overlap(i,j)
- enddo
- enddo
-
- print *, 'Overlap of perturbed states:'
- do k=1,N_states
- print *, pt2_overlap(k,:)
- enddo
- print *, '-------'
-
- if (N_in > 0) then
- b%cur = min(N_in,b%cur)
- if (s2_eig) then
- call make_selection_buffer_s2(b)
- else
- call remove_duplicates_in_selection_buffer(b)
- endif
- call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0)
- endif
- call delete_selection_buffer(b)
-
- state_average_weight(:) = state_average_weight_save(:)
- TOUCH state_average_weight
- call update_pt2_and_variance_weights(pt2_data, N_states)
- endif
-
-
-end subroutine
-
-
-subroutine pt2_slave_inproc(i)
- implicit none
- integer, intent(in) :: i
-
- PROVIDE global_selection_buffer
- call run_pt2_slave(1,i,pt2_e0_denominator)
+subroutine provide_for_zmq_pt2
+ PROVIDE psi_selectors_coef_transp_tc psi_det_sorted_tc psi_det_sorted_tc_order
end
-
-
-subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2_data, pt2_data_err, b, N_)
- use f77_zmq
- use selection_types
- use bitmasks
- implicit none
-
-
- integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
- double precision, intent(in) :: relative_error, E
- type(pt2_type), intent(inout) :: pt2_data, pt2_data_err
- type(selection_buffer), intent(inout) :: b
- integer, intent(in) :: N_
-
- type(pt2_type), allocatable :: pt2_data_task(:)
- type(pt2_type), allocatable :: pt2_data_I(:)
- type(pt2_type), allocatable :: pt2_data_S(:)
- type(pt2_type), allocatable :: pt2_data_S2(:)
- type(pt2_type) :: pt2_data_teeth
- integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
- integer(ZMQ_PTR) :: zmq_to_qp_run_socket
- integer, external :: zmq_delete_tasks_async_send
- integer, external :: zmq_delete_tasks_async_recv
- integer, external :: zmq_abort
- integer, external :: pt2_find_sample_lr
-
- PROVIDE pt2_stoch_istate
-
- integer :: more, n, i, p, c, t, n_tasks, U
- integer, allocatable :: task_id(:)
- integer, allocatable :: index(:)
-
- double precision :: v, x, x2, x3, avg, avg2, avg3(N_states), eqt, E0, v0, n0(N_states)
- double precision :: eqta(N_states)
- double precision :: time, time1, time0
-
- integer, allocatable :: f(:)
- logical, allocatable :: d(:)
- logical :: do_exit, stop_now, sending
- logical, external :: qp_stop
- type(selection_buffer) :: b2
-
-
- double precision :: rss
- double precision, external :: memory_of_double, memory_of_int
-
- sending =.False.
-
- rss = memory_of_int(pt2_n_tasks_max*2+N_det_generators*2)
- rss += memory_of_double(N_states*N_det_generators)*3.d0
- rss += memory_of_double(N_states*pt2_n_tasks_max)*3.d0
- rss += memory_of_double(pt2_N_teeth+1)*4.d0
- call check_mem(rss,irp_here)
-
- ! If an allocation is added here, the estimate of the memory should also be
- ! updated in ZMQ_pt2
- allocate(task_id(pt2_n_tasks_max), index(pt2_n_tasks_max), f(N_det_generators))
- allocate(d(N_det_generators+1))
- allocate(pt2_data_task(pt2_n_tasks_max))
- allocate(pt2_data_I(N_det_generators))
- allocate(pt2_data_S(pt2_N_teeth+1))
- allocate(pt2_data_S2(pt2_N_teeth+1))
-
-
-
- zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
- call create_selection_buffer(N_, N_*2, b2)
-
-
- pt2_data % pt2(pt2_stoch_istate) = -huge(1.)
- pt2_data_err % pt2(pt2_stoch_istate) = huge(1.)
- pt2_data % variance(pt2_stoch_istate) = huge(1.)
- pt2_data_err % variance(pt2_stoch_istate) = huge(1.)
- pt2_data % overlap(:,pt2_stoch_istate) = 0.d0
- pt2_data_err % overlap(:,pt2_stoch_istate) = huge(1.)
- n = 1
- t = 0
- U = 0
- do i=1,pt2_n_tasks_max
- call pt2_alloc(pt2_data_task(i),N_states)
- enddo
- do i=1,pt2_N_teeth+1
- call pt2_alloc(pt2_data_S(i),N_states)
- call pt2_alloc(pt2_data_S2(i),N_states)
- enddo
- do i=1,N_det_generators
- call pt2_alloc(pt2_data_I(i),N_states)
- enddo
- f(:) = pt2_F(:)
- d(:) = .false.
- n_tasks = 0
- E0 = E
- v0 = 0.d0
- n0(:) = 0.d0
- more = 1
- call wall_time(time0)
- time1 = time0
-
- do_exit = .false.
- stop_now = .false.
- do while (n <= N_det_generators)
- if(f(pt2_J(n)) == 0) then
- d(pt2_J(n)) = .true.
- do while(d(U+1))
- U += 1
- end do
-
- ! Deterministic part
- do while(t <= pt2_N_teeth)
- if(U >= pt2_n_0(t+1)) then
- t=t+1
- E0 = 0.d0
- v0 = 0.d0
- n0(:) = 0.d0
- do i=pt2_n_0(t),1,-1
- E0 += pt2_data_I(i) % pt2(pt2_stoch_istate)
- v0 += pt2_data_I(i) % variance(pt2_stoch_istate)
- n0(:) += pt2_data_I(i) % overlap(:,pt2_stoch_istate)
- end do
- else
- exit
- end if
- end do
-
- ! Add Stochastic part
- c = pt2_R(n)
- if(c > 0) then
-
- call pt2_alloc(pt2_data_teeth,N_states)
- do p=pt2_N_teeth, 1, -1
- v = pt2_u_0 + pt2_W_T * (pt2_u(c) + dble(p-1))
- i = pt2_find_sample_lr(v, pt2_cW,pt2_n_0(p),pt2_n_0(p+1))
- v = pt2_W_T / pt2_w(i)
- call pt2_add ( pt2_data_teeth, v, pt2_data_I(i) )
- call pt2_add ( pt2_data_S(p), 1.d0, pt2_data_teeth )
- call pt2_add2( pt2_data_S2(p), 1.d0, pt2_data_teeth )
- enddo
- call pt2_dealloc(pt2_data_teeth)
-
- avg = E0 + pt2_data_S(t) % pt2(pt2_stoch_istate) / dble(c)
- avg2 = v0 + pt2_data_S(t) % variance(pt2_stoch_istate) / dble(c)
- avg3(:) = n0(:) + pt2_data_S(t) % overlap(:,pt2_stoch_istate) / dble(c)
- if ((avg /= 0.d0) .or. (n == N_det_generators) ) then
- do_exit = .true.
- endif
- if (qp_stop()) then
- stop_now = .True.
- endif
- pt2_data % pt2(pt2_stoch_istate) = avg
- pt2_data % variance(pt2_stoch_istate) = avg2
- pt2_data % overlap(:,pt2_stoch_istate) = avg3(:)
- call wall_time(time)
- ! 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))
- 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))
- 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))
- 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), &
- time-time0
- if (stop_now .or. ( &
- (do_exit .and. (dabs(pt2_data_err % pt2(pt2_stoch_istate)) / &
- (1.d-20 + dabs(pt2_data % pt2(pt2_stoch_istate)) ) <= relative_error))) ) then
- if (zmq_abort(zmq_to_qp_run_socket) == -1) then
- call sleep(10)
- if (zmq_abort(zmq_to_qp_run_socket) == -1) then
- print *, irp_here, ': Error in sending abort signal (2)'
- endif
- endif
- endif
- endif
- endif
- end if
- n += 1
- else if(more == 0) then
- exit
- else
- call pull_pt2_results(zmq_socket_pull, index, pt2_data_task, task_id, n_tasks, b2)
- if(n_tasks > pt2_n_tasks_max)then
- print*,'PB !!!'
- print*,'If you see this, send a bug report with the following content'
- print*,irp_here
- print*,'n_tasks,pt2_n_tasks_max = ',n_tasks,pt2_n_tasks_max
- stop -1
- endif
- if (zmq_delete_tasks_async_send(zmq_to_qp_run_socket,task_id,n_tasks,sending) == -1) then
- stop 'PT2: Unable to delete tasks (send)'
- endif
- do i=1,n_tasks
- if(index(i).gt.size(pt2_data_I,1).or.index(i).lt.1)then
- print*,'PB !!!'
- print*,'If you see this, send a bug report with the following content'
- print*,irp_here
- print*,'i,index(i),size(pt2_data_I,1) = ',i,index(i),size(pt2_data_I,1)
- stop -1
- endif
- call pt2_add(pt2_data_I(index(i)),1.d0,pt2_data_task(i))
- f(index(i)) -= 1
- end do
- do i=1, b2%cur
- ! We assume the pulled buffer is sorted
- if (b2%val(i) > b%mini) exit
- call add_to_selection_buffer(b, b2%det(1,1,i), b2%val(i))
- end do
- if (zmq_delete_tasks_async_recv(zmq_to_qp_run_socket,more,sending) == -1) then
- stop 'PT2: Unable to delete tasks (recv)'
- endif
- end if
- end do
- do i=1,N_det_generators
- call pt2_dealloc(pt2_data_I(i))
- enddo
- do i=1,pt2_N_teeth+1
- call pt2_dealloc(pt2_data_S(i))
- call pt2_dealloc(pt2_data_S2(i))
- enddo
- do i=1,pt2_n_tasks_max
- call pt2_dealloc(pt2_data_task(i))
- enddo
-!print *, 'deleting b2'
- call delete_selection_buffer(b2)
-!print *, 'sorting b'
- call sort_selection_buffer(b)
-!print *, 'done'
- call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
-
-end subroutine
-
-
-integer function pt2_find_sample(v, w)
- implicit none
- double precision, intent(in) :: v, w(0:N_det_generators)
- integer, external :: pt2_find_sample_lr
-
- pt2_find_sample = pt2_find_sample_lr(v, w, 0, N_det_generators)
-end function
-
-
-integer function pt2_find_sample_lr(v, w, l_in, r_in)
- implicit none
- double precision, intent(in) :: v, w(0:N_det_generators)
- integer, intent(in) :: l_in,r_in
- integer :: i,l,r
-
- l=l_in
- r=r_in
-
- do while(r-l > 1)
- i = shiftr(r+l,1)
- if(w(i) < v) then
- l = i
- else
- r = i
- end if
- end do
- i = r
- do r=i+1,N_det_generators
- if (w(r) /= w(i)) then
- exit
- endif
- enddo
- pt2_find_sample_lr = r-1
-end function
-
-
-BEGIN_PROVIDER [ integer, pt2_n_tasks ]
- implicit none
- BEGIN_DOC
- ! Number of parallel tasks for the Monte Carlo
- END_DOC
- pt2_n_tasks = N_det_generators
-END_PROVIDER
-
-BEGIN_PROVIDER[ double precision, pt2_u, (N_det_generators)]
- implicit none
- integer, allocatable :: seed(:)
- integer :: m,i
- call random_seed(size=m)
- allocate(seed(m))
- do i=1,m
- seed(i) = i
- enddo
- call random_seed(put=seed)
- deallocate(seed)
-
- call RANDOM_NUMBER(pt2_u)
- END_PROVIDER
-
- BEGIN_PROVIDER[ integer, pt2_J, (N_det_generators)]
-&BEGIN_PROVIDER[ integer, pt2_R, (N_det_generators)]
- implicit none
- BEGIN_DOC
-! pt2_J contains the list of generators after ordering them according to the
-! Monte Carlo sampling.
-!
-! pt2_R(i) is the number of combs drawn when determinant i is computed.
- END_DOC
- integer :: N_c, N_j
- integer :: U, t, i
- double precision :: v
- integer, external :: pt2_find_sample_lr
-
- logical, allocatable :: pt2_d(:)
- integer :: m,l,r,k
- integer :: ncache
- integer, allocatable :: ii(:,:)
- double precision :: dt
-
- ncache = min(N_det_generators,10000)
-
- double precision :: rss
- double precision, external :: memory_of_double, memory_of_int
- rss = memory_of_int(ncache)*dble(pt2_N_teeth) + memory_of_int(N_det_generators)
- call check_mem(rss,irp_here)
-
- allocate(ii(pt2_N_teeth,ncache),pt2_d(N_det_generators))
-
- pt2_R(:) = 0
- pt2_d(:) = .false.
- N_c = 0
- N_j = pt2_n_0(1)
- do i=1,N_j
- pt2_d(i) = .true.
- pt2_J(i) = i
- end do
-
- U = 0
- do while(N_j < pt2_n_tasks)
-
- if (N_c+ncache > N_det_generators) then
- ncache = N_det_generators - N_c
- endif
-
- !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(dt,v,t,k)
- do k=1, ncache
- dt = pt2_u_0
- do t=1, pt2_N_teeth
- v = dt + pt2_W_T *pt2_u(N_c+k)
- dt = dt + pt2_W_T
- ii(t,k) = pt2_find_sample_lr(v, pt2_cW,pt2_n_0(t),pt2_n_0(t+1))
- end do
- enddo
- !$OMP END PARALLEL DO
-
- do k=1,ncache
- !ADD_COMB
- N_c = N_c+1
- do t=1, pt2_N_teeth
- i = ii(t,k)
- if(.not. pt2_d(i)) then
- N_j += 1
- pt2_J(N_j) = i
- pt2_d(i) = .true.
- end if
- end do
-
- pt2_R(N_j) = N_c
-
- !FILL_TOOTH
- do while(U < N_det_generators)
- U += 1
- if(.not. pt2_d(U)) then
- N_j += 1
- pt2_J(N_j) = U
- pt2_d(U) = .true.
- exit
- end if
- end do
- if (N_j >= pt2_n_tasks) exit
- end do
- enddo
-
- if(N_det_generators > 1) then
- pt2_R(N_det_generators-1) = 0
- pt2_R(N_det_generators) = N_c
- end if
-
- deallocate(ii,pt2_d)
-
-END_PROVIDER
-
-
-
- BEGIN_PROVIDER [ double precision, pt2_w, (N_det_generators) ]
-&BEGIN_PROVIDER [ double precision, pt2_cW, (0:N_det_generators) ]
-&BEGIN_PROVIDER [ double precision, pt2_W_T ]
-&BEGIN_PROVIDER [ double precision, pt2_u_0 ]
-&BEGIN_PROVIDER [ integer, pt2_n_0, (pt2_N_teeth+1) ]
- implicit none
- integer :: i, t
- double precision, allocatable :: tilde_w(:), tilde_cW(:)
- double precision :: r, tooth_width
- integer, external :: pt2_find_sample
-
- double precision :: rss
- double precision, external :: memory_of_double, memory_of_int
- rss = memory_of_double(2*N_det_generators+1)
- call check_mem(rss,irp_here)
-
- if (N_det_generators == 1) then
-
- pt2_w(1) = 1.d0
- pt2_cw(1) = 1.d0
- pt2_u_0 = 1.d0
- pt2_W_T = 0.d0
- pt2_n_0(1) = 0
- pt2_n_0(2) = 1
-
- else
-
- allocate(tilde_w(N_det_generators), tilde_cW(0:N_det_generators))
-
- tilde_cW(0) = 0d0
-
- do i=1,N_det_generators
- tilde_w(i) = psi_coef_sorted_tc_gen(i,pt2_stoch_istate)**2 !+ 1.d-20
- enddo
-
- double precision :: norm2
- norm2 = 0.d0
- do i=N_det_generators,1,-1
- norm2 += tilde_w(i)
- enddo
-
- tilde_w(:) = tilde_w(:) / norm2
-
- tilde_cW(0) = -1.d0
- do i=1,N_det_generators
- tilde_cW(i) = tilde_cW(i-1) + tilde_w(i)
- enddo
- tilde_cW(:) = tilde_cW(:) + 1.d0
-
- pt2_n_0(1) = 0
- do
- pt2_u_0 = tilde_cW(pt2_n_0(1))
- r = tilde_cW(pt2_n_0(1) + pt2_minDetInFirstTeeth)
- pt2_W_T = (1d0 - pt2_u_0) / dble(pt2_N_teeth)
- if(pt2_W_T >= r - pt2_u_0) then
- exit
- end if
- pt2_n_0(1) += 1
- if(N_det_generators - pt2_n_0(1) < pt2_minDetInFirstTeeth * pt2_N_teeth) then
- print *, "teeth building failed"
- stop -1
- end if
- end do
-
- do t=2, pt2_N_teeth
- r = pt2_u_0 + pt2_W_T * dble(t-1)
- pt2_n_0(t) = pt2_find_sample(r, tilde_cW)
- end do
- pt2_n_0(pt2_N_teeth+1) = N_det_generators
-
- pt2_w(:pt2_n_0(1)) = tilde_w(:pt2_n_0(1))
- do t=1, pt2_N_teeth
- tooth_width = tilde_cW(pt2_n_0(t+1)) - tilde_cW(pt2_n_0(t))
- if (tooth_width == 0.d0) then
- tooth_width = sum(tilde_w(pt2_n_0(t):pt2_n_0(t+1)))
- endif
- ASSERT(tooth_width > 0.d0)
- do i=pt2_n_0(t)+1, pt2_n_0(t+1)
- pt2_w(i) = tilde_w(i) * pt2_W_T / tooth_width
- end do
- end do
-
- pt2_cW(0) = 0d0
- do i=1,N_det_generators
- pt2_cW(i) = pt2_cW(i-1) + pt2_w(i)
- end do
- pt2_n_0(pt2_N_teeth+1) = N_det_generators
-
- endif
-END_PROVIDER
-
-
-
-
-
diff --git a/plugins/local/cipsi_tc_bi_ortho/run_pt2_slave.irp.f b/plugins/local/cipsi_tc_bi_ortho/run_pt2_slave.irp.f
deleted file mode 100644
index aa6546e7..00000000
--- a/plugins/local/cipsi_tc_bi_ortho/run_pt2_slave.irp.f
+++ /dev/null
@@ -1,549 +0,0 @@
- use omp_lib
- use selection_types
- use f77_zmq
-BEGIN_PROVIDER [ integer(omp_lock_kind), global_selection_buffer_lock ]
- use omp_lib
- implicit none
- BEGIN_DOC
- ! Global buffer for the OpenMP selection
- END_DOC
- call omp_init_lock(global_selection_buffer_lock)
-END_PROVIDER
-
-BEGIN_PROVIDER [ type(selection_buffer), global_selection_buffer ]
- use omp_lib
- implicit none
- BEGIN_DOC
- ! Global buffer for the OpenMP selection
- END_DOC
- call omp_set_lock(global_selection_buffer_lock)
- call delete_selection_buffer(global_selection_buffer)
- call create_selection_buffer(N_det_generators, 2*N_det_generators, &
- global_selection_buffer)
- call omp_unset_lock(global_selection_buffer_lock)
-END_PROVIDER
-
-
-subroutine run_pt2_slave(thread,iproc,energy)
- use selection_types
- use f77_zmq
- implicit none
-
- double precision, intent(in) :: energy(N_states_diag)
- integer, intent(in) :: thread, iproc
- if (N_det > 100000 ) then
- call run_pt2_slave_large(thread,iproc,energy)
- else
- call run_pt2_slave_small(thread,iproc,energy)
- endif
-end
-
-subroutine run_pt2_slave_small(thread,iproc,energy)
- use selection_types
- use f77_zmq
- implicit none
-
- double precision, intent(in) :: energy(N_states_diag)
- integer, intent(in) :: thread, iproc
- integer :: rc, i
-
- integer :: worker_id, ctask, ltask
- character*(512), allocatable :: task(:)
- integer, allocatable :: task_id(:)
-
- integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
- integer(ZMQ_PTR) :: zmq_to_qp_run_socket
-
- integer(ZMQ_PTR), external :: new_zmq_push_socket
- integer(ZMQ_PTR) :: zmq_socket_push
-
- type(selection_buffer) :: b
- logical :: done, buffer_ready
-
- type(pt2_type), allocatable :: pt2_data(:)
- integer :: n_tasks, k, N
- integer, allocatable :: i_generator(:), subset(:)
-
- double precision, external :: memory_of_double, memory_of_int
- integer :: bsize ! Size of selection buffers
-
- allocate(task_id(pt2_n_tasks_max), task(pt2_n_tasks_max))
- allocate(pt2_data(pt2_n_tasks_max), i_generator(pt2_n_tasks_max), subset(pt2_n_tasks_max))
- zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
-
- integer, external :: connect_to_taskserver
- if (connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) == -1) then
- call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
- return
- endif
-
- zmq_socket_push = new_zmq_push_socket(thread)
-
- b%N = 0
- buffer_ready = .False.
- n_tasks = 1
-
- done = .False.
- do while (.not.done)
-
- n_tasks = max(1,n_tasks)
- n_tasks = min(pt2_n_tasks_max,n_tasks)
-
- integer, external :: get_tasks_from_taskserver
- if (get_tasks_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task, n_tasks) == -1) then
- exit
- endif
- done = task_id(n_tasks) == 0
- if (done) then
- n_tasks = n_tasks-1
- endif
- if (n_tasks == 0) exit
-
- do k=1,n_tasks
- call sscanf_ddd(task(k), subset(k), i_generator(k), N)
- enddo
- if (b%N == 0) then
- ! Only first time
- bsize = min(N, (elec_alpha_num * (mo_num-elec_alpha_num))**2)
- call create_selection_buffer(bsize, bsize*2, b)
- buffer_ready = .True.
- else
- ASSERT (b%N == bsize)
- endif
-
- double precision :: time0, time1
- call wall_time(time0)
- do k=1,n_tasks
- call pt2_alloc(pt2_data(k),N_states)
- b%cur = 0
- call select_connected(i_generator(k),energy,pt2_data(k),b,subset(k),pt2_F(i_generator(k)))
- enddo
- call wall_time(time1)
-
- integer, external :: tasks_done_to_taskserver
- if (tasks_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id,n_tasks) == -1) then
- done = .true.
- endif
- call sort_selection_buffer(b)
- call push_pt2_results(zmq_socket_push, i_generator, pt2_data, b, task_id, n_tasks)
- do k=1,n_tasks
- call pt2_dealloc(pt2_data(k))
- enddo
- b%cur=0
-
-! ! Try to adjust n_tasks around nproc/2 seconds per job
- n_tasks = min(2*n_tasks,int( dble(n_tasks * nproc/2) / (time1 - time0 + 1.d0)))
- n_tasks = min(n_tasks, pt2_n_tasks_max)
-! n_tasks = 1
- end do
-
- integer, external :: disconnect_from_taskserver
- do i=1,300
- if (disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id) /= -2) exit
- call usleep(500)
- print *, 'Retry disconnect...'
- end do
-
- call end_zmq_push_socket(zmq_socket_push,thread)
- call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
- if (buffer_ready) then
- call delete_selection_buffer(b)
- endif
- deallocate(pt2_data)
-end subroutine
-
-
-subroutine run_pt2_slave_large(thread,iproc,energy)
- use selection_types
- use f77_zmq
- implicit none
-
- double precision, intent(in) :: energy(N_states_diag)
- integer, intent(in) :: thread, iproc
- integer :: rc, i
-
- integer :: worker_id, ctask, ltask
- character*(512) :: task
- integer :: task_id(1)
-
- integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
- integer(ZMQ_PTR) :: zmq_to_qp_run_socket
-
- integer(ZMQ_PTR), external :: new_zmq_push_socket
- integer(ZMQ_PTR) :: zmq_socket_push
-
- type(selection_buffer) :: b
- logical :: done, buffer_ready
-
- type(pt2_type) :: pt2_data
- integer :: n_tasks, k, N
- integer :: i_generator, subset
-
- integer :: bsize ! Size of selection buffers
- logical :: sending
- double precision :: time_shift
-
- PROVIDE global_selection_buffer global_selection_buffer_lock
-
- call random_number(time_shift)
- time_shift = time_shift*15.d0
-
- zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
-
- integer, external :: connect_to_taskserver
- if (connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) == -1) then
- call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
- return
- endif
-
- zmq_socket_push = new_zmq_push_socket(thread)
-
- b%N = 0
- buffer_ready = .False.
- n_tasks = 1
-
- sending = .False.
- done = .False.
- double precision :: time0, time1
- call wall_time(time0)
- time0 = time0+time_shift
- do while (.not.done)
-
- integer, external :: get_tasks_from_taskserver
- if (get_tasks_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task, n_tasks) == -1) then
- exit
- endif
- done = task_id(1) == 0
- if (done) then
- n_tasks = n_tasks-1
- endif
- if (n_tasks == 0) exit
-
- call sscanf_ddd(task, subset, i_generator, N)
- if( pt2_F(i_generator) <= 0 .or. pt2_F(i_generator) > N_det ) then
- print *, irp_here
- stop 'bug in selection'
- endif
- if (b%N == 0) then
- ! Only first time
- bsize = min(N, (elec_alpha_num * (mo_num-elec_alpha_num))**2)
- call create_selection_buffer(bsize, bsize*2, b)
- buffer_ready = .True.
- else
- ASSERT (b%N == bsize)
- endif
-
- call pt2_alloc(pt2_data,N_states)
- b%cur = 0
- call select_connected(i_generator,energy,pt2_data,b,subset,pt2_F(i_generator))
-
- integer, external :: tasks_done_to_taskserver
- if (tasks_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id,n_tasks) == -1) then
- done = .true.
- endif
- call sort_selection_buffer(b)
-
- call wall_time(time1)
-! if (time1-time0 > 15.d0) then
- call omp_set_lock(global_selection_buffer_lock)
- global_selection_buffer%mini = b%mini
- call merge_selection_buffers(b,global_selection_buffer)
- b%cur=0
- call omp_unset_lock(global_selection_buffer_lock)
- call wall_time(time0)
-! endif
-
- call push_pt2_results_async_recv(zmq_socket_push,b%mini,sending)
- if ( iproc == 1 .or. i_generator < 100 .or. done) then
- call omp_set_lock(global_selection_buffer_lock)
- call push_pt2_results_async_send(zmq_socket_push, (/i_generator/), (/pt2_data/), global_selection_buffer, (/task_id/), 1,sending)
- global_selection_buffer%cur = 0
- call omp_unset_lock(global_selection_buffer_lock)
- else
- call push_pt2_results_async_send(zmq_socket_push, (/i_generator/), (/pt2_data/), b, (/task_id/), 1,sending)
- endif
-
- call pt2_dealloc(pt2_data)
- end do
- call push_pt2_results_async_recv(zmq_socket_push,b%mini,sending)
-
- integer, external :: disconnect_from_taskserver
- do i=1,300
- if (disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id) /= -2) exit
- call sleep(1)
- print *, 'Retry disconnect...'
- end do
-
- call end_zmq_push_socket(zmq_socket_push,thread)
- call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
- if (buffer_ready) then
- call delete_selection_buffer(b)
- endif
- FREE global_selection_buffer
-end subroutine
-
-
-subroutine push_pt2_results(zmq_socket_push, index, pt2_data, b, task_id, n_tasks)
- use selection_types
- use f77_zmq
- implicit none
-
- integer(ZMQ_PTR), intent(in) :: zmq_socket_push
- type(pt2_type), intent(in) :: pt2_data(n_tasks)
- integer, intent(in) :: n_tasks, index(n_tasks), task_id(n_tasks)
- type(selection_buffer), intent(inout) :: b
-
- logical :: sending
- sending = .False.
- call push_pt2_results_async_send(zmq_socket_push, index, pt2_data, b, task_id, n_tasks, sending)
- call push_pt2_results_async_recv(zmq_socket_push, b%mini, sending)
-end subroutine
-
-
-subroutine push_pt2_results_async_send(zmq_socket_push, index, pt2_data, b, task_id, n_tasks, sending)
- use selection_types
- use f77_zmq
- implicit none
-
- integer(ZMQ_PTR), intent(in) :: zmq_socket_push
- type(pt2_type), intent(in) :: pt2_data(n_tasks)
- integer, intent(in) :: n_tasks, index(n_tasks), task_id(n_tasks)
- type(selection_buffer), intent(inout) :: b
- logical, intent(inout) :: sending
- integer :: rc, i
- integer*8 :: rc8
- double precision, allocatable :: pt2_serialized(:,:)
-
- if (sending) then
- print *, irp_here, ': sending is true'
- stop -1
- endif
- sending = .True.
-
- rc = f77_zmq_send( zmq_socket_push, n_tasks, 4, ZMQ_SNDMORE)
- if (rc == -1) then
- print *, irp_here, ': error sending result'
- stop 1
- return
- else if(rc /= 4) then
- stop 'push'
- endif
-
-
- rc = f77_zmq_send( zmq_socket_push, index, 4*n_tasks, ZMQ_SNDMORE)
- if (rc == -1) then
- print *, irp_here, ': error sending result'
- stop 2
- return
- else if(rc /= 4*n_tasks) then
- stop 'push'
- endif
-
-
- allocate(pt2_serialized (pt2_type_size(N_states),n_tasks) )
- do i=1,n_tasks
- call pt2_serialize(pt2_data(i),N_states,pt2_serialized(1,i))
- enddo
-
- rc = f77_zmq_send( zmq_socket_push, pt2_serialized, size(pt2_serialized)*8, ZMQ_SNDMORE)
- deallocate(pt2_serialized)
- if (rc == -1) then
- print *, irp_here, ': error sending result'
- stop 3
- return
- else if(rc /= size(pt2_serialized)*8) then
- stop 'push'
- endif
-
-
- rc = f77_zmq_send( zmq_socket_push, task_id, n_tasks*4, ZMQ_SNDMORE)
- if (rc == -1) then
- print *, irp_here, ': error sending result'
- stop 6
- return
- else if(rc /= 4*n_tasks) then
- stop 'push'
- endif
-
-
- if (b%cur == 0) then
-
- rc = f77_zmq_send( zmq_socket_push, b%cur, 4, 0)
- if (rc == -1) then
- print *, irp_here, ': error sending result'
- stop 7
- return
- else if(rc /= 4) then
- stop 'push'
- endif
-
- else
-
- rc = f77_zmq_send( zmq_socket_push, b%cur, 4, ZMQ_SNDMORE)
- if (rc == -1) then
- print *, irp_here, ': error sending result'
- stop 7
- return
- else if(rc /= 4) then
- stop 'push'
- endif
-
-
- rc8 = f77_zmq_send8( zmq_socket_push, b%val, 8_8*int(b%cur,8), ZMQ_SNDMORE)
- if (rc8 == -1_8) then
- print *, irp_here, ': error sending result'
- stop 8
- return
- else if(rc8 /= 8_8*int(b%cur,8)) then
- stop 'push'
- endif
-
-
- rc8 = f77_zmq_send8( zmq_socket_push, b%det, int(bit_kind*N_int*2,8)*int(b%cur,8), 0)
- if (rc8 == -1_8) then
- print *, irp_here, ': error sending result'
- stop 9
- return
- else if(rc8 /= int(N_int*2*8,8)*int(b%cur,8)) then
- stop 'push'
- endif
-
- endif
-
-end subroutine
-
-subroutine push_pt2_results_async_recv(zmq_socket_push,mini,sending)
- use selection_types
- use f77_zmq
- implicit none
-
- integer(ZMQ_PTR), intent(in) :: zmq_socket_push
- double precision, intent(out) :: mini
- logical, intent(inout) :: sending
- integer :: rc
-
- if (.not.sending) return
-
-! Activate is zmq_socket_push is a REQ
-IRP_IF ZMQ_PUSH
-IRP_ELSE
- character*(2) :: ok
- rc = f77_zmq_recv( zmq_socket_push, ok, 2, 0)
- if (rc == -1) then
- print *, irp_here, ': error sending result'
- stop 10
- return
- else if ((rc /= 2).and.(ok(1:2) /= 'ok')) then
- print *, irp_here//': error in receiving ok'
- stop -1
- endif
- rc = f77_zmq_recv( zmq_socket_push, mini, 8, 0)
- if (rc == -1) then
- print *, irp_here, ': error sending result'
- stop 11
- return
- else if (rc /= 8) then
- print *, irp_here//': error in receiving mini'
- stop 12
- endif
-IRP_ENDIF
- sending = .False.
-end subroutine
-
-
-
-subroutine pull_pt2_results(zmq_socket_pull, index, pt2_data, task_id, n_tasks, b)
- use selection_types
- use f77_zmq
- implicit none
- integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
- type(pt2_type), intent(inout) :: pt2_data(*)
- type(selection_buffer), intent(inout) :: b
- integer, intent(out) :: index(*)
- integer, intent(out) :: n_tasks, task_id(*)
- integer :: rc, rn, i
- integer*8 :: rc8
- double precision, allocatable :: pt2_serialized(:,:)
-
- rc = f77_zmq_recv( zmq_socket_pull, n_tasks, 4, 0)
- if (rc == -1) then
- n_tasks = 1
- task_id(1) = 0
- else if(rc /= 4) then
- stop 'pull'
- endif
-
- rc = f77_zmq_recv( zmq_socket_pull, index, 4*n_tasks, 0)
- if (rc == -1) then
- n_tasks = 1
- task_id(1) = 0
- else if(rc /= 4*n_tasks) then
- stop 'pull'
- endif
-
- allocate(pt2_serialized (pt2_type_size(N_states),n_tasks) )
- rc = f77_zmq_recv( zmq_socket_pull, pt2_serialized, 8*size(pt2_serialized)*n_tasks, 0)
- if (rc == -1) then
- n_tasks = 1
- task_id(1) = 0
- else if(rc /= 8*size(pt2_serialized)) then
- stop 'pull'
- endif
-
- do i=1,n_tasks
- call pt2_deserialize(pt2_data(i),N_states,pt2_serialized(1,i))
- enddo
- deallocate(pt2_serialized)
-
- rc = f77_zmq_recv( zmq_socket_pull, task_id, n_tasks*4, 0)
- if (rc == -1) then
- n_tasks = 1
- task_id(1) = 0
- else if(rc /= 4*n_tasks) then
- stop 'pull'
- endif
-
- rc = f77_zmq_recv( zmq_socket_pull, b%cur, 4, 0)
- if (rc == -1) then
- n_tasks = 1
- task_id(1) = 0
- else if(rc /= 4) then
- stop 'pull'
- endif
-
- if (b%cur > 0) then
-
- rc8 = f77_zmq_recv8( zmq_socket_pull, b%val, 8_8*int(b%cur,8), 0)
- if (rc8 == -1_8) then
- n_tasks = 1
- task_id(1) = 0
- else if(rc8 /= 8_8*int(b%cur,8)) then
- stop 'pull'
- endif
-
- rc8 = f77_zmq_recv8( zmq_socket_pull, b%det, int(bit_kind*N_int*2,8)*int(b%cur,8), 0)
- if (rc8 == -1_8) then
- n_tasks = 1
- task_id(1) = 0
- else if(rc8 /= int(N_int*2*8,8)*int(b%cur,8)) then
- stop 'pull'
- endif
-
- endif
-
-! Activate is zmq_socket_pull is a REP
-IRP_IF ZMQ_PUSH
-IRP_ELSE
- rc = f77_zmq_send( zmq_socket_pull, 'ok', 2, ZMQ_SNDMORE)
- if (rc == -1) then
- n_tasks = 1
- task_id(1) = 0
- else if (rc /= 2) then
- print *, irp_here//': error in sending ok'
- stop -1
- endif
- rc = f77_zmq_send( zmq_socket_pull, b%mini, 8, 0)
-IRP_ENDIF
-
-end subroutine
-
diff --git a/plugins/local/cipsi_tc_bi_ortho/run_selection_slave.irp.f b/plugins/local/cipsi_tc_bi_ortho/run_selection_slave.irp.f
index d351cc79..aaf2f31d 100644
--- a/plugins/local/cipsi_tc_bi_ortho/run_selection_slave.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/run_selection_slave.irp.f
@@ -1,255 +1,5 @@
-subroutine run_selection_slave(thread, iproc, energy)
-
- use f77_zmq
- use selection_types
-
- implicit none
-
- double precision, intent(in) :: energy(N_states)
- integer, intent(in) :: thread, iproc
-
- integer :: rc, i
- integer :: worker_id, task_id(1), ctask, ltask
- character*(512) :: task
- integer(ZMQ_PTR) :: zmq_to_qp_run_socket
- integer(ZMQ_PTR) :: zmq_socket_push
- integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket
- integer(ZMQ_PTR), external :: new_zmq_push_socket
- type(selection_buffer) :: buf, buf2
- type(pt2_type) :: pt2_data
- logical :: done, buffer_ready
-
- PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
- PROVIDE psi_bilinear_matrix_rows psi_det_sorted_tc_order psi_bilinear_matrix_order
- PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
- PROVIDE psi_bilinear_matrix_transp_order N_int pt2_F pseudo_sym
- PROVIDE psi_selectors_coef_transp_tc psi_det_sorted_tc weight_selection
-
- call pt2_alloc(pt2_data,N_states)
-
- zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
-
- integer, external :: connect_to_taskserver
- if (connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) == -1) then
- call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
- return
- endif
-
- zmq_socket_push = new_zmq_push_socket(thread)
-
- buf%N = 0
- buffer_ready = .False.
- ctask = 1
-
- do
- integer, external :: get_task_from_taskserver
- if (get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id(ctask), task) == -1) then
- exit
- endif
- done = task_id(ctask) == 0
- if (done) then
- ctask = ctask - 1
- else
- integer :: i_generator, N, subset, bsize
- call sscanf_ddd(task, subset, i_generator, N)
- if(buf%N == 0) then
- ! Only first time
- call create_selection_buffer(N, N*2, buf)
- buffer_ready = .True.
- else
- if (N /= buf%N) then
- print *, 'N=', N
- print *, 'buf%N=', buf%N
- print *, 'bug in ', irp_here
- stop '-1'
- end if
- end if
- call select_connected(i_generator, energy, pt2_data, buf,subset, pt2_F(i_generator))
- endif
-
- integer, external :: task_done_to_taskserver
-
- if(done .or. ctask == size(task_id)) then
- do i=1, ctask
- if (task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i)) == -1) then
- call usleep(100)
- if (task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i)) == -1) then
- ctask = 0
- done = .true.
- exit
- endif
- endif
- end do
- if(ctask > 0) then
- call sort_selection_buffer(buf)
-! call merge_selection_buffers(buf,buf2)
- call push_selection_results(zmq_socket_push, pt2_data, buf, task_id(1), ctask)
- call pt2_dealloc(pt2_data)
- call pt2_alloc(pt2_data,N_states)
-! buf%mini = buf2%mini
- buf%cur = 0
- end if
- ctask = 0
- end if
-
- if(done) exit
- ctask = ctask + 1
- end do
-
- if(ctask > 0) then
- call sort_selection_buffer(buf)
-! call merge_selection_buffers(buf,buf2)
- call push_selection_results(zmq_socket_push, pt2_data, buf, task_id(1), ctask)
-! buf%mini = buf2%mini
- buf%cur = 0
- end if
- ctask = 0
- call pt2_dealloc(pt2_data)
-
- integer, external :: disconnect_from_taskserver
- if (disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id) == -1) then
- continue
- endif
-
- call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
- call end_zmq_push_socket(zmq_socket_push,thread)
- if (buffer_ready) then
- call delete_selection_buffer(buf)
-! call delete_selection_buffer(buf2)
- endif
-end subroutine
-
-
-subroutine push_selection_results(zmq_socket_push, pt2_data, b, task_id, ntasks)
- use f77_zmq
- use selection_types
- implicit none
-
- integer(ZMQ_PTR), intent(in) :: zmq_socket_push
- type(pt2_type), intent(in) :: pt2_data
- type(selection_buffer), intent(inout) :: b
- integer, intent(in) :: ntasks, task_id(*)
- integer :: rc
- double precision, allocatable :: pt2_serialized(:)
-
- rc = f77_zmq_send( zmq_socket_push, b%cur, 4, ZMQ_SNDMORE)
- if(rc /= 4) then
- print *, 'f77_zmq_send( zmq_socket_push, b%cur, 4, ZMQ_SNDMORE)'
- endif
-
-
- allocate(pt2_serialized (pt2_type_size(N_states)) )
- call pt2_serialize(pt2_data,N_states,pt2_serialized)
-
- rc = f77_zmq_send( zmq_socket_push, pt2_serialized, size(pt2_serialized)*8, ZMQ_SNDMORE)
- if (rc == -1) then
- print *, irp_here, ': error sending result'
- stop 3
- return
- else if(rc /= size(pt2_serialized)*8) then
- stop 'push'
- endif
- deallocate(pt2_serialized)
-
- if (b%cur > 0) then
-
- rc = f77_zmq_send( zmq_socket_push, b%val(1), 8*b%cur, ZMQ_SNDMORE)
- if(rc /= 8*b%cur) then
- print *, 'f77_zmq_send( zmq_socket_push, b%val(1), 8*b%cur, ZMQ_SNDMORE)'
- endif
-
- rc = f77_zmq_send( zmq_socket_push, b%det(1,1,1), bit_kind*N_int*2*b%cur, ZMQ_SNDMORE)
- if(rc /= bit_kind*N_int*2*b%cur) then
- print *, 'f77_zmq_send( zmq_socket_push, b%det(1,1,1), bit_kind*N_int*2*b%cur, ZMQ_SNDMORE)'
- endif
-
- endif
-
- rc = f77_zmq_send( zmq_socket_push, ntasks, 4, ZMQ_SNDMORE)
- if(rc /= 4) then
- print *, 'f77_zmq_send( zmq_socket_push, ntasks, 4, ZMQ_SNDMORE)'
- endif
-
- rc = f77_zmq_send( zmq_socket_push, task_id(1), ntasks*4, 0)
- if(rc /= 4*ntasks) then
- print *, 'f77_zmq_send( zmq_socket_push, task_id(1), ntasks*4, 0)'
- endif
-
-! Activate is zmq_socket_push is a REQ
-IRP_IF ZMQ_PUSH
-IRP_ELSE
- character*(2) :: ok
- rc = f77_zmq_recv( zmq_socket_push, ok, 2, 0)
- if ((rc /= 2).and.(ok(1:2) /= 'ok')) then
- print *, irp_here//': error in receiving ok'
- stop -1
- endif
-IRP_ENDIF
-
-end subroutine
-
-
-subroutine pull_selection_results(zmq_socket_pull, pt2_data, val, det, N, task_id, ntasks)
- use f77_zmq
- use selection_types
- implicit none
- integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
- type(pt2_type), intent(inout) :: pt2_data
- double precision, intent(out) :: val(*)
- integer(bit_kind), intent(out) :: det(N_int, 2, *)
- integer, intent(out) :: N, ntasks, task_id(*)
- integer :: rc, rn, i
- double precision, allocatable :: pt2_serialized(:)
-
- rc = f77_zmq_recv( zmq_socket_pull, N, 4, 0)
- if(rc /= 4) then
- print *, 'f77_zmq_recv( zmq_socket_pull, N, 4, 0)'
- endif
-
- allocate(pt2_serialized (pt2_type_size(N_states)) )
- rc = f77_zmq_recv( zmq_socket_pull, pt2_serialized, 8*size(pt2_serialized), 0)
- if (rc == -1) then
- ntasks = 1
- task_id(1) = 0
- else if(rc /= 8*size(pt2_serialized)) then
- stop 'pull'
- endif
-
- call pt2_deserialize(pt2_data,N_states,pt2_serialized)
- deallocate(pt2_serialized)
-
- if (N>0) then
- rc = f77_zmq_recv( zmq_socket_pull, val(1), 8*N, 0)
- if(rc /= 8*N) then
- print *, 'f77_zmq_recv( zmq_socket_pull, val(1), 8*N, 0)'
- endif
-
- rc = f77_zmq_recv( zmq_socket_pull, det(1,1,1), bit_kind*N_int*2*N, 0)
- if(rc /= bit_kind*N_int*2*N) then
- print *, 'f77_zmq_recv( zmq_socket_pull, det(1,1,1), bit_kind*N_int*2*N, 0)'
- endif
- endif
-
- rc = f77_zmq_recv( zmq_socket_pull, ntasks, 4, 0)
- if(rc /= 4) then
- print *, 'f77_zmq_recv( zmq_socket_pull, ntasks, 4, 0)'
- endif
-
- rc = f77_zmq_recv( zmq_socket_pull, task_id(1), ntasks*4, 0)
- if(rc /= 4*ntasks) then
- print *, 'f77_zmq_recv( zmq_socket_pull, task_id(1), ntasks*4, 0)'
- endif
-
-! Activate is zmq_socket_pull is a REP
-IRP_IF ZMQ_PUSH
-IRP_ELSE
- rc = f77_zmq_send( zmq_socket_pull, 'ok', 2, 0)
- if (rc /= 2) then
- print *, irp_here//': error in sending ok'
- stop -1
- endif
-IRP_ENDIF
-end subroutine
-
-
+subroutine provide_for_selection_slave
+ PROVIDE psi_det_sorted_tc_order
+ PROVIDE psi_selectors_coef_transp_tc psi_det_sorted_tc
+end
diff --git a/plugins/local/cipsi_tc_bi_ortho/selection.irp.f b/plugins/local/cipsi_tc_bi_ortho/selection.irp.f
index 06cf848b..72ccf9c4 100644
--- a/plugins/local/cipsi_tc_bi_ortho/selection.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/selection.irp.f
@@ -76,6 +76,8 @@ subroutine select_connected(i_generator,E0,pt2_data,b,subset,csubset)
double precision, allocatable :: fock_diag_tmp(:,:)
+ if (csubset == 0) return
+
allocate(fock_diag_tmp(2,mo_num+1))
call build_fock_tmp_tc(fock_diag_tmp, psi_det_generators(1,1,i_generator), N_int)
@@ -86,10 +88,13 @@ subroutine select_connected(i_generator,E0,pt2_data,b,subset,csubset)
particle_mask(k,1) = iand(generators_bitmask(k,1,s_part), not(psi_det_generators(k,1,i_generator)) )
particle_mask(k,2) = iand(generators_bitmask(k,2,s_part), not(psi_det_generators(k,2,i_generator)) )
enddo
+! if ((subset == 1).and.(sum(hole_mask(:,2)) == 0_bit_kind)) then
+! ! No beta electron to excite
+! call select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2_data,b)
+! endif
call select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2_data,b,subset,csubset)
deallocate(fock_diag_tmp)
-end subroutine select_connected
-
+end subroutine
double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2, Nint)
@@ -136,7 +141,7 @@ double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2, Nint)
end
-subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock_diag_tmp, E0, pt2_data, buf, subset, csubset)
+subroutine select_singles_and_doubles(i_generator, hole_mask, particle_mask, fock_diag_tmp, E0, pt2_data, buf, subset, csubset)
use bitmasks
use selection_types
implicit none
@@ -151,8 +156,6 @@ subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock
type(pt2_type), intent(inout) :: pt2_data
type(selection_buffer), intent(inout) :: buf
- double precision, parameter :: norm_thr = 1.d-16
-
integer :: h1, h2, s1, s2, s3, i1, i2, ib, sp, k, i, j, nt, ii, sze
integer :: maskInd
integer :: N_holes(2), N_particles(2)
@@ -170,6 +173,7 @@ subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock
integer, allocatable :: preinteresting(:), prefullinteresting(:)
integer, allocatable :: interesting(:), fullinteresting(:)
integer, allocatable :: tmp_array(:)
+
integer, allocatable :: indices(:), exc_degree(:), iorder(:)
integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :)
logical, allocatable :: banned(:,:,:), bannedOrb(:,:)
@@ -178,15 +182,16 @@ subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock
PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
- PROVIDE psi_bilinear_matrix_rows psi_det_sorted_tc_order psi_bilinear_matrix_order
+ PROVIDE psi_bilinear_matrix_rows psi_bilinear_matrix_order psi_bilinear_matrix_transp_order
PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
- PROVIDE psi_bilinear_matrix_transp_order psi_selectors_coef_transp_tc
+ PROVIDE psi_selectors_coef_transp_tc psi_det_sorted_tc_order
PROVIDE banned_excitation
monoAdo = .true.
monoBdo = .true.
+ if (csubset == 0) return
do k=1,N_int
hole (k,1) = iand(psi_det_generators(k,1,i_generator), hole_mask(k,1))
@@ -198,7 +203,11 @@ subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock
call bitstring_to_list_ab(hole , hole_list , N_holes , N_int)
call bitstring_to_list_ab(particle, particle_list, N_particles, N_int)
- allocate( indices(N_det), exc_degree( max(N_det_alpha_unique, N_det_beta_unique) ) )
+ ! Removed to avoid introducing determinants already presents in the wf
+ !double precision, parameter :: norm_thr = 1.d-16
+
+ allocate (indices(N_det), &
+ exc_degree(max(N_det_alpha_unique,N_det_beta_unique)))
! Pre-compute excitation degrees wrt alpha determinants
k=1
@@ -214,73 +223,76 @@ subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock
if (nt > 2) cycle
do l_a=psi_bilinear_matrix_columns_loc(j), psi_bilinear_matrix_columns_loc(j+1)-1
i = psi_bilinear_matrix_rows(l_a)
- if(nt + exc_degree(i) <= 4) then
+ if (nt + exc_degree(i) <= 4) then
idx = psi_det_sorted_tc_order(psi_bilinear_matrix_order(l_a))
-! if (psi_average_norm_contrib_sorted_tc(idx) > norm_thr) then
+ ! Removed to avoid introducing determinants already presents in the wf
+ !if (psi_average_norm_contrib_sorted_tc(idx) > norm_thr) then
indices(k) = idx
- k = k + 1
-! endif
+ k=k+1
+ !endif
endif
enddo
enddo
! Pre-compute excitation degrees wrt beta determinants
do i=1,N_det_beta_unique
- call get_excitation_degree_spin(psi_det_beta_unique(1,i), psi_det_generators(1,2,i_generator), exc_degree(i), N_int)
+ call get_excitation_degree_spin(psi_det_beta_unique(1,i), &
+ psi_det_generators(1,2,i_generator), exc_degree(i), N_int)
enddo
! Iterate on 0S alpha, and find betas TQ such that exc_degree <= 4
- ! Remove also contributions < 1.d-20)
do j=1,N_det_alpha_unique
- call get_excitation_degree_spin(psi_det_alpha_unique(1,j), psi_det_generators(1,1,i_generator), nt, N_int)
+ call get_excitation_degree_spin(psi_det_alpha_unique(1,j), &
+ psi_det_generators(1,1,i_generator), nt, N_int)
if (nt > 1) cycle
- do l_a = psi_bilinear_matrix_transp_rows_loc(j), psi_bilinear_matrix_transp_rows_loc(j+1)-1
+ do l_a=psi_bilinear_matrix_transp_rows_loc(j), psi_bilinear_matrix_transp_rows_loc(j+1)-1
i = psi_bilinear_matrix_transp_columns(l_a)
- if(exc_degree(i) < 3) cycle
- if(nt + exc_degree(i) <= 4) then
+ if (exc_degree(i) < 3) cycle
+ if (nt + exc_degree(i) <= 4) then
idx = psi_det_sorted_tc_order( &
psi_bilinear_matrix_order( &
psi_bilinear_matrix_transp_order(l_a)))
-! if(psi_average_norm_contrib_sorted_tc(idx) > norm_thr) then
+ ! Removed to avoid introducing determinants already presents in the wf
+ !if(psi_average_norm_contrib_sorted_tc(idx) > norm_thr) then
indices(k) = idx
- k = k + 1
-! endif
+ k=k+1
+ !endif
endif
enddo
enddo
deallocate(exc_degree)
- nmax = k - 1
+ nmax=k-1
call isort_noidx(indices,nmax)
! Start with 32 elements. Size will double along with the filtering.
- allocate(preinteresting(0:32), prefullinteresting(0:32), interesting(0:32), fullinteresting(0:32))
+ allocate(preinteresting(0:32), prefullinteresting(0:32), &
+ interesting(0:32), fullinteresting(0:32))
preinteresting(:) = 0
prefullinteresting(:) = 0
- do i = 1, N_int
+ do i=1,N_int
negMask(i,1) = not(psi_det_generators(i,1,i_generator))
negMask(i,2) = not(psi_det_generators(i,2,i_generator))
- enddo
-
- do k = 1, nmax
+ end do
+ do k=1,nmax
i = indices(k)
mobMask(1,1) = iand(negMask(1,1), psi_det_sorted_tc(1,1,i))
mobMask(1,2) = iand(negMask(1,2), psi_det_sorted_tc(1,2,i))
nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2))
- do j = 2, N_int
+ do j=2,N_int
mobMask(j,1) = iand(negMask(j,1), psi_det_sorted_tc(j,1,i))
mobMask(j,2) = iand(negMask(j,2), psi_det_sorted_tc(j,2,i))
nt = nt + popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2))
- enddo
+ end do
if(nt <= 4) then
if(i <= N_det_selectors) then
sze = preinteresting(0)
- if(sze+1 == size(preinteresting)) then
- allocate(tmp_array(0:sze))
+ if (sze+1 == size(preinteresting)) then
+ allocate (tmp_array(0:sze))
tmp_array(0:sze) = preinteresting(0:sze)
deallocate(preinteresting)
allocate(preinteresting(0:2*sze))
@@ -289,9 +301,9 @@ subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock
endif
preinteresting(0) = sze+1
preinteresting(sze+1) = i
- elseif(nt <= 2) then
+ else if(nt <= 2) then
sze = prefullinteresting(0)
- if(sze+1 == size(prefullinteresting)) then
+ if (sze+1 == size(prefullinteresting)) then
allocate (tmp_array(0:sze))
tmp_array(0:sze) = prefullinteresting(0:sze)
deallocate(prefullinteresting)
@@ -301,20 +313,16 @@ subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock
endif
prefullinteresting(0) = sze+1
prefullinteresting(sze+1) = i
- endif
- endif
-
- enddo
+ end if
+ end if
+ end do
deallocate(indices)
- allocate( banned(mo_num, mo_num,2), bannedOrb(mo_num, 2) )
- allocate( mat(N_states, mo_num, mo_num) )
- allocate( mat_l(N_states, mo_num, mo_num), mat_r(N_states, mo_num, mo_num) )
+ allocate(banned(mo_num, mo_num,2), bannedOrb(mo_num, 2))
+ allocate(mat(N_states, mo_num, mo_num))
+ allocate(mat_l(N_states, mo_num, mo_num), mat_r(N_states, mo_num, mo_num))
maskInd = -1
-
-
-
do s1 = 1, 2
do i1 = N_holes(s1), 1, -1 ! Generate low excitations first
@@ -347,17 +355,17 @@ subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock
do ii = 1, preinteresting(0)
i = preinteresting(ii)
- select case(N_int)
- case(1)
+ select case (N_int)
+ case (1)
mobMask(1,1) = iand(negMask(1,1), psi_det_sorted_tc(1,1,i))
mobMask(1,2) = iand(negMask(1,2), psi_det_sorted_tc(1,2,i))
nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2))
- case(2)
+ case (2)
mobMask(1:2,1) = iand(negMask(1:2,1), psi_det_sorted_tc(1:2,1,i))
mobMask(1:2,2) = iand(negMask(1:2,2), psi_det_sorted_tc(1:2,2,i))
nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2)) + &
popcnt(mobMask(2, 1)) + popcnt(mobMask(2, 2))
- case(3)
+ case (3)
mobMask(1:3,1) = iand(negMask(1:3,1), psi_det_sorted_tc(1:3,1,i))
mobMask(1:3,2) = iand(negMask(1:3,2), psi_det_sorted_tc(1:3,2,i))
nt = 0
@@ -370,8 +378,8 @@ subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock
nt = nt+ popcnt(mobMask(j, 2))
if (nt > 4) exit
endif
- enddo
- case(4)
+ end do
+ case (4)
mobMask(1:4,1) = iand(negMask(1:4,1), psi_det_sorted_tc(1:4,1,i))
mobMask(1:4,2) = iand(negMask(1:4,2), psi_det_sorted_tc(1:4,2,i))
nt = 0
@@ -384,7 +392,7 @@ subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock
nt = nt+ popcnt(mobMask(j, 2))
if (nt > 4) exit
endif
- enddo
+ end do
case default
mobMask(1:N_int,1) = iand(negMask(1:N_int,1), psi_det_sorted_tc(1:N_int,1,i))
mobMask(1:N_int,2) = iand(negMask(1:N_int,2), psi_det_sorted_tc(1:N_int,2,i))
@@ -398,12 +406,12 @@ subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock
nt = nt+ popcnt(mobMask(j, 2))
if (nt > 4) exit
endif
- enddo
+ end do
end select
if(nt <= 4) then
sze = interesting(0)
- if(sze+1 == size(interesting)) then
+ if (sze+1 == size(interesting)) then
allocate (tmp_array(0:sze))
tmp_array(0:sze) = interesting(0:sze)
deallocate(interesting)
@@ -425,8 +433,8 @@ subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock
endif
fullinteresting(0) = sze+1
fullinteresting(sze+1) = i
- endif
- endif
+ end if
+ end if
enddo
@@ -456,10 +464,10 @@ subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock
endif
fullinteresting(0) = sze+1
fullinteresting(sze+1) = i
- endif
- enddo
- allocate( fullminilist (N_int, 2, fullinteresting(0)), &
- minilist (N_int, 2, interesting(0)) )
+ end if
+ end do
+ allocate (fullminilist (N_int, 2, fullinteresting(0)), &
+ minilist (N_int, 2, interesting(0)) )
do i = 1, fullinteresting(0)
do k = 1, N_int
@@ -517,7 +525,8 @@ subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock
call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting, mat_l, mat_r)
call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2_data, mat, buf, mat_l, mat_r)
- endif
+ end if
+
enddo
@@ -533,7 +542,8 @@ subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock
deallocate(banned, bannedOrb,mat)
deallocate(mat_l, mat_r)
-end subroutine select_singles_and_doubles
+
+end subroutine
! ---
@@ -626,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
@@ -681,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
- 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)))
+ 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)
@@ -785,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
@@ -872,104 +896,27 @@ 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
- val = 4.d0 * psi_h_alpha * alpha_h_psi
+ 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
- coef(istate) = e_pert(istate) / psi_h_alpha
+ 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
+ coef(istate) = alpha_h_psi / delta_E
endif
if(selection_tc == 1)then
- if(e_pert(istate).lt.0.d0)then
+ if(e_pert(istate).lt.0.d0)then
e_pert(istate)=0.d0
- else
+ else
e_pert(istate)=-e_pert(istate)
endif
else if(selection_tc == -1)then
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
@@ -980,8 +927,11 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
psi_h_alpha = mat_l(istate, p1, p2)
pt2_data % overlap(:,istate) = pt2_data % overlap(:,istate) + coef(:) * coef(istate)
- pt2_data % variance(istate) = pt2_data % variance(istate) + dabs(e_pert(istate))
- pt2_data % pt2(istate) = pt2_data % pt2(istate) + e_pert(istate)
+ if(e_pert(istate).gt.0.d0)then! accumulate the positive part of the pt2
+ pt2_data % variance(istate) = pt2_data % variance(istate) + e_pert(istate)
+ else ! accumulate the negative part of the pt2
+ pt2_data % pt2(istate) = pt2_data % pt2(istate) + e_pert(istate)
+ endif
select case (weight_selection)
case(5)
diff --git a/plugins/local/cipsi_tc_bi_ortho/selection_buffer.irp.f b/plugins/local/cipsi_tc_bi_ortho/selection_buffer.irp.f
deleted file mode 100644
index 0bd51464..00000000
--- a/plugins/local/cipsi_tc_bi_ortho/selection_buffer.irp.f
+++ /dev/null
@@ -1,424 +0,0 @@
-
-subroutine create_selection_buffer(N, size_in, res)
- use selection_types
- implicit none
- BEGIN_DOC
-! Allocates the memory for a selection buffer.
-! The arrays have dimension size_in and the maximum number of elements is N
- END_DOC
-
- integer, intent(in) :: N, size_in
- type(selection_buffer), intent(out) :: res
-
- integer :: siz
- siz = max(size_in,1)
-
- double precision :: rss
- double precision, external :: memory_of_double
- rss = memory_of_double(siz)*(N_int*2+1)
- call check_mem(rss,irp_here)
-
- allocate(res%det(N_int, 2, siz), res%val(siz))
-
- res%val(:) = 0d0
- res%det(:,:,:) = 0_8
- res%N = N
- res%mini = 0d0
- res%cur = 0
-end subroutine
-
-subroutine delete_selection_buffer(b)
- use selection_types
- implicit none
- type(selection_buffer), intent(inout) :: b
- if (associated(b%det)) then
- deallocate(b%det)
- endif
- if (associated(b%val)) then
- deallocate(b%val)
- endif
- NULLIFY(b%det)
- NULLIFY(b%val)
- b%cur = 0
- b%mini = 0.d0
- b%N = 0
-end
-
-
-subroutine add_to_selection_buffer(b, det, val)
- use selection_types
- implicit none
-
- type(selection_buffer), intent(inout) :: b
- integer(bit_kind), intent(in) :: det(N_int, 2)
- double precision, intent(in) :: val
- integer :: i
-
- if(b%N > 0 .and. val <= b%mini) then
- b%cur += 1
- b%det(1:N_int,1:2,b%cur) = det(1:N_int,1:2)
- b%val(b%cur) = val
- if(b%cur == size(b%val)) then
- call sort_selection_buffer(b)
- end if
- end if
-end subroutine
-
-subroutine merge_selection_buffers(b1, b2)
- use selection_types
- implicit none
- BEGIN_DOC
-! Merges the selection buffers b1 and b2 into b2
- END_DOC
- type(selection_buffer), intent(inout) :: b1
- type(selection_buffer), intent(inout) :: b2
- integer(bit_kind), pointer :: detmp(:,:,:)
- double precision, pointer :: val(:)
- integer :: i, i1, i2, k, nmwen, sze
- if (b1%cur == 0) return
- do while (b1%val(b1%cur) > b2%mini)
- b1%cur = b1%cur-1
- if (b1%cur == 0) then
- return
- endif
- enddo
- nmwen = min(b1%N, b1%cur+b2%cur)
- double precision :: rss
- double precision, external :: memory_of_double
- sze = max(size(b1%val), size(b2%val))
- rss = memory_of_double(sze) + 2*N_int*memory_of_double(sze)
- call check_mem(rss,irp_here)
- allocate(val(sze), detmp(N_int, 2, sze))
- i1=1
- i2=1
- do i=1,nmwen
- if ( (i1 > b1%cur).and.(i2 > b2%cur) ) then
- exit
- else if (i1 > b1%cur) then
- val(i) = b2%val(i2)
- detmp(1:N_int,1,i) = b2%det(1:N_int,1,i2)
- detmp(1:N_int,2,i) = b2%det(1:N_int,2,i2)
- i2=i2+1
- else if (i2 > b2%cur) then
- val(i) = b1%val(i1)
- detmp(1:N_int,1,i) = b1%det(1:N_int,1,i1)
- detmp(1:N_int,2,i) = b1%det(1:N_int,2,i1)
- i1=i1+1
- else
- if (b1%val(i1) <= b2%val(i2)) then
- val(i) = b1%val(i1)
- detmp(1:N_int,1,i) = b1%det(1:N_int,1,i1)
- detmp(1:N_int,2,i) = b1%det(1:N_int,2,i1)
- i1=i1+1
- else
- val(i) = b2%val(i2)
- detmp(1:N_int,1,i) = b2%det(1:N_int,1,i2)
- detmp(1:N_int,2,i) = b2%det(1:N_int,2,i2)
- i2=i2+1
- endif
- endif
- enddo
- deallocate(b2%det, b2%val)
- do i=nmwen+1,b2%N
- val(i) = 0.d0
- detmp(1:N_int,1:2,i) = 0_bit_kind
- enddo
- b2%det => detmp
- b2%val => val
-! if(selection_tc == 1)then
-! b2%mini = max(b2%mini,b2%val(b2%N))
-! else
- b2%mini = min(b2%mini,b2%val(b2%N))
-! endif
- b2%cur = nmwen
-end
-
-
-subroutine sort_selection_buffer(b)
- use selection_types
- implicit none
-
- type(selection_buffer), intent(inout) :: b
- integer, allocatable :: iorder(:)
- integer(bit_kind), pointer :: detmp(:,:,:)
- integer :: i, nmwen
- logical, external :: detEq
- if (b%N == 0 .or. b%cur == 0) return
- nmwen = min(b%N, b%cur)
-
- double precision :: rss
- double precision, external :: memory_of_double, memory_of_int
- rss = memory_of_int(b%cur) + 2*N_int*memory_of_double(size(b%det,3))
- call check_mem(rss,irp_here)
- allocate(iorder(b%cur), detmp(N_int, 2, size(b%det,3)))
- do i=1,b%cur
- iorder(i) = i
- end do
- call dsort(b%val, iorder, b%cur)
- do i=1, nmwen
- detmp(1:N_int,1,i) = b%det(1:N_int,1,iorder(i))
- detmp(1:N_int,2,i) = b%det(1:N_int,2,iorder(i))
- end do
- deallocate(b%det,iorder)
- b%det => detmp
-! if(selection_tc == 1)then
-! b%mini = max(b%mini,b%val(b%N))
-! else
- b%mini = min(b%mini,b%val(b%N))
-! endif
- b%cur = nmwen
-end subroutine
-
-subroutine make_selection_buffer_s2(b)
- use selection_types
- type(selection_buffer), intent(inout) :: b
-
- integer(bit_kind), allocatable :: o(:,:,:)
- double precision, allocatable :: val(:)
-
- integer :: n_d
- integer :: i,k,sze,n_alpha,j,n
- logical :: dup
-
- ! Sort
- integer, allocatable :: iorder(:)
- integer*8, allocatable :: bit_tmp(:)
- integer*8, external :: configuration_search_key
- integer(bit_kind), allocatable :: tmp_array(:,:,:)
- logical, allocatable :: duplicate(:)
-
- n_d = b%cur
- double precision :: rss
- double precision, external :: memory_of_double
- rss = (4*N_int+4)*memory_of_double(n_d)
- call check_mem(rss,irp_here)
- allocate(o(N_int,2,n_d), iorder(n_d), duplicate(n_d), bit_tmp(n_d), &
- tmp_array(N_int,2,n_d), val(n_d) )
-
- do i=1,n_d
- do k=1,N_int
- o(k,1,i) = ieor(b%det(k,1,i), b%det(k,2,i))
- o(k,2,i) = iand(b%det(k,1,i), b%det(k,2,i))
- enddo
- iorder(i) = i
- bit_tmp(i) = configuration_search_key(o(1,1,i),N_int)
- enddo
-
- deallocate(b%det)
-
- call i8sort(bit_tmp,iorder,n_d)
-
- do i=1,n_d
- do k=1,N_int
- tmp_array(k,1,i) = o(k,1,iorder(i))
- tmp_array(k,2,i) = o(k,2,iorder(i))
- enddo
- val(i) = b%val(iorder(i))
- duplicate(i) = .False.
- enddo
-
- ! Find duplicates
- do i=1,n_d-1
- if (duplicate(i)) then
- cycle
- endif
- j = i+1
- do while (bit_tmp(j)==bit_tmp(i))
- if (duplicate(j)) then
- j+=1
- if (j>n_d) then
- exit
- endif
- cycle
- endif
- dup = .True.
- do k=1,N_int
- if ( (tmp_array(k,1,i) /= tmp_array(k,1,j)) &
- .or. (tmp_array(k,2,i) /= tmp_array(k,2,j)) ) then
- dup = .False.
- exit
- endif
- enddo
- if (dup) then
- val(i) = max(val(i), val(j))
- duplicate(j) = .True.
- endif
- j+=1
- if (j>n_d) then
- exit
- endif
- enddo
- enddo
-
- deallocate (b%val)
- ! Copy filtered result
- integer :: n_p
- n_p=0
- do i=1,n_d
- if (duplicate(i)) then
- cycle
- endif
- n_p = n_p + 1
- do k=1,N_int
- o(k,1,n_p) = tmp_array(k,1,i)
- o(k,2,n_p) = tmp_array(k,2,i)
- enddo
- val(n_p) = val(i)
- enddo
-
- ! Sort by importance
- do i=1,n_p
- iorder(i) = i
- end do
- call dsort(val,iorder,n_p)
- do i=1,n_p
- do k=1,N_int
- tmp_array(k,1,i) = o(k,1,iorder(i))
- tmp_array(k,2,i) = o(k,2,iorder(i))
- enddo
- enddo
- do i=1,n_p
- do k=1,N_int
- o(k,1,i) = tmp_array(k,1,i)
- o(k,2,i) = tmp_array(k,2,i)
- enddo
- enddo
-
- ! Create determinants
- n_d = 0
- do i=1,n_p
- call configuration_to_dets_size(o(1,1,i),sze,elec_alpha_num,N_int)
- n_d = n_d + sze
- if (n_d > b%cur) then
-! if (n_d - b%cur > b%cur - n_d + sze) then
-! n_d = n_d - sze
-! endif
- exit
- endif
- enddo
-
- rss = (4*N_int+2)*memory_of_double(n_d)
- call check_mem(rss,irp_here)
- allocate(b%det(N_int,2,2*n_d), b%val(2*n_d))
- k=1
- do i=1,n_p
- n=n_d
- call configuration_to_dets_size(o(1,1,i),n,elec_alpha_num,N_int)
- call configuration_to_dets(o(1,1,i),b%det(1,1,k),n,elec_alpha_num,N_int)
- do j=k,k+n-1
- b%val(j) = val(i)
- enddo
- k = k+n
- if (k > n_d) exit
- enddo
- deallocate(o)
- b%cur = n_d
- b%N = n_d
-end
-
-
-
-
-subroutine remove_duplicates_in_selection_buffer(b)
- use selection_types
- type(selection_buffer), intent(inout) :: b
-
- integer(bit_kind), allocatable :: o(:,:,:)
- double precision, allocatable :: val(:)
-
- integer :: n_d
- integer :: i,k,sze,n_alpha,j,n
- logical :: dup
-
- ! Sort
- integer, allocatable :: iorder(:)
- integer*8, allocatable :: bit_tmp(:)
- integer*8, external :: det_search_key
- integer(bit_kind), allocatable :: tmp_array(:,:,:)
- logical, allocatable :: duplicate(:)
-
- n_d = b%cur
- logical :: found_duplicates
- double precision :: rss
- double precision, external :: memory_of_double
- rss = (4*N_int+4)*memory_of_double(n_d)
- call check_mem(rss,irp_here)
-
- found_duplicates = .False.
- allocate(iorder(n_d), duplicate(n_d), bit_tmp(n_d), &
- tmp_array(N_int,2,n_d), val(n_d) )
-
- do i=1,n_d
- iorder(i) = i
- bit_tmp(i) = det_search_key(b%det(1,1,i),N_int)
- enddo
-
- call i8sort(bit_tmp,iorder,n_d)
-
- do i=1,n_d
- do k=1,N_int
- tmp_array(k,1,i) = b%det(k,1,iorder(i))
- tmp_array(k,2,i) = b%det(k,2,iorder(i))
- enddo
- val(i) = b%val(iorder(i))
- duplicate(i) = .False.
- enddo
-
- ! Find duplicates
- do i=1,n_d-1
- if (duplicate(i)) then
- cycle
- endif
- j = i+1
- do while (bit_tmp(j)==bit_tmp(i))
- if (duplicate(j)) then
- j+=1
- if (j>n_d) then
- exit
- endif
- cycle
- endif
- dup = .True.
- do k=1,N_int
- if ( (tmp_array(k,1,i) /= tmp_array(k,1,j)) &
- .or. (tmp_array(k,2,i) /= tmp_array(k,2,j)) ) then
- dup = .False.
- exit
- endif
- enddo
- if (dup) then
- duplicate(j) = .True.
- found_duplicates = .True.
- endif
- j+=1
- if (j>n_d) then
- exit
- endif
- enddo
- enddo
-
- if (found_duplicates) then
-
- ! Copy filtered result
- integer :: n_p
- n_p=0
- do i=1,n_d
- if (duplicate(i)) then
- cycle
- endif
- n_p = n_p + 1
- do k=1,N_int
- b%det(k,1,n_p) = tmp_array(k,1,i)
- b%det(k,2,n_p) = tmp_array(k,2,i)
- enddo
- val(n_p) = val(i)
- enddo
- b%cur=n_p
- b%N=n_p
-
- endif
-
-end
-
-
-
diff --git a/plugins/local/cipsi_tc_bi_ortho/selection_weight.irp.f b/plugins/local/cipsi_tc_bi_ortho/selection_weight.irp.f
deleted file mode 100644
index 3c09e59a..00000000
--- a/plugins/local/cipsi_tc_bi_ortho/selection_weight.irp.f
+++ /dev/null
@@ -1,134 +0,0 @@
-BEGIN_PROVIDER [ double precision, pt2_match_weight, (N_states) ]
- implicit none
- BEGIN_DOC
- ! Weights adjusted along the selection to make the PT2 contributions
- ! of each state coincide.
- END_DOC
- pt2_match_weight(:) = 1.d0
-END_PROVIDER
-
-
-
-BEGIN_PROVIDER [ double precision, variance_match_weight, (N_states) ]
- implicit none
- BEGIN_DOC
- ! Weights adjusted along the selection to make the variances
- ! of each state coincide.
- END_DOC
- variance_match_weight(:) = 1.d0
-END_PROVIDER
-
-
-
-subroutine update_pt2_and_variance_weights(pt2_data, N_st)
- implicit none
- use selection_types
- BEGIN_DOC
-! Updates the PT2- and Variance- matching weights.
- END_DOC
- integer, intent(in) :: N_st
- type(pt2_type), intent(in) :: pt2_data
- double precision :: pt2(N_st)
- double precision :: variance(N_st)
-
- double precision :: avg, element, dt, x
- integer :: k
- pt2(:) = pt2_data % pt2(:)
- variance(:) = pt2_data % variance(:)
-
- avg = sum(pt2(1:N_st)) / dble(N_st) + 1.d-32 ! Avoid future division by zero
-
- dt = 8.d0 !* selection_factor
- do k=1,N_st
- element = exp(dt*(pt2(k)/avg - 1.d0))
- element = min(2.0d0 , element)
- element = max(0.5d0 , element)
- pt2_match_weight(k) *= element
- enddo
-
-
- avg = sum(variance(1:N_st)) / dble(N_st) + 1.d-32 ! Avoid future division by zero
-
- do k=1,N_st
- element = exp(dt*(variance(k)/avg -1.d0))
- element = min(2.0d0 , element)
- element = max(0.5d0 , element)
- variance_match_weight(k) *= element
- enddo
-
- if (N_det < 100) then
- ! For tiny wave functions, weights are 1.d0
- pt2_match_weight(:) = 1.d0
- variance_match_weight(:) = 1.d0
- endif
-
- threshold_davidson_pt2 = min(1.d-6, &
- max(threshold_davidson, 1.e-1 * PT2_relative_error * minval(abs(pt2(1:N_states)))) )
-
- SOFT_TOUCH pt2_match_weight variance_match_weight threshold_davidson_pt2
-end
-
-
-
-
-BEGIN_PROVIDER [ double precision, selection_weight, (N_states) ]
- implicit none
- BEGIN_DOC
- ! Weights used in the selection criterion
- END_DOC
- select case (weight_selection)
-
- case (0)
- print *, 'Using input weights in selection'
- selection_weight(1:N_states) = c0_weight(1:N_states) * state_average_weight(1:N_states)
-
- case (1)
- print *, 'Using 1/c_max^2 weight in selection'
- selection_weight(1:N_states) = c0_weight(1:N_states)
-
- case (2)
- print *, 'Using pt2-matching weight in selection'
- selection_weight(1:N_states) = c0_weight(1:N_states) * pt2_match_weight(1:N_states)
- print *, '# PT2 weight ', real(pt2_match_weight(:),4)
-
- case (3)
- print *, 'Using variance-matching weight in selection'
- selection_weight(1:N_states) = c0_weight(1:N_states) * variance_match_weight(1:N_states)
- print *, '# var weight ', real(variance_match_weight(:),4)
-
- case (4)
- print *, 'Using variance- and pt2-matching weights in selection'
- selection_weight(1:N_states) = c0_weight(1:N_states) * sqrt(variance_match_weight(1:N_states) * pt2_match_weight(1:N_states))
- print *, '# PT2 weight ', real(pt2_match_weight(:),4)
- print *, '# var weight ', real(variance_match_weight(:),4)
-
- case (5)
- print *, 'Using variance-matching weight in selection'
- selection_weight(1:N_states) = c0_weight(1:N_states) * variance_match_weight(1:N_states)
- print *, '# var weight ', real(variance_match_weight(:),4)
-
- case (6)
- print *, 'Using CI coefficient-based selection'
- selection_weight(1:N_states) = c0_weight(1:N_states)
-
- case (7)
- print *, 'Input weights multiplied by variance- and pt2-matching'
- selection_weight(1:N_states) = c0_weight(1:N_states) * sqrt(variance_match_weight(1:N_states) * pt2_match_weight(1:N_states)) * state_average_weight(1:N_states)
- print *, '# PT2 weight ', real(pt2_match_weight(:),4)
- print *, '# var weight ', real(variance_match_weight(:),4)
-
- case (8)
- print *, 'Input weights multiplied by pt2-matching'
- selection_weight(1:N_states) = c0_weight(1:N_states) * pt2_match_weight(1:N_states) * state_average_weight(1:N_states)
- print *, '# PT2 weight ', real(pt2_match_weight(:),4)
-
- case (9)
- print *, 'Input weights multiplied by variance-matching'
- selection_weight(1:N_states) = c0_weight(1:N_states) * variance_match_weight(1:N_states) * state_average_weight(1:N_states)
- print *, '# var weight ', real(variance_match_weight(:),4)
-
- end select
- print *, '# Total weight ', real(selection_weight(:),4)
-
-END_PROVIDER
-
diff --git a/plugins/local/cipsi_tc_bi_ortho/slave_cipsi.irp.f b/plugins/local/cipsi_tc_bi_ortho/slave_cipsi.irp.f
deleted file mode 100644
index 6343bf8b..00000000
--- a/plugins/local/cipsi_tc_bi_ortho/slave_cipsi.irp.f
+++ /dev/null
@@ -1,348 +0,0 @@
-subroutine run_slave_cipsi
-
- BEGIN_DOC
- ! Helper program for distributed parallelism
- END_DOC
-
- implicit none
-
- call omp_set_max_active_levels(1)
- distributed_davidson = .False.
- read_wf = .False.
- SOFT_TOUCH read_wf distributed_davidson
- call provide_everything
- call switch_qp_run_to_master
- call run_slave_main
-end
-
-subroutine provide_everything
- PROVIDE H_apply_buffer_allocated mo_two_e_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context N_states_diag
-
- PROVIDE pt2_e0_denominator mo_num N_int ci_energy mpi_master zmq_state zmq_context
- PROVIDE psi_det psi_coef threshold_generators state_average_weight
- PROVIDE N_det_selectors pt2_stoch_istate N_det selection_weight pseudo_sym
-end
-
-
-subroutine run_slave_main
-
- use f77_zmq
-
- implicit none
- IRP_IF MPI
- include 'mpif.h'
- IRP_ENDIF
-
- integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket
- integer(ZMQ_PTR) :: zmq_to_qp_run_socket
- double precision :: energy(N_states)
- character*(64) :: states(10)
- character*(64) :: old_state
- integer :: rc, i, ierr
- double precision :: t0, t1
-
- integer, external :: zmq_get_dvector, zmq_get_N_det_generators
- integer, external :: zmq_get8_dvector
- integer, external :: zmq_get_ivector
- integer, external :: zmq_get_psi, zmq_get_N_det_selectors, zmq_get_psi_bilinear
- integer, external :: zmq_get_psi_notouch
- integer, external :: zmq_get_N_states_diag
-
- zmq_context = f77_zmq_ctx_new ()
- states(1) = 'selection'
- states(2) = 'davidson'
- states(3) = 'pt2'
- old_state = 'Waiting'
-
- zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
-
- PROVIDE psi_det psi_coef threshold_generators state_average_weight mpi_master
- PROVIDE zmq_state N_det_selectors pt2_stoch_istate N_det pt2_e0_denominator
- PROVIDE N_det_generators N_states N_states_diag pt2_e0_denominator mpi_rank
-
- IRP_IF MPI
- call MPI_BARRIER(MPI_COMM_WORLD, ierr)
- IRP_ENDIF
- do
-
- if (mpi_master) then
- call wait_for_states(states,zmq_state,size(states))
- if (zmq_state(1:64) == old_state(1:64)) then
- call usleep(200)
- cycle
- else
- old_state(1:64) = zmq_state(1:64)
- endif
- print *, trim(zmq_state)
- endif
-
- IRP_IF MPI_DEBUG
- print *, irp_here, mpi_rank
- call MPI_BARRIER(MPI_COMM_WORLD, ierr)
- IRP_ENDIF
- IRP_IF MPI
- call MPI_BCAST (zmq_state, 128, MPI_CHARACTER, 0, MPI_COMM_WORLD, ierr)
- if (ierr /= MPI_SUCCESS) then
- print *, irp_here, 'error in broadcast of zmq_state'
- endif
- IRP_ENDIF
-
- if(zmq_state(1:7) == 'Stopped') then
- exit
- endif
-
-
- if (zmq_state(1:9) == 'selection') then
-
- ! Selection
- ! ---------
-
- call wall_time(t0)
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_psi')
- IRP_ENDIF
- if (zmq_get_psi(zmq_to_qp_run_socket,1) == -1) cycle
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_dvector threshold_generators')
- IRP_ENDIF
- if (zmq_get_dvector(zmq_to_qp_run_socket,1,'threshold_generators',(/threshold_generators/),1) == -1) cycle
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_dvector energy')
- IRP_ENDIF
- if (zmq_get_dvector(zmq_to_qp_run_socket,1,'energy',energy,N_states) == -1) cycle
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_N_det_generators')
- IRP_ENDIF
- if (zmq_get_N_det_generators (zmq_to_qp_run_socket, 1) == -1) cycle
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_N_det_selectors')
- IRP_ENDIF
- if (zmq_get_N_det_selectors(zmq_to_qp_run_socket, 1) == -1) cycle
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_dvector state_average_weight')
- IRP_ENDIF
- if (zmq_get_dvector(zmq_to_qp_run_socket,1,'state_average_weight',state_average_weight,N_states) == -1) cycle
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_dvector selection_weight')
- IRP_ENDIF
- if (zmq_get_dvector(zmq_to_qp_run_socket,1,'selection_weight',selection_weight,N_states) == -1) cycle
- pt2_e0_denominator(1:N_states) = energy(1:N_states)
- TOUCH pt2_e0_denominator state_average_weight threshold_generators selection_weight psi_det psi_coef
-
- if (mpi_master) then
- print *, 'N_det', N_det
- print *, 'N_det_generators', N_det_generators
- print *, 'N_det_selectors', N_det_selectors
- print *, 'pt2_e0_denominator', pt2_e0_denominator
- print *, 'pt2_stoch_istate', pt2_stoch_istate
- print *, 'state_average_weight', state_average_weight
- print *, 'selection_weight', selection_weight
- endif
- call wall_time(t1)
- call write_double(6,(t1-t0),'Broadcast time')
-
- IRP_IF MPI_DEBUG
- call mpi_print('Entering OpenMP section')
- IRP_ENDIF
- !$OMP PARALLEL PRIVATE(i)
- i = omp_get_thread_num()
- call run_selection_slave(0,i,energy)
- !$OMP END PARALLEL
- print *, mpi_rank, ': Selection done'
- IRP_IF MPI
- call MPI_BARRIER(MPI_COMM_WORLD, ierr)
- if (ierr /= MPI_SUCCESS) then
- print *, irp_here, 'error in barrier'
- endif
- IRP_ENDIF
- call mpi_print('----------')
-
- else if (zmq_state(1:8) == 'davidson') then
-
- ! Davidson
- ! --------
-
- call wall_time(t0)
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_N_states_diag')
- IRP_ENDIF
- if (zmq_get_N_states_diag(zmq_to_qp_run_socket,1) == -1) cycle
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_psi')
- IRP_ENDIF
- if (zmq_get_psi(zmq_to_qp_run_socket,1) == -1) cycle
-
- call wall_time(t1)
- call write_double(6,(t1-t0),'Broadcast time')
-
- !---
- call omp_set_max_active_levels(8)
- call davidson_slave_tcp(0)
- call omp_set_max_active_levels(1)
- print *, mpi_rank, ': Davidson done'
- !---
-
- IRP_IF MPI
- call MPI_BARRIER(MPI_COMM_WORLD, ierr)
- if (ierr /= MPI_SUCCESS) then
- print *, irp_here, 'error in barrier'
- endif
- IRP_ENDIF
- call mpi_print('----------')
-
- else if (zmq_state(1:3) == 'pt2') then
-
- ! PT2
- ! ---
-
- IRP_IF MPI
- call MPI_BARRIER(MPI_COMM_WORLD, ierr)
- if (ierr /= MPI_SUCCESS) then
- print *, irp_here, 'error in barrier'
- endif
- IRP_ENDIF
- call wall_time(t0)
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_psi')
- IRP_ENDIF
- if (zmq_get_psi(zmq_to_qp_run_socket,1) == -1) cycle
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_N_det_generators')
- IRP_ENDIF
- if (zmq_get_N_det_generators (zmq_to_qp_run_socket, 1) == -1) cycle
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_N_det_selectors')
- IRP_ENDIF
- if (zmq_get_N_det_selectors(zmq_to_qp_run_socket, 1) == -1) cycle
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_dvector threshold_generators')
- IRP_ENDIF
- if (zmq_get_dvector(zmq_to_qp_run_socket,1,'threshold_generators',(/threshold_generators/),1) == -1) cycle
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_dvector energy')
- IRP_ENDIF
- if (zmq_get_dvector(zmq_to_qp_run_socket,1,'energy',energy,N_states) == -1) cycle
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_ivector pt2_stoch_istate')
- IRP_ENDIF
- if (zmq_get_ivector(zmq_to_qp_run_socket,1,'pt2_stoch_istate',pt2_stoch_istate,1) == -1) cycle
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_dvector state_average_weight')
- IRP_ENDIF
- if (zmq_get_dvector(zmq_to_qp_run_socket,1,'state_average_weight',state_average_weight,N_states) == -1) cycle
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_dvector selection_weight')
- IRP_ENDIF
- if (zmq_get_dvector(zmq_to_qp_run_socket,1,'selection_weight',selection_weight,N_states) == -1) cycle
- pt2_e0_denominator(1:N_states) = energy(1:N_states)
- SOFT_TOUCH pt2_e0_denominator state_average_weight pt2_stoch_istate threshold_generators selection_weight psi_det psi_coef N_det_generators N_det_selectors
-
-
- call wall_time(t1)
- call write_double(6,(t1-t0),'Broadcast time')
- IRP_IF MPI
- call MPI_BARRIER(MPI_COMM_WORLD, ierr)
- if (ierr /= MPI_SUCCESS) then
- print *, irp_here, 'error in barrier'
- endif
- IRP_ENDIF
-
-
- IRP_IF MPI_DEBUG
- call mpi_print('Entering OpenMP section')
- IRP_ENDIF
- if (.true.) then
- integer :: nproc_target, ii
- double precision :: mem_collector, mem, rss
-
- call resident_memory(rss)
-
- nproc_target = nthreads_pt2
- ii = min(N_det, (elec_alpha_num*(mo_num-elec_alpha_num))**2)
-
- do
- mem = rss + & !
- nproc_target * 8.d0 * & ! bytes
- ( 0.5d0*pt2_n_tasks_max & ! task_id
- + 64.d0*pt2_n_tasks_max & ! task
- + 3.d0*pt2_n_tasks_max*N_states & ! pt2, variance, norm
- + 1.d0*pt2_n_tasks_max & ! i_generator, subset
- + 3.d0*(N_int*2.d0*ii+ ii) & ! selection buffer
- + 1.d0*(N_int*2.d0*ii+ ii) & ! sort selection buffer
- + 2.0d0*(ii) & ! preinteresting, interesting,
- ! prefullinteresting, fullinteresting
- + 2.0d0*(N_int*2*ii) & ! minilist, fullminilist
- + 1.0d0*(N_states*mo_num*mo_num) & ! mat
- ) / 1024.d0**3
-
- if (nproc_target == 0) then
- call check_mem(mem,irp_here)
- nproc_target = 1
- exit
- endif
-
- if (mem+rss < qp_max_mem) then
- exit
- endif
-
- nproc_target = nproc_target - 1
-
- enddo
-
- if (N_det > 100000) then
-
- if (mpi_master) then
- print *, 'N_det', N_det
- print *, 'N_det_generators', N_det_generators
- print *, 'N_det_selectors', N_det_selectors
- print *, 'pt2_e0_denominator', pt2_e0_denominator
- print *, 'pt2_stoch_istate', pt2_stoch_istate
- print *, 'state_average_weight', state_average_weight
- print *, 'selection_weight', selection_weight
- print *, 'Number of threads', nproc_target
- endif
-
- if (h0_type == 'CFG') then
- PROVIDE det_to_configuration
- endif
-
- PROVIDE global_selection_buffer pt2_N_teeth pt2_F N_det_generators
- PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
- PROVIDE psi_bilinear_matrix_rows psi_det_sorted_tc_order psi_bilinear_matrix_order
- PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
- PROVIDE psi_bilinear_matrix_transp_order psi_selectors_coef_transp psi_det_sorted_tc
-
- PROVIDE psi_det_hii selection_weight pseudo_sym pt2_min_parallel_tasks
-
- if (mpi_master) then
- print *, 'Running PT2'
- endif
- !$OMP PARALLEL PRIVATE(i) NUM_THREADS(nproc_target+1)
- i = omp_get_thread_num()
- call run_pt2_slave(0,i,pt2_e0_denominator)
- !$OMP END PARALLEL
- FREE state_average_weight
- print *, mpi_rank, ': PT2 done'
- print *, '-------'
-
- endif
- endif
-
- IRP_IF MPI
- call MPI_BARRIER(MPI_COMM_WORLD, ierr)
- if (ierr /= MPI_SUCCESS) then
- print *, irp_here, 'error in barrier'
- endif
- IRP_ENDIF
- call mpi_print('----------')
-
- endif
-
- end do
- IRP_IF MPI
- call MPI_finalize(ierr)
- IRP_ENDIF
-end
-
-
-
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 66d82964..e363830d 100644
--- a/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f
@@ -11,15 +11,13 @@ subroutine run_stochastic_cipsi
implicit none
integer :: i, j, k, ndet
integer :: to_select
- logical :: print_pt2
logical :: has
type(pt2_type) :: pt2_data, pt2_data_err
double precision :: rss
- double precision :: correlation_energy_ratio, E_denom, E_tc, norm
+ double precision :: correlation_energy_ratio
double precision :: hf_energy_ref
double precision :: relative_error
- double precision, allocatable :: ept2(:), pt1(:), extrap_energy(:)
- double precision, allocatable :: zeros(:)
+ double precision, allocatable :: zeros(:),E_tc(:), norm(:)
logical, external :: qp_stop
double precision, external :: memory_of_double
@@ -32,14 +30,13 @@ subroutine run_stochastic_cipsi
write(*,*) i, Fock_matrix_tc_mo_tot(i,i)
enddo
- N_iter = 1
threshold_generators = 1.d0
SOFT_TOUCH threshold_generators
rss = memory_of_double(N_states)*4.d0
call check_mem(rss, irp_here)
- allocate(zeros(N_states))
+ allocate(zeros(N_states),E_tc(N_states), norm(N_states))
call pt2_alloc(pt2_data, N_states)
call pt2_alloc(pt2_data_err, N_states)
@@ -55,32 +52,27 @@ subroutine run_stochastic_cipsi
! if (s2_eig) then
! call make_s2_eigenfunction
! endif
- print_pt2 = .False.
- call diagonalize_CI_tc_bi_ortho(ndet, E_tc, norm, pt2_data, print_pt2)
-! call routine_save_right
+ call diagonalize_CI_tc_bi_ortho(ndet, E_tc, norm)
! if (N_det > N_det_max) then
! psi_det(1:N_int,1:2,1:N_det) = psi_det_generators(1:N_int,1:2,1:N_det)
-! psi_coef(1:N_det,1:N_states) = psi_coef_sorted_tc_gen(1:N_det,1:N_states)
+! psi_coef(1:N_det,1:N_states) = psi_coef_sorted_gen(1:N_det,1:N_states)
! N_det = N_det_max
! soft_touch N_det psi_det psi_coef
! if (s2_eig) then
! call make_s2_eigenfunction
! endif
-! print_pt2 = .False.
-! call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2)
+! call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm)
! call routine_save_right
! endif
- allocate(ept2(1000),pt1(1000),extrap_energy(100))
correlation_energy_ratio = 0.d0
! thresh_it_dav = 5.d-5
! soft_touch thresh_it_dav
- print_pt2 = .True.
do while( (N_det < N_det_max) .and. &
(maxval(abs(pt2_data % pt2(1:N_states))) > pt2_max))
@@ -91,15 +83,18 @@ subroutine run_stochastic_cipsi
to_select = int(sqrt(dble(N_states))*dble(N_det)*selection_factor)
to_select = max(N_states_diag, to_select)
- E_denom = E_tc ! TC Energy of the current wave function
+ print*,'E_tc = ',E_tc
call pt2_dealloc(pt2_data)
call pt2_dealloc(pt2_data_err)
call pt2_alloc(pt2_data, N_states)
call pt2_alloc(pt2_data_err, N_states)
- call ZMQ_pt2(E_denom, pt2_data, pt2_data_err, relative_error,to_select) ! Stochastic PT2 and selection
+ if(transpose_two_e_int)then
+ provide mo_bi_ortho_tc_two_e_transp tc_2e_3idx_coulomb_integrals_transp
+ endif
+ call ZMQ_pt2(E_tc, pt2_data, pt2_data_err, relative_error,to_select) ! Stochastic PT2 and selection
! stop
- call print_summary(psi_energy_with_nucl_rep, pt2_data, pt2_data_err, N_det, N_configuration, N_states, psi_s2)
+ call print_summary_tc(psi_energy_with_nucl_rep, pt2_data, pt2_data_err, N_det, N_configuration, N_states, psi_s2)
call save_energy(psi_energy_with_nucl_rep, pt2_data % pt2)
@@ -117,48 +112,19 @@ subroutine run_stochastic_cipsi
PROVIDE psi_det
PROVIDE psi_det_sorted_tc
- ept2(N_iter-1) = E_tc + nuclear_repulsion + (pt2_data % pt2(1))/norm
- pt1(N_iter-1) = dsqrt(pt2_data % overlap(1,1))
- call diagonalize_CI_tc_bi_ortho(ndet, E_tc, norm, pt2_data, print_pt2)
+ call diagonalize_CI_tc_bi_ortho(ndet, E_tc, norm)
! stop
if (qp_stop()) exit
enddo
-! print*,'data to extrapolate '
-! do i = 2, N_iter
-! print*,'iteration ',i
-! print*,'pt1,Ept2',pt1(i),ept2(i)
-! call get_extrapolated_energy(i-1,ept2(i),pt1(i),extrap_energy(i))
-! do j = 2, i
-! print*,'j,e,energy',j,extrap_energy(j)
-! enddo
-! enddo
-
-! thresh_it_dav = 5.d-6
-! soft_touch thresh_it_dav
call pt2_dealloc(pt2_data)
call pt2_dealloc(pt2_data_err)
call pt2_alloc(pt2_data, N_states)
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)
-! if (.not.qp_stop()) then
-! if (N_det < N_det_max) then
-! thresh_it_dav = 5.d-7
-! soft_touch thresh_it_dav
-! call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2)
-! endif
-!
-! call pt2_dealloc(pt2_data)
-! call pt2_dealloc(pt2_data_err)
-! call pt2_alloc(pt2_data, N_states)
-! call pt2_alloc(pt2_data_err, N_states)
-! call ZMQ_pt2(E_denom, pt2_data, pt2_data_err, relative_error, 0) ! Stochastic PT2
-! call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2)
-! endif
-! call pt2_dealloc(pt2_data)
-! call pt2_dealloc(pt2_data_err)
-! call routine_save_right
+ call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm)
+ call pt2_dealloc(pt2_data)
+ call pt2_dealloc(pt2_data_err)
end
diff --git a/plugins/local/cipsi_tc_bi_ortho/write_cipsi_json.irp.f b/plugins/local/cipsi_tc_bi_ortho/write_cipsi_json.irp.f
index 98a402a2..f8c95d38 100644
--- a/plugins/local/cipsi_tc_bi_ortho/write_cipsi_json.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/write_cipsi_json.irp.f
@@ -9,6 +9,8 @@ subroutine write_cipsi_json(pt2_data, pt2_data_err)
call lock_io
character*(64), allocatable :: fmtk(:)
+ double precision:: pt2_minus,pt2_plus,pt2_tot, pt2_abs
+ double precision :: error_pt2_minus, error_pt2_plus, error_pt2_tot, error_pt2_abs
integer :: N_states_p, N_iter_p
N_states_p = min(N_states,N_det)
N_iter_p = min(N_iter,8)
@@ -26,15 +28,34 @@ subroutine write_cipsi_json(pt2_data, pt2_data_err)
endif
write(json_unit, json_array_open_fmt) 'states'
do k=1,N_states_p
+ pt2_plus = pt2_data % variance(k)
+ pt2_minus = pt2_data % pt2(k)
+ pt2_abs = pt2_plus - pt2_minus
+ pt2_tot = pt2_plus + pt2_minus
+ error_pt2_minus = pt2_data_err % pt2(k)
+ error_pt2_plus = pt2_data_err % variance(k)
+ error_pt2_tot = dsqrt(error_pt2_minus**2+error_pt2_plus**2)
+ error_pt2_abs = error_pt2_tot ! same variance because independent variables
write(json_unit, json_dict_uopen_fmt)
write(json_unit, json_real_fmt) 'energy', psi_energy_with_nucl_rep(k)
write(json_unit, json_real_fmt) 's2', psi_s2(k)
- write(json_unit, json_real_fmt) 'pt2', pt2_data % pt2(k)
- write(json_unit, json_real_fmt) 'pt2_err', pt2_data_err % pt2(k)
+
+ write(json_unit, json_real_fmt) 'pt2', pt2_tot
+ write(json_unit, json_real_fmt) 'pt2_err', error_pt2_tot
+
+ write(json_unit, json_real_fmt) 'pt2_minus', pt2_minus
+ write(json_unit, json_real_fmt) 'pt2_minus_err', error_pt2_minus
+
+ write(json_unit, json_real_fmt) 'pt2_abs', pt2_abs
+ write(json_unit, json_real_fmt) 'pt2_abs_err', error_pt2_abs
+
+ write(json_unit, json_real_fmt) 'pt2_plus', pt2_plus
+ write(json_unit, json_real_fmt) 'pt2_plus_err', error_pt2_plus
+
write(json_unit, json_real_fmt) 'rpt2', pt2_data % rpt2(k)
write(json_unit, json_real_fmt) 'rpt2_err', pt2_data_err % rpt2(k)
- write(json_unit, json_real_fmt) 'variance', pt2_data % variance(k)
- write(json_unit, json_real_fmt) 'variance_err', pt2_data_err % variance(k)
+! write(json_unit, json_real_fmt) 'variance', pt2_data % variance(k)
+! write(json_unit, json_real_fmt) 'variance_err', pt2_data_err % variance(k)
write(json_unit, json_array_open_fmt) 'ex_energy'
do i=2,N_iter_p
write(json_unit, fmtk(i)) extrapolated_energy(i,k)
diff --git a/plugins/local/cipsi_tc_bi_ortho/zmq_selection.irp.f b/plugins/local/cipsi_tc_bi_ortho/zmq_selection.irp.f
deleted file mode 100644
index dc3e0f27..00000000
--- a/plugins/local/cipsi_tc_bi_ortho/zmq_selection.irp.f
+++ /dev/null
@@ -1,235 +0,0 @@
-subroutine ZMQ_selection(N_in, pt2_data)
- use f77_zmq
- use selection_types
-
- implicit none
-
- integer(ZMQ_PTR) :: zmq_to_qp_run_socket , zmq_socket_pull
- integer, intent(in) :: N_in
- type(selection_buffer) :: b
- integer :: i, l, N
- integer, external :: omp_get_thread_num
- type(pt2_type), intent(inout) :: pt2_data
-
- PROVIDE psi_det psi_coef N_det qp_max_mem N_states pt2_F s2_eig N_det_generators
-
- N = max(N_in,1)
- N = min(N, (elec_alpha_num * (mo_num-elec_alpha_num))**2)
- if (.True.) then
- PROVIDE pt2_e0_denominator nproc
- PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
- PROVIDE psi_bilinear_matrix_rows psi_det_sorted_tc_order psi_bilinear_matrix_order
- PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
- PROVIDE psi_bilinear_matrix_transp_order selection_weight pseudo_sym
- PROVIDE n_act_orb n_inact_orb n_core_orb n_virt_orb n_del_orb seniority_max
- PROVIDE excitation_beta_max excitation_alpha_max excitation_max
-
- call new_parallel_job(zmq_to_qp_run_socket,zmq_socket_pull,'selection')
-
- integer, external :: zmq_put_psi
- integer, external :: zmq_put_N_det_generators
- integer, external :: zmq_put_N_det_selectors
- integer, external :: zmq_put_dvector
-
- if (zmq_put_psi(zmq_to_qp_run_socket,1) == -1) then
- stop 'Unable to put psi on ZMQ server'
- endif
- if (zmq_put_N_det_generators(zmq_to_qp_run_socket, 1) == -1) then
- stop 'Unable to put N_det_generators on ZMQ server'
- endif
- if (zmq_put_N_det_selectors(zmq_to_qp_run_socket, 1) == -1) then
- stop 'Unable to put N_det_selectors on ZMQ server'
- endif
- if (zmq_put_dvector(zmq_to_qp_run_socket,1,'energy',pt2_e0_denominator,size(pt2_e0_denominator)) == -1) then
- stop 'Unable to put energy on ZMQ server'
- endif
- if (zmq_put_dvector(zmq_to_qp_run_socket,1,'state_average_weight',state_average_weight,N_states) == -1) then
- stop 'Unable to put state_average_weight on ZMQ server'
- endif
- if (zmq_put_dvector(zmq_to_qp_run_socket,1,'selection_weight',selection_weight,N_states) == -1) then
- stop 'Unable to put selection_weight on ZMQ server'
- endif
- if (zmq_put_dvector(zmq_to_qp_run_socket,1,'threshold_generators',(/threshold_generators/),1) == -1) then
- stop 'Unable to put threshold_generators on ZMQ server'
- endif
- call create_selection_buffer(N, N*2, b)
- endif
-
- integer, external :: add_task_to_taskserver
- character(len=100000) :: task
- integer :: j,k,ipos
- ipos=1
- task = ' '
-
-
- do i= 1, N_det_generators
- do j=1,pt2_F(i)
- write(task(ipos:ipos+30),'(I9,1X,I9,1X,I9,''|'')') j, i, N
- ipos += 30
- if (ipos > 100000-30) then
- if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
- stop 'Unable to add task to task server'
- endif
- ipos=1
- endif
- end do
- enddo
- if (ipos > 1) then
- if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
- stop 'Unable to add task to task server'
- endif
- endif
- N = max(N_in,1)
-
-
- ASSERT (associated(b%det))
- ASSERT (associated(b%val))
-
- integer, external :: zmq_set_running
- if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
- print *, irp_here, ': Failed in zmq_set_running'
- endif
-
- integer :: nproc_target
- if (N_det < 3*nproc) then
- nproc_target = N_det/4
- else
- nproc_target = nproc
- endif
- double precision :: mem
- mem = 8.d0 * N_det * (N_int * 2.d0 * 3.d0 + 3.d0 + 5.d0) / (1024.d0**3)
- call write_double(6,mem,'Estimated memory/thread (Gb)')
- if (qp_max_mem > 0) then
- nproc_target = max(1,int(dble(qp_max_mem)/(0.1d0 + mem)))
- nproc_target = min(nproc_target,nproc)
- endif
-
- f(:) = 1.d0
- if (.not.do_pt2) then
- double precision :: f(N_states), u_dot_u
- do k=1,min(N_det,N_states)
- f(k) = 1.d0 / u_dot_u(psi_selectors_coef(1,k), N_det_selectors)
- enddo
- endif
-
- !$OMP PARALLEL DEFAULT(shared) SHARED(b, pt2_data) PRIVATE(i) NUM_THREADS(nproc_target+1)
- i = omp_get_thread_num()
- if (i==0) then
- call selection_collector(zmq_socket_pull, b, N, pt2_data)
- else
- call selection_slave_inproc(i)
- endif
- !$OMP END PARALLEL
-
- call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'selection')
- if (N_in > 0) then
- if (s2_eig) then
- call make_selection_buffer_s2(b)
- endif
- call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0)
- endif
- call delete_selection_buffer(b)
-
- do k=1,N_states
- pt2_data % pt2(k) = pt2_data % pt2(k) * f(k)
- pt2_data % variance(k) = pt2_data % variance(k) * f(k)
- do l=1,N_states
- pt2_data % overlap(k,l) = pt2_data % overlap(k,l) * dsqrt(f(k)*f(l))
- pt2_data % overlap(l,k) = pt2_data % overlap(l,k) * dsqrt(f(k)*f(l))
- enddo
-
- pt2_data % rpt2(k) = &
- pt2_data % pt2(k)/(1.d0 + pt2_data % overlap(k,k))
- enddo
-
- pt2_overlap(:,:) = pt2_data % overlap(:,:)
-
- print *, 'Overlap of perturbed states:'
- do l=1,N_states
- print *, pt2_overlap(l,:)
- enddo
- print *, '-------'
- SOFT_TOUCH pt2_overlap
- call update_pt2_and_variance_weights(pt2_data, N_states)
-
-end subroutine
-
-
-subroutine selection_slave_inproc(i)
- implicit none
- integer, intent(in) :: i
-
- call run_selection_slave(1,i,pt2_e0_denominator)
-end
-
-subroutine selection_collector(zmq_socket_pull, b, N, pt2_data)
- use f77_zmq
- use selection_types
- use bitmasks
- implicit none
-
-
- integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
- type(selection_buffer), intent(inout) :: b
- integer, intent(in) :: N
- type(pt2_type), intent(inout) :: pt2_data
- type(pt2_type) :: pt2_data_tmp
-
- double precision :: pt2_mwen(N_states)
- double precision :: variance_mwen(N_states)
- double precision :: norm2_mwen(N_states)
- integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
- integer(ZMQ_PTR) :: zmq_to_qp_run_socket
-
- integer(ZMQ_PTR), external :: new_zmq_pull_socket
-
- integer :: msg_size, rc, more
- integer :: acc, i, j, robin, ntask
- double precision, pointer :: val(:)
- integer(bit_kind), pointer :: det(:,:,:)
- integer, allocatable :: task_id(:)
- type(selection_buffer) :: b2
-
-
-
-
- zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
- call create_selection_buffer(N, N*2, b2)
- integer :: k
- double precision :: rss
- double precision, external :: memory_of_int
- rss = memory_of_int(N_det_generators)
- call check_mem(rss,irp_here)
- allocate(task_id(N_det_generators))
- more = 1
- pt2_data % pt2(:) = 0d0
- pt2_data % variance(:) = 0.d0
- pt2_data % overlap(:,:) = 0.d0
- call pt2_alloc(pt2_data_tmp,N_states)
- do while (more == 1)
- call pull_selection_results(zmq_socket_pull, pt2_data_tmp, b2%val(1), b2%det(1,1,1), b2%cur, task_id, ntask)
-
- call pt2_add(pt2_data, 1.d0, pt2_data_tmp)
- do i=1, b2%cur
- call add_to_selection_buffer(b, b2%det(1,1,i), b2%val(i))
- if (b2%val(i) > b%mini) exit
- end do
-
- do i=1, ntask
- if(task_id(i) == 0) then
- print *, "Error in collector"
- endif
- integer, external :: zmq_delete_task
- if (zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id(i),more) == -1) then
- stop 'Unable to delete task'
- endif
- end do
- end do
- call pt2_dealloc(pt2_data_tmp)
-
-
- call delete_selection_buffer(b2)
- call sort_selection_buffer(b)
- call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
-end subroutine
-
diff --git a/plugins/local/fci_tc_bi/NEED b/plugins/local/fci_tc_bi/NEED
index 3bb9515a..8e9ae1c8 100644
--- a/plugins/local/fci_tc_bi/NEED
+++ b/plugins/local/fci_tc_bi/NEED
@@ -1,3 +1,4 @@
+generators_full_tc
json
tc_bi_ortho
davidson_undressed
diff --git a/plugins/local/fci_tc_bi/diagonalize_ci.irp.f b/plugins/local/fci_tc_bi/diagonalize_ci.irp.f
index 6c8f3431..85518116 100644
--- a/plugins/local/fci_tc_bi/diagonalize_ci.irp.f
+++ b/plugins/local/fci_tc_bi/diagonalize_ci.irp.f
@@ -1,7 +1,7 @@
! ---
-subroutine diagonalize_CI_tc_bi_ortho(ndet, E_tc, norm, pt2_data, print_pt2)
+subroutine diagonalize_CI_tc_bi_ortho(ndet, E_tc, norm )
BEGIN_DOC
! Replace the coefficients of the CI states by the coefficients of the
@@ -11,49 +11,19 @@ subroutine diagonalize_CI_tc_bi_ortho(ndet, E_tc, norm, pt2_data, print_pt2)
use selection_types
implicit none
integer, intent(inout) :: ndet ! number of determinants from before
- double precision, intent(inout) :: E_tc, norm ! E and norm from previous wave function
- type(pt2_type) , intent(in) :: pt2_data ! PT2 from previous wave function
- logical, intent(in) :: print_pt2
- integer :: i, j
- double precision :: pt2_tmp, pt1_norm, rpt2_tmp, abs_pt2
+ double precision, intent(inout) :: E_tc(N_states), norm(N_states) ! E and norm from previous wave function
+ integer :: i, j,k
PROVIDE mo_l_coef mo_r_coef
- pt2_tmp = pt2_data % pt2(1)
- abs_pt2 = pt2_data % variance(1)
- pt1_norm = pt2_data % overlap(1,1)
- rpt2_tmp = pt2_tmp/(1.d0 + pt1_norm)
-
- print*,'*****'
- print*,'New wave function information'
- print*,'N_det tc = ',N_det
- print*,'norm_ground_left_right_bi_orth = ',norm_ground_left_right_bi_orth
- print*,'eigval_right_tc = ',eigval_right_tc_bi_orth(1)
- print*,'Ndet, E_tc = ',N_det,eigval_right_tc_bi_orth(1)
- print*,'*****'
-
- if(print_pt2) then
- print*,'*****'
- print*,'previous wave function info'
- print*,'norm(before) = ',norm
- print*,'E(before) = ',E_tc
- print*,'PT1 norm = ',dsqrt(pt1_norm)
- print*,'PT2 = ',pt2_tmp
- print*,'rPT2 = ',rpt2_tmp
- print*,'|PT2| = ',abs_pt2
- print*,'Positive PT2 = ',(pt2_tmp + abs_pt2)*0.5d0
- print*,'Negative PT2 = ',(pt2_tmp - abs_pt2)*0.5d0
- print*,'E(before) + PT2 = ',E_tc + pt2_tmp/norm
- print*,'E(before) +rPT2 = ',E_tc + rpt2_tmp/norm
- write(*,'(A28,X,I10,X,100(F16.8,X))')'Ndet,E,E+PT2,E+RPT2,|PT2|=',ndet,E_tc ,E_tc + pt2_tmp/norm,E_tc + rpt2_tmp/norm,abs_pt2
- print*,'*****'
- endif
+ do k = 1, N_states
+ E_tc(k) = eigval_right_tc_bi_orth(k)
+ norm(k) = norm_ground_left_right_bi_orth(k)
+ enddo
psi_energy(1:N_states) = eigval_right_tc_bi_orth(1:N_states) - nuclear_repulsion
psi_s2(1:N_states) = s2_eigvec_tc_bi_orth(1:N_states)
- E_tc = eigval_right_tc_bi_orth(1)
- norm = norm_ground_left_right_bi_orth
ndet = N_det
do j = 1, N_states
do i = 1, N_det
@@ -71,53 +41,3 @@ end
! ---
-subroutine print_CI_dressed(ndet, E_tc, norm, pt2_data, print_pt2)
-
- BEGIN_DOC
- ! Replace the coefficients of the CI states by the coefficients of the
- ! eigenstates of the CI matrix
- END_DOC
-
- use selection_types
- implicit none
- integer, intent(inout) :: ndet ! number of determinants from before
- double precision, intent(inout) :: E_tc,norm ! E and norm from previous wave function
- type(pt2_type) , intent(in) :: pt2_data ! PT2 from previous wave function
- logical, intent(in) :: print_pt2
- integer :: i, j
-
- print*,'*****'
- print*,'New wave function information'
- print*,'N_det tc = ',N_det
- print*,'norm_ground_left_right_bi_orth = ',norm_ground_left_right_bi_orth
- print*,'eigval_right_tc = ',eigval_right_tc_bi_orth(1)
- print*,'Ndet, E_tc = ',N_det,eigval_right_tc_bi_orth(1)
- print*,'*****'
-
- if(print_pt2) then
- print*,'*****'
- print*,'previous wave function info'
- print*,'norm(before) = ',norm
- print*,'E(before) = ',E_tc
- print*,'PT1 norm = ',dsqrt(pt2_data % overlap(1,1))
- print*,'E(before) + PT2 = ',E_tc + (pt2_data % pt2(1))/norm
- print*,'PT2 = ',pt2_data % pt2(1)
- print*,'Ndet, E_tc, E+PT2 = ',ndet,E_tc,E_tc + (pt2_data % pt2(1))/norm,dsqrt(pt2_data % overlap(1,1))
- print*,'*****'
- endif
-
- E_tc = eigval_right_tc_bi_orth(1)
- norm = norm_ground_left_right_bi_orth
- ndet = N_det
-
- do j = 1, N_states
- do i = 1, N_det
- psi_coef(i,j) = reigvec_tc_bi_orth(i,j)
- enddo
- enddo
- SOFT_TOUCH eigval_left_tc_bi_orth eigval_right_tc_bi_orth leigvec_tc_bi_orth norm_ground_left_right_bi_orth psi_coef reigvec_tc_bi_orth
-
-end
-
-! ---
-
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/fci_tc_bi/selectors.irp.f b/plugins/local/fci_tc_bi/selectors.irp.f
index 7f93ae55..606660fd 100644
--- a/plugins/local/fci_tc_bi/selectors.irp.f
+++ b/plugins/local/fci_tc_bi/selectors.irp.f
@@ -40,7 +40,7 @@ END_PROVIDER
enddo
do k=1,N_states
do i=1,N_det_selectors
- psi_selectors_coef(i,k) = psi_coef_sorted_tc_gen(i,k)
+ psi_selectors_coef(i,k) = psi_coef_sorted_gen(i,k)
psi_selectors_coef_tc(i,1,k) = psi_l_coef_sorted_bi_ortho(i,k)
psi_selectors_coef_tc(i,2,k) = psi_r_coef_sorted_bi_ortho(i,k)
enddo
diff --git a/plugins/local/jastrow/EZFIO.cfg b/plugins/local/jastrow/EZFIO.cfg
index 0d4141af..8fd2d05a 100644
--- a/plugins/local/jastrow/EZFIO.cfg
+++ b/plugins/local/jastrow/EZFIO.cfg
@@ -1,13 +1,13 @@
[j2e_type]
type: character*(32)
-doc: type of the 2e-Jastrow: [ None | Mu | Mur | Qmckl ]
+doc: type of the 2e-Jastrow: [ None | Mu | Mu_Nu | Mur | Boys | Boys_Handy | Qmckl ]
interface: ezfio,provider,ocaml
default: Mu
[j1e_type]
type: character*(32)
-doc: type of the 1e-Jastrow: [ None | Gauss | Charge_Harmonizer ]
+doc: type of the 1e-Jastrow: [ None | Gauss | Charge_Harmonizer | Charge_Harmonizer_AO ]
interface: ezfio,provider,ocaml
default: None
@@ -99,7 +99,7 @@ size: (ao_basis.ao_num)
type: double precision
doc: coefficients of the 1-electron Jastrow in AOsxAOs
interface: ezfio
-size: (ao_basis.ao_num*ao_basis.ao_num)
+size: (ao_basis.ao_num,ao_basis.ao_num)
[j1e_coef_ao3]
type: double precision
@@ -144,3 +144,52 @@ interface: ezfio,provider,ocaml
default: 1.0
ezfio_name: a_boys
+[nu_erf]
+type: double precision
+doc: e-e correlation in the core
+interface: ezfio,provider,ocaml
+default: 1.0
+ezfio_name: nu_erf
+
+[jBH_size]
+type: integer
+doc: number of terms per atom in Boys-Handy-Jastrow
+interface: ezfio,provider,ocaml
+default: 1
+
+[jBH_c]
+type: double precision
+doc: coefficients of terms in Boys-Handy-Jastrow
+interface: ezfio
+size: (jastrow.jBH_size,nuclei.nucl_num)
+
+[jBH_m]
+type: integer
+doc: powers of terms in Boys-Handy-Jastrow
+interface: ezfio
+size: (jastrow.jBH_size,nuclei.nucl_num)
+
+[jBH_n]
+type: integer
+doc: powers of terms in Boys-Handy-Jastrow
+interface: ezfio
+size: (jastrow.jBH_size,nuclei.nucl_num)
+
+[jBH_o]
+type: integer
+doc: powers of terms in Boys-Handy-Jastrow
+interface: ezfio
+size: (jastrow.jBH_size,nuclei.nucl_num)
+
+[jBH_ee]
+type: double precision
+doc: parameters of e-e terms in Boys-Handy-Jastrow
+interface: ezfio
+size: (nuclei.nucl_num)
+
+[jBH_en]
+type: double precision
+doc: parameters of e-n terms in Boys-Handy-Jastrow
+interface: ezfio
+size: (nuclei.nucl_num)
+
diff --git a/plugins/local/jastrow/README.md b/plugins/local/jastrow/README.md
index 67898e23..a9e568db 100644
--- a/plugins/local/jastrow/README.md
+++ b/plugins/local/jastrow/README.md
@@ -20,6 +20,12 @@ The main keywords are:
=u(r_%7B12%7D)=%5Cfrac%7Br_%7B12%7D%7D%7B2%7D%5Cleft%5B1-%5Ctext%7Berf%7D(%5Cmu%20r_%7B12%7D)%5Cright%5D-%5Cfrac%7B%5Cexp%5B-(%5Cmu%20r_%7B12%7D)%5E2%5D%7D%7B2%5Csqrt%7B%5Cpi%7D%5Cmu%7D)
+3. **Mu_Nu:** A valence and a core correlation terms are used
+
+ =u(\mu;r_{12})\,v(\mathbf{r}_1)\,v(\mathbf{r}_2)+u(\nu;r_{12})[1-v(\mathbf{r}_1)\,v(\mathbf{r}_2)])
+
+ with envelop \(v\).
+
## env_type Options
diff --git a/plugins/local/jastrow/bh_param.irp.f b/plugins/local/jastrow/bh_param.irp.f
new file mode 100644
index 00000000..1ed871bc
--- /dev/null
+++ b/plugins/local/jastrow/bh_param.irp.f
@@ -0,0 +1,252 @@
+
+ BEGIN_PROVIDER [double precision, jBH_ee, (nucl_num)]
+&BEGIN_PROVIDER [double precision, jBH_en, (nucl_num)]
+&BEGIN_PROVIDER [double precision, jBH_c , (jBH_size, nucl_num)]
+&BEGIN_PROVIDER [integer , jBH_m , (jBH_size, nucl_num)]
+&BEGIN_PROVIDER [integer , jBH_n , (jBH_size, nucl_num)]
+&BEGIN_PROVIDER [integer , jBH_o , (jBH_size, nucl_num)]
+
+ BEGIN_DOC
+ !
+ ! parameters of Boys-Handy-Jastrow
+ !
+ END_DOC
+
+ implicit none
+ logical :: exists
+ integer :: i_nucl, p
+ integer :: ierr
+
+ PROVIDE ezfio_filename
+
+ ! ---
+
+ if(mpi_master) then
+ call ezfio_has_jastrow_jBH_ee(exists)
+ 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'
+ call MPI_BCAST(jBH_ee, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
+ if(ierr /= MPI_SUCCESS) then
+ stop 'Unable to read Boys-Handy e-e param with MPI'
+ endif
+ IRP_ENDIF
+
+ if(exists) then
+ if(mpi_master) then
+ write(6,'(A)') '.. >>>>> [ IO READ: jBH_ee ] <<<<< ..'
+ call ezfio_get_jastrow_jBH_ee(jBH_ee)
+ IRP_IF MPI
+ call MPI_BCAST(jBH_ee, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
+ if(ierr /= MPI_SUCCESS) then
+ stop 'Unable to read jBH_ee with MPI'
+ endif
+ IRP_ENDIF
+ endif
+ else
+
+ jBH_ee = 1.d0
+ call ezfio_set_jastrow_jBH_ee(jBH_ee)
+ endif
+
+ ! ---
+
+ if(mpi_master) then
+ call ezfio_has_jastrow_jBH_en(exists)
+ endif
+
+ IRP_IF MPI_DEBUG
+ print *, irp_here, mpi_rank
+ call MPI_BARRIER(MPI_COMM_WORLD, ierr)
+ IRP_ENDIF
+
+ IRP_IF MPI
+ call MPI_BCAST(jBH_en, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
+ if(ierr /= MPI_SUCCESS) then
+ stop 'Unable to read Boys-Handy e-n param with MPI'
+ endif
+ IRP_ENDIF
+
+ if(exists) then
+ if(mpi_master) then
+ write(6,'(A)') '.. >>>>> [ IO READ: jBH_en ] <<<<< ..'
+ call ezfio_get_jastrow_jBH_en(jBH_en)
+ IRP_IF MPI
+ call MPI_BCAST(jBH_en, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
+ if (ierr /= MPI_SUCCESS) then
+ stop 'Unable to read jBH_en with MPI'
+ endif
+ IRP_ENDIF
+ endif
+ else
+
+ jBH_en = 1.d0
+ call ezfio_set_jastrow_jBH_en(jBH_en)
+ endif
+
+ ! ---
+
+ if(mpi_master) then
+ call ezfio_has_jastrow_jBH_c(exists)
+ endif
+
+ IRP_IF MPI_DEBUG
+ print *, irp_here, mpi_rank
+ call MPI_BARRIER(MPI_COMM_WORLD, ierr)
+ IRP_ENDIF
+
+ IRP_IF MPI
+ call MPI_BCAST(jBH_c, (jBH_size*nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
+ if(ierr /= MPI_SUCCESS) then
+ stop 'Unable to read Boys-Handy coeff with MPI'
+ endif
+ IRP_ENDIF
+
+ if(exists) then
+ if(mpi_master) then
+ write(6,'(A)') '.. >>>>> [ IO READ: jBH_c ] <<<<< ..'
+ call ezfio_get_jastrow_jBH_c(jBH_c)
+ IRP_IF MPI
+ call MPI_BCAST(jBH_c, (jBH_size*nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
+ if(ierr /= MPI_SUCCESS) then
+ stop 'Unable to read jBH_c with MPI'
+ endif
+ IRP_ENDIF
+ endif
+ else
+
+ jBH_c = 0.d0
+ call ezfio_set_jastrow_jBH_c(jBH_c)
+ endif
+
+ ! ---
+
+ if(mpi_master) then
+ call ezfio_has_jastrow_jBH_m(exists)
+ endif
+
+ IRP_IF MPI_DEBUG
+ print *, irp_here, mpi_rank
+ call MPI_BARRIER(MPI_COMM_WORLD, ierr)
+ IRP_ENDIF
+
+ IRP_IF MPI
+ call MPI_BCAST(jBH_m, (jBH_size*nucl_num), MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
+ if(ierr /= MPI_SUCCESS) then
+ stop 'Unable to read Boys-Handy m powers with MPI'
+ endif
+ IRP_ENDIF
+
+ if(exists) then
+ if(mpi_master) then
+ write(6,'(A)') '.. >>>>> [ IO READ: jBH_m ] <<<<< ..'
+ call ezfio_get_jastrow_jBH_m(jBH_m)
+ IRP_IF MPI
+ call MPI_BCAST(jBH_m, (jBH_size*nucl_num), MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
+ if(ierr /= MPI_SUCCESS) then
+ stop 'Unable to read jBH_m with MPI'
+ endif
+ IRP_ENDIF
+ endif
+ else
+
+ jBH_m = 0
+ call ezfio_set_jastrow_jBH_m(jBH_m)
+ endif
+
+ ! ---
+
+ if(mpi_master) then
+ call ezfio_has_jastrow_jBH_n(exists)
+ endif
+
+ IRP_IF MPI_DEBUG
+ print *, irp_here, mpi_rank
+ call MPI_BARRIER(MPI_COMM_WORLD, ierr)
+ IRP_ENDIF
+
+ IRP_IF MPI
+ call MPI_BCAST(jBH_n, (jBH_size*nucl_num), MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
+ if(ierr /= MPI_SUCCESS) then
+ stop 'Unable to read Boys-Handy n powers with MPI'
+ endif
+ IRP_ENDIF
+
+ if(exists) then
+ if(mpi_master) then
+ write(6,'(A)') '.. >>>>> [ IO READ: jBH_n ] <<<<< ..'
+ call ezfio_get_jastrow_jBH_n(jBH_n)
+ IRP_IF MPI
+ call MPI_BCAST(jBH_n, (jBH_size*nucl_num), MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
+ if(ierr /= MPI_SUCCESS) then
+ stop 'Unable to read jBH_n with MPI'
+ endif
+ IRP_ENDIF
+ endif
+ else
+
+ jBH_n = 0
+ call ezfio_set_jastrow_jBH_n(jBH_n)
+ endif
+
+ ! ---
+
+ if(mpi_master) then
+ call ezfio_has_jastrow_jBH_o(exists)
+ endif
+
+ IRP_IF MPI_DEBUG
+ print *, irp_here, mpi_rank
+ call MPI_BARRIER(MPI_COMM_WORLD, ierr)
+ IRP_ENDIF
+
+ IRP_IF MPI
+ call MPI_BCAST(jBH_o, (jBH_size*nucl_num), MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
+ if(ierr /= MPI_SUCCESS) then
+ stop 'Unable to read Boys-Handy o powers with MPI'
+ endif
+ IRP_ENDIF
+
+ if(exists) then
+ if(mpi_master) then
+ write(6,'(A)') '.. >>>>> [ IO READ: jBH_o ] <<<<< ..'
+ call ezfio_get_jastrow_jBH_o(jBH_o)
+ IRP_IF MPI
+ call MPI_BCAST(jBH_o, (jBH_size*nucl_num), MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
+ if(ierr /= MPI_SUCCESS) then
+ stop 'Unable to read jBH_o with MPI'
+ endif
+ IRP_ENDIF
+ endif
+ else
+
+ jBH_o = 0
+ call ezfio_set_jastrow_jBH_o(jBH_o)
+ endif
+
+ ! ---
+
+ print *, ' parameters for Boys-Handy Jastrow'
+ print *, ' nb of terms per nucleus = ', jBH_size
+
+ do i_nucl = 1, nucl_num
+ print *, ' nucl = ', nucl_label(i_nucl)
+ print *, ' ee-term = ', jBH_ee(i_nucl)
+ print *, ' en-term = ', jBH_en(i_nucl)
+ print *, ' m n o c'
+ do p = 1, jBH_size
+ write(*,'(3(I4,2x), E15.7)') jBH_m(p,i_nucl), jBH_n(p,i_nucl), jBH_o(p,i_nucl), jBH_c(p,i_nucl)
+ enddo
+ enddo
+
+
+END_PROVIDER
+
+! ---
+
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.irp.f b/plugins/local/non_h_ints_mu/jast_1e.irp.f
index fbd032ed..e994d27a 100644
--- a/plugins/local/non_h_ints_mu/jast_1e.irp.f
+++ b/plugins/local/non_h_ints_mu/jast_1e.irp.f
@@ -78,7 +78,7 @@ END_PROVIDER
double precision :: cx, cy, cz
double precision :: time0, time1
double precision, allocatable :: Pa(:,:), Pb(:,:), Pt(:,:)
- double precision, allocatable :: coef_fit(:), coef_fit2(:), coef_fit3(:,:)
+ double precision, allocatable :: coef_fit2(:,:)
PROVIDE j1e_type
@@ -163,75 +163,6 @@ END_PROVIDER
deallocate(Pa, Pb, Pt)
-! elseif(j1e_type .eq. "Charge_Harmonizer_AO") then
-!
-! ! \grad_1 \sum_{\eta} C_{\eta} \chi_{\eta}
-! ! where
-! ! \chi_{\eta} are the AOs
-! ! C_{\eta} are fitted to mimic (j1e_type .eq. "Charge_Harmonizer")
-! !
-! ! The - sign is in the parameters C_{\eta}
-!
-! PROVIDE aos_grad_in_r_array
-!
-! allocate(coef_fit(ao_num))
-!
-! if(mpi_master) then
-! call ezfio_has_jastrow_j1e_coef_ao(exists)
-! 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'
-! call MPI_BCAST(coef_fit, ao_num, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
-! if (ierr /= MPI_SUCCESS) then
-! stop 'Unable to read j1e_coef_ao with MPI'
-! endif
-! IRP_ENDIF
-! if(exists) then
-! if(mpi_master) then
-! write(6,'(A)') '.. >>>>> [ IO READ: j1e_coef_ao ] <<<<< ..'
-! call ezfio_get_jastrow_j1e_coef_ao(coef_fit)
-! IRP_IF MPI
-! call MPI_BCAST(coef_fit, ao_num, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
-! if (ierr /= MPI_SUCCESS) then
-! stop 'Unable to read j1e_coef_ao with MPI'
-! endif
-! IRP_ENDIF
-! endif
-! else
-!
-! call get_j1e_coef_fit_ao(ao_num, coef_fit)
-! call ezfio_set_jastrow_j1e_coef_ao(coef_fit)
-!
-! endif
-!
-! !$OMP PARALLEL &
-! !$OMP DEFAULT (NONE) &
-! !$OMP PRIVATE (i, ipoint, c) &
-! !$OMP SHARED (n_points_final_grid, ao_num, &
-! !$OMP aos_grad_in_r_array, coef_fit, &
-! !$OMP j1e_gradx, j1e_grady, j1e_gradz)
-! !$OMP DO SCHEDULE (static)
-! do ipoint = 1, n_points_final_grid
-!
-! j1e_gradx(ipoint) = 0.d0
-! j1e_grady(ipoint) = 0.d0
-! j1e_gradz(ipoint) = 0.d0
-! do i = 1, ao_num
-! c = coef_fit(i)
-! j1e_gradx(ipoint) = j1e_gradx(ipoint) + c * aos_grad_in_r_array(i,ipoint,1)
-! j1e_grady(ipoint) = j1e_grady(ipoint) + c * aos_grad_in_r_array(i,ipoint,2)
-! j1e_gradz(ipoint) = j1e_gradz(ipoint) + c * aos_grad_in_r_array(i,ipoint,3)
-! enddo
-! enddo
-! !$OMP END DO
-! !$OMP END PARALLEL
-!
-! deallocate(coef_fit)
-
elseif(j1e_type .eq. "Charge_Harmonizer_AO") then
! \grad_1 \sum_{\eta,\beta} C_{\eta,\beta} \chi_{\eta} \chi_{\beta}
@@ -243,7 +174,7 @@ END_PROVIDER
PROVIDE aos_grad_in_r_array
- allocate(coef_fit2(ao_num*ao_num))
+ allocate(coef_fit2(ao_num,ao_num))
if(mpi_master) then
call ezfio_has_jastrow_j1e_coef_ao2(exists)
@@ -254,7 +185,7 @@ END_PROVIDER
IRP_ENDIF
IRP_IF MPI
include 'mpif.h'
- call MPI_BCAST(coef_fit2, ao_num*ao_num, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
+ call MPI_BCAST(coef_fit2, (ao_num*ao_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read j1e_coef_ao2 with MPI'
endif
@@ -264,22 +195,20 @@ END_PROVIDER
write(6,'(A)') '.. >>>>> [ IO READ: j1e_coef_ao2 ] <<<<< ..'
call ezfio_get_jastrow_j1e_coef_ao2(coef_fit2)
IRP_IF MPI
- call MPI_BCAST(coef_fit2, ao_num*ao_num, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
+ call MPI_BCAST(coef_fit2, (ao_num*ao_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read j1e_coef_ao2 with MPI'
endif
IRP_ENDIF
endif
else
-
- call get_j1e_coef_fit_ao2(ao_num*ao_num, coef_fit2)
+ call get_j1e_coef_fit_ao2(ao_num, coef_fit2)
call ezfio_set_jastrow_j1e_coef_ao2(coef_fit2)
-
endif
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (i, j, ij, ipoint, c) &
+ !$OMP PRIVATE (i, j, ipoint, c) &
!$OMP SHARED (n_points_final_grid, ao_num, &
!$OMP aos_grad_in_r_array, coef_fit2, &
!$OMP aos_in_r_array, j1e_gradx, j1e_grady, j1e_gradz)
@@ -292,9 +221,7 @@ END_PROVIDER
do i = 1, ao_num
do j = 1, ao_num
- ij = (i-1)*ao_num + j
-
- c = coef_fit2(ij)
+ c = coef_fit2(j,i)
j1e_gradx(ipoint) += c * (aos_in_r_array(i,ipoint) * aos_grad_in_r_array(j,ipoint,1) + aos_grad_in_r_array(i,ipoint,1) * aos_in_r_array(j,ipoint))
j1e_grady(ipoint) += c * (aos_in_r_array(i,ipoint) * aos_grad_in_r_array(j,ipoint,2) + aos_grad_in_r_array(i,ipoint,2) * aos_in_r_array(j,ipoint))
@@ -307,78 +234,6 @@ END_PROVIDER
deallocate(coef_fit2)
-! elseif(j1e_type .eq. "Charge_Harmonizer_AO3") then
-!
-! ! \sum_{\eta} \vec{C}_{\eta} \chi_{\eta}
-! ! where
-! ! \chi_{\eta} are the AOs
-! ! \vec{C}_{\eta} are fitted to mimic (j1e_type .eq. "Charge_Harmonizer")
-! !
-! ! The - sign is in the parameters \vec{C}_{\eta}
-!
-! PROVIDE aos_grad_in_r_array
-!
-! allocate(coef_fit3(ao_num,3))
-!
-! if(mpi_master) then
-! call ezfio_has_jastrow_j1e_coef_ao3(exists)
-! 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'
-! call MPI_BCAST(coef_fit3, (ao_num*3), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
-! if (ierr /= MPI_SUCCESS) then
-! stop 'Unable to read j1e_coef_ao3 with MPI'
-! endif
-! IRP_ENDIF
-! if(exists) then
-! if(mpi_master) then
-! write(6,'(A)') '.. >>>>> [ IO READ: j1e_coef_ao3 ] <<<<< ..'
-! call ezfio_get_jastrow_j1e_coef_ao3(coef_fit3)
-! IRP_IF MPI
-! call MPI_BCAST(coef_fit3, (ao_num*3), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
-! if (ierr /= MPI_SUCCESS) then
-! stop 'Unable to read j1e_coef_ao3 with MPI'
-! endif
-! IRP_ENDIF
-! endif
-! else
-!
-! call get_j1e_coef_fit_ao3(ao_num, coef_fit3)
-! call ezfio_set_jastrow_j1e_coef_ao3(coef_fit3)
-!
-! endif
-!
-! !$OMP PARALLEL &
-! !$OMP DEFAULT (NONE) &
-! !$OMP PRIVATE (i, ipoint, cx, cy, cz) &
-! !$OMP SHARED (n_points_final_grid, ao_num, &
-! !$OMP aos_grad_in_r_array, coef_fit3, &
-! !$OMP aos_in_r_array, j1e_gradx, j1e_grady, j1e_gradz)
-! !$OMP DO SCHEDULE (static)
-! do ipoint = 1, n_points_final_grid
-!
-! j1e_gradx(ipoint) = 0.d0
-! j1e_grady(ipoint) = 0.d0
-! j1e_gradz(ipoint) = 0.d0
-! do i = 1, ao_num
-! cx = coef_fit3(i,1)
-! cy = coef_fit3(i,2)
-! cz = coef_fit3(i,3)
-!
-! j1e_gradx(ipoint) += cx * aos_in_r_array(i,ipoint)
-! j1e_grady(ipoint) += cy * aos_in_r_array(i,ipoint)
-! j1e_gradz(ipoint) += cz * aos_in_r_array(i,ipoint)
-! enddo
-! enddo
-! !$OMP END DO
-! !$OMP END PARALLEL
-!
-! deallocate(coef_fit3)
-
else
print *, ' Error in j1e_grad: Unknown j1e_type = ', j1e_type
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 842908a7..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
@@ -120,15 +120,20 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
implicit none
integer , intent(in) :: dim_fit
- double precision, intent(out) :: coef_fit(dim_fit)
+ double precision, intent(out) :: coef_fit(dim_fit,dim_fit)
integer :: i, j, k, l, ipoint
- integer :: ij, kl
+ integer :: ij, kl, mn
+ integer :: info, n_svd, LWORK
double precision :: g
- double precision :: t0, t1
- double precision, allocatable :: A(:,:), b(:), A_inv(:,:)
+ double precision :: t0, t1, svd_t0, svd_t1
+ double precision :: cutoff_svd, D1_inv
+ double precision, allocatable :: diff(:)
+ double precision, allocatable :: A(:,:,:,:), b(:), A_tmp(:,:,:,:)
double precision, allocatable :: Pa(:,:), Pb(:,:), Pt(:,:)
- double precision, allocatable :: u1e_tmp(:)
+ double precision, allocatable :: u1e_tmp(:), tmp(:,:,:)
+ double precision, allocatable :: tmp1(:,:,:), tmp2(:,:,:)
+ double precision, allocatable :: U(:,:), D(:), Vt(:,:), work(:)
PROVIDE j1e_type
@@ -136,6 +141,9 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
PROVIDE elec_alpha_num elec_beta_num elec_num
PROVIDE mo_coef
+
+ cutoff_svd = 1d-10
+
call wall_time(t0)
print*, ' PROVIDING the representation of 1e-Jastrow in AOs x AOs ... '
@@ -169,98 +177,133 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
! --- --- ---
! get A
- allocate(A(ao_num*ao_num,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, k, l, ij, kl, ipoint) &
- !$OMP SHARED (n_points_final_grid, ao_num, &
- !$OMP final_weight_at_r_vector, aos_in_r_array_transp, A)
+ !$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, tmp1, tmp2)
!$OMP DO COLLAPSE(2)
- do k = 1, ao_num
- do l = 1, ao_num
- kl = (k-1)*ao_num + l
-
- do i = 1, ao_num
- do j = 1, ao_num
- ij = (i-1)*ao_num + j
-
- A(ij,kl) = 0.d0
- do ipoint = 1, n_points_final_grid
- A(ij,kl) += final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j) &
- * aos_in_r_array_transp(ipoint,k) * aos_in_r_array_transp(ipoint,l)
- enddo
- enddo
+ do j = 1, ao_num
+ do i = 1, ao_num
+ do ipoint = 1, n_points_final_grid
+ 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
-! print *, ' A'
-! do ij = 1, ao_num*ao_num
-! write(*, '(100000(f15.7))') (A(ij,kl), kl = 1, ao_num*ao_num)
-! enddo
+ 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))
+ A_tmp = A
! --- --- ---
! get b
allocate(b(ao_num*ao_num))
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (i, j, ij, ipoint) &
- !$OMP SHARED (n_points_final_grid, ao_num, &
- !$OMP final_weight_at_r_vector, aos_in_r_array_transp, u1e_tmp, b)
- !$OMP DO COLLAPSE(2)
- do i = 1, ao_num
- do j = 1, ao_num
- ij = (i-1)*ao_num + j
+ do ipoint = 1, n_points_final_grid
+ u1e_tmp(ipoint) = u1e_tmp(ipoint)
+ enddo
- b(ij) = 0.d0
- do ipoint = 1, n_points_final_grid
- b(ij) = b(ij) + final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j) * u1e_tmp(ipoint)
- enddo
+ 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(tmp1, tmp2)
+
+ ! --- --- ---
+ ! solve Ax = b
+
+ allocate(D(ao_num*ao_num), U(ao_num*ao_num,ao_num*ao_num), Vt(ao_num*ao_num,ao_num*ao_num))
+
+ call wall_time(svd_t0)
+
+ allocate(work(1))
+ lwork = -1
+ call dgesvd( 'S', 'A', ao_num*ao_num, ao_num*ao_num, A(1,1,1,1), ao_num*ao_num &
+ , D(1), U(1,1), ao_num*ao_num, Vt(1,1), ao_num*ao_num, work, lwork, info)
+ if(info /= 0) then
+ print *, info, ': SVD failed'
+ stop
+ endif
+
+ LWORK = max(5*ao_num*ao_num, int(WORK(1)))
+ deallocate(work)
+ allocate(work(lwork))
+ call dgesvd( 'S', 'A', ao_num*ao_num, ao_num*ao_num, A(1,1,1,1), ao_num*ao_num &
+ , D(1), U(1,1), ao_num*ao_num, Vt(1,1), ao_num*ao_num, work, lwork, info)
+ if(info /= 0) then
+ print *, info, ':: SVD failed'
+ stop 1
+ endif
+
+ deallocate(work)
+
+ call wall_time(svd_t1)
+ print*, ' SVD time (min) ', (svd_t1-svd_t0)/60.d0
+
+ if(D(1) .lt. 1d-14) then
+ print*, ' largest singular value is very small:', D(1)
+ n_svd = 1
+ else
+ n_svd = 0
+ D1_inv = 1.d0 / D(1)
+ do ij = 1, ao_num*ao_num
+ if(D(ij)*D1_inv > cutoff_svd) then
+ D(ij) = 1.d0 / D(ij)
+ n_svd = n_svd + 1
+ else
+ D(ij) = 0.d0
+ endif
+ enddo
+ endif
+ print*, ' n_svd = ', n_svd
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ij, kl) &
+ !$OMP SHARED (ao_num, n_svd, D, Vt)
+ !$OMP DO
+ do kl = 1, ao_num*ao_num
+ do ij = 1, n_svd
+ Vt(ij,kl) = Vt(ij,kl) * D(ij)
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
- deallocate(u1e_tmp)
+ ! A = A_inv
+ call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_svd, 1.d0 &
+ , U(1,1), ao_num*ao_num, Vt(1,1), ao_num*ao_num &
+ , 0.d0, A(1,1,1,1), ao_num*ao_num)
- ! --- --- ---
- ! solve Ax = b
+ deallocate(D, U, Vt)
- allocate(A_inv(ao_num*ao_num,ao_num*ao_num))
- !call get_inverse(A, ao_num*ao_num, ao_num*ao_num, A_inv, ao_num*ao_num)
- call get_pseudo_inverse(A, ao_num*ao_num, ao_num*ao_num, ao_num*ao_num, A_inv, ao_num*ao_num, 5d-8)
+
+ ! ---
! coef_fit = A_inv x b
- call dgemv("N", ao_num*ao_num, ao_num*ao_num, 1.d0, A_inv, ao_num*ao_num, b, 1, 0.d0, coef_fit, 1)
+ call dgemv("N", ao_num*ao_num, ao_num*ao_num, 1.d0, A(1,1,1,1), ao_num*ao_num, b(1), 1, 0.d0, coef_fit(1,1), 1)
- integer :: mn
- double precision :: tmp, acc, nrm
+ ! ---
- acc = 0.d0
- nrm = 0.d0
- do ij = 1, ao_num*ao_num
- tmp = 0.d0
- do kl = 1, ao_num*ao_num
- tmp += A(ij,kl) * coef_fit(kl)
- enddo
- tmp = tmp - b(ij)
- if(dabs(tmp) .gt. 1d-7) then
- print*, ' problem found in fitting 1e-Jastrow'
- print*, ij, tmp
- endif
+ allocate(diff(ao_num*ao_num))
- acc += dabs(tmp)
- nrm += dabs(b(ij))
- enddo
- print *, ' Relative Error (%) =', 100.d0*acc/nrm
+ call dgemv("N", ao_num*ao_num, ao_num*ao_num, 1.d0, A_tmp(1,1,1,1), ao_num*ao_num, coef_fit(1,1), 1, 0.d0, diff(1), 1)
+ print*, ' accu total on Ax = b (%) = ', 100.d0*sum(dabs(diff-b))/sum(dabs(b))
+ deallocate(diff)
+ deallocate(A_tmp)
- deallocate(A, A_inv, b)
+ ! ---
+
+ deallocate(A, b)
call wall_time(t1)
print*, ' END after (min) ', (t1-t0)/60.d0
diff --git a/plugins/local/non_h_ints_mu/jast_2e_utils.irp.f b/plugins/local/non_h_ints_mu/jast_2e_utils.irp.f
index 8c25b377..34d01fb2 100644
--- a/plugins/local/non_h_ints_mu/jast_2e_utils.irp.f
+++ b/plugins/local/non_h_ints_mu/jast_2e_utils.irp.f
@@ -12,12 +12,17 @@ BEGIN_PROVIDER [double precision, int2_u2e_ao, (ao_num, ao_num, n_points_final_g
END_DOC
implicit none
- integer :: ipoint, i, j, jpoint
- double precision :: time0, time1
- double precision :: x, y, z, r2
- double precision :: dx, dy, dz
- double precision :: tmp_ct
- double precision :: tmp0, tmp1, tmp2, tmp3
+ integer :: ipoint, i, j, jpoint
+ integer :: n_blocks, n_rest, n_pass
+ integer :: i_blocks, i_rest, i_pass, ii
+ double precision :: mem, n_double
+ double precision :: time0, time1
+ double precision :: x, y, z, r2
+ double precision :: dx, dy, dz
+ double precision :: tmp_ct
+ double precision :: tmp0, tmp1, tmp2, tmp3
+ double precision, allocatable :: tmp(:,:,:)
+ double precision, allocatable :: tmp_u12(:,:)
PROVIDE j2e_type
PROVIDE Env_type
@@ -25,59 +30,152 @@ BEGIN_PROVIDER [double precision, int2_u2e_ao, (ao_num, ao_num, n_points_final_g
call wall_time(time0)
print*, ' providing int2_u2e_ao ...'
- if( (j2e_type .eq. "Mu") .and. &
- ( (env_type .eq. "None") .or. (env_type .eq. "Prod_Gauss") .or. (env_type .eq. "Sum_Gauss") ) ) then
+ if(tc_integ_type .eq. "numeric") then
- PROVIDE mu_erf
- PROVIDE env_type env_val
- PROVIDE Ir2_Mu_long_Du_0 Ir2_Mu_long_Du_x Ir2_Mu_long_Du_y Ir2_Mu_long_Du_z Ir2_Mu_long_Du_2
- PROVIDE Ir2_Mu_gauss_Du
+ PROVIDE final_weight_at_r_vector_extra aos_in_r_array_extra
- tmp_ct = 0.5d0 / (dsqrt(dacos(-1.d0)) * mu_erf)
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, i, j, x, y, z, r2, dx, dy, dz, &
- !$OMP tmp0, tmp1, tmp2, tmp3) &
- !$OMP SHARED (ao_num, n_points_final_grid, final_grid_points, &
- !$OMP tmp_ct, env_val, Ir2_Mu_long_Du_0, &
- !$OMP Ir2_Mu_long_Du_x, Ir2_Mu_long_Du_y, &
- !$OMP Ir2_Mu_long_Du_z, Ir2_Mu_gauss_Du, &
- !$OMP Ir2_Mu_long_Du_2, int2_u2e_ao)
+ 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 SCHEDULE (static)
- do ipoint = 1, n_points_final_grid
-
- x = final_grid_points(1,ipoint)
- y = final_grid_points(2,ipoint)
- z = final_grid_points(3,ipoint)
- r2 = x*x + y*y + z*z
-
- dx = x * env_val(ipoint)
- dy = y * env_val(ipoint)
- dz = z * env_val(ipoint)
-
- tmp0 = 0.5d0 * env_val(ipoint) * r2
- tmp1 = 0.5d0 * env_val(ipoint)
- tmp3 = tmp_ct * env_val(ipoint)
-
- do j = 1, ao_num
- do i = 1, ao_num
-
- tmp2 = tmp1 * Ir2_Mu_long_Du_2(i,j,ipoint) - dx * Ir2_Mu_long_Du_x(i,j,ipoint) - dy * Ir2_Mu_long_Du_y(i,j,ipoint) - dz * Ir2_Mu_long_Du_z(i,j,ipoint)
-
- int2_u2e_ao(i,j,ipoint) = tmp0 * Ir2_Mu_long_Du_0(i,j,ipoint) + tmp2 - tmp3 * Ir2_Mu_gauss_Du(i,j,ipoint)
+ 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
- else
+ 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 * 1.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)
- print *, ' Error in int2_u2e_ao: Unknown Jastrow'
+ 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_u12(n_points_extra_final_grid,n_blocks))
+
+ 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_u12)
+ !$OMP DO
+ do i_blocks = 1, n_blocks
+ ipoint = ii - 1 + i_blocks ! r1
+ call get_u12_2e_r1_seq(ipoint, n_points_extra_final_grid, tmp_u12(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, 1.d0 &
+ , tmp(1,1,1), n_points_extra_final_grid, tmp_u12(1,1), n_points_extra_final_grid &
+ , 0.d0, int2_u2e_ao(1,1,ii), ao_num*ao_num)
+ enddo
+
+ deallocate(tmp_u12)
+
+ if(n_rest .gt. 0) then
+
+ allocate(tmp_u12(n_points_extra_final_grid,n_rest))
+
+ 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_u12)
+ !$OMP DO
+ do i_rest = 1, n_rest
+ ipoint = ii - 1 + i_rest ! r1
+ call get_u12_2e_r1_seq(ipoint, n_points_extra_final_grid, tmp_u12(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, 1.d0 &
+ , tmp(1,1,1), n_points_extra_final_grid, tmp_u12(1,1), n_points_extra_final_grid &
+ , 0.d0, int2_u2e_ao(1,1,ii), ao_num*ao_num)
+
+ deallocate(tmp_u12)
+ endif
+
+ deallocate(tmp)
+
+ elseif(tc_integ_type .eq. "semi-analytic") then
+
+ if( (j2e_type .eq. "Mu") .and. &
+ ( (env_type .eq. "None") .or. (env_type .eq. "Prod_Gauss") .or. (env_type .eq. "Sum_Gauss") ) ) then
+
+ PROVIDE mu_erf
+ PROVIDE env_type env_val
+ PROVIDE Ir2_Mu_long_Du_0 Ir2_Mu_long_Du_x Ir2_Mu_long_Du_y Ir2_Mu_long_Du_z Ir2_Mu_long_Du_2
+ PROVIDE Ir2_Mu_gauss_Du
+
+ tmp_ct = 0.5d0 / (dsqrt(dacos(-1.d0)) * mu_erf)
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, i, j, x, y, z, r2, dx, dy, dz, &
+ !$OMP tmp0, tmp1, tmp2, tmp3) &
+ !$OMP SHARED (ao_num, n_points_final_grid, final_grid_points, &
+ !$OMP tmp_ct, env_val, Ir2_Mu_long_Du_0, &
+ !$OMP Ir2_Mu_long_Du_x, Ir2_Mu_long_Du_y, &
+ !$OMP Ir2_Mu_long_Du_z, Ir2_Mu_gauss_Du, &
+ !$OMP Ir2_Mu_long_Du_2, int2_u2e_ao)
+ !$OMP DO SCHEDULE (static)
+ do ipoint = 1, n_points_final_grid
+
+ x = final_grid_points(1,ipoint)
+ y = final_grid_points(2,ipoint)
+ z = final_grid_points(3,ipoint)
+ r2 = x*x + y*y + z*z
+
+ dx = x * env_val(ipoint)
+ dy = y * env_val(ipoint)
+ dz = z * env_val(ipoint)
+
+ tmp0 = 0.5d0 * env_val(ipoint) * r2
+ tmp1 = 0.5d0 * env_val(ipoint)
+ tmp3 = tmp_ct * env_val(ipoint)
+
+ do j = 1, ao_num
+ do i = 1, ao_num
+
+ tmp2 = tmp1 * Ir2_Mu_long_Du_2(i,j,ipoint) - dx * Ir2_Mu_long_Du_x(i,j,ipoint) - dy * Ir2_Mu_long_Du_y(i,j,ipoint) - dz * Ir2_Mu_long_Du_z(i,j,ipoint)
+
+ int2_u2e_ao(i,j,ipoint) = tmp0 * Ir2_Mu_long_Du_0(i,j,ipoint) + tmp2 - tmp3 * Ir2_Mu_gauss_Du(i,j,ipoint)
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ else
+
+ print *, ' Error in int2_u2e_ao: Unknown Jastrow'
+ stop
+
+ endif ! j2e_type
+
+ else
+
+ print *, ' Error in int2_u2e_ao: Unknown tc_integ_type'
stop
- endif ! j2e_type
+ endif ! tc_integ_type
call wall_time(time1)
print*, ' wall time for int2_u2e_ao (min) =', (time1-time0)/60.d0
@@ -98,14 +196,20 @@ BEGIN_PROVIDER [double precision, int2_grad1_u2e_ao, (ao_num, ao_num, n_points_f
END_DOC
implicit none
- integer :: ipoint, i, j, m, jpoint
- double precision :: time0, time1
- double precision :: x, y, z, r2
- double precision :: dx, dy, dz
- double precision :: tmp_ct
- double precision :: tmp0, tmp1, tmp2
- double precision :: tmp0_x, tmp0_y, tmp0_z
- double precision :: tmp1_x, tmp1_y, tmp1_z
+ integer :: ipoint, i, j, m, jpoint
+ integer :: n_blocks, n_rest, n_pass
+ integer :: i_blocks, i_rest, i_pass, ii
+ double precision :: mem, n_double
+ double precision :: time0, time1
+ double precision :: x, y, z, r2
+ double precision :: dx, dy, dz
+ double precision :: tmp_ct
+ double precision :: tmp0, tmp1, tmp2
+ double precision :: tmp0_x, tmp0_y, tmp0_z
+ double precision :: tmp1_x, tmp1_y, tmp1_z
+ double precision, allocatable :: tmp(:,:,:)
+ double precision, allocatable :: tmp_grad1_u12(:,:,:)
+
PROVIDE j2e_type
PROVIDE Env_type
@@ -113,70 +217,171 @@ BEGIN_PROVIDER [double precision, int2_grad1_u2e_ao, (ao_num, ao_num, n_points_f
call wall_time(time0)
print*, ' providing int2_grad1_u2e_ao ...'
- if( (j2e_type .eq. "Mu") .and. &
- ( (env_type .eq. "None") .or. (env_type .eq. "Prod_Gauss") .or. (env_type .eq. "Sum_Gauss") ) ) then
+ if(tc_integ_type .eq. "numeric") then
- PROVIDE mu_erf
- PROVIDE env_type env_val env_grad
- PROVIDE Ir2_Mu_long_Du_0 Ir2_Mu_long_Du_x Ir2_Mu_long_Du_y Ir2_Mu_long_Du_z Ir2_Mu_long_Du_2
- PROVIDE Ir2_Mu_gauss_Du
+ PROVIDE final_weight_at_r_vector_extra aos_in_r_array_extra
- tmp_ct = 0.5d0 / (dsqrt(dacos(-1.d0)) * mu_erf)
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, i, j, x, y, z, r2, dx, dy, dz, tmp1, tmp2, &
- !$OMP tmp0_x, tmp0_y, tmp0_z, tmp1_x, tmp1_y, tmp1_z) &
- !$OMP SHARED (ao_num, n_points_final_grid, final_grid_points, &
- !$OMP tmp_ct, env_val, env_grad, Ir2_Mu_long_Du_0, &
- !$OMP Ir2_Mu_long_Du_x, Ir2_Mu_long_Du_y, &
- !$OMP Ir2_Mu_long_Du_z, Ir2_Mu_gauss_Du, &
- !$OMP Ir2_Mu_long_Du_2, int2_grad1_u2e_ao)
+ 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 SCHEDULE (static)
- do ipoint = 1, n_points_final_grid
-
- x = final_grid_points(1,ipoint)
- y = final_grid_points(2,ipoint)
- z = final_grid_points(3,ipoint)
- r2 = x*x + y*y + z*z
-
- dx = env_grad(1,ipoint)
- dy = env_grad(2,ipoint)
- dz = env_grad(3,ipoint)
-
- tmp0_x = 0.5d0 * (env_val(ipoint) * x + r2 * dx)
- tmp0_y = 0.5d0 * (env_val(ipoint) * y + r2 * dy)
- tmp0_z = 0.5d0 * (env_val(ipoint) * z + r2 * dz)
-
- tmp1 = 0.5d0 * env_val(ipoint)
-
- tmp1_x = tmp_ct * dx
- tmp1_y = tmp_ct * dy
- tmp1_z = tmp_ct * dz
-
- do j = 1, ao_num
- do i = 1, ao_num
-
- tmp2 = 0.5d0 * Ir2_Mu_long_Du_2(i,j,ipoint) - x * Ir2_Mu_long_Du_x(i,j,ipoint) - y * Ir2_Mu_long_Du_y(i,j,ipoint) - z * Ir2_Mu_long_Du_z(i,j,ipoint)
-
- int2_grad1_u2e_ao(i,j,ipoint,1) = Ir2_Mu_long_Du_0(i,j,ipoint) * tmp0_x - tmp1 * Ir2_Mu_long_Du_x(i,j,ipoint) + dx * tmp2 - tmp1_x * Ir2_Mu_gauss_Du(i,j,ipoint)
- int2_grad1_u2e_ao(i,j,ipoint,2) = Ir2_Mu_long_Du_0(i,j,ipoint) * tmp0_y - tmp1 * Ir2_Mu_long_Du_y(i,j,ipoint) + dy * tmp2 - tmp1_y * Ir2_Mu_gauss_Du(i,j,ipoint)
- int2_grad1_u2e_ao(i,j,ipoint,3) = Ir2_Mu_long_Du_0(i,j,ipoint) * tmp0_z - tmp1 * Ir2_Mu_long_Du_z(i,j,ipoint) + dz * tmp2 - tmp1_z * Ir2_Mu_gauss_Du(i,j,ipoint)
+ 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
- FREE Ir2_Mu_long_Du_0 Ir2_Mu_long_Du_x Ir2_Mu_long_Du_y Ir2_Mu_long_Du_z Ir2_Mu_long_Du_2
- FREE Ir2_Mu_gauss_Du
+ 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 * 3.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, &
+ !$OMP final_grid_points, tmp_grad1_u12)
+ !$OMP DO
+ do i_blocks = 1, n_blocks
+ ipoint = ii - 1 + i_blocks ! r1
+ call get_grad1_u12_2e_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))
+ 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_u2e_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, &
+ !$OMP final_grid_points, tmp_grad1_u12)
+ !$OMP DO
+ do i_rest = 1, n_rest
+ ipoint = ii - 1 + i_rest ! r1
+ call get_grad1_u12_2e_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))
+ 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_u2e_ao(1,1,ii,m), ao_num*ao_num)
+ enddo
+
+ deallocate(tmp_grad1_u12)
+ endif
+
+ deallocate(tmp)
+
+ elseif(tc_integ_type .eq. "semi-analytic") then
+
+ if( (j2e_type .eq. "Mu") .and. &
+ ( (env_type .eq. "None") .or. (env_type .eq. "Prod_Gauss") .or. (env_type .eq. "Sum_Gauss") ) ) then
+
+ PROVIDE mu_erf
+ PROVIDE env_type env_val env_grad
+ PROVIDE Ir2_Mu_long_Du_0 Ir2_Mu_long_Du_x Ir2_Mu_long_Du_y Ir2_Mu_long_Du_z Ir2_Mu_long_Du_2
+ PROVIDE Ir2_Mu_gauss_Du
+
+ tmp_ct = 0.5d0 / (dsqrt(dacos(-1.d0)) * mu_erf)
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, i, j, x, y, z, r2, dx, dy, dz, tmp1, tmp2, &
+ !$OMP tmp0_x, tmp0_y, tmp0_z, tmp1_x, tmp1_y, tmp1_z) &
+ !$OMP SHARED (ao_num, n_points_final_grid, final_grid_points, &
+ !$OMP tmp_ct, env_val, env_grad, Ir2_Mu_long_Du_0, &
+ !$OMP Ir2_Mu_long_Du_x, Ir2_Mu_long_Du_y, &
+ !$OMP Ir2_Mu_long_Du_z, Ir2_Mu_gauss_Du, &
+ !$OMP Ir2_Mu_long_Du_2, int2_grad1_u2e_ao)
+ !$OMP DO SCHEDULE (static)
+ do ipoint = 1, n_points_final_grid
+
+ x = final_grid_points(1,ipoint)
+ y = final_grid_points(2,ipoint)
+ z = final_grid_points(3,ipoint)
+ r2 = x*x + y*y + z*z
+
+ dx = env_grad(1,ipoint)
+ dy = env_grad(2,ipoint)
+ dz = env_grad(3,ipoint)
+
+ tmp0_x = 0.5d0 * (env_val(ipoint) * x + r2 * dx)
+ tmp0_y = 0.5d0 * (env_val(ipoint) * y + r2 * dy)
+ tmp0_z = 0.5d0 * (env_val(ipoint) * z + r2 * dz)
+
+ tmp1 = 0.5d0 * env_val(ipoint)
+
+ tmp1_x = tmp_ct * dx
+ tmp1_y = tmp_ct * dy
+ tmp1_z = tmp_ct * dz
+
+ do j = 1, ao_num
+ do i = 1, ao_num
+
+ tmp2 = 0.5d0 * Ir2_Mu_long_Du_2(i,j,ipoint) - x * Ir2_Mu_long_Du_x(i,j,ipoint) - y * Ir2_Mu_long_Du_y(i,j,ipoint) - z * Ir2_Mu_long_Du_z(i,j,ipoint)
+
+ int2_grad1_u2e_ao(i,j,ipoint,1) = Ir2_Mu_long_Du_0(i,j,ipoint) * tmp0_x - tmp1 * Ir2_Mu_long_Du_x(i,j,ipoint) + dx * tmp2 - tmp1_x * Ir2_Mu_gauss_Du(i,j,ipoint)
+ int2_grad1_u2e_ao(i,j,ipoint,2) = Ir2_Mu_long_Du_0(i,j,ipoint) * tmp0_y - tmp1 * Ir2_Mu_long_Du_y(i,j,ipoint) + dy * tmp2 - tmp1_y * Ir2_Mu_gauss_Du(i,j,ipoint)
+ int2_grad1_u2e_ao(i,j,ipoint,3) = Ir2_Mu_long_Du_0(i,j,ipoint) * tmp0_z - tmp1 * Ir2_Mu_long_Du_z(i,j,ipoint) + dz * tmp2 - tmp1_z * Ir2_Mu_gauss_Du(i,j,ipoint)
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ FREE Ir2_Mu_long_Du_0 Ir2_Mu_long_Du_x Ir2_Mu_long_Du_y Ir2_Mu_long_Du_z Ir2_Mu_long_Du_2
+ FREE Ir2_Mu_gauss_Du
+
+ else
+
+ print *, ' Error in int2_grad1_u2e_ao: Unknown Jastrow'
+ stop
+
+ endif ! j2e_type
else
-
- print *, ' Error in int2_grad1_u2e_ao: Unknown Jastrow'
+
+ print *, ' Error in int2_grad1_u2e_ao: Unknown tc_integ_type'
stop
- endif ! j2e_type
+ endif ! tc_integ_type
call wall_time(time1)
print*, ' wall time for int2_grad1_u2e_ao (min) =', (time1-time0)/60.d0
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 b58d8c17..2c41b535 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
@@ -19,11 +19,13 @@ subroutine get_grad1_u12_withsq_r1_seq(ipoint, n_grid2, resx, resy, resz, res)
double precision :: env_r1, tmp
double precision :: grad1_env(3), r1(3)
double precision, allocatable :: env_r2(:)
- double precision, allocatable :: u2b_r12(:)
- double precision, allocatable :: gradx1_u2b(:), grady1_u2b(:), gradz1_u2b(:)
+ double precision, allocatable :: u2b_r12(:), gradx1_u2b(:), grady1_u2b(:), gradz1_u2b(:)
+ double precision, allocatable :: u2b_mu(:), gradx1_mu(:), grady1_mu(:), gradz1_mu(:)
+ double precision, allocatable :: u2b_nu(:), gradx1_nu(:), grady1_nu(:), gradz1_nu(:)
double precision, external :: env_nucl
PROVIDE j1e_type j2e_type env_type
+ PROVIDE mu_erf nu_erf a_boys
PROVIDE final_grid_points
PROVIDE final_grid_points_extra
@@ -41,8 +43,8 @@ subroutine get_grad1_u12_withsq_r1_seq(ipoint, n_grid2, resx, resy, resz, res)
else
- ! u(r1,r2) = j12_mu(r12) x v(r1) x v(r2)
- ! grad1 u(r1, r2) = [(grad1 j12_mu) v(r1) + j12_mu grad1 v(r1)] v(r2)
+ ! u(r1,r2) = j12_mu(r12) x v(r1) x v(r2)
+ ! grad1 u(r1, r2) = [(grad1 j12_mu) v(r1) + j12_mu grad1 v(r1)] v(r2)
allocate(env_r2(n_grid2))
allocate(u2b_r12(n_grid2))
@@ -67,6 +69,54 @@ subroutine get_grad1_u12_withsq_r1_seq(ipoint, n_grid2, resx, resy, resz, res)
endif ! env_type
+ elseif(j2e_type .eq. "Mu_Nu") then
+
+ if(env_type .eq. "None") then
+
+ call grad1_jmu_r1_seq(mu_erf, r1, n_grid2, resx, resy, resz)
+
+ else
+
+ ! u(r1,r2) = jmu(r12) x v(r1) x v(r2) + jnu(r12) x [1 - v(r1) x v(r2)]
+
+ allocate(env_r2(n_grid2))
+ allocate(u2b_mu(n_grid2))
+ allocate(u2b_nu(n_grid2))
+ allocate(gradx1_mu(n_grid2), grady1_mu(n_grid2), gradz1_mu(n_grid2))
+ allocate(gradx1_nu(n_grid2), grady1_nu(n_grid2), gradz1_nu(n_grid2))
+
+ env_r1 = env_nucl(r1)
+ call grad1_env_nucl(r1, grad1_env)
+ call env_nucl_r1_seq(n_grid2, env_r2)
+
+ call jmu_r1_seq(mu_erf, r1, n_grid2, u2b_mu)
+ call jmu_r1_seq(nu_erf, r1, n_grid2, u2b_nu)
+
+ call grad1_jmu_r1_seq(mu_erf, r1, n_grid2, gradx1_mu, grady1_mu, gradz1_mu)
+ call grad1_jmu_r1_seq(nu_erf, r1, n_grid2, gradx1_nu, grady1_nu, gradz1_nu)
+
+ do jpoint = 1, n_points_extra_final_grid
+ resx(jpoint) = gradx1_nu(jpoint) + ((gradx1_mu(jpoint) - gradx1_nu(jpoint)) * env_r1 + (u2b_mu(jpoint) - u2b_nu(jpoint)) * grad1_env(1)) * env_r2(jpoint)
+ resy(jpoint) = grady1_nu(jpoint) + ((grady1_mu(jpoint) - grady1_nu(jpoint)) * env_r1 + (u2b_mu(jpoint) - u2b_nu(jpoint)) * grad1_env(2)) * env_r2(jpoint)
+ resz(jpoint) = gradz1_nu(jpoint) + ((gradz1_mu(jpoint) - gradz1_nu(jpoint)) * env_r1 + (u2b_mu(jpoint) - u2b_nu(jpoint)) * grad1_env(3)) * env_r2(jpoint)
+ enddo
+
+ deallocate(env_r2)
+ deallocate(u2b_mu)
+ deallocate(u2b_nu)
+ deallocate(gradx1_mu, grady1_mu, gradz1_mu)
+ deallocate(gradx1_nu, grady1_nu, gradz1_nu)
+
+ endif ! env_type
+
+ elseif(j2e_type .eq. "Boys_Handy") then
+
+ PROVIDE jBH_size jBH_en jBH_ee jBH_m jBH_n jBH_o jBH_c
+
+ if(env_type .eq. "None") then
+ call grad1_j12_r1_seq(r1, n_grid2, resx, resy, resz)
+ endif ! env_type
+
else
print *, ' Error in get_grad1_u12_withsq_r1_seq: Unknown Jastrow'
@@ -99,6 +149,9 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
BEGIN_DOC
!
+ ! d/dx1 j_2e(1,2)
+ ! d/dy1 j_2e(1,2)
+ ! d/dz1 j_2e(1,2)
!
END_DOC
@@ -112,14 +165,21 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
double precision, intent(out) :: gradz(n_grid2)
integer :: jpoint
+ integer :: i_nucl, p, mpA, npA, opA
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, grad1_f1A(3), f2A, grad2_f2A(3), g12, grad1_g12(3)
+ double precision :: tmp1, tmp2
+
+
+ PROVIDE j2e_type
if(j2e_type .eq. "Mu") then
- ! d/dx1 j(mu,r12) = 0.5 * (1 - erf(mu *r12))/r12 * (x1 - x2)
- !
+ ! d/dx1 j(mu,r12) = 0.5 * [(1 - erf(mu * r12)) / r12] * (x1 - x2)
+ ! d/dy1 j(mu,r12) = 0.5 * [(1 - erf(mu * r12)) / r12] * (y1 - y2)
+ ! d/dz1 j(mu,r12) = 0.5 * [(1 - erf(mu * r12)) / r12] * (z1 - z2)
do jpoint = 1, n_points_extra_final_grid ! r2
@@ -185,7 +245,12 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
elseif(j2e_type .eq. "Boys") then
- ! j(r12) = 0.5 r12 / (1 + a_boys r_12)
+ !
+ ! j(r12) = 0.5 r12 / (1 + a_boys r_12)
+ !
+ ! d/dx1 j(r12) = 0.5 (x1 - x2) / [r12 * (1 + b r12^2)^2]
+ ! d/dy1 j(r12) = 0.5 (y1 - y2) / [r12 * (1 + b r12^2)^2]
+ ! d/dz1 j(r12) = 0.5 (z1 - z2) / [r12 * (1 + b r12^2)^2]
PROVIDE a_boys
@@ -214,6 +279,93 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
gradz(jpoint) = tmp * dz
enddo
+ 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)
+ r2(2) = final_grid_points_extra(2,jpoint)
+ r2(3) = final_grid_points_extra(3,jpoint)
+
+ gradx(jpoint) = 0.d0
+ grady(jpoint) = 0.d0
+ gradz(jpoint) = 0.d0
+ do i_nucl = 1, nucl_num
+
+ rn(1) = nucl_coord(i_nucl,1)
+ 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, 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)
+ npA = jBH_n(p,i_nucl)
+ opA = jBH_o(p,i_nucl)
+ tmp = jBH_c(p,i_nucl)
+ if(mpA .eq. npA) then
+ tmp = tmp * 0.5d0
+ endif
+
+ 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) * tmp
+ tmp2 = double_p(opA) * g12_power(opA-1) * (f1A_power(mpA) * f2A_power(npA) + f1A_power(npA) * f2A_power(mpA)) * tmp
+
+ !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 * 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))
+ gradx(jpoint) = gradx(jpoint) + tmp1 * grad1_f1A(1) + tmp2 * grad1_g12(1)
+ grady(jpoint) = grady(jpoint) + tmp1 * grad1_f1A(2) + tmp2 * grad1_g12(2)
+ gradz(jpoint) = gradz(jpoint) + tmp1 * grad1_f1A(3) + tmp2 * grad1_g12(3)
+ enddo ! p
+ enddo ! i_nucl
+ enddo ! jpoint
+
else
print *, ' Error in grad1_j12_r1_seq: Unknown j2e_type = ', j2e_type
@@ -226,6 +378,58 @@ end
! ---
+subroutine grad1_jmu_r1_seq(mu, r1, n_grid2, gradx, grady, gradz)
+
+ BEGIN_DOC
+ !
+ ! d/dx1 jmu(r12) = 0.5 * [(1 - erf(mu * r12)) / r12] * (x1 - x2)
+ ! d/dy1 jmu(r12) = 0.5 * [(1 - erf(mu * r12)) / r12] * (y1 - y2)
+ ! d/dz1 jmu(r12) = 0.5 * [(1 - erf(mu * r12)) / r12] * (z1 - z2)
+ !
+ END_DOC
+
+ implicit none
+ integer , intent(in) :: n_grid2
+ double precision, intent(in) :: mu, r1(3)
+ double precision, intent(out) :: gradx(n_grid2)
+ double precision, intent(out) :: grady(n_grid2)
+ double precision, intent(out) :: gradz(n_grid2)
+
+ integer :: jpoint
+ double precision :: r2(3)
+ double precision :: dx, dy, dz, r12, tmp
+
+
+ do jpoint = 1, n_points_extra_final_grid ! r2
+
+ r2(1) = final_grid_points_extra(1,jpoint)
+ r2(2) = final_grid_points_extra(2,jpoint)
+ r2(3) = final_grid_points_extra(3,jpoint)
+
+ dx = r1(1) - r2(1)
+ dy = r1(2) - r2(2)
+ dz = r1(3) - r2(3)
+
+ r12 = dsqrt(dx * dx + dy * dy + dz * dz)
+ if(r12 .lt. 1d-10) then
+ gradx(jpoint) = 0.d0
+ grady(jpoint) = 0.d0
+ gradz(jpoint) = 0.d0
+ cycle
+ endif
+
+ tmp = 0.5d0 * (1.d0 - derf(mu * r12)) / r12
+
+ gradx(jpoint) = tmp * dx
+ grady(jpoint) = tmp * dy
+ gradz(jpoint) = tmp * dz
+ enddo
+
+ return
+end
+
+! ---
+
subroutine j12_r1_seq(r1, n_grid2, res)
include 'constants.include.F'
@@ -294,6 +498,44 @@ end
! ---
+subroutine jmu_r1_seq(mu, r1, n_grid2, res)
+
+ include 'constants.include.F'
+
+ implicit none
+ integer, intent(in) :: n_grid2
+ double precision, intent(in) :: mu, r1(3)
+ double precision, intent(out) :: res(n_grid2)
+
+ integer :: jpoint
+ double precision :: r2(3)
+ double precision :: dx, dy, dz
+ double precision :: r12, tmp1, tmp2
+
+ tmp1 = inv_sq_pi_2 / mu
+
+ do jpoint = 1, n_points_extra_final_grid ! r2
+
+ r2(1) = final_grid_points_extra(1,jpoint)
+ r2(2) = final_grid_points_extra(2,jpoint)
+ r2(3) = final_grid_points_extra(3,jpoint)
+
+ dx = r1(1) - r2(1)
+ dy = r1(2) - r2(2)
+ dz = r1(3) - r2(3)
+ r12 = dsqrt(dx * dx + dy * dy + dz * dz)
+
+ tmp2 = mu * r12
+
+ res(jpoint) = 0.5d0 * r12 * (1.d0 - derf(tmp2)) - tmp1 * dexp(-tmp2*tmp2)
+ enddo
+
+ return
+end
+
+! ---
+
+
subroutine env_nucl_r1_seq(n_grid2, res)
! TODO
@@ -395,3 +637,254 @@ end
! ---
+subroutine get_grad1_u12_2e_r1_seq(ipoint, n_grid2, resx, resy, resz)
+
+ BEGIN_DOC
+ !
+ ! grad_1 u_2e(r1,r2)
+ !
+ ! we use grid for r1 and extra_grid for r2
+ !
+ END_DOC
+
+ implicit none
+ integer, intent(in) :: ipoint, n_grid2
+ double precision, intent(out) :: resx(n_grid2), resy(n_grid2), resz(n_grid2)
+
+ integer :: jpoint
+ double precision :: env_r1, tmp
+ double precision :: grad1_env(3), r1(3)
+ double precision, allocatable :: env_r2(:)
+ double precision, allocatable :: u2b_r12(:)
+ double precision, allocatable :: gradx1_u2b(:), grady1_u2b(:), gradz1_u2b(:)
+ double precision, allocatable :: u2b_mu(:), gradx1_mu(:), grady1_mu(:), gradz1_mu(:)
+ double precision, allocatable :: u2b_nu(:), gradx1_nu(:), grady1_nu(:), gradz1_nu(:)
+ double precision, external :: env_nucl
+
+ PROVIDE j1e_type j2e_type env_type
+ PROVIDE final_grid_points
+ PROVIDE final_grid_points_extra
+
+ r1(1) = final_grid_points(1,ipoint)
+ r1(2) = final_grid_points(2,ipoint)
+ r1(3) = final_grid_points(3,ipoint)
+
+ if( (j2e_type .eq. "Mu") .or. &
+ (j2e_type .eq. "Mur") .or. &
+ (j2e_type .eq. "Boys") ) then
+
+ if(env_type .eq. "None") then
+
+ call grad1_j12_r1_seq(r1, n_grid2, resx, resy, resz)
+
+ else
+
+ ! u(r1,r2) = j12_mu(r12) x v(r1) x v(r2)
+ ! grad1 u(r1, r2) = [(grad1 j12_mu) v(r1) + j12_mu grad1 v(r1)] v(r2)
+
+ allocate(env_r2(n_grid2))
+ allocate(u2b_r12(n_grid2))
+ allocate(gradx1_u2b(n_grid2))
+ allocate(grady1_u2b(n_grid2))
+ allocate(gradz1_u2b(n_grid2))
+
+ env_r1 = env_nucl(r1)
+ call grad1_env_nucl(r1, grad1_env)
+
+ call env_nucl_r1_seq(n_grid2, env_r2)
+ call j12_r1_seq(r1, n_grid2, u2b_r12)
+ call grad1_j12_r1_seq(r1, n_grid2, gradx1_u2b, grady1_u2b, gradz1_u2b)
+
+ do jpoint = 1, n_points_extra_final_grid
+ resx(jpoint) = (gradx1_u2b(jpoint) * env_r1 + u2b_r12(jpoint) * grad1_env(1)) * env_r2(jpoint)
+ resy(jpoint) = (grady1_u2b(jpoint) * env_r1 + u2b_r12(jpoint) * grad1_env(2)) * env_r2(jpoint)
+ resz(jpoint) = (gradz1_u2b(jpoint) * env_r1 + u2b_r12(jpoint) * grad1_env(3)) * env_r2(jpoint)
+ enddo
+
+ deallocate(env_r2, u2b_r12, gradx1_u2b, grady1_u2b, gradz1_u2b)
+
+ endif ! env_type
+
+ elseif(j2e_type .eq. "Mu_Nu") then
+
+ if(env_type .eq. "None") then
+
+ call grad1_jmu_r1_seq(mu_erf, r1, n_grid2, resx, resy, resz)
+
+ else
+
+ ! u(r1,r2) = jmu(r12) x v(r1) x v(r2) + jnu(r12) x [1 - v(r1) x v(r2)]
+
+ allocate(env_r2(n_grid2))
+ allocate(u2b_mu(n_grid2))
+ allocate(u2b_nu(n_grid2))
+ allocate(gradx1_mu(n_grid2), grady1_mu(n_grid2), gradz1_mu(n_grid2))
+ allocate(gradx1_nu(n_grid2), grady1_nu(n_grid2), gradz1_nu(n_grid2))
+
+ env_r1 = env_nucl(r1)
+ call grad1_env_nucl(r1, grad1_env)
+ call env_nucl_r1_seq(n_grid2, env_r2)
+
+ call jmu_r1_seq(mu_erf, r1, n_grid2, u2b_mu)
+ call jmu_r1_seq(nu_erf, r1, n_grid2, u2b_nu)
+
+ call grad1_jmu_r1_seq(mu_erf, r1, n_grid2, gradx1_mu, grady1_mu, gradz1_mu)
+ call grad1_jmu_r1_seq(nu_erf, r1, n_grid2, gradx1_nu, grady1_nu, gradz1_nu)
+
+ do jpoint = 1, n_points_extra_final_grid
+ resx(jpoint) = gradx1_nu(jpoint) + ((gradx1_mu(jpoint) - gradx1_nu(jpoint)) * env_r1 + (u2b_mu(jpoint) - u2b_nu(jpoint)) * grad1_env(1)) * env_r2(jpoint)
+ resy(jpoint) = grady1_nu(jpoint) + ((grady1_mu(jpoint) - grady1_nu(jpoint)) * env_r1 + (u2b_mu(jpoint) - u2b_nu(jpoint)) * grad1_env(2)) * env_r2(jpoint)
+ resz(jpoint) = gradz1_nu(jpoint) + ((gradz1_mu(jpoint) - gradz1_nu(jpoint)) * env_r1 + (u2b_mu(jpoint) - u2b_nu(jpoint)) * grad1_env(3)) * env_r2(jpoint)
+ enddo
+
+ deallocate(env_r2)
+ deallocate(u2b_mu)
+ deallocate(u2b_nu)
+ deallocate(gradx1_mu, grady1_mu, gradz1_mu)
+ deallocate(gradx1_nu, grady1_nu, gradz1_nu)
+
+ endif ! env_type
+
+ else
+
+ print *, ' Error in get_grad1_u12_withsq_r1_seq: Unknown Jastrow'
+ stop
+
+ endif ! j2e_type
+
+ return
+end
+
+! ---
+
+subroutine get_u12_2e_r1_seq(ipoint, n_grid2, res)
+
+ BEGIN_DOC
+ !
+ ! u_2e(r1,r2)
+ !
+ ! we use grid for r1 and extra_grid for r2
+ !
+ END_DOC
+
+ implicit none
+ integer, intent(in) :: ipoint, n_grid2
+ double precision, intent(out) :: res(n_grid2)
+
+ integer :: jpoint
+ double precision :: env_r1, tmp
+ double precision :: grad1_env(3), r1(3)
+ double precision, allocatable :: env_r2(:)
+ double precision, allocatable :: u2b_r12(:)
+ double precision, allocatable :: u2b_mu(:), u2b_nu(:)
+ double precision, external :: env_nucl
+
+ PROVIDE j1e_type j2e_type env_type
+ PROVIDE final_grid_points
+ PROVIDE final_grid_points_extra
+
+ r1(1) = final_grid_points(1,ipoint)
+ r1(2) = final_grid_points(2,ipoint)
+ r1(3) = final_grid_points(3,ipoint)
+
+ if( (j2e_type .eq. "Mu") .or. &
+ (j2e_type .eq. "Mur") .or. &
+ (j2e_type .eq. "Boys") ) then
+
+ if(env_type .eq. "None") then
+
+ call j12_r1_seq(r1, n_grid2, res)
+
+ else
+
+ ! u(r1,r2) = j12_mu(r12) x v(r1) x v(r2)
+
+ allocate(env_r2(n_grid2))
+ allocate(u2b_r12(n_grid2))
+
+ env_r1 = env_nucl(r1)
+ call j12_r1_seq(r1, n_grid2, u2b_r12)
+ call env_nucl_r1_seq(n_grid2, env_r2)
+
+ do jpoint = 1, n_points_extra_final_grid
+ res(jpoint) = env_r1 * u2b_r12(jpoint) * env_r2(jpoint)
+ enddo
+
+ deallocate(env_r2, u2b_r12)
+
+ endif ! env_type
+
+ elseif(j2e_type .eq. "Mu_Nu") then
+
+ if(env_type .eq. "None") then
+
+ call jmu_r1_seq(mu_erf, r1, n_grid2, res)
+
+ else
+
+ ! u(r1,r2) = jmu(r12) x v(r1) x v(r2) + jnu(r12) x [1 - v(r1) x v(r2)]
+
+ allocate(env_r2(n_grid2))
+ allocate(u2b_mu(n_grid2))
+ allocate(u2b_nu(n_grid2))
+
+ env_r1 = env_nucl(r1)
+ call env_nucl_r1_seq(n_grid2, env_r2)
+
+ call jmu_r1_seq(mu_erf, r1, n_grid2, u2b_mu)
+ call jmu_r1_seq(nu_erf, r1, n_grid2, u2b_nu)
+
+ do jpoint = 1, n_points_extra_final_grid
+ res(jpoint) = u2b_nu(jpoint) + (u2b_mu(jpoint) - u2b_nu(jpoint)) * env_r1 * env_r2(jpoint)
+ enddo
+
+ deallocate(env_r2)
+ deallocate(u2b_mu)
+ deallocate(u2b_nu)
+
+ endif ! env_type
+
+ else
+
+ print *, ' Error in get_u12_withsq_r1_seq: Unknown Jastrow'
+ stop
+
+ endif ! j2e_type
+
+ return
+end
+
+! ---
+
+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, grad1_fct(3)
+ double precision :: dist, tmp1, tmp2
+
+ dist = dsqrt( (r1(1) - r2(1)) * (r1(1) - r2(1)) &
+ + (r1(2) - r2(2)) * (r1(2) - r2(2)) &
+ + (r1(3) - r2(3)) * (r1(3) - r2(3)) )
+
+
+ if(dist .ge. 1d-10) then
+ tmp1 = 1.d0 / (1.d0 + alpha * dist)
+
+ fct = alpha * dist * tmp1
+ tmp2 = alpha * tmp1 * tmp1 / dist
+ grad1_fct(1) = tmp2 * (r1(1) - r2(1))
+ grad1_fct(2) = tmp2 * (r1(2) - r2(2))
+ grad1_fct(3) = tmp2 * (r1(3) - r2(3))
+ else
+ grad1_fct(1) = 0.d0
+ grad1_fct(2) = 0.d0
+ grad1_fct(3) = 0.d0
+ fct = 0.d0
+ endif
+
+ return
+end
+
+! ---
+
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/print_j1ecoef_info.irp.f b/plugins/local/non_h_ints_mu/print_j1ecoef_info.irp.f
new file mode 100644
index 00000000..feb2685a
--- /dev/null
+++ b/plugins/local/non_h_ints_mu/print_j1ecoef_info.irp.f
@@ -0,0 +1,94 @@
+
+! ---
+
+program print_j1ecoef_info
+
+ 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
+
+ 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
+ endif
+
+ call print_j1ecoef()
+
+end
+
+! ---
+
+subroutine print_j1ecoef()
+
+ implicit none
+ integer :: i, j, ij
+ integer :: ierr
+ logical :: exists
+ character(len=10) :: ni, nj
+ double precision, allocatable :: coef_fit2(:)
+
+ PROVIDE ao_l_char_space
+
+ allocate(coef_fit2(ao_num*ao_num))
+
+ if(mpi_master) then
+ call ezfio_has_jastrow_j1e_coef_ao2(exists)
+ 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'
+ call MPI_BCAST(coef_fit2, ao_num*ao_num, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
+ if (ierr /= MPI_SUCCESS) then
+ stop 'Unable to read j1e_coef_ao2 with MPI'
+ endif
+ IRP_ENDIF
+ if(exists) then
+ if(mpi_master) then
+ write(6,'(A)') '.. >>>>> [ IO READ: j1e_coef_ao2 ] <<<<< ..'
+ call ezfio_get_jastrow_j1e_coef_ao2(coef_fit2)
+ IRP_IF MPI
+ call MPI_BCAST(coef_fit2, ao_num*ao_num, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
+ if (ierr /= MPI_SUCCESS) then
+ stop 'Unable to read j1e_coef_ao2 with MPI'
+ endif
+ IRP_ENDIF
+ endif
+ else
+
+ call get_j1e_coef_fit_ao2(ao_num*ao_num, coef_fit2)
+ call ezfio_set_jastrow_j1e_coef_ao2(coef_fit2)
+
+ endif
+
+
+ do i = 1, ao_num
+ write(ni, '(I0)') ao_l(i)+1
+ do j = 1, ao_num
+ write(nj, '(I0)') ao_l(j)+1
+ ij = (i-1)*ao_num + j
+ print *, trim(adjustl(ni)) // trim(adjustl(ao_l_char_space(i))), " " &
+ , trim(adjustl(nj)) // trim(adjustl(ao_l_char_space(j))), " " &
+ , dabs(coef_fit2(ij))
+ enddo
+! print *, ' '
+ enddo
+
+
+ deallocate(coef_fit2)
+
+ return
+end
+
+! ---
+
+
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 6b6e755d..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
@@ -45,7 +45,6 @@
!$OMP END DO
!$OMP END PARALLEL
- ! n_points_final_grid = n_blocks * n_pass + n_rest
call total_memory(mem)
mem = max(1.d0, qp_max_mem - mem)
n_double = mem * 1.d8
@@ -64,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
@@ -100,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
@@ -132,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 90e5a7b3..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
@@ -39,8 +39,13 @@ program test_non_h
!call test_j1e_fit_ao()
- call test_tc_grad_and_lapl_ao_new()
- call test_tc_grad_square_ao_new()
+ !call test_tc_grad_and_lapl_ao_new()
+ !call test_tc_grad_square_ao_new()
+
+ !call test_fit_coef_A1()
+ !call test_fit_coef_inv()
+
+ call test_fit_coef_testinvA()
end
! ---
@@ -1112,3 +1117,417 @@ END_PROVIDER
! ---
+subroutine test_fit_coef_A1()
+
+ implicit none
+ integer :: i, j, k, l, ij, kl, ipoint
+ double precision :: t1, t2
+ double precision :: accu, norm, diff
+ double precision, allocatable :: A1(:,:)
+ double precision, allocatable :: A2(:,:,:,:), tmp(:,:,:)
+ double precision, allocatable :: tmp1(:,:,:), tmp2(:,:,:)
+
+ ! ---
+
+ allocate(A1(ao_num*ao_num,ao_num*ao_num))
+
+ call wall_time(t1)
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i, j, k, l, ij, kl, ipoint) &
+ !$OMP SHARED (n_points_final_grid, ao_num, &
+ !$OMP final_weight_at_r_vector, aos_in_r_array_transp, A1)
+ !$OMP DO COLLAPSE(2)
+ do k = 1, ao_num
+ do l = 1, ao_num
+ kl = (k-1)*ao_num + l
+
+ do i = 1, ao_num
+ do j = 1, ao_num
+ ij = (i-1)*ao_num + j
+
+ A1(ij,kl) = 0.d0
+ do ipoint = 1, n_points_final_grid
+ A1(ij,kl) += final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j) &
+ * aos_in_r_array_transp(ipoint,k) * aos_in_r_array_transp(ipoint,l)
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ call wall_time(t2)
+ print*, ' WALL TIME FOR A1 (min) =', (t2-t1)/60.d0
+
+ ! ---
+
+ call wall_time(t1)
+
+ 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, tmp1, tmp2)
+ !$OMP DO COLLAPSE(2)
+ do j = 1, ao_num
+ do i = 1, ao_num
+ do ipoint = 1, n_points_final_grid
+ 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
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ 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 &
+ , 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(tmp1, tmp2)
+
+ call wall_time(t2)
+ print*, ' WALL TIME FOR A2 (min) =', (t2-t1)/60.d0
+
+ ! ---
+
+ accu = 0.d0
+ norm = 0.d0
+ do k = 1, ao_num
+ do l = 1, ao_num
+ kl = (k-1)*ao_num + l
+
+ do i = 1, ao_num
+ do j = 1, ao_num
+ ij = (i-1)*ao_num + j
+
+ diff = dabs(A2(j,i,l,k) - A1(ij,kl))
+ if(diff .gt. 1d-10) then
+ print *, ' problem in A2 on:', i, i, l, k
+ print *, ' A1 :', A1(ij,kl)
+ print *, ' A2 :', A2(j,i,l,k)
+ stop
+ endif
+
+ accu += diff
+ norm += dabs(A1(ij,kl))
+ enddo
+ enddo
+ enddo
+ enddo
+
+ deallocate(A1, A2)
+
+ print*, ' accuracy (%) = ', 100.d0 * accu / norm
+
+ return
+end
+
+! ---
+
+subroutine test_fit_coef_inv()
+
+ implicit none
+ integer :: i, j, k, l, ij, kl, ipoint
+ integer :: n_svd, info, lwork, mn, m, n
+ double precision :: t1, t2
+ double precision :: accu, norm, diff
+ double precision :: cutoff_svd, D1_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
+
+ ! ---
+
+ call wall_time(t1)
+
+ allocate(A1(ao_num*ao_num,ao_num*ao_num))
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i, j, k, l, ij, kl, ipoint) &
+ !$OMP SHARED (n_points_final_grid, ao_num, &
+ !$OMP final_weight_at_r_vector, aos_in_r_array_transp, A1)
+ !$OMP DO COLLAPSE(2)
+ do k = 1, ao_num
+ do l = 1, ao_num
+ kl = (k-1)*ao_num + l
+
+ do i = 1, ao_num
+ do j = 1, ao_num
+ ij = (i-1)*ao_num + j
+
+ A1(ij,kl) = 0.d0
+ do ipoint = 1, n_points_final_grid
+ A1(ij,kl) += final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j) &
+ * aos_in_r_array_transp(ipoint,k) * aos_in_r_array_transp(ipoint,l)
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ call wall_time(t2)
+ print*, ' WALL TIME FOR A1 (min) =', (t2-t1)/60.d0
+
+ allocate(A1_inv(ao_num*ao_num,ao_num*ao_num))
+ call get_pseudo_inverse(A1, ao_num*ao_num, ao_num*ao_num, ao_num*ao_num, A1_inv, ao_num*ao_num, cutoff_svd)
+
+ call wall_time(t1)
+ print*, ' WALL TIME FOR A1_inv (min) =', (t1-t2)/60.d0
+
+ ! ---
+
+ call wall_time(t1)
+
+ 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, tmp1, tmp2)
+ !$OMP DO COLLAPSE(2)
+ do j = 1, ao_num
+ do i = 1, ao_num
+ do ipoint = 1, n_points_final_grid
+ 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
+
+ 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 &
+ , 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(tmp1, tmp2)
+
+ call wall_time(t2)
+ print*, ' WALL TIME FOR A2 (min) =', (t2-t1)/60.d0
+
+ allocate(A1_tmp(ao_num*ao_num,ao_num*ao_num))
+ A1_tmp = A1
+ allocate(A2_tmp(ao_num,ao_num,ao_num,ao_num))
+ A2_tmp = A2
+
+ allocate(A2_inv(ao_num,ao_num,ao_num,ao_num))
+
+ allocate(D(ao_num*ao_num), U(ao_num*ao_num,ao_num*ao_num), Vt(ao_num*ao_num,ao_num*ao_num))
+
+ allocate(work(1))
+ lwork = -1
+
+ call dgesvd( 'S', 'A', ao_num*ao_num, ao_num*ao_num, A1_tmp(1,1), ao_num*ao_num &
+ !call dgesvd( 'S', 'A', ao_num*ao_num, ao_num*ao_num, A2_tmp(1,1,1,1), ao_num*ao_num &
+ , D(1), U(1,1), ao_num*ao_num, Vt(1,1), ao_num*ao_num, work, lwork, info)
+ if(info /= 0) then
+ print *, info, ': SVD failed'
+ stop
+ endif
+
+ LWORK = max(5*ao_num*ao_num, int(WORK(1)))
+ deallocate(work)
+ allocate(work(lwork))
+
+ call dgesvd( 'S', 'A', ao_num*ao_num, ao_num*ao_num, A1_tmp(1,1), ao_num*ao_num &
+ !call dgesvd( 'S', 'A', ao_num*ao_num, ao_num*ao_num, A2_tmp(1,1,1,1), ao_num*ao_num &
+ , D(1), U(1,1), ao_num*ao_num, Vt(1,1), ao_num*ao_num, work, lwork, info)
+ if(info /= 0) then
+ print *, info, ':: SVD failed'
+ stop 1
+ endif
+
+ deallocate(A2_tmp)
+ deallocate(work)
+
+ n_svd = 0
+ D1_inv = 1.d0 / D(1)
+ do ij = 1, ao_num*ao_num
+ if(D(ij)*D1_inv > cutoff_svd) then
+ D(ij) = 1.d0 / D(ij)
+ n_svd = n_svd + 1
+ else
+ D(ij) = 0.d0
+ endif
+ enddo
+ print*, ' n_svd = ', n_svd
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ij, kl) &
+ !$OMP SHARED (ao_num, n_svd, D, Vt)
+ !$OMP DO
+ do kl = 1, ao_num*ao_num
+ do ij = 1, n_svd
+ Vt(ij,kl) = Vt(ij,kl) * D(ij)
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_svd, 1.d0 &
+ , U(1,1), ao_num*ao_num, Vt(1,1), ao_num*ao_num &
+ , 0.d0, A2_inv(1,1,1,1), ao_num*ao_num)
+
+ deallocate(D, U, Vt)
+
+ call wall_time(t1)
+ print*, ' WALL TIME FOR A2_inv (min) =', (t1-t2)/60.d0
+
+ ! ---
+
+ accu = 0.d0
+ norm = 0.d0
+ do k = 1, ao_num
+ do l = 1, ao_num
+ kl = (k-1)*ao_num + l
+
+ do i = 1, ao_num
+ do j = 1, ao_num
+ ij = (i-1)*ao_num + j
+
+ diff = dabs(A2(j,i,l,k) - A1(ij,kl))
+ if(diff .gt. 1d-10) then
+ print *, ' problem in A2 on:', i, i, l, k
+ print *, ' A1 :', A1(ij,kl)
+ print *, ' A2 :', A2(j,i,l,k)
+ stop
+ endif
+
+ accu += diff
+ norm += dabs(A1(ij,kl))
+ enddo
+ enddo
+ enddo
+ enddo
+
+ print*, ' accuracy on A (%) = ', 100.d0 * accu / norm
+
+ accu = 0.d0
+ norm = 0.d0
+ do k = 1, ao_num
+ do l = 1, ao_num
+ kl = (k-1)*ao_num + l
+
+ do i = 1, ao_num
+ do j = 1, ao_num
+ ij = (i-1)*ao_num + j
+
+ diff = dabs(A2_inv(j,i,l,k) - A1_inv(ij,kl))
+ if(diff .gt. cutoff_svd) then
+ print *, ' problem in A2_inv on:', i, i, l, k
+ print *, ' A1_inv :', A1_inv(ij,kl)
+ print *, ' A2_inv :', A2_inv(j,i,l,k)
+ stop
+ endif
+
+ accu += diff
+ norm += dabs(A1_inv(ij,kl))
+ enddo
+ enddo
+ enddo
+ enddo
+
+ print*, ' accuracy on A_inv (%) = ', 100.d0 * accu / norm
+
+ deallocate(A1_inv, A2_inv)
+ deallocate(A1, A2)
+
+ return
+end
+
+! ---
+
+subroutine test_fit_coef_testinvA()
+
+ implicit none
+ integer :: i, j, k, l, m, n, ij, kl, mn, ipoint
+ double precision :: t1, t2
+ double precision :: accu, norm, diff
+ double precision :: cutoff_svd
+ double precision, allocatable :: A1(:,:), A1_inv(:,:)
+
+ cutoff_svd = 1d-17
+
+ ! ---
+
+ call wall_time(t1)
+
+ allocate(A1(ao_num*ao_num,ao_num*ao_num))
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i, j, k, l, ij, kl, ipoint) &
+ !$OMP SHARED (n_points_final_grid, ao_num, &
+ !$OMP final_weight_at_r_vector, aos_in_r_array_transp, A1)
+ !$OMP DO COLLAPSE(2)
+ do k = 1, ao_num
+ do l = 1, ao_num
+ kl = (k-1)*ao_num + l
+
+ do i = 1, ao_num
+ do j = 1, ao_num
+ ij = (i-1)*ao_num + j
+
+ A1(ij,kl) = 0.d0
+ do ipoint = 1, n_points_final_grid
+ A1(ij,kl) += final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j) &
+ * aos_in_r_array_transp(ipoint,k) * aos_in_r_array_transp(ipoint,l)
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ call wall_time(t2)
+ print*, ' WALL TIME FOR A1 (min) =', (t2-t1)/60.d0
+
+ allocate(A1_inv(ao_num*ao_num,ao_num*ao_num))
+ call get_pseudo_inverse(A1, ao_num*ao_num, ao_num*ao_num, ao_num*ao_num, A1_inv, ao_num*ao_num, cutoff_svd)
+
+ call wall_time(t1)
+ print*, ' WALL TIME FOR A1_inv (min) =', (t1-t2)/60.d0
+
+ ! ---
+
+ print*, ' check inv'
+
+ do kl = 1, ao_num*ao_num
+ do ij = 1, ao_num*ao_num
+
+ diff = 0.d0
+ do mn = 1, ao_num*ao_num
+ diff += A1(kl,mn) * A1_inv(mn,ij)
+ enddo
+
+ if(kl .eq. ij) then
+ accu += dabs(diff - 1.d0)
+ else
+ accu += dabs(diff - 0.d0)
+ endif
+ enddo
+ enddo
+
+ print*, ' accuracy (%) = ', accu * 100.d0
+
+ deallocate(A1, A1_inv)
+
+ return
+end
+
+! ---
+
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 38da4047..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 &
@@ -125,12 +162,15 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
, 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, ao_num*ao_num)
+ , 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,67 +178,139 @@ 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, ao_num*ao_num)
- enddo
- deallocate(b_mat)
+ else
- FREE int2_grad1_u12_ao
- FREE int2_grad1_u2e_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
+ endif
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
@@ -208,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 99%
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
index c767f090..5f37b11e 100644
--- a/plugins/local/tc_bi_ortho/h_tc_s2_u0.irp.f
+++ b/plugins/local/slater_tc/h_tc_s2_u0.irp.f
@@ -520,6 +520,7 @@ compute_singles=.True.
ASSERT (lrow <= N_det_alpha_unique)
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
+ ! TODO: i_htc "optimized" for normal ordering for single/double by spin
! call i_h_j_single_spin( tmp_det, tmp_det2, $N_int, 1, hij)
if(do_right)then
call htilde_mu_mat_opt_bi_ortho_tot(tmp_det,tmp_det2,$N_int,hij)
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 73%
rename from plugins/local/tc_bi_ortho/slater_tc_opt.irp.f
rename to plugins/local/slater_tc/slater_tc_opt.irp.f
index 9901a853..5651a299 100644
--- a/plugins/local/tc_bi_ortho/slater_tc_opt.irp.f
+++ b/plugins/local/slater_tc/slater_tc_opt.irp.f
@@ -8,8 +8,13 @@ subroutine provide_all_three_ints_bi_ortho()
END_DOC
implicit none
+ double precision :: t1, t2
+
PROVIDE ao_two_e_integrals_in_map
+ print *, ' start provide_all_three_ints_bi_ortho'
+ call wall_time(t1)
+
if(three_body_h_tc) then
if(three_e_3_idx_term) then
@@ -32,6 +37,9 @@ subroutine provide_all_three_ints_bi_ortho()
endif
+ call wall_time(t2)
+ print *, ' end provide_all_three_ints_bi_ortho after (min) = ', (t2-t1)/60.d0
+
return
end
@@ -83,8 +91,11 @@ subroutine htilde_mu_mat_opt_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree,
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
double precision, intent(out) :: hmono, htwoe, hthree, htot
+
integer :: degree
+ PROVIDE pure_three_body_h_tc
+
hmono = 0.d0
htwoe = 0.d0
htot = 0.d0
@@ -99,7 +110,7 @@ subroutine htilde_mu_mat_opt_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree,
if(degree == 0) then
call diag_htilde_mu_mat_fock_bi_ortho (Nint, key_i, hmono, htwoe, hthree, htot)
else if (degree == 1) then
- call single_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i , hmono, htwoe, hthree, htot)
+ call single_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot)
else if(degree == 2) then
call double_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot)
endif
@@ -111,7 +122,7 @@ subroutine htilde_mu_mat_opt_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree,
if(degree == 0) then
call diag_htilde_mu_mat_fock_bi_ortho (Nint, key_i, hmono, htwoe, hthree, htot)
else if (degree == 1) then
- call single_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i , hmono, htwoe, hthree, htot)
+ call single_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot)
else if(degree == 2) then
call double_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot)
else
@@ -149,16 +160,16 @@ subroutine htilde_mu_mat_opt_bi_ortho_no_3e(key_j, key_i, Nint, htot)
double precision, intent(out) :: htot
integer :: degree
- htot = 0.d0
+ htot = 0.d0
call get_excitation_degree(key_i, key_j, degree, Nint)
if(degree.gt.2) return
- if(degree == 0)then
+ if(degree == 0) then
call diag_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_i,htot)
- else if (degree == 1)then
+ else if (degree == 1) then
call single_htilde_mu_mat_fock_bi_ortho_no_3e(Nint,key_j, key_i , htot)
- else if(degree == 2)then
+ else if(degree == 2) then
call double_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_j, key_i, htot)
endif
@@ -170,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 60%
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 cc1a0603..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
@@ -15,15 +15,17 @@
implicit none
double precision :: hmono, htwoe, htot, hthree
+ PROVIDE N_int
+ 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
@@ -522,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 51%
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 81bf69f4..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
@@ -19,6 +19,7 @@ subroutine single_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe,
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2)
double precision, intent(out) :: hmono, htwoe, hthree, htot
+
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)
@@ -44,27 +45,28 @@ subroutine single_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe,
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(key_i, key_j, h1, p1, s1, phase, hmono, htwoe, hthree, htot)
+ call get_single_excitation_from_fock_tc(Nint, key_i, key_j, h1, p1, s1, phase, hmono, htwoe, hthree, htot)
end
! ---
-subroutine get_single_excitation_from_fock_tc(key_i, key_j, h, p, spin, phase, hmono, htwoe, hthree, htot)
+subroutine get_single_excitation_from_fock_tc(Nint, key_i, key_j, h, p, spin, phase, hmono, htwoe, hthree, htot)
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(N_int,2), key_j(N_int,2)
+ integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
double precision, intent(out) :: hmono, htwoe, hthree, htot
- integer(bit_kind) :: differences(N_int,2)
- integer(bit_kind) :: hole(N_int,2)
- integer(bit_kind) :: partcl(N_int,2)
- integer :: occ_hole(N_int*bit_kind_size,2)
- integer :: occ_partcl(N_int*bit_kind_size,2)
+ 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(mo_num),buffer_x(mo_num)
@@ -74,7 +76,7 @@ subroutine get_single_excitation_from_fock_tc(key_i, key_j, h, p, spin, phase, h
buffer_x(i) = tc_2e_3idx_exchange_integrals(i,p,h)
enddo
- do i = 1, N_int
+ 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))
@@ -83,8 +85,8 @@ subroutine get_single_excitation_from_fock_tc(key_i, key_j, h, p, spin, phase, h
partcl (i,2) = iand(differences(i,2), key_i(i,2))
enddo
- call bitstring_to_list_ab(hole, occ_hole, n_occ_ab_hole, N_int)
- call bitstring_to_list_ab(partcl, occ_partcl, n_occ_ab_partcl, N_int)
+ 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 = mo_bi_ortho_tc_one_e(p,h)
htwoe = fock_op_2_e_tc_closed_shell(p,h)
@@ -122,7 +124,7 @@ subroutine get_single_excitation_from_fock_tc(key_i, key_j, h, p, spin, phase, h
hthree = 0.d0
if (three_body_h_tc .and. elec_num.gt.2 .and. three_e_4_idx_term) then
- call three_comp_fock_elem(key_i, h, p, spin, hthree)
+ call three_comp_fock_elem(Nint, key_i, h, p, spin, hthree)
endif
htwoe = htwoe * phase
@@ -134,24 +136,27 @@ end
! ---
-subroutine three_comp_fock_elem(key_i,h_fock,p_fock,ispin_fock,hthree)
- implicit none
- integer,intent(in) :: h_fock,p_fock,ispin_fock
- integer(bit_kind), intent(in) :: key_i(N_int,2)
- double precision, intent(out) :: hthree
- integer :: nexc(2),i,ispin,na,nb
- integer(bit_kind) :: hole(N_int,2)
- integer(bit_kind) :: particle(N_int,2)
- integer :: occ_hole(N_int*bit_kind_size,2)
- integer :: occ_particle(N_int*bit_kind_size,2)
- integer :: n_occ_ab_hole(2),n_occ_ab_particle(2)
- integer(bit_kind) :: det_tmp(N_int,2)
+subroutine three_comp_fock_elem(Nint, key_i, h_fock, p_fock, ispin_fock, hthree)
+ implicit none
+ integer, intent(in) :: Nint
+ integer, intent(in) :: h_fock, p_fock, ispin_fock
+ integer(bit_kind), intent(in) :: key_i(Nint,2)
+ double precision, intent(out) :: hthree
+
+ integer :: nexc(2),i,ispin,na,nb
+ integer(bit_kind) :: hole(Nint,2)
+ integer(bit_kind) :: particle(Nint,2)
+ integer :: occ_hole(Nint*bit_kind_size,2)
+ integer :: occ_particle(Nint*bit_kind_size,2)
+ integer :: n_occ_ab_hole(2),n_occ_ab_particle(2)
+ integer(bit_kind) :: det_tmp(Nint,2)
nexc(1) = 0
nexc(2) = 0
+
!! Get all the holes and particles of key_i with respect to the ROHF determinant
- do i=1,N_int
+ do i = 1, Nint
hole(i,1) = xor(key_i(i,1),ref_bitmask(i,1))
hole(i,2) = xor(key_i(i,2),ref_bitmask(i,2))
particle(i,1) = iand(hole(i,1),key_i(i,1))
@@ -161,13 +166,14 @@ subroutine three_comp_fock_elem(key_i,h_fock,p_fock,ispin_fock,hthree)
nexc(1) = nexc(1) + popcnt(hole(i,1))
nexc(2) = nexc(2) + popcnt(hole(i,2))
enddo
+
integer :: tmp(2)
!DIR$ FORCEINLINE
- call bitstring_to_list_ab(particle, occ_particle, tmp, N_int)
+ call bitstring_to_list_ab(particle, occ_particle, tmp, Nint)
ASSERT (tmp(1) == nexc(1)) ! Number of particles alpha
ASSERT (tmp(2) == nexc(2)) ! Number of particle beta
!DIR$ FORCEINLINE
- call bitstring_to_list_ab(hole, occ_hole, tmp, N_int)
+ call bitstring_to_list_ab(hole, occ_hole, tmp, Nint)
ASSERT (tmp(1) == nexc(1)) ! Number of holes alpha
ASSERT (tmp(2) == nexc(2)) ! Number of holes beta
@@ -181,15 +187,18 @@ subroutine three_comp_fock_elem(key_i,h_fock,p_fock,ispin_fock,hthree)
do ispin=1,2
na = elec_num_tab(ispin)
nb = elec_num_tab(iand(ispin,1)+1)
- do i=1,nexc(ispin)
+ do i = 1, nexc(ispin)
!DIR$ FORCEINLINE
- call fock_ac_tc_operator( occ_particle(i,ispin), ispin, det_tmp, h_fock,p_fock, ispin_fock, hthree, N_int,na,nb)
+ call fock_ac_tc_operator( occ_particle(i,ispin), ispin, det_tmp, h_fock,p_fock, ispin_fock, hthree, Nint, na, nb)
!DIR$ FORCEINLINE
- call fock_a_tc_operator ( occ_hole (i,ispin), ispin, det_tmp, h_fock,p_fock, ispin_fock, hthree, N_int,na,nb)
+ call fock_a_tc_operator ( occ_hole (i,ispin), ispin, det_tmp, h_fock,p_fock, ispin_fock, hthree, Nint, na, nb)
enddo
enddo
+
end
+! ---
+
subroutine fock_ac_tc_operator(iorb,ispin,key, h_fock,p_fock, ispin_fock,hthree,Nint,na,nb)
use bitmasks
implicit none
@@ -365,111 +374,118 @@ subroutine fock_a_tc_operator(iorb,ispin,key, h_fock,p_fock, ispin_fock,hthree,N
end
+! ---
-BEGIN_PROVIDER [double precision, fock_op_2_e_tc_closed_shell, (mo_num, mo_num) ]
- implicit none
- BEGIN_DOC
-! Closed-shell part of the Fock operator for the TC operator
- END_DOC
- integer :: h0,p0,h,p,k0,k,i
- integer :: n_occ_ab(2)
- integer :: occ(N_int*bit_kind_size,2)
- integer :: n_occ_ab_virt(2)
- integer :: occ_virt(N_int*bit_kind_size,2)
- integer(bit_kind) :: key_test(N_int)
- integer(bit_kind) :: key_virt(N_int,2)
- double precision :: accu
+BEGIN_PROVIDER [double precision, fock_op_2_e_tc_closed_shell, (mo_num, mo_num)]
- fock_op_2_e_tc_closed_shell = -1000.d0
- call bitstring_to_list_ab(ref_closed_shell_bitmask, occ, n_occ_ab, N_int)
- do i = 1, N_int
- key_virt(i,1) = full_ijkl_bitmask(i)
- key_virt(i,2) = full_ijkl_bitmask(i)
- key_virt(i,1) = xor(key_virt(i,1),ref_closed_shell_bitmask(i,1))
- key_virt(i,2) = xor(key_virt(i,2),ref_closed_shell_bitmask(i,2))
- enddo
- call bitstring_to_list_ab(key_virt, occ_virt, n_occ_ab_virt, N_int)
- ! docc ---> virt single excitations
- do h0 = 1, n_occ_ab(1)
- h=occ(h0,1)
- do p0 = 1, n_occ_ab_virt(1)
- p = occ_virt(p0,1)
- accu = 0.d0
- do k0 = 1, n_occ_ab(1)
- k = occ(k0,1)
- accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
- enddo
- fock_op_2_e_tc_closed_shell(p,h) = accu
+ BEGIN_DOC
+ ! Closed-shell part of the Fock operator for the TC operator
+ END_DOC
+
+ implicit none
+
+ PROVIDE N_int
+
+ integer :: h0,p0,h,p,k0,k,i
+ integer :: n_occ_ab(2)
+ integer :: occ(N_int*bit_kind_size,2)
+ integer :: n_occ_ab_virt(2)
+ integer :: occ_virt(N_int*bit_kind_size,2)
+ integer(bit_kind) :: key_test(N_int)
+ integer(bit_kind) :: key_virt(N_int,2)
+ double precision :: accu
+
+ fock_op_2_e_tc_closed_shell = -1000.d0
+ call bitstring_to_list_ab(ref_closed_shell_bitmask, occ, n_occ_ab, N_int)
+
+ do i = 1, N_int
+ key_virt(i,1) = full_ijkl_bitmask(i)
+ key_virt(i,2) = full_ijkl_bitmask(i)
+ key_virt(i,1) = xor(key_virt(i,1),ref_closed_shell_bitmask(i,1))
+ key_virt(i,2) = xor(key_virt(i,2),ref_closed_shell_bitmask(i,2))
enddo
- enddo
-
- do h0 = 1, n_occ_ab_virt(1)
- h = occ_virt(h0,1)
- do p0 = 1, n_occ_ab(1)
- p=occ(p0,1)
- accu = 0.d0
- do k0 = 1, n_occ_ab(1)
- k = occ(k0,1)
- accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
- enddo
- fock_op_2_e_tc_closed_shell(p,h) = accu
+ call bitstring_to_list_ab(key_virt, occ_virt, n_occ_ab_virt, N_int)
+ ! docc ---> virt single excitations
+ do h0 = 1, n_occ_ab(1)
+ h = occ(h0,1)
+ do p0 = 1, n_occ_ab_virt(1)
+ p = occ_virt(p0,1)
+ accu = 0.d0
+ do k0 = 1, n_occ_ab(1)
+ k = occ(k0,1)
+ accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
+ enddo
+ fock_op_2_e_tc_closed_shell(p,h) = accu
+ enddo
enddo
- enddo
-
- ! virt ---> virt single excitations
- do h0 = 1, n_occ_ab_virt(1)
- h=occ_virt(h0,1)
- do p0 = 1, n_occ_ab_virt(1)
- p = occ_virt(p0,1)
- accu = 0.d0
- do k0 = 1, n_occ_ab(1)
- k = occ(k0,1)
- accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
- enddo
- fock_op_2_e_tc_closed_shell(p,h) = accu
+
+ do h0 = 1, n_occ_ab_virt(1)
+ h = occ_virt(h0,1)
+ do p0 = 1, n_occ_ab(1)
+ p = occ(p0,1)
+ accu = 0.d0
+ do k0 = 1, n_occ_ab(1)
+ k = occ(k0,1)
+ accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
+ enddo
+ fock_op_2_e_tc_closed_shell(p,h) = accu
+ enddo
enddo
- enddo
-
- do h0 = 1, n_occ_ab_virt(1)
- h = occ_virt(h0,1)
- do p0 = 1, n_occ_ab_virt(1)
- p=occ_virt(p0,1)
- accu = 0.d0
- do k0 = 1, n_occ_ab(1)
- k = occ(k0,1)
- accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
+
+ ! virt ---> virt single excitations
+ do h0 = 1, n_occ_ab_virt(1)
+ h=occ_virt(h0,1)
+ do p0 = 1, n_occ_ab_virt(1)
+ p = occ_virt(p0,1)
+ accu = 0.d0
+ do k0 = 1, n_occ_ab(1)
+ k = occ(k0,1)
+ accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
+ enddo
+ fock_op_2_e_tc_closed_shell(p,h) = accu
enddo
- fock_op_2_e_tc_closed_shell(p,h) = accu
enddo
- enddo
-
-
- ! docc ---> docc single excitations
- do h0 = 1, n_occ_ab(1)
- h=occ(h0,1)
- do p0 = 1, n_occ_ab(1)
- p = occ(p0,1)
- accu = 0.d0
- do k0 = 1, n_occ_ab(1)
- k = occ(k0,1)
- accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
+
+ do h0 = 1, n_occ_ab_virt(1)
+ h = occ_virt(h0,1)
+ do p0 = 1, n_occ_ab_virt(1)
+ p=occ_virt(p0,1)
+ accu = 0.d0
+ do k0 = 1, n_occ_ab(1)
+ k = occ(k0,1)
+ accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
+ enddo
+ fock_op_2_e_tc_closed_shell(p,h) = accu
enddo
- fock_op_2_e_tc_closed_shell(p,h) = accu
enddo
- enddo
-
- do h0 = 1, n_occ_ab(1)
- h = occ(h0,1)
- do p0 = 1, n_occ_ab(1)
- p=occ(p0,1)
- accu = 0.d0
- do k0 = 1, n_occ_ab(1)
- k = occ(k0,1)
- accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
+
+
+ ! docc ---> docc single excitations
+ do h0 = 1, n_occ_ab(1)
+ h=occ(h0,1)
+ do p0 = 1, n_occ_ab(1)
+ p = occ(p0,1)
+ accu = 0.d0
+ do k0 = 1, n_occ_ab(1)
+ k = occ(k0,1)
+ accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
+ enddo
+ fock_op_2_e_tc_closed_shell(p,h) = accu
+ enddo
+ enddo
+
+ do h0 = 1, n_occ_ab(1)
+ h = occ(h0,1)
+ do p0 = 1, n_occ_ab(1)
+ p=occ(p0,1)
+ accu = 0.d0
+ do k0 = 1, n_occ_ab(1)
+ k = occ(k0,1)
+ accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
+ enddo
+ fock_op_2_e_tc_closed_shell(p,h) = accu
enddo
- fock_op_2_e_tc_closed_shell(p,h) = accu
enddo
- enddo
! do i = 1, mo_num
! write(*,'(100(F10.5,X))')fock_op_2_e_tc_closed_shell(:,i)
@@ -477,8 +493,10 @@ BEGIN_PROVIDER [double precision, fock_op_2_e_tc_closed_shell, (mo_num, mo_num)
END_PROVIDER
+! ---
subroutine single_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_j, key_i, htot)
+
BEGIN_DOC
! for single excitation ONLY FOR ONE- AND TWO-BODY TERMS
!!
@@ -492,8 +510,9 @@ subroutine single_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_j, key_i, htot)
implicit none
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2)
- double precision, intent(out) :: htot
- double precision :: hmono, htwoe
+ double precision, intent(out) :: htot
+
+ 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)
@@ -517,75 +536,227 @@ subroutine single_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_j, key_i, htot)
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(key_i,key_j,h1,p1,s1,phase,hmono,htwoe,htot)
-end
-
-
-subroutine get_single_excitation_from_fock_tc_no_3e(key_i,key_j,h,p,spin,phase,hmono,htwoe,htot)
- use bitmasks
- implicit none
- integer,intent(in) :: h,p,spin
- double precision, intent(in) :: phase
- integer(bit_kind), intent(in) :: key_i(N_int,2), key_j(N_int,2)
- double precision, intent(out) :: hmono,htwoe,htot
- integer(bit_kind) :: differences(N_int,2)
- integer(bit_kind) :: hole(N_int,2)
- integer(bit_kind) :: partcl(N_int,2)
- integer :: occ_hole(N_int*bit_kind_size,2)
- integer :: occ_partcl(N_int*bit_kind_size,2)
- integer :: n_occ_ab_hole(2),n_occ_ab_partcl(2)
- integer :: i0,i
- double precision :: buffer_c(mo_num),buffer_x(mo_num)
- do i=1, mo_num
- buffer_c(i) = tc_2e_3idx_coulomb_integrals(i,p,h)
- buffer_x(i) = tc_2e_3idx_exchange_integrals(i,p,h)
- enddo
- do i = 1, N_int
- 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, N_int)
- call bitstring_to_list_ab(partcl, occ_partcl, n_occ_ab_partcl, N_int)
- hmono = mo_bi_ortho_tc_one_e(p,h)
- htwoe = fock_op_2_e_tc_closed_shell(p,h)
- ! holes :: direct terms
- do i0 = 1, n_occ_ab_hole(1)
- i = occ_hole(i0,1)
- htwoe -= buffer_c(i)
- enddo
- do i0 = 1, n_occ_ab_hole(2)
- i = occ_hole(i0,2)
- htwoe -= buffer_c(i)
- enddo
-
- ! holes :: exchange terms
- do i0 = 1, n_occ_ab_hole(spin)
- i = occ_hole(i0,spin)
- htwoe += buffer_x(i)
- enddo
-
- ! particles :: direct terms
- do i0 = 1, n_occ_ab_partcl(1)
- i = occ_partcl(i0,1)
- htwoe += buffer_c(i)
- enddo
- do i0 = 1, n_occ_ab_partcl(2)
- i = occ_partcl(i0,2)
- htwoe += buffer_c(i)
- enddo
-
- ! particles :: exchange terms
- do i0 = 1, n_occ_ab_partcl(spin)
- i = occ_partcl(i0,spin)
- htwoe -= buffer_x(i)
- enddo
- htwoe = htwoe * phase
- hmono = hmono * phase
- htot = htwoe + hmono
+ call get_single_excitation_from_fock_tc_no_3e(Nint, key_i, key_j, h1, p1, s1, phase, hmono, htwoe, htot)
+
+end
+
+! ---
+
+subroutine get_single_excitation_from_fock_tc_no_3e(Nint, key_i, key_j, h, p, spin, phase, hmono, htwoe, htot)
+
+ 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) :: hmono,htwoe,htot
+
+ 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(mo_num), buffer_x(mo_num)
+
+ do i = 1, mo_num
+ buffer_c(i) = tc_2e_3idx_coulomb_integrals(i,p,h)
+ buffer_x(i) = tc_2e_3idx_exchange_integrals(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 = mo_bi_ortho_tc_one_e(p,h)
+ htwoe = fock_op_2_e_tc_closed_shell(p,h)
+
+ ! holes :: direct terms
+ do i0 = 1, n_occ_ab_hole(1)
+ i = occ_hole(i0,1)
+ htwoe -= buffer_c(i)
+ enddo
+ do i0 = 1, n_occ_ab_hole(2)
+ i = occ_hole(i0,2)
+ htwoe -= buffer_c(i)
+ enddo
+
+ ! holes :: exchange terms
+ do i0 = 1, n_occ_ab_hole(spin)
+ i = occ_hole(i0,spin)
+ htwoe += buffer_x(i)
+ enddo
+
+ ! particles :: direct terms
+ do i0 = 1, n_occ_ab_partcl(1)
+ i = occ_partcl(i0,1)
+ htwoe += buffer_c(i)
+ enddo
+ do i0 = 1, n_occ_ab_partcl(2)
+ i = occ_partcl(i0,2)
+ htwoe += buffer_c(i)
+ enddo
+
+ ! particles :: exchange terms
+ do i0 = 1, n_occ_ab_partcl(spin)
+ i = occ_partcl(i0,spin)
+ htwoe -= buffer_x(i)
+ enddo
+ htwoe = htwoe * phase
+ hmono = hmono * phase
+ htot = htwoe + hmono
+
+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 63%
rename from plugins/local/tc_bi_ortho/tc_hmat.irp.f
rename to plugins/local/slater_tc/tc_hmat.irp.f
index 88652caa..cc780364 100644
--- a/plugins/local/tc_bi_ortho/tc_hmat.irp.f
+++ b/plugins/local/slater_tc/tc_hmat.irp.f
@@ -13,16 +13,35 @@ BEGIN_PROVIDER [double precision, htilde_matrix_elmt_bi_ortho, (N_det,N_det)]
implicit none
integer :: i, j
+ double precision :: t1, t2
double precision :: htot
+
+ PROVIDE N_int
+ PROVIDE psi_det
+ PROVIDE three_e_3_idx_term
- call provide_all_three_ints_bi_ortho
+ if(noL_standard) then
+ PROVIDE noL_0e
+ print*, "noL_0e =", noL_0e
+ PROVIDE noL_1e
+ PROVIDE noL_2e
+ endif
+
+ print *, ' PROVIDING htilde_matrix_elmt_bi_ortho ...'
+ call wall_time(t1)
+
+ call provide_all_three_ints_bi_ortho()
i = 1
j = 1
call htilde_mu_mat_opt_bi_ortho_tot(psi_det(1,1,j), psi_det(1,1,i), N_int, htot)
- !$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,j, htot) &
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT(NONE) &
+ !$OMP PRIVATE(i, j, htot) &
!$OMP SHARED (N_det, psi_det, N_int, htilde_matrix_elmt_bi_ortho)
+ !$OMP DO
do i = 1, N_det
do j = 1, N_det
! < J |Htilde | I >
@@ -31,7 +50,11 @@ BEGIN_PROVIDER [double precision, htilde_matrix_elmt_bi_ortho, (N_det,N_det)]
htilde_matrix_elmt_bi_ortho(j,i) = htot
enddo
enddo
- !$OMP END PARALLEL DO
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ call wall_time(t2)
+ print *, ' wall time for htilde_matrix_elmt_bi_ortho (min) =', (t2-t1)/60.d0
END_PROVIDER
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_h_eigvectors.irp.f b/plugins/local/tc_bi_ortho/tc_h_eigvectors.irp.f
index a636e8d6..16844221 100644
--- a/plugins/local/tc_bi_ortho/tc_h_eigvectors.irp.f
+++ b/plugins/local/tc_bi_ortho/tc_h_eigvectors.irp.f
@@ -45,12 +45,12 @@ end
! ---
- BEGIN_PROVIDER [double precision, eigval_right_tc_bi_orth, (N_states) ]
-&BEGIN_PROVIDER [double precision, eigval_left_tc_bi_orth , (N_states) ]
-&BEGIN_PROVIDER [double precision, reigvec_tc_bi_orth , (N_det,N_states)]
-&BEGIN_PROVIDER [double precision, leigvec_tc_bi_orth , (N_det,N_states)]
-&BEGIN_PROVIDER [double precision, s2_eigvec_tc_bi_orth , (N_states) ]
-&BEGIN_PROVIDER [double precision, norm_ground_left_right_bi_orth ]
+ BEGIN_PROVIDER [double precision, eigval_right_tc_bi_orth , (N_states) ]
+&BEGIN_PROVIDER [double precision, eigval_left_tc_bi_orth , (N_states) ]
+&BEGIN_PROVIDER [double precision, reigvec_tc_bi_orth , (N_det,N_states)]
+&BEGIN_PROVIDER [double precision, leigvec_tc_bi_orth , (N_det,N_states)]
+&BEGIN_PROVIDER [double precision, s2_eigvec_tc_bi_orth , (N_states) ]
+&BEGIN_PROVIDER [double precision, norm_ground_left_right_bi_orth , (N_states) ]
BEGIN_DOC
! eigenvalues, right and left eigenvectors of the transcorrelated Hamiltonian on the BI-ORTHO basis
@@ -86,17 +86,20 @@ end
endif
call non_hrmt_real_diag(N_det, H_prime, leigvec_tc_bi_orth_tmp, reigvec_tc_bi_orth_tmp, n_real_tc_bi_orth_eigval_right, eigval_right_tmp)
+ if(N_states.gt.1)then
+ print*,'n_real_tc_bi_orth_eigval_right = ',n_real_tc_bi_orth_eigval_right
+ endif
! do i = 1, N_det
! call get_H_tc_s2_l0_r0(leigvec_tc_bi_orth_tmp(1,i),reigvec_tc_bi_orth_tmp(1,i),1,N_det,expect_e(i), s2_values_tmp(i))
! enddo
call get_H_tc_s2_l0_r0(leigvec_tc_bi_orth_tmp,reigvec_tc_bi_orth_tmp,N_det,N_det,expect_e, s2_values_tmp)
+
allocate(index_good_state_array(N_det),good_state_array(N_det))
i_state = 0
good_state_array = .False.
if(s2_eig) then
-
if(only_expected_s2) then
do j = 1, N_det
! Select at least n_states states with S^2 values closed to "expected_s2"
@@ -116,6 +119,9 @@ end
good_state_array(j) = .True.
enddo
endif
+ if(N_states.gt.1)then
+ print*,'i_state = ',i_state
+ endif
if(i_state .ne. 0) then
! Fill the first "i_state" states that have a correct S^2 value
@@ -230,6 +236,7 @@ end
allocate(H_jj(N_det),vec_tmp(N_det,n_states_diag))
+ ! TODO : OPEN-MP
do i = 1, N_det
call htilde_mu_mat_opt_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,i), N_int, H_jj(i))
enddo
@@ -277,7 +284,6 @@ end
do istate = N_states+1, n_states_diag
vec_tmp(istate,istate) = 1.d0
enddo
- !call davidson_general_ext_rout_nonsym_b1space(vec_tmp, H_jj, eigval_right_tc_bi_orth, N_det, n_states, n_states_diag, converged, H_tc_u_0_opt)
converged = .False.
i_it = 0
do while (.not. converged)
@@ -309,19 +315,18 @@ end
deallocate(Stmp)
print*,'leigvec_tc_bi_orth(1,1),reigvec_tc_bi_orth(1,1) = ', leigvec_tc_bi_orth(1,1), reigvec_tc_bi_orth(1,1)
+ norm_ground_left_right_bi_orth = 0.d0
do i = 1, N_states
- norm_ground_left_right_bi_orth = 0.d0
do j = 1, N_det
- norm_ground_left_right_bi_orth += leigvec_tc_bi_orth(j,i) * reigvec_tc_bi_orth(j,i)
+ norm_ground_left_right_bi_orth(i) += leigvec_tc_bi_orth(j,i) * reigvec_tc_bi_orth(j,i)
enddo
print*,' state ', i
- print*,' norm l/r = ', norm_ground_left_right_bi_orth
+ print*,' norm l/r = ', norm_ground_left_right_bi_orth(i)
print*,' = ', s2_eigvec_tc_bi_orth(i)
enddo
double precision, allocatable :: buffer(:,:)
allocate(buffer(psi_det_size,N_states))
- print*,'passed the allocate'
! print*,N_det,N_states
! print*,size(psi_l_coef_bi_ortho,1),size(psi_l_coef_bi_ortho,2)
! print*,size(leigvec_tc_bi_orth,1),size(leigvec_tc_bi_orth,2)
@@ -334,29 +339,17 @@ end
buffer(i,k) = leigvec_tc_bi_orth(i,k)
enddo
enddo
- print*,'passed the first loop'
TOUCH psi_l_coef_bi_ortho
- print*,'passed the TOUCH psi_l_coef_bi_ortho'
call ezfio_set_tc_bi_ortho_psi_l_coef_bi_ortho(buffer)
- print*,'passed the ezfio_set_tc_bi_ortho_psi_l_coef_bi_ortho'
do k = 1, N_states
do i = 1, N_det
psi_r_coef_bi_ortho(i,k) = reigvec_tc_bi_orth(i,k)
buffer(i,k) = reigvec_tc_bi_orth(i,k)
enddo
enddo
- print*,'passed the second loop'
TOUCH psi_r_coef_bi_ortho
- print*,'passed the TOUCH psi_r_coef_bi_ortho'
call ezfio_set_tc_bi_ortho_psi_r_coef_bi_ortho(buffer)
- print*,'passed the ezfio_set_tc_bi_ortho_psi_r_coef_bi_ortho'
deallocate(buffer)
- print*,'passed saving the wf'
-! print*,'After diag'
-! do i = 1, N_det! old version
-! print*,'i',i,psi_l_coef_bi_ortho(i,1),psi_r_coef_bi_ortho(i,1)
-! call debug_det(psi_det(1,1,i),N_int)
-! enddo
END_PROVIDER
@@ -371,22 +364,29 @@ subroutine bi_normalize(u_l, u_r, n, ld, nstates)
implicit none
integer, intent(in) :: n, ld, nstates
double precision, intent(inout) :: u_l(ld,nstates), u_r(ld,nstates)
- integer :: i, j
- double precision :: accu, tmp
+ integer :: i, j,j_loc
+ double precision :: accu, tmp, maxval_tmp
do i = 1, nstates
!!!! Normalization of right eigenvectors |Phi>
accu = 0.d0
+ ! TODO: dot product lapack
+ maxval_tmp = 0.d0
do j = 1, n
accu += u_r(j,i) * u_r(j,i)
+ if(dabs(u_r(j,i)).gt.maxval_tmp)then
+ maxval_tmp = dabs(u_r(j,i))
+ j_loc = j
+ endif
enddo
accu = 1.d0/dsqrt(accu)
print*,'accu_r = ',accu
+ print*,'j_loc = ',j_loc
do j = 1, n
u_r(j,i) *= accu
enddo
- tmp = u_r(1,i) / dabs(u_r(1,i))
+ tmp = u_r(j_loc,i) / dabs(u_r(j_loc,i))
do j = 1, n
u_r(j,i) *= tmp
enddo
@@ -403,7 +403,7 @@ subroutine bi_normalize(u_l, u_r, n, ld, nstates)
else
accu = 1.d0/dsqrt(-accu)
endif
- tmp = (u_l(1,i) * u_r(1,i) )/dabs(u_l(1,i) * u_r(1,i))
+ tmp = (u_l(j_loc,i) * u_r(j_loc,i) )/dabs(u_l(j_loc,i) * u_r(j_loc,i))
do j = 1, n
u_l(j,i) *= accu * tmp
u_r(j,i) *= accu
diff --git a/plugins/local/tc_bi_ortho/tc_natorb.irp.f b/plugins/local/tc_bi_ortho/tc_natorb.irp.f
index b8cf5e81..cc24256f 100644
--- a/plugins/local/tc_bi_ortho/tc_natorb.irp.f
+++ b/plugins/local/tc_bi_ortho/tc_natorb.irp.f
@@ -33,7 +33,6 @@
do i = 1, ao_num
write(*, '(100(F16.10,X))') tc_transition_matrix_ao(:,i,1,1)
enddo
- stop
thr_d = 1.d-6
thr_nd = 1.d-6
@@ -52,7 +51,6 @@
! call diag_mat_per_fock_degen( fock_diag, dm_tmp, mo_num, thr_d, thr_nd, thr_deg &
! , natorb_tc_leigvec_mo, natorb_tc_reigvec_mo, natorb_tc_eigval)
! endif
-
call non_hrmt_bieig(mo_num, dm_tmp, thresh_biorthog_diag, thresh_biorthog_nondiag &
, natorb_tc_leigvec_mo, natorb_tc_reigvec_mo &
, mo_num, natorb_tc_eigval )
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 93ff790f..b7ce0b19 100644
--- a/plugins/local/tc_keywords/EZFIO.cfg
+++ b/plugins/local/tc_keywords/EZFIO.cfg
@@ -14,7 +14,7 @@ default: False
type: logical
doc: If |true|, three-body terms are included
interface: ezfio,provider,ocaml
-default: True
+default: False
[three_e_3_idx_term]
type: logical
@@ -50,7 +50,7 @@ default: False
type: logical
doc: If |true|, standard normal-ordering for L (to be used with three_body_h_tc |false|)
interface: ezfio,provider,ocaml
-default: False
+default: True
[core_tc_op]
type: logical
@@ -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,3 +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-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 86%
rename from plugins/local/tc_bi_ortho/print_tc_wf.irp.f
rename to plugins/local/tc_progs/print_tc_wf.irp.f
index c755485b..3e010e01 100644
--- a/plugins/local/tc_bi_ortho/print_tc_wf.irp.f
+++ b/plugins/local/tc_progs/print_tc_wf.irp.f
@@ -37,7 +37,8 @@ subroutine write_l_r_wf
integer :: i
print*,'Writing the left-right wf'
do i = 1, N_det
- write(i_unit_output,*)i, psi_l_coef_sorted_bi_ortho_left(i)/psi_l_coef_sorted_bi_ortho_left(1) &
+ write(i_unit_output,'(I8,X,10(F16.10,X))')i, psi_coef_sorted_tc(i,1),psi_coef_sorted_tc(i,1)/psi_coef_sorted_tc(1,1)&
+ , psi_l_coef_sorted_bi_ortho_left(i)/psi_l_coef_sorted_bi_ortho_left(1) &
, psi_r_coef_sorted_bi_ortho_right(i)/psi_r_coef_sorted_bi_ortho_right(1)
enddo
@@ -60,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 95%
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
index 6b3acce6..02e8144f 100644
--- 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
@@ -33,7 +33,8 @@ program tc_natorb_bi_ortho
read_wf = .True.
touch read_wf
- call print_energy_and_mos()
+ logical :: good_angles
+ call print_energy_and_mos(good_angles)
call save_tc_natorb()
call print_angles_tc()
!call minimize_tc_orb_angles()
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/11.tc_scf.bats b/plugins/local/tc_scf/11.tc_scf.bats
index b81c2f4b..f5f2e3c1 100644
--- a/plugins/local/tc_scf/11.tc_scf.bats
+++ b/plugins/local/tc_scf/11.tc_scf.bats
@@ -10,16 +10,17 @@ function run_Ne() {
qp create_ezfio -b cc-pcvdz Ne.xyz -o Ne_tc_scf
qp run scf
+ qp set tc_keywords tc_integ_type numeric
+ qp set jastrow env_type Sum_Gauss
qp set hamiltonian mu_erf 0.87
- qp set tc_keywords j1b_type 3
- qp set tc_keywords j1b_pen [1.5]
- qp set tc_keywords bi_ortho True
- qp set tc_keywords test_cycle_tc True
+ qp set jastrow j1e_type None
+ qp set jastrow env_coef "[1.]"
+ qp set jastrow env_expo "[1.5]"
qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out
eref=-128.552134
energy="$(qp get tc_scf bitc_energy)"
- eq $energy $eref 1e-6
+ eq $energy $eref 2e-4
}
@@ -33,16 +34,17 @@ function run_C() {
qp create_ezfio -b cc-pcvdz C.xyz -o C_tc_scf -m 3
qp run scf
+ qp set tc_keywords tc_integ_type numeric
+ qp set jastrow env_type Sum_Gauss
qp set hamiltonian mu_erf 0.87
- qp set tc_keywords j1b_type 3
- qp set tc_keywords j1b_pen [1.5]
- qp set tc_keywords bi_ortho True
- qp set tc_keywords test_cycle_tc True
+ qp set jastrow j1e_type None
+ qp set jastrow env_coef "[1.]"
+ qp set jastrow env_expo "[1.5]"
qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out
eref=-37.691254356408791
energy="$(qp get tc_scf bitc_energy)"
- eq $energy $eref 1e-6
+ eq $energy $eref 2e-4
}
@@ -57,16 +59,17 @@ function run_O() {
qp create_ezfio -b cc-pcvdz O.xyz -o O_tc_scf -m 3
qp run scf
+ qp set tc_keywords tc_integ_type numeric
+ qp set jastrow env_type Sum_Gauss
+ qp set jastrow j1e_type None
+ qp set jastrow env_coef "[1.]"
+ qp set jastrow env_expo "[1.5]"
qp set hamiltonian mu_erf 0.87
- qp set tc_keywords j1b_type 3
- qp set tc_keywords j1b_pen [1.5]
- qp set tc_keywords bi_ortho True
- qp set tc_keywords test_cycle_tc True
qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out
eref=-74.814687229354590
energy="$(qp get tc_scf bitc_energy)"
- eq $energy $eref 1e-6
+ eq $energy $eref 2e-4
}
@@ -82,16 +85,17 @@ function run_ch2() {
qp create_ezfio -b "C:cc-pcvdz|H:cc-pvdz" ch2.xyz -o ch2_tc_scf
qp run scf
+ qp set tc_keywords tc_integ_type numeric
+ qp set jastrow env_type Sum_Gauss
+ qp set jastrow j1e_type None
+ qp set jastrow env_coef "[1., 1., 1.]"
+ qp set jastrow env_expo '[1.5,10000,10000]'
qp set hamiltonian mu_erf 0.87
- qp set tc_keywords j1b_type 3
- qp set tc_keywords j1b_pen '[1.5,10000,10000]'
- qp set tc_keywords bi_ortho True
- qp set tc_keywords test_cycle_tc True
qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out
eref=-38.903247818077737
energy="$(qp get tc_scf bitc_energy)"
- eq $energy $eref 1e-6
+ eq $energy $eref 2e-4
}
diff --git a/plugins/local/tc_scf/EZFIO.cfg b/plugins/local/tc_scf/EZFIO.cfg
index 313d6f2b..e3d24338 100644
--- a/plugins/local/tc_scf/EZFIO.cfg
+++ b/plugins/local/tc_scf/EZFIO.cfg
@@ -1,4 +1,41 @@
-[bitc_energy]
+[tcscf_energy]
type: Threshold
-doc: Energy bi-tc HF
+doc: TC-SCF ENERGY
interface: ezfio
+
+[converged_tcscf]
+type: logical
+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/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/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 12678500..1cade02a 100644
--- a/plugins/local/tc_scf/rh_tcscf_diis.irp.f
+++ b/plugins/local/tc_scf/rh_tcscf_diis.irp.f
@@ -22,6 +22,9 @@ subroutine rh_tcscf_diis()
logical, external :: qp_stop
+ PROVIDE level_shift_TCSCF
+ PROVIDE mo_l_coef mo_r_coef
+
it = 0
e_save = 0.d0
dim_DIIS = 0
@@ -41,19 +44,6 @@ subroutine rh_tcscf_diis()
! ---
- 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)') &
- ! '====', '================', '================', '================', '================', '================' &
- ! , '================', '================', '================', '====', '========'
-
write(6, '(A4,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A4, 1X, A8)') &
'====', '================', '================', '================', '================', '================' &
, '================', '================', '====', '========'
@@ -71,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)
@@ -81,8 +71,6 @@ subroutine rh_tcscf_diis()
er_save = er_DIIS
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
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
@@ -91,6 +79,8 @@ subroutine rh_tcscf_diis()
PROVIDE FQS_SQF_ao Fock_matrix_tc_ao_tot
converged = .false.
+ call ezfio_set_tc_scf_converged_tcscf(converged)
+
!do while((tc_grad .gt. dsqrt(thresh_tcscf)) .and. (er_DIIS .gt. dsqrt(thresh_tcscf)))
do while(.not. converged)
@@ -199,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)
@@ -244,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'
@@ -253,8 +243,9 @@ subroutine rh_tcscf_diis()
endif
call lock_io
- if (converged) then
+ if(converged) then
write(json_unit, json_true_fmtx) 'converged'
+ call ezfio_set_tc_scf_converged_tcscf(converged)
else
write(json_unit, json_false_fmtx) 'converged'
endif
@@ -272,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 cc825429..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-8
+ 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,17 +157,51 @@ 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
- 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))
+ 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(*,'(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)
+ 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
+ endif
+ print*,'Right orbitals '
+ 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
! Orthogonalization of right functions
print *, ' Orthogonalization of RIGHT functions'
@@ -269,6 +304,7 @@ subroutine routine_save_rotated_mos(thr_deg, good_angles)
! check if TC energy has changed
E_new = TC_HF_energy
+ E_thr = thresh_de_tc_angles
if(dabs(E_new - E_old) .gt. E_thr) then
mo_r_coef = mo_r_coef_old
mo_l_coef = mo_l_coef_old
@@ -407,18 +443,18 @@ subroutine print_energy_and_mos(good_angles)
if(max_angle_left_right .lt. thresh_lr_angle) then
print *, ' Maximum angle BELOW 45 degrees, everthing is OK !'
good_angles = .true.
- else if(max_angle_left_right .gt. thresh_lr_angle .and. max_angle_left_right .lt. 75.d0) then
- print *, ' Maximum angle between thresh_lr_angle and 75 degrees, this is not the best for TC-CI calculations ...'
- good_angles = .false.
- else if(max_angle_left_right .gt. 75.d0) then
- print *, ' Maximum angle between ABOVE 75 degrees, YOU WILL CERTAINLY FIND TROUBLES IN TC-CI calculations ...'
- good_angles = .false.
+! else if(max_angle_left_right .gt. thresh_lr_angle .and. max_angle_left_right .lt. 75.d0) then
+! print *, ' Maximum angle between thresh_lr_angle and 75 degrees, this is not the best for TC-CI calculations ...'
+! good_angles = .false.
+! else if(max_angle_left_right .gt. 75.d0) then
+! print *, ' Maximum angle between ABOVE 75 degrees, YOU WILL CERTAINLY FIND TROUBLES IN TC-CI calculations ...'
+! good_angles = .false.
endif
-
- print *, ' Diag Fock elem, product of left/right norm, angle left/right '
- do i = 1, mo_num
- write(*, '(I3,X,100(F16.10,X))') i, Fock_matrix_tc_mo_tot(i,i), overlap_mo_l(i,i)*overlap_mo_r(i,i), angle_left_right(i)
- enddo
+!
+! print *, ' Diag Fock elem, product of left/right norm, angle left/right '
+! do i = 1, mo_num
+! write(*, '(I3,X,100(F16.10,X))') i, Fock_matrix_tc_mo_tot(i,i), overlap_mo_l(i,i)*overlap_mo_r(i,i), angle_left_right(i)
+! enddo
end
@@ -445,3 +481,31 @@ subroutine sort_by_tc_fock
end
+
+subroutine print_strong_overlap(i_list, j_list)
+ implicit none
+ integer, intent(in) :: i_list,j_list
+ double precision :: o_i, o_j,o_ij
+ double precision :: s_mat_r(2,2),s_mat_l(2,2)
+ o_i = dsqrt(overlap_mo_r(i_list, i_list))
+ o_j = dsqrt(overlap_mo_r(j_list, j_list))
+ o_ij = overlap_mo_r(j_list, i_list)
+ s_mat_r(1,1) = o_i*o_i
+ s_mat_r(2,1) = o_ij/(o_i * o_j)
+ s_mat_r(2,2) = o_j*o_j
+ s_mat_r(1,2) = s_mat_r(2,1)
+ print*,'Right overlap matrix '
+ write(*,'(2(F10.5,X))')s_mat_r(1:2,1)
+ write(*,'(2(F10.5,X))')s_mat_r(1:2,2)
+ o_i = dsqrt(overlap_mo_l(i_list, i_list))
+ o_j = dsqrt(overlap_mo_l(j_list, j_list))
+ o_ij = overlap_mo_l(j_list, i_list)
+ s_mat_l(1,1) = o_i*o_i
+ s_mat_l(2,1) = o_ij/(o_i * o_j)
+ s_mat_l(2,2) = o_j*o_j
+ s_mat_l(1,2) = s_mat_l(2,1)
+ print*,'Left overlap matrix '
+ write(*,'(2(F10.5,X))')s_mat_l(1:2,1)
+ write(*,'(2(F10.5,X))')s_mat_l(1:2,2)
+
+end
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/scripts/get_fci_tc_conv.sh b/scripts/get_fci_tc_conv.sh
index 643f3ac0..f0c99baf 100755
--- a/scripts/get_fci_tc_conv.sh
+++ b/scripts/get_fci_tc_conv.sh
@@ -1,2 +1,2 @@
file=$1
-grep "Ndet,E,E+PT2,E+RPT2,|PT2|=" $file | cut -d "=" -f 2 > ${file}.conv_fci_tc
+grep "Ndet,E,E+PT2,pt2_minus,pt2_plus,pt2_abs=" $file | cut -d "=" -f 2 > ${file}.conv_fci_tc
diff --git a/src/.gitignore b/src/.gitignore
index 6353c21a..abc6a4c0 100644
--- a/src/.gitignore
+++ b/src/.gitignore
@@ -1,5 +1,6 @@
*
!README.rst
+!NEED
!*/
*/*
!*/*.*
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_one_e_ints/spread_dipole_ao.irp.f b/src/ao_one_e_ints/spread_dipole_ao.irp.f
index c52d0548..86469a3f 100644
--- a/src/ao_one_e_ints/spread_dipole_ao.irp.f
+++ b/src/ao_one_e_ints/spread_dipole_ao.irp.f
@@ -224,7 +224,7 @@
subroutine overlap_bourrin_spread(A_center,B_center,alpha,beta,power_A,power_B,overlap_x,lower_exp_val,dx,nx)
BEGIN_DOC
! Computes the following integral :
-! int [-infty ; +infty] of [(x-A_center)^(power_A) * (x-B_center)^power_B * exp(-alpha(x-A_center)^2) * exp(-beta(x-B_center)^2) * x ]
+! int [-infty ; +infty] of [(x-A_center)^(power_A) * (x-B_center)^power_B * exp(-alpha(x-A_center)^2) * exp(-beta(x-B_center)^2) * x^2 ]
! needed for the dipole and those things
END_DOC
implicit none
diff --git a/src/ao_two_e_ints/EZFIO.cfg b/src/ao_two_e_ints/EZFIO.cfg
index ff932b0c..c2e083a3 100644
--- a/src/ao_two_e_ints/EZFIO.cfg
+++ b/src/ao_two_e_ints/EZFIO.cfg
@@ -25,16 +25,16 @@ default: 1.e-12
[do_direct_integrals]
type: logical
-doc: Compute integrals on the fly (very slow, only for debugging)
+doc: Compute integrals on the fly (Useful only for Cholesky decomposition)
interface: ezfio,provider,ocaml
-default: False
+default: True
ezfio_name: direct
[do_ao_cholesky]
type: logical
doc: Perform Cholesky decomposition of AO integrals
interface: ezfio,provider,ocaml
-default: False
+default: True
[io_ao_two_e_integrals_erf]
type: Disk_access
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 0386f3c6..9da8a099 100644
--- a/src/becke_numerical_grid/grid_becke_vector.irp.f
+++ b/src/becke_numerical_grid/grid_becke_vector.irp.f
@@ -55,7 +55,7 @@ END_PROVIDER
do j = 1, nucl_num
do i = 1, n_points_radial_grid -1
do k = 1, n_points_integration_angular
- if(dabs(final_weight_at_r(k,i,j)) < thresh_grid)then
+ if(dabs(final_weight_at_r(k,i,j)) < thresh_grid) then
cycle
endif
i_count += 1
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/casscf_cipsi/README.rst b/src/casscf_cipsi/README.rst
index f84cde75..75c99de2 100644
--- a/src/casscf_cipsi/README.rst
+++ b/src/casscf_cipsi/README.rst
@@ -4,13 +4,15 @@ casscf
|CASSCF| program with the CIPSI algorithm.
-Example of inputs
------------------
+
+Example of inputs for GROUND STATE calculations
+-----------------------------------------------
+NOTICE :: FOR EXCITED STATES CALCULATIONS SEE THE FILE "example_casscf_multistate.sh"
a) Small active space : standard CASSCF
---------------------------------------
Let's do O2 (triplet) in aug-cc-pvdz with the following geometry (xyz format, Bohr units)
-3
+2
O 0.0000000000 0.0000000000 -1.1408000000
O 0.0000000000 0.0000000000 1.1408000000
@@ -45,3 +47,4 @@ qp set casscf_cipsi small_active_space False
qp run casscf | tee ${EZFIO_FILE}.casscf_large.out
# you should find around -149.9046
+
diff --git a/src/casscf_cipsi/casscf.irp.f b/src/casscf_cipsi/casscf.irp.f
index addca236..d0a26d36 100644
--- a/src/casscf_cipsi/casscf.irp.f
+++ b/src/casscf_cipsi/casscf.irp.f
@@ -54,14 +54,24 @@ subroutine run
call write_time(6)
call write_int(6,iteration,'CAS-SCF iteration = ')
- call write_double(6,energy,'CAS-SCF energy = ')
+ call write_double(6,energy,'State-average CAS-SCF energy = ')
! if(n_states == 1)then
! call ezfio_get_casscf_cipsi_energy_pt2(E_PT2)
! call ezfio_get_casscf_cipsi_energy(PT2)
+ double precision :: delta_E_istate, e_av
+ e_av = 0.d0
do istate=1,N_states
- call write_double(6,E_PT2(istate),'E + PT2 energy = ')
- call write_double(6,PT2(istate),' PT2 = ')
+ e_av += state_average_weight(istate) * Ev(istate)
+ if(istate.gt.1)then
+ delta_E_istate = E_PT2(istate) - E_PT2(1)
+ write(*,'(A6,I2,A18,F16.10)')'state ',istate,' Delta E+PT2 = ',delta_E_istate
+ endif
+ write(*,'(A6,I2,A18,F16.10)')'state ',istate,' E + PT2 energy = ',E_PT2(istate)
+ write(*,'(A6,I2,A18,F16.10)')'state ',istate,' PT2 energy = ',PT2(istate)
+! call write_double(6,E_PT2(istate),'E + PT2 energy = ')
+! call write_double(6,PT2(istate),' PT2 = ')
enddo
+ call write_double(6,e_av,'State-average CAS-SCF energy bis = ')
call write_double(6,pt2_max,' PT2_MAX = ')
! endif
@@ -99,8 +109,8 @@ subroutine run
mo_coef = NewOrbs
mo_occ = occnum
- call save_mos
if(.not.converged)then
+ call save_mos
iteration += 1
if(norm_grad_vec2.gt.0.01d0)then
N_det = N_states
diff --git a/src/casscf_cipsi/example_casscf_multistate.sh b/src/casscf_cipsi/example_casscf_multistate.sh
new file mode 100755
index 00000000..716c211a
--- /dev/null
+++ b/src/casscf_cipsi/example_casscf_multistate.sh
@@ -0,0 +1,66 @@
+# This is an example for MULTI STATE CALCULATION STATE AVERAGE CASSCF
+# We will compute 3 states on the O2 molecule
+# The Ground state and 2 degenerate excited states
+# Please follow carefully the tuto :)
+
+##### PREPARING THE EZFIO
+# Set the path to your QP2 directory
+QP_ROOT=my_fancy_path
+source ${QP_ROOT}/quantum_package.rc
+# Create the EZFIO folder
+qp create_ezfio -b aug-cc-pvdz O2.xyz -m 3 -a -o O2_avdz_multi_state
+# Start with ROHF orbitals
+qp run scf # ROHF energy : -149.619992871398
+# Freeze the 1s orbitals of the two oxygen
+qp set_frozen_core
+
+##### PREPARING THE ORBITALS WITH NATURAL ORBITALS OF A CIS
+# Tell that you want 3 states in your WF
+qp set determinants n_states 3
+# Run a CIS wave function to start your calculation
+qp run cis | tee ${EZFIO_FILE}.cis_3_states.out # -149.6652601409258 -149.4714726176746 -149.4686165431939
+# Save the STATE AVERAGE natural orbitals for having a balanced description
+# This will also order the orbitals according to their occupation number
+# Which makes the active space selection easyer !
+qp run save_natorb | tee ${EZFIO_FILE}.natorb_3states.out
+
+##### PREPARING A CIS GUESS WITHIN THE ACTIVE SPACE
+# Set an active space which has the most of important excitations
+# and that maintains symmetry : the ACTIVE ORBITALS are from """6 to 13"""
+
+# YOU FIRST FREEZE THE VIRTUALS THAT ARE NOT IN THE ACTIVE SPACE
+# !!!!! WE SET TO "-D" for DELETED !!!!
+qp set_mo_class -c "[1-5]" -a "[6-13]" -d "[14-46]"
+# You create a guess of CIS type WITHIN THE ACTIVE SPACE
+qp run cis | tee ${EZFIO_FILE}.cis_3_states_active_space.out # -149.6515472533511 -149.4622878024821 -149.4622878024817
+# You tell to read the WFT stored (i.e. the guess we just created)
+qp set determinants read_wf True
+
+##### DOING THE CASSCF
+### SETTING PROPERLY THE ACTIVE SPACE FOR CASSCF
+# You set the active space WITH THE VIRTUAL ORBITALS !!!
+# !!!!! NOW WE SET TO "-v" for VIRTUALS !!!!!
+qp set_mo_class -c "[1-5]" -a "[6-13]" -v "[14-46]"
+
+# You tell that it is a small actice space so the CIPSI can take all Slater determinants
+qp set casscf_cipsi small_active_space True
+# You specify the output file
+output=${EZFIO_FILE}.casscf_3states.out
+# You run the CASSCF calculation
+qp run casscf | tee ${output} # -149.7175867510 -149.5059010227 -149.5059010226
+
+# Some grep in order to get some numbers useful to check convergence
+# State average energy
+grep "State-average CAS-SCF energy =" $output | cut -d "=" -f 2 > data_e_average
+# Delta E anticipated for State-average energy, only usefull to check convergence
+grep "Predicted energy improvement =" $output | cut -d "=" -f 2 > data_improve
+# Ground state energy
+grep "state 1 E + PT2 energy" $output | cut -d "=" -f 2 > data_1
+# First excited state energy
+grep "state 2 E + PT2 energy" $output | cut -d "=" -f 2 > data_2
+# First excitation energy
+grep "state 2 Delta E+PT2" $output | cut -d "=" -f 2 > data_delta_E2
+# Second excited state energy
+grep "state 3 E + PT2 energy" $output | cut -d "=" -f 2 > data_3
+# Second excitation energy
+grep "state 3 Delta E+PT2" $output | cut -d "=" -f 2 > data_delta_E3
diff --git a/src/casscf_cipsi/neworbs.irp.f b/src/casscf_cipsi/neworbs.irp.f
index a7cebbb2..ca2deebb 100644
--- a/src/casscf_cipsi/neworbs.irp.f
+++ b/src/casscf_cipsi/neworbs.irp.f
@@ -226,27 +226,28 @@ BEGIN_PROVIDER [real*8, Umat, (mo_num,mo_num) ]
end do
! Form the exponential
+ call exp_matrix_taylor(Tmat,mo_num,Umat,converged)
- Tpotmat(:,:)=0.D0
- Umat(:,:) =0.D0
- do i=1,mo_num
- Tpotmat(i,i)=1.D0
- Umat(i,i) =1.d0
- end do
- iter=0
- converged=.false.
- do while (.not.converged)
- iter+=1
- f = 1.d0 / dble(iter)
- Tpotmat2(:,:) = Tpotmat(:,:) * f
- call dgemm('N','N', mo_num,mo_num,mo_num,1.d0, &
- Tpotmat2, size(Tpotmat2,1), &
- Tmat, size(Tmat,1), 0.d0, &
- Tpotmat, size(Tpotmat,1))
- Umat(:,:) = Umat(:,:) + Tpotmat(:,:)
-
- converged = ( sum(abs(Tpotmat(:,:))) < 1.d-6).or.(iter>30)
- end do
+! Tpotmat(:,:)=0.D0
+! Umat(:,:) =0.D0
+! do i=1,mo_num
+! Tpotmat(i,i)=1.D0
+! Umat(i,i) =1.d0
+! end do
+! iter=0
+! converged=.false.
+! do while (.not.converged)
+! iter+=1
+! f = 1.d0 / dble(iter)
+! Tpotmat2(:,:) = Tpotmat(:,:) * f
+! call dgemm('N','N', mo_num,mo_num,mo_num,1.d0, &
+! Tpotmat2, size(Tpotmat2,1), &
+! Tmat, size(Tmat,1), 0.d0, &
+! Tpotmat, size(Tpotmat,1))
+! Umat(:,:) = Umat(:,:) + Tpotmat(:,:)
+!
+! converged = ( sum(abs(Tpotmat(:,:))) < 1.d-6).or.(iter>30)
+! end do
END_PROVIDER
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/NEED b/src/cipsi/NEED
index 89c128ec..ddd1e8cc 100644
--- a/src/cipsi/NEED
+++ b/src/cipsi/NEED
@@ -1,3 +1,4 @@
+cipsi_utils
json
perturbation
zmq
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/cipsi.irp.f b/src/cipsi/cipsi.irp.f
index cf770049..446e8d87 100644
--- a/src/cipsi/cipsi.irp.f
+++ b/src/cipsi/cipsi.irp.f
@@ -1,10 +1,13 @@
subroutine run_cipsi
- implicit none
- use selection_types
+
BEGIN_DOC
-! Selected Full Configuration Interaction with deterministic selection and
-! stochastic PT2.
+ ! Selected Full Configuration Interaction with deterministic selection and
+ ! stochastic PT2.
END_DOC
+
+ use selection_types
+
+ implicit none
integer :: i,j,k
type(pt2_type) :: pt2_data, pt2_data_err
double precision, allocatable :: zeros(:)
diff --git a/src/cipsi/energy.irp.f b/src/cipsi/energy.irp.f
index 1f7cf122..4b496c11 100644
--- a/src/cipsi/energy.irp.f
+++ b/src/cipsi/energy.irp.f
@@ -36,12 +36,3 @@ BEGIN_PROVIDER [ double precision, pt2_E0_denominator, (N_states) ]
endif
END_PROVIDER
-
-BEGIN_PROVIDER [ double precision, pt2_overlap, (N_states, N_states) ]
- implicit none
- BEGIN_DOC
- ! Overlap between the perturbed wave functions
- END_DOC
- pt2_overlap(1:N_states,1:N_states) = 0.d0
-END_PROVIDER
-
diff --git a/src/cipsi/lock_2rdm.irp.f b/src/cipsi/lock_2rdm.irp.f
deleted file mode 100644
index e69de29b..00000000
diff --git a/src/cipsi/pt2_stoch_routines.irp.f b/src/cipsi/pt2_stoch_routines.irp.f
index 3b048c14..bd5943da 100644
--- a/src/cipsi/pt2_stoch_routines.irp.f
+++ b/src/cipsi/pt2_stoch_routines.irp.f
@@ -1,923 +1,3 @@
-BEGIN_PROVIDER [ integer, pt2_stoch_istate ]
- implicit none
- BEGIN_DOC
- ! State for stochatsic PT2
- END_DOC
- pt2_stoch_istate = 1
-END_PROVIDER
-
- BEGIN_PROVIDER [ integer, pt2_F, (N_det_generators) ]
-&BEGIN_PROVIDER [ integer, pt2_n_tasks_max ]
- implicit none
- logical, external :: testTeethBuilding
- integer :: i,j
- pt2_n_tasks_max = elec_alpha_num*elec_alpha_num + elec_alpha_num*elec_beta_num - n_core_orb*2
- pt2_n_tasks_max = min(pt2_n_tasks_max,1+N_det_generators/10000)
- call write_int(6,pt2_n_tasks_max,'pt2_n_tasks_max')
-
- pt2_F(:) = max(int(sqrt(float(pt2_n_tasks_max))),1)
- do i=1,pt2_n_0(1+pt2_N_teeth/4)
- pt2_F(i) = pt2_n_tasks_max*pt2_min_parallel_tasks
- enddo
- do i=1+pt2_n_0(pt2_N_teeth-pt2_N_teeth/4), pt2_n_0(pt2_N_teeth-pt2_N_teeth/10)
- pt2_F(i) = pt2_min_parallel_tasks
- enddo
- do i=1+pt2_n_0(pt2_N_teeth-pt2_N_teeth/10), N_det_generators
- pt2_F(i) = 1
- enddo
-
-END_PROVIDER
-
- BEGIN_PROVIDER [ integer, pt2_N_teeth ]
-&BEGIN_PROVIDER [ integer, pt2_minDetInFirstTeeth ]
- implicit none
- logical, external :: testTeethBuilding
-
- if(N_det_generators < 1024) then
- pt2_minDetInFirstTeeth = 1
- pt2_N_teeth = 1
- else
- pt2_minDetInFirstTeeth = min(5, N_det_generators)
- do pt2_N_teeth=100,2,-1
- if(testTeethBuilding(pt2_minDetInFirstTeeth, pt2_N_teeth)) exit
- end do
- end if
- call write_int(6,pt2_N_teeth,'Number of comb teeth')
-END_PROVIDER
-
-
-logical function testTeethBuilding(minF, N)
- implicit none
- integer, intent(in) :: minF, N
- integer :: n0, i
- double precision :: u0, Wt, r
-
- double precision, allocatable :: tilde_w(:), tilde_cW(:)
- integer, external :: dress_find_sample
-
- double precision :: rss
- double precision, external :: memory_of_double, memory_of_int
-
- rss = memory_of_double(2*N_det_generators+1)
- call check_mem(rss,irp_here)
-
- allocate(tilde_w(N_det_generators), tilde_cW(0:N_det_generators))
-
- double precision :: norm2
- norm2 = 0.d0
- do i=N_det_generators,1,-1
- tilde_w(i) = psi_coef_sorted_gen(i,pt2_stoch_istate) * &
- psi_coef_sorted_gen(i,pt2_stoch_istate)
- norm2 = norm2 + tilde_w(i)
- enddo
-
- f = 1.d0/norm2
- tilde_w(:) = tilde_w(:) * f
-
- tilde_cW(0) = -1.d0
- do i=1,N_det_generators
- tilde_cW(i) = tilde_cW(i-1) + tilde_w(i)
- enddo
- tilde_cW(:) = tilde_cW(:) + 1.d0
- deallocate(tilde_w)
-
- n0 = 0
- testTeethBuilding = .false.
- double precision :: f
- integer :: minFN
- minFN = N_det_generators - minF * N
- f = 1.d0/dble(N)
- do
- u0 = tilde_cW(n0)
- r = tilde_cW(n0 + minF)
- Wt = (1d0 - u0) * f
- if (dabs(Wt) <= 1.d-3) then
- exit
- endif
- if(Wt >= r - u0) then
- testTeethBuilding = .true.
- exit
- end if
- n0 += 1
- if(n0 > minFN) then
- exit
- end if
- end do
- deallocate(tilde_cW)
-
-end function
-
-
-
-subroutine ZMQ_pt2(E, pt2_data, pt2_data_err, relative_error, N_in)
- use f77_zmq
- use selection_types
-
- implicit none
-
- integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull
- integer, intent(in) :: N_in
- double precision, intent(in) :: relative_error, E(N_states)
- type(pt2_type), intent(inout) :: pt2_data, pt2_data_err
-!
- integer :: i, N
-
- double precision :: state_average_weight_save(N_states), w(N_states,4)
- integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket
- type(selection_buffer) :: b
-
- PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
- PROVIDE psi_bilinear_matrix_rows psi_det_sorted_order psi_bilinear_matrix_order
- PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
- PROVIDE psi_bilinear_matrix_transp_order psi_selectors_coef_transp psi_det_sorted
- PROVIDE psi_det_hii selection_weight pseudo_sym
- PROVIDE n_act_orb n_inact_orb n_core_orb n_virt_orb n_del_orb seniority_max
- PROVIDE excitation_beta_max excitation_alpha_max excitation_max
-
- if (h0_type == 'CFG') then
- PROVIDE psi_configuration_hii det_to_configuration
- endif
-
- if (N_det <= max(4,N_states) .or. pt2_N_teeth < 2) then
- call ZMQ_selection(N_in, pt2_data)
- else
-
- N = max(N_in,1) * N_states
- state_average_weight_save(:) = state_average_weight(:)
- if (int(N,8)*2_8 > huge(1)) then
- print *, irp_here, ': integer too large'
- stop -1
- endif
- call create_selection_buffer(N, N*2, b)
- ASSERT (associated(b%det))
- ASSERT (associated(b%val))
-
- do pt2_stoch_istate=1,N_states
- state_average_weight(:) = 0.d0
- state_average_weight(pt2_stoch_istate) = 1.d0
- TOUCH state_average_weight pt2_stoch_istate selection_weight
-
- PROVIDE nproc pt2_F mo_two_e_integrals_in_map mo_one_e_integrals pt2_w
- PROVIDE psi_selectors pt2_u pt2_J pt2_R
- call new_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'pt2')
-
- integer, external :: zmq_put_psi
- integer, external :: zmq_put_N_det_generators
- integer, external :: zmq_put_N_det_selectors
- integer, external :: zmq_put_dvector
- integer, external :: zmq_put_ivector
- if (zmq_put_psi(zmq_to_qp_run_socket,1) == -1) then
- stop 'Unable to put psi on ZMQ server'
- endif
- if (zmq_put_N_det_generators(zmq_to_qp_run_socket, 1) == -1) then
- stop 'Unable to put N_det_generators on ZMQ server'
- endif
- if (zmq_put_N_det_selectors(zmq_to_qp_run_socket, 1) == -1) then
- stop 'Unable to put N_det_selectors on ZMQ server'
- endif
- if (zmq_put_dvector(zmq_to_qp_run_socket,1,'energy',pt2_e0_denominator,size(pt2_e0_denominator)) == -1) then
- stop 'Unable to put energy on ZMQ server'
- endif
- if (zmq_put_dvector(zmq_to_qp_run_socket,1,'state_average_weight',state_average_weight,N_states) == -1) then
- stop 'Unable to put state_average_weight on ZMQ server'
- endif
- if (zmq_put_dvector(zmq_to_qp_run_socket,1,'selection_weight',selection_weight,N_states) == -1) then
- stop 'Unable to put selection_weight on ZMQ server'
- endif
- if (zmq_put_ivector(zmq_to_qp_run_socket,1,'pt2_stoch_istate',pt2_stoch_istate,1) == -1) then
- stop 'Unable to put pt2_stoch_istate on ZMQ server'
- endif
- if (zmq_put_dvector(zmq_to_qp_run_socket,1,'threshold_generators',(/threshold_generators/),1) == -1) then
- stop 'Unable to put threshold_generators on ZMQ server'
- endif
-
-
- integer, external :: add_task_to_taskserver
- character(300000) :: task
-
- integer :: j,k,ipos,ifirst
- ifirst=0
-
- ipos=0
- do i=1,N_det_generators
- if (pt2_F(i) > 1) then
- ipos += 1
- endif
- enddo
- call write_int(6,sum(pt2_F),'Number of tasks')
- call write_int(6,ipos,'Number of fragmented tasks')
-
- ipos=1
- do i= 1, N_det_generators
- do j=1,pt2_F(pt2_J(i))
- write(task(ipos:ipos+30),'(I9,1X,I9,1X,I9,''|'')') j, pt2_J(i), N_in
- ipos += 30
- if (ipos > 300000-30) then
- if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
- stop 'Unable to add task to task server'
- endif
- ipos=1
- if (ifirst == 0) then
- ifirst=1
- if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
- print *, irp_here, ': Failed in zmq_set_running'
- endif
- endif
- endif
- end do
- enddo
- if (ipos > 1) then
- if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
- stop 'Unable to add task to task server'
- endif
- endif
-
- integer, external :: zmq_set_running
- if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
- print *, irp_here, ': Failed in zmq_set_running'
- endif
-
-
- double precision :: mem_collector, mem, rss
-
- call resident_memory(rss)
-
- mem_collector = 8.d0 * & ! bytes
- ( 1.d0*pt2_n_tasks_max & ! task_id, index
- + 0.635d0*N_det_generators & ! f,d
- + pt2_n_tasks_max*pt2_type_size(N_states) & ! pt2_data_task
- + N_det_generators*pt2_type_size(N_states) & ! pt2_data_I
- + 4.d0*(pt2_N_teeth+1) & ! S, S2, T2, T3
- + 1.d0*(N_int*2.d0*N + N) & ! selection buffer
- + 1.d0*(N_int*2.d0*N + N) & ! sort selection buffer
- ) / 1024.d0**3
-
- integer :: nproc_target, ii
- nproc_target = nthreads_pt2
- ii = min(N_det, (elec_alpha_num*(mo_num-elec_alpha_num))**2)
-
- do
- mem = mem_collector + & !
- nproc_target * 8.d0 * & ! bytes
- ( 0.5d0*pt2_n_tasks_max & ! task_id
- + 64.d0*pt2_n_tasks_max & ! task
- + pt2_type_size(N_states)*pt2_n_tasks_max*N_states & ! pt2, variance, overlap
- + 1.d0*pt2_n_tasks_max & ! i_generator, subset
- + 1.d0*(N_int*2.d0*ii+ ii) & ! selection buffer
- + 1.d0*(N_int*2.d0*ii+ ii) & ! sort selection buffer
- + 2.0d0*(ii) & ! preinteresting, interesting,
- ! prefullinteresting, fullinteresting
- + 2.0d0*(N_int*2*ii) & ! minilist, fullminilist
- + 1.0d0*(N_states*mo_num*mo_num) & ! mat
- ) / 1024.d0**3
-
- if (nproc_target == 0) then
- call check_mem(mem,irp_here)
- nproc_target = 1
- exit
- endif
-
- if (mem+rss < qp_max_mem) then
- exit
- endif
-
- nproc_target = nproc_target - 1
-
- enddo
- call write_int(6,nproc_target,'Number of threads for PT2')
- call write_double(6,mem,'Memory (Gb)')
-
- call set_multiple_levels_omp(.False.)
-
-
- print '(A)', '========== ==================== ================ ================ ================ ============= ==========='
- print '(A)', ' Samples Energy PT2 Variance Norm^2 Convergence Seconds'
- print '(A)', '========== ==================== ================ ================ ================ ============= ==========='
-
- PROVIDE global_selection_buffer
-
- !$OMP PARALLEL DEFAULT(shared) NUM_THREADS(nproc_target+1) &
- !$OMP PRIVATE(i)
- i = omp_get_thread_num()
- if (i==0) then
-
- call pt2_collector(zmq_socket_pull, E(pt2_stoch_istate),relative_error, pt2_data, pt2_data_err, b, N)
- pt2_data % rpt2(pt2_stoch_istate) = &
- pt2_data % pt2(pt2_stoch_istate)/(1.d0+pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate))
-
- !TODO : We should use here the correct formula for the error of X/Y
- pt2_data_err % rpt2(pt2_stoch_istate) = &
- pt2_data_err % pt2(pt2_stoch_istate)/(1.d0 + pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate))
-
- else
- call pt2_slave_inproc(i)
- endif
- !$OMP END PARALLEL
- call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'pt2')
- call set_multiple_levels_omp(.True.)
-
- print '(A)', '========== ==================== ================ ================ ================ ============= ==========='
-
-
- do k=1,N_states
- pt2_overlap(pt2_stoch_istate,k) = pt2_data % overlap(k,pt2_stoch_istate)
- enddo
- SOFT_TOUCH pt2_overlap
-
- enddo
- FREE pt2_stoch_istate
-
- ! Symmetrize overlap
- do j=2,N_states
- do i=1,j-1
- pt2_overlap(i,j) = 0.5d0 * (pt2_overlap(i,j) + pt2_overlap(j,i))
- pt2_overlap(j,i) = pt2_overlap(i,j)
- enddo
- enddo
-
- print *, 'Overlap of perturbed states:'
- do k=1,N_states
- print *, pt2_overlap(k,:)
- enddo
- print *, '-------'
-
- if (N_in > 0) then
- b%cur = min(N_in,b%cur)
- if (s2_eig) then
- call make_selection_buffer_s2(b)
- else
- call remove_duplicates_in_selection_buffer(b)
- endif
- call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0)
- endif
- call delete_selection_buffer(b)
-
- state_average_weight(:) = state_average_weight_save(:)
- TOUCH state_average_weight
- call update_pt2_and_variance_weights(pt2_data, N_states)
- endif
-
-
-end subroutine
-
-
-subroutine pt2_slave_inproc(i)
- implicit none
- integer, intent(in) :: i
-
- PROVIDE global_selection_buffer
- call run_pt2_slave(1,i,pt2_e0_denominator)
+subroutine provide_for_zmq_pt2
+ PROVIDE psi_selectors_coef_transp psi_det_sorted psi_det_sorted_order psi_det_hii
end
-
-
-subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2_data, pt2_data_err, b, N_)
- use f77_zmq
- use selection_types
- use bitmasks
- implicit none
-
-
- integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
- double precision, intent(in) :: relative_error, E
- type(pt2_type), intent(inout) :: pt2_data, pt2_data_err
- type(selection_buffer), intent(inout) :: b
- integer, intent(in) :: N_
-
- type(pt2_type), allocatable :: pt2_data_task(:)
- type(pt2_type), allocatable :: pt2_data_I(:)
- type(pt2_type), allocatable :: pt2_data_S(:)
- type(pt2_type), allocatable :: pt2_data_S2(:)
- type(pt2_type) :: pt2_data_teeth
- integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
- integer(ZMQ_PTR) :: zmq_to_qp_run_socket
- integer, external :: zmq_delete_tasks_async_send
- integer, external :: zmq_delete_tasks_async_recv
- integer, external :: zmq_abort
- integer, external :: pt2_find_sample_lr
-
- PROVIDE pt2_stoch_istate
-
- integer :: more, n, i, p, c, t, n_tasks, U
- integer, allocatable :: task_id(:)
- integer, allocatable :: index(:)
-
- double precision :: v, x, x2, x3, avg, avg2, avg3(N_states), eqt, E0, v0, n0(N_states)
- double precision :: eqta(N_states)
- double precision :: time, time1, time0
-
- integer, allocatable :: f(:)
- logical, allocatable :: d(:)
- logical :: do_exit, stop_now, sending
- logical, external :: qp_stop
- type(selection_buffer) :: b2
-
-
- double precision :: rss
- double precision, external :: memory_of_double, memory_of_int
-
- character(len=20) :: format_str1, str_error1, format_str2, str_error2
- character(len=20) :: format_str3, str_error3, format_str4, str_error4
- character(len=20) :: format_value1, format_value2, format_value3, format_value4
- character(len=20) :: str_value1, str_value2, str_value3, str_value4
- character(len=20) :: str_conv
- double precision :: value1, value2, value3, value4
- double precision :: error1, error2, error3, error4
- integer :: size1,size2,size3,size4
-
- double precision :: conv_crit
-
- sending =.False.
-
- rss = memory_of_int(pt2_n_tasks_max*2+N_det_generators*2)
- rss += memory_of_double(N_states*N_det_generators)*3.d0
- rss += memory_of_double(N_states*pt2_n_tasks_max)*3.d0
- rss += memory_of_double(pt2_N_teeth+1)*4.d0
- call check_mem(rss,irp_here)
-
- ! If an allocation is added here, the estimate of the memory should also be
- ! updated in ZMQ_pt2
- allocate(task_id(pt2_n_tasks_max), index(pt2_n_tasks_max), f(N_det_generators))
- allocate(d(N_det_generators+1))
- allocate(pt2_data_task(pt2_n_tasks_max))
- allocate(pt2_data_I(N_det_generators))
- allocate(pt2_data_S(pt2_N_teeth+1))
- allocate(pt2_data_S2(pt2_N_teeth+1))
-
-
-
- zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
- call create_selection_buffer(N_, N_*2, b2)
-
-
- pt2_data % pt2(pt2_stoch_istate) = -huge(1.)
- pt2_data_err % pt2(pt2_stoch_istate) = huge(1.)
- pt2_data % variance(pt2_stoch_istate) = huge(1.)
- pt2_data_err % variance(pt2_stoch_istate) = huge(1.)
- pt2_data % overlap(:,pt2_stoch_istate) = 0.d0
- pt2_data_err % overlap(:,pt2_stoch_istate) = huge(1.)
- n = 1
- t = 0
- U = 0
- do i=1,pt2_n_tasks_max
- call pt2_alloc(pt2_data_task(i),N_states)
- enddo
- do i=1,pt2_N_teeth+1
- call pt2_alloc(pt2_data_S(i),N_states)
- call pt2_alloc(pt2_data_S2(i),N_states)
- enddo
- do i=1,N_det_generators
- call pt2_alloc(pt2_data_I(i),N_states)
- enddo
- f(:) = pt2_F(:)
- d(:) = .false.
- n_tasks = 0
- E0 = E
- v0 = 0.d0
- n0(:) = 0.d0
- more = 1
- call wall_time(time0)
- time1 = time0
-
- do_exit = .false.
- stop_now = .false.
- do while (n <= N_det_generators)
- if(f(pt2_J(n)) == 0) then
- d(pt2_J(n)) = .true.
- do while(d(U+1))
- U += 1
- end do
-
- ! Deterministic part
- do while(t <= pt2_N_teeth)
- if(U >= pt2_n_0(t+1)) then
- t=t+1
- E0 = 0.d0
- v0 = 0.d0
- n0(:) = 0.d0
- do i=pt2_n_0(t),1,-1
- E0 += pt2_data_I(i) % pt2(pt2_stoch_istate)
- v0 += pt2_data_I(i) % variance(pt2_stoch_istate)
- n0(:) += pt2_data_I(i) % overlap(:,pt2_stoch_istate)
- end do
- else
- exit
- end if
- end do
-
- ! Add Stochastic part
- c = pt2_R(n)
- if(c > 0) then
-
- call pt2_alloc(pt2_data_teeth,N_states)
- do p=pt2_N_teeth, 1, -1
- v = pt2_u_0 + pt2_W_T * (pt2_u(c) + dble(p-1))
- i = pt2_find_sample_lr(v, pt2_cW,pt2_n_0(p),pt2_n_0(p+1))
- v = pt2_W_T / pt2_w(i)
- call pt2_add ( pt2_data_teeth, v, pt2_data_I(i) )
- call pt2_add ( pt2_data_S(p), 1.d0, pt2_data_teeth )
- call pt2_add2( pt2_data_S2(p), 1.d0, pt2_data_teeth )
- enddo
- call pt2_dealloc(pt2_data_teeth)
-
- avg = E0 + pt2_data_S(t) % pt2(pt2_stoch_istate) / dble(c)
- avg2 = v0 + pt2_data_S(t) % variance(pt2_stoch_istate) / dble(c)
- avg3(:) = n0(:) + pt2_data_S(t) % overlap(:,pt2_stoch_istate) / dble(c)
- if ((avg /= 0.d0) .or. (n == N_det_generators) ) then
- do_exit = .true.
- endif
- if (qp_stop()) then
- stop_now = .True.
- endif
- pt2_data % pt2(pt2_stoch_istate) = avg
- pt2_data % variance(pt2_stoch_istate) = avg2
- pt2_data % overlap(:,pt2_stoch_istate) = avg3(:)
- call wall_time(time)
- ! 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 = 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 = 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(:) = 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
-
- 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
-
- ! Old print
- !print '(I10, X, F12.6, X, G10.3, X, F10.6, X, G10.3, X, F10.6, X, G10.3, X, F10.1,ES16.6,ES16.6)', 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), &
- ! time-time0, &
- ! pt2_data % pt2(pt2_stoch_istate), &
- ! dabs(pt2_data_err % pt2(pt2_stoch_istate)) / &
- ! (1.d-20 + dabs(pt2_data % pt2(pt2_stoch_istate)) )
-
- if (stop_now .or. ( &
- (do_exit .and. (dabs(pt2_data_err % pt2(pt2_stoch_istate)) / &
- (1.d-20 + dabs(pt2_data % pt2(pt2_stoch_istate)) ) <= relative_error))) ) then
- if (zmq_abort(zmq_to_qp_run_socket) == -1) then
- call sleep(10)
- if (zmq_abort(zmq_to_qp_run_socket) == -1) then
- print *, irp_here, ': Error in sending abort signal (2)'
- endif
- endif
- endif
- endif
- endif
- end if
- n += 1
- else if(more == 0) then
- exit
- else
- call pull_pt2_results(zmq_socket_pull, index, pt2_data_task, task_id, n_tasks, b2)
- if(n_tasks > pt2_n_tasks_max)then
- print*,'PB !!!'
- print*,'If you see this, send a bug report with the following content'
- print*,irp_here
- print*,'n_tasks,pt2_n_tasks_max = ',n_tasks,pt2_n_tasks_max
- stop -1
- endif
- if (zmq_delete_tasks_async_send(zmq_to_qp_run_socket,task_id,n_tasks,sending) == -1) then
- stop 'PT2: Unable to delete tasks (send)'
- endif
- do i=1,n_tasks
- if(index(i).gt.size(pt2_data_I,1).or.index(i).lt.1)then
- print*,'PB !!!'
- print*,'If you see this, send a bug report with the following content'
- print*,irp_here
- print*,'i,index(i),size(pt2_data_I,1) = ',i,index(i),size(pt2_data_I,1)
- stop -1
- endif
- call pt2_add(pt2_data_I(index(i)),1.d0,pt2_data_task(i))
- f(index(i)) -= 1
- end do
- do i=1, b2%cur
- ! We assume the pulled buffer is sorted
- if (b2%val(i) > b%mini) exit
- call add_to_selection_buffer(b, b2%det(1,1,i), b2%val(i))
- end do
- if (zmq_delete_tasks_async_recv(zmq_to_qp_run_socket,more,sending) == -1) then
- stop 'PT2: Unable to delete tasks (recv)'
- endif
- end if
- end do
- do i=1,N_det_generators
- call pt2_dealloc(pt2_data_I(i))
- enddo
- do i=1,pt2_N_teeth+1
- call pt2_dealloc(pt2_data_S(i))
- call pt2_dealloc(pt2_data_S2(i))
- enddo
- do i=1,pt2_n_tasks_max
- call pt2_dealloc(pt2_data_task(i))
- enddo
-!print *, 'deleting b2'
- call delete_selection_buffer(b2)
-!print *, 'sorting b'
- call sort_selection_buffer(b)
-!print *, 'done'
- call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
-
-end subroutine
-
-
-integer function pt2_find_sample(v, w)
- implicit none
- double precision, intent(in) :: v, w(0:N_det_generators)
- integer, external :: pt2_find_sample_lr
-
- pt2_find_sample = pt2_find_sample_lr(v, w, 0, N_det_generators)
-end function
-
-
-integer function pt2_find_sample_lr(v, w, l_in, r_in)
- implicit none
- double precision, intent(in) :: v, w(0:N_det_generators)
- integer, intent(in) :: l_in,r_in
- integer :: i,l,r
-
- l=l_in
- r=r_in
-
- do while(r-l > 1)
- i = shiftr(r+l,1)
- if(w(i) < v) then
- l = i
- else
- r = i
- end if
- end do
- i = r
- do r=i+1,N_det_generators
- if (w(r) /= w(i)) then
- exit
- endif
- enddo
- pt2_find_sample_lr = r-1
-end function
-
-
-BEGIN_PROVIDER [ integer, pt2_n_tasks ]
- implicit none
- BEGIN_DOC
- ! Number of parallel tasks for the Monte Carlo
- END_DOC
- pt2_n_tasks = N_det_generators
-END_PROVIDER
-
-BEGIN_PROVIDER[ double precision, pt2_u, (N_det_generators)]
- implicit none
- integer, allocatable :: seed(:)
- integer :: m,i
- call random_seed(size=m)
- allocate(seed(m))
- do i=1,m
- seed(i) = i
- enddo
- call random_seed(put=seed)
- deallocate(seed)
-
- call RANDOM_NUMBER(pt2_u)
- END_PROVIDER
-
- BEGIN_PROVIDER[ integer, pt2_J, (N_det_generators)]
-&BEGIN_PROVIDER[ integer, pt2_R, (N_det_generators)]
- implicit none
- BEGIN_DOC
-! pt2_J contains the list of generators after ordering them according to the
-! Monte Carlo sampling.
-!
-! pt2_R(i) is the number of combs drawn when determinant i is computed.
- END_DOC
- integer :: N_c, N_j
- integer :: U, t, i
- double precision :: v
- integer, external :: pt2_find_sample_lr
-
- logical, allocatable :: pt2_d(:)
- integer :: m,l,r,k
- integer :: ncache
- integer, allocatable :: ii(:,:)
- double precision :: dt
-
- ncache = min(N_det_generators,10000)
-
- double precision :: rss
- double precision, external :: memory_of_double, memory_of_int
- rss = memory_of_int(ncache)*dble(pt2_N_teeth) + memory_of_int(N_det_generators)
- call check_mem(rss,irp_here)
-
- allocate(ii(pt2_N_teeth,ncache),pt2_d(N_det_generators))
-
- pt2_R(:) = 0
- pt2_d(:) = .false.
- N_c = 0
- N_j = pt2_n_0(1)
- do i=1,N_j
- pt2_d(i) = .true.
- pt2_J(i) = i
- end do
-
- U = 0
- do while(N_j < pt2_n_tasks)
-
- if (N_c+ncache > N_det_generators) then
- ncache = N_det_generators - N_c
- endif
-
- !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(dt,v,t,k)
- do k=1, ncache
- dt = pt2_u_0
- do t=1, pt2_N_teeth
- v = dt + pt2_W_T *pt2_u(N_c+k)
- dt = dt + pt2_W_T
- ii(t,k) = pt2_find_sample_lr(v, pt2_cW,pt2_n_0(t),pt2_n_0(t+1))
- end do
- enddo
- !$OMP END PARALLEL DO
-
- do k=1,ncache
- !ADD_COMB
- N_c = N_c+1
- do t=1, pt2_N_teeth
- i = ii(t,k)
- if(.not. pt2_d(i)) then
- N_j += 1
- pt2_J(N_j) = i
- pt2_d(i) = .true.
- end if
- end do
-
- pt2_R(N_j) = N_c
-
- !FILL_TOOTH
- do while(U < N_det_generators)
- U += 1
- if(.not. pt2_d(U)) then
- N_j += 1
- pt2_J(N_j) = U
- pt2_d(U) = .true.
- exit
- end if
- end do
- if (N_j >= pt2_n_tasks) exit
- end do
- enddo
-
- if(N_det_generators > 1) then
- pt2_R(N_det_generators-1) = 0
- pt2_R(N_det_generators) = N_c
- end if
-
- deallocate(ii,pt2_d)
-
-END_PROVIDER
-
-
-
- BEGIN_PROVIDER [ double precision, pt2_w, (N_det_generators) ]
-&BEGIN_PROVIDER [ double precision, pt2_cW, (0:N_det_generators) ]
-&BEGIN_PROVIDER [ double precision, pt2_W_T ]
-&BEGIN_PROVIDER [ double precision, pt2_u_0 ]
-&BEGIN_PROVIDER [ integer, pt2_n_0, (pt2_N_teeth+1) ]
- implicit none
- integer :: i, t
- double precision, allocatable :: tilde_w(:), tilde_cW(:)
- double precision :: r, tooth_width
- integer, external :: pt2_find_sample
-
- double precision :: rss
- double precision, external :: memory_of_double, memory_of_int
- rss = memory_of_double(2*N_det_generators+1)
- call check_mem(rss,irp_here)
-
- if (N_det_generators == 1) then
-
- pt2_w(1) = 1.d0
- pt2_cw(1) = 1.d0
- pt2_u_0 = 1.d0
- pt2_W_T = 0.d0
- pt2_n_0(1) = 0
- pt2_n_0(2) = 1
-
- else
-
- allocate(tilde_w(N_det_generators), tilde_cW(0:N_det_generators))
-
- tilde_cW(0) = 0d0
-
- do i=1,N_det_generators
- tilde_w(i) = psi_coef_sorted_gen(i,pt2_stoch_istate)**2 !+ 1.d-20
- enddo
-
- double precision :: norm2
- norm2 = 0.d0
- do i=N_det_generators,1,-1
- norm2 += tilde_w(i)
- enddo
-
- tilde_w(:) = tilde_w(:) / norm2
-
- tilde_cW(0) = -1.d0
- do i=1,N_det_generators
- tilde_cW(i) = tilde_cW(i-1) + tilde_w(i)
- enddo
- tilde_cW(:) = tilde_cW(:) + 1.d0
-
- pt2_n_0(1) = 0
- do
- pt2_u_0 = tilde_cW(pt2_n_0(1))
- r = tilde_cW(pt2_n_0(1) + pt2_minDetInFirstTeeth)
- pt2_W_T = (1d0 - pt2_u_0) / dble(pt2_N_teeth)
- if(pt2_W_T >= r - pt2_u_0) then
- exit
- end if
- pt2_n_0(1) += 1
- if(N_det_generators - pt2_n_0(1) < pt2_minDetInFirstTeeth * pt2_N_teeth) then
- print *, "teeth building failed"
- stop -1
- end if
- end do
-
- do t=2, pt2_N_teeth
- r = pt2_u_0 + pt2_W_T * dble(t-1)
- pt2_n_0(t) = pt2_find_sample(r, tilde_cW)
- end do
- pt2_n_0(pt2_N_teeth+1) = N_det_generators
-
- pt2_w(:pt2_n_0(1)) = tilde_w(:pt2_n_0(1))
- do t=1, pt2_N_teeth
- tooth_width = tilde_cW(pt2_n_0(t+1)) - tilde_cW(pt2_n_0(t))
- if (tooth_width == 0.d0) then
- tooth_width = max(1.d-15,sum(tilde_w(pt2_n_0(t):pt2_n_0(t+1))))
- endif
- ASSERT(tooth_width > 0.d0)
- do i=pt2_n_0(t)+1, pt2_n_0(t+1)
- pt2_w(i) = tilde_w(i) * pt2_W_T / tooth_width
- end do
- end do
-
- pt2_cW(0) = 0d0
- do i=1,N_det_generators
- pt2_cW(i) = pt2_cW(i-1) + pt2_w(i)
- end do
- pt2_n_0(pt2_N_teeth+1) = N_det_generators
-
- endif
-END_PROVIDER
-
-
-
-
-
diff --git a/src/cipsi/pt2_type.irp.f b/src/cipsi/pt2_type.irp.f
deleted file mode 100644
index ee90d421..00000000
--- a/src/cipsi/pt2_type.irp.f
+++ /dev/null
@@ -1,128 +0,0 @@
-subroutine pt2_alloc(pt2_data,N)
- implicit none
- use selection_types
- type(pt2_type), intent(inout) :: pt2_data
- integer, intent(in) :: N
- integer :: k
-
- allocate(pt2_data % pt2(N) &
- ,pt2_data % variance(N) &
- ,pt2_data % rpt2(N) &
- ,pt2_data % overlap(N,N) &
- )
-
- pt2_data % pt2(:) = 0.d0
- pt2_data % variance(:) = 0.d0
- pt2_data % rpt2(:) = 0.d0
- pt2_data % overlap(:,:) = 0.d0
-
-end subroutine
-
-subroutine pt2_dealloc(pt2_data)
- implicit none
- use selection_types
- type(pt2_type), intent(inout) :: pt2_data
- deallocate(pt2_data % pt2 &
- ,pt2_data % variance &
- ,pt2_data % rpt2 &
- ,pt2_data % overlap &
- )
-end subroutine
-
-subroutine pt2_add(p1, w, p2)
- implicit none
- use selection_types
- BEGIN_DOC
-! p1 += w * p2
- END_DOC
- type(pt2_type), intent(inout) :: p1
- double precision, intent(in) :: w
- type(pt2_type), intent(in) :: p2
-
- if (w == 1.d0) then
-
- p1 % pt2(:) = p1 % pt2(:) + p2 % pt2(:)
- p1 % rpt2(:) = p1 % rpt2(:) + p2 % rpt2(:)
- p1 % variance(:) = p1 % variance(:) + p2 % variance(:)
- p1 % overlap(:,:) = p1 % overlap(:,:) + p2 % overlap(:,:)
-
- else
-
- p1 % pt2(:) = p1 % pt2(:) + w * p2 % pt2(:)
- p1 % rpt2(:) = p1 % rpt2(:) + w * p2 % rpt2(:)
- p1 % variance(:) = p1 % variance(:) + w * p2 % variance(:)
- p1 % overlap(:,:) = p1 % overlap(:,:) + w * p2 % overlap(:,:)
-
- endif
-
-end subroutine
-
-
-subroutine pt2_add2(p1, w, p2)
- implicit none
- use selection_types
- BEGIN_DOC
-! p1 += w * p2**2
- END_DOC
- type(pt2_type), intent(inout) :: p1
- double precision, intent(in) :: w
- type(pt2_type), intent(in) :: p2
-
- if (w == 1.d0) then
-
- p1 % pt2(:) = p1 % pt2(:) + p2 % pt2(:) * p2 % pt2(:)
- p1 % rpt2(:) = p1 % rpt2(:) + p2 % rpt2(:) * p2 % rpt2(:)
- p1 % variance(:) = p1 % variance(:) + p2 % variance(:) * p2 % variance(:)
- p1 % overlap(:,:) = p1 % overlap(:,:) + p2 % overlap(:,:) * p2 % overlap(:,:)
-
- else
-
- p1 % pt2(:) = p1 % pt2(:) + w * p2 % pt2(:) * p2 % pt2(:)
- p1 % rpt2(:) = p1 % rpt2(:) + w * p2 % rpt2(:) * p2 % rpt2(:)
- p1 % variance(:) = p1 % variance(:) + w * p2 % variance(:) * p2 % variance(:)
- p1 % overlap(:,:) = p1 % overlap(:,:) + w * p2 % overlap(:,:) * p2 % overlap(:,:)
-
- endif
-
-end subroutine
-
-
-subroutine pt2_serialize(pt2_data, n, x)
- implicit none
- use selection_types
- type(pt2_type), intent(in) :: pt2_data
- integer, intent(in) :: n
- double precision, intent(out) :: x(*)
-
- integer :: i,k,n2
-
- n2 = n*n
- x(1:n) = pt2_data % pt2(1:n)
- k=n
- x(k+1:k+n) = pt2_data % rpt2(1:n)
- k=k+n
- x(k+1:k+n) = pt2_data % variance(1:n)
- k=k+n
- x(k+1:k+n2) = reshape(pt2_data % overlap(1:n,1:n), (/ n2 /))
-
-end
-
-subroutine pt2_deserialize(pt2_data, n, x)
- implicit none
- use selection_types
- type(pt2_type), intent(inout) :: pt2_data
- integer, intent(in) :: n
- double precision, intent(in) :: x(*)
-
- integer :: i,k,n2
-
- n2 = n*n
- pt2_data % pt2(1:n) = x(1:n)
- k=n
- pt2_data % rpt2(1:n) = x(k+1:k+n)
- k=k+n
- pt2_data % variance(1:n) = x(k+1:k+n)
- k=k+n
- pt2_data % overlap(1:n,1:n) = reshape(x(k+1:k+n2), (/ n, n /))
-
-end
diff --git a/src/cipsi/run_selection_slave.irp.f b/src/cipsi/run_selection_slave.irp.f
index 91bd3a38..38a8f362 100644
--- a/src/cipsi/run_selection_slave.irp.f
+++ b/src/cipsi/run_selection_slave.irp.f
@@ -1,256 +1,5 @@
-subroutine run_selection_slave(thread,iproc,energy)
- use f77_zmq
- use selection_types
- implicit none
-
- double precision, intent(in) :: energy(N_states)
- integer, intent(in) :: thread, iproc
- integer :: rc, i
-
- integer :: worker_id, task_id(1), ctask, ltask
- character*(512) :: task
-
- integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
- integer(ZMQ_PTR) :: zmq_to_qp_run_socket
-
- integer(ZMQ_PTR), external :: new_zmq_push_socket
- integer(ZMQ_PTR) :: zmq_socket_push
-
- type(selection_buffer) :: buf, buf2
- logical :: done, buffer_ready
- type(pt2_type) :: pt2_data
-
- PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
- PROVIDE psi_bilinear_matrix_rows psi_det_sorted_order psi_bilinear_matrix_order
- PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
- PROVIDE psi_bilinear_matrix_transp_order N_int pt2_F pseudo_sym
- PROVIDE psi_selectors_coef_transp psi_det_sorted weight_selection
-
- call pt2_alloc(pt2_data,N_states)
-
- zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
-
- integer, external :: connect_to_taskserver
- if (connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) == -1) then
- call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
- return
- endif
-
- zmq_socket_push = new_zmq_push_socket(thread)
-
- buf%N = 0
- buffer_ready = .False.
- ctask = 1
-
- do
- integer, external :: get_task_from_taskserver
- if (get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id(ctask), task) == -1) then
- exit
- endif
- done = task_id(ctask) == 0
- if (done) then
- ctask = ctask - 1
- else
- integer :: i_generator, N, subset, bsize
- call sscanf_ddd(task, subset, i_generator, N)
- if(buf%N == 0) then
- ! Only first time
- call create_selection_buffer(N, N*2, buf)
- buffer_ready = .True.
- else
- if (N /= buf%N) then
- print *, 'N=', N
- print *, 'buf%N=', buf%N
- print *, 'bug in ', irp_here
- stop '-1'
- end if
- end if
- call select_connected(i_generator,energy,pt2_data,buf,subset,pt2_F(i_generator))
- endif
-
- integer, external :: task_done_to_taskserver
-
- if(done .or. ctask == size(task_id)) then
- do i=1, ctask
- if (task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i)) == -1) then
- call usleep(100)
- if (task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i)) == -1) then
- ctask = 0
- done = .true.
- exit
- endif
- endif
- end do
- if(ctask > 0) then
- call sort_selection_buffer(buf)
-! call merge_selection_buffers(buf,buf2)
- call push_selection_results(zmq_socket_push, pt2_data, buf, task_id(1), ctask)
- call pt2_dealloc(pt2_data)
- call pt2_alloc(pt2_data,N_states)
-! buf%mini = buf2%mini
- buf%cur = 0
- end if
- ctask = 0
- end if
-
- if(done) exit
- ctask = ctask + 1
- end do
-
- if(ctask > 0) then
- call sort_selection_buffer(buf)
-! call merge_selection_buffers(buf,buf2)
- call push_selection_results(zmq_socket_push, pt2_data, buf, task_id(1), ctask)
-! buf%mini = buf2%mini
- buf%cur = 0
- end if
- ctask = 0
- call pt2_dealloc(pt2_data)
-
- integer, external :: disconnect_from_taskserver
- if (disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id) == -1) then
- continue
- endif
-
- call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
- call end_zmq_push_socket(zmq_socket_push,thread)
- if (buffer_ready) then
- call delete_selection_buffer(buf)
-! call delete_selection_buffer(buf2)
- endif
-end subroutine
-
-
-subroutine push_selection_results(zmq_socket_push, pt2_data, b, task_id, ntasks)
- use f77_zmq
- use selection_types
- implicit none
-
- integer(ZMQ_PTR), intent(in) :: zmq_socket_push
- type(pt2_type), intent(in) :: pt2_data
- type(selection_buffer), intent(inout) :: b
- integer, intent(in) :: ntasks, task_id(*)
- integer :: rc
- double precision, allocatable :: pt2_serialized(:)
-
- rc = f77_zmq_send( zmq_socket_push, b%cur, 4, ZMQ_SNDMORE)
- if(rc /= 4) then
- print *, 'f77_zmq_send( zmq_socket_push, b%cur, 4, ZMQ_SNDMORE)'
- endif
-
-
- allocate(pt2_serialized (pt2_type_size(N_states)) )
- call pt2_serialize(pt2_data,N_states,pt2_serialized)
-
- rc = f77_zmq_send( zmq_socket_push, pt2_serialized, size(pt2_serialized)*8, ZMQ_SNDMORE)
- if (rc == -1) then
- print *, irp_here, ': error sending result'
- stop 3
- return
- else if(rc /= size(pt2_serialized)*8) then
- stop 'push'
- endif
- deallocate(pt2_serialized)
-
- if (b%cur > 0) then
-
- rc = f77_zmq_send( zmq_socket_push, b%val(1), 8*b%cur, ZMQ_SNDMORE)
- if(rc /= 8*b%cur) then
- print *, 'f77_zmq_send( zmq_socket_push, b%val(1), 8*b%cur, ZMQ_SNDMORE)'
- endif
-
- rc = f77_zmq_send( zmq_socket_push, b%det(1,1,1), bit_kind*N_int*2*b%cur, ZMQ_SNDMORE)
- if(rc /= bit_kind*N_int*2*b%cur) then
- print *, 'f77_zmq_send( zmq_socket_push, b%det(1,1,1), bit_kind*N_int*2*b%cur, ZMQ_SNDMORE)'
- endif
-
- endif
-
- rc = f77_zmq_send( zmq_socket_push, ntasks, 4, ZMQ_SNDMORE)
- if(rc /= 4) then
- print *, 'f77_zmq_send( zmq_socket_push, ntasks, 4, ZMQ_SNDMORE)'
- endif
-
- rc = f77_zmq_send( zmq_socket_push, task_id(1), ntasks*4, 0)
- if(rc /= 4*ntasks) then
- print *, 'f77_zmq_send( zmq_socket_push, task_id(1), ntasks*4, 0)'
- endif
-
-! Activate is zmq_socket_push is a REQ
-IRP_IF ZMQ_PUSH
-IRP_ELSE
- character*(2) :: ok
- rc = f77_zmq_recv( zmq_socket_push, ok, 2, 0)
- if ((rc /= 2).and.(ok(1:2) /= 'ok')) then
- print *, irp_here//': error in receiving ok'
- stop -1
- endif
-IRP_ENDIF
-
-end subroutine
-
-
-subroutine pull_selection_results(zmq_socket_pull, pt2_data, val, det, N, task_id, ntasks)
- use f77_zmq
- use selection_types
- implicit none
- integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
- type(pt2_type), intent(inout) :: pt2_data
- double precision, intent(out) :: val(*)
- integer(bit_kind), intent(out) :: det(N_int, 2, *)
- integer, intent(out) :: N, ntasks, task_id(*)
- integer :: rc, rn, i
- double precision, allocatable :: pt2_serialized(:)
-
- rc = f77_zmq_recv( zmq_socket_pull, N, 4, 0)
- if(rc /= 4) then
- print *, 'f77_zmq_recv( zmq_socket_pull, N, 4, 0)'
- endif
-
- allocate(pt2_serialized (pt2_type_size(N_states)) )
- rc = f77_zmq_recv( zmq_socket_pull, pt2_serialized, 8*size(pt2_serialized), 0)
- if (rc == -1) then
- ntasks = 1
- task_id(1) = 0
- else if(rc /= 8*size(pt2_serialized)) then
- stop 'pull'
- endif
-
- call pt2_deserialize(pt2_data,N_states,pt2_serialized)
- deallocate(pt2_serialized)
-
- if (N>0) then
- rc = f77_zmq_recv( zmq_socket_pull, val(1), 8*N, 0)
- if(rc /= 8*N) then
- print *, 'f77_zmq_recv( zmq_socket_pull, val(1), 8*N, 0)'
- endif
-
- rc = f77_zmq_recv( zmq_socket_pull, det(1,1,1), bit_kind*N_int*2*N, 0)
- if(rc /= bit_kind*N_int*2*N) then
- print *, 'f77_zmq_recv( zmq_socket_pull, det(1,1,1), bit_kind*N_int*2*N, 0)'
- endif
- endif
-
- rc = f77_zmq_recv( zmq_socket_pull, ntasks, 4, 0)
- if(rc /= 4) then
- print *, 'f77_zmq_recv( zmq_socket_pull, ntasks, 4, 0)'
- endif
-
- rc = f77_zmq_recv( zmq_socket_pull, task_id(1), ntasks*4, 0)
- if(rc /= 4*ntasks) then
- print *, 'f77_zmq_recv( zmq_socket_pull, task_id(1), ntasks*4, 0)'
- endif
-
-! Activate is zmq_socket_pull is a REP
-IRP_IF ZMQ_PUSH
-IRP_ELSE
- rc = f77_zmq_send( zmq_socket_pull, 'ok', 2, 0)
- if (rc /= 2) then
- print *, irp_here//': error in sending ok'
- stop -1
- endif
-IRP_ENDIF
-end subroutine
-
-
+subroutine provide_for_selection_slave
+ PROVIDE psi_det_sorted_order
+ PROVIDE psi_selectors_coef_transp psi_det_sorted
+end
diff --git a/src/cipsi/selection.irp.f b/src/cipsi/selection.irp.f
index b8fa2895..0281a1d4 100644
--- a/src/cipsi/selection.irp.f
+++ b/src/cipsi/selection.irp.f
@@ -141,12 +141,12 @@ double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2, Nint)
end
-subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2_data,buf,subset,csubset)
+subroutine select_singles_and_doubles(i_generator, hole_mask, particle_mask, fock_diag_tmp, E0, pt2_data, buf, subset, csubset)
use bitmasks
use selection_types
implicit none
BEGIN_DOC
-! WARNING /!\ : It is assumed that the generators and selectors are psi_det_sorted
+ ! WARNING /!\ : It is assumed that the generators and selectors are psi_det_sorted
END_DOC
integer, intent(in) :: i_generator, subset, csubset
@@ -156,28 +156,35 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
type(pt2_type), intent(inout) :: pt2_data
type(selection_buffer), intent(inout) :: buf
- integer :: h1,h2,s1,s2,s3,i1,i2,ib,sp,k,i,j,nt,ii,sze
- integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2), pmask(N_int, 2)
- logical :: fullMatch, ok
+ integer :: h1, h2, s1, s2, s3, i1, i2, ib, sp, k, i, j, nt, ii, sze
+ integer :: maskInd
+ integer :: N_holes(2), N_particles(2)
+ integer :: hole_list(N_int*bit_kind_size,2)
+ integer :: particle_list(N_int*bit_kind_size,2)
+ integer :: l_a, nmax, idx
+ integer :: nb_count, maskInd_save
+ integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2), pmask(N_int, 2)
+ integer(bit_kind) :: mobMask(N_int, 2), negMask(N_int, 2)
+ logical :: fullMatch, ok
+ logical :: monoAdo, monoBdo
+ logical :: monoBdo_save
+ logical :: found
- integer(bit_kind) :: mobMask(N_int, 2), negMask(N_int, 2)
- integer,allocatable :: preinteresting(:), prefullinteresting(:)
- integer,allocatable :: interesting(:), fullinteresting(:)
- integer,allocatable :: tmp_array(:)
- integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :)
- logical, allocatable :: banned(:,:,:), bannedOrb(:,:)
- double precision, allocatable :: coef_fullminilist_rev(:,:)
+ integer, allocatable :: preinteresting(:), prefullinteresting(:)
+ integer, allocatable :: interesting(:), fullinteresting(:)
+ integer, allocatable :: tmp_array(:)
+ integer, allocatable :: indices(:), exc_degree(:), iorder(:)
+ integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :)
+ logical, allocatable :: banned(:,:,:), bannedOrb(:,:)
+ double precision, allocatable :: coef_fullminilist_rev(:,:)
+ double precision, allocatable :: mat(:,:,:)
- double precision, allocatable :: mat(:,:,:)
-
- logical :: monoAdo, monoBdo
- integer :: maskInd
PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
- PROVIDE psi_bilinear_matrix_rows psi_det_sorted_order psi_bilinear_matrix_order
+ PROVIDE psi_bilinear_matrix_rows psi_bilinear_matrix_order psi_bilinear_matrix_transp_order
PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
- PROVIDE psi_bilinear_matrix_transp_order psi_selectors_coef_transp
+ PROVIDE psi_selectors_coef_transp psi_det_sorted_order
PROVIDE banned_excitation
monoAdo = .true.
@@ -192,17 +199,9 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
particle(k,2) = iand(not(psi_det_generators(k,2,i_generator)), particle_mask(k,2))
enddo
-
- integer :: N_holes(2), N_particles(2)
- integer :: hole_list(N_int*bit_kind_size,2)
- integer :: particle_list(N_int*bit_kind_size,2)
-
call bitstring_to_list_ab(hole , hole_list , N_holes , N_int)
call bitstring_to_list_ab(particle, particle_list, N_particles, N_int)
- integer :: l_a, nmax, idx
- integer, allocatable :: indices(:), exc_degree(:), iorder(:)
-
! Removed to avoid introducing determinants already presents in the wf
!double precision, parameter :: norm_thr = 1.d-16
@@ -320,22 +319,19 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
allocate(banned(mo_num, mo_num,2), bannedOrb(mo_num, 2))
- allocate (mat(N_states, mo_num, mo_num))
+ allocate(mat(N_states, mo_num, mo_num))
maskInd = -1
- integer :: nb_count, maskInd_save
- logical :: monoBdo_save
- logical :: found
- do s1=1,2
- do i1=N_holes(s1),1,-1 ! Generate low excitations first
+ do s1 = 1, 2
+ do i1 = N_holes(s1), 1, -1 ! Generate low excitations first
found = .False.
monoBdo_save = monoBdo
maskInd_save = maskInd
- do s2=s1,2
+ do s2 = s1, 2
ib = 1
if(s1 == s2) ib = i1+1
- do i2=N_holes(s2),ib,-1
+ do i2 = N_holes(s2), ib, -1
maskInd = maskInd + 1
if(mod(maskInd, csubset) == (subset-1)) then
found = .True.
@@ -349,14 +345,14 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
maskInd = maskInd_save
h1 = hole_list(i1,s1)
- call apply_hole(psi_det_generators(1,1,i_generator), s1,h1, pmask, ok, N_int)
+ call apply_hole(psi_det_generators(1,1,i_generator), s1, h1, pmask, ok, N_int)
negMask = not(pmask)
interesting(0) = 0
fullinteresting(0) = 0
- do ii=1,preinteresting(0)
+ do ii = 1, preinteresting(0)
i = preinteresting(ii)
select case (N_int)
case (1)
@@ -372,7 +368,7 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
mobMask(1:3,1) = iand(negMask(1:3,1), psi_det_sorted(1:3,1,i))
mobMask(1:3,2) = iand(negMask(1:3,2), psi_det_sorted(1:3,2,i))
nt = 0
- do j=3,1,-1
+ do j = 3, 1, -1
if (mobMask(j,1) /= 0_bit_kind) then
nt = nt+ popcnt(mobMask(j, 1))
if (nt > 4) exit
@@ -386,7 +382,7 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
mobMask(1:4,1) = iand(negMask(1:4,1), psi_det_sorted(1:4,1,i))
mobMask(1:4,2) = iand(negMask(1:4,2), psi_det_sorted(1:4,2,i))
nt = 0
- do j=4,1,-1
+ do j = 4, 1, -1
if (mobMask(j,1) /= 0_bit_kind) then
nt = nt+ popcnt(mobMask(j, 1))
if (nt > 4) exit
@@ -400,7 +396,7 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
mobMask(1:N_int,1) = iand(negMask(1:N_int,1), psi_det_sorted(1:N_int,1,i))
mobMask(1:N_int,2) = iand(negMask(1:N_int,2), psi_det_sorted(1:N_int,2,i))
nt = 0
- do j=N_int,1,-1
+ do j = N_int, 1, -1
if (mobMask(j,1) /= 0_bit_kind) then
nt = nt+ popcnt(mobMask(j, 1))
if (nt > 4) exit
@@ -441,7 +437,7 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
end do
- do ii=1,prefullinteresting(0)
+ do ii = 1, prefullinteresting(0)
i = prefullinteresting(ii)
nt = 0
mobMask(1,1) = iand(negMask(1,1), psi_det_sorted(1,1,i))
@@ -480,40 +476,38 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
minilist(:,:,i) = psi_det_sorted(:,:,interesting(i))
enddo
- do s2=s1,2
+ do s2 = s1, 2
sp = s1
- if(s1 /= s2) then
- sp = 3
- endif
+ if(s1 /= s2) sp = 3
ib = 1
if(s1 == s2) ib = i1+1
monoAdo = .true.
- do i2=N_holes(s2),ib,-1 ! Generate low excitations first
+ do i2 = N_holes(s2), ib, -1 ! Generate low excitations first
h2 = hole_list(i2,s2)
call apply_hole(pmask, s2,h2, mask, ok, N_int)
banned(:,:,1) = banned_excitation(:,:)
banned(:,:,2) = banned_excitation(:,:)
- do j=1,mo_num
+ do j = 1, mo_num
bannedOrb(j, 1) = .true.
bannedOrb(j, 2) = .true.
enddo
- do s3=1,2
- do i=1,N_particles(s3)
+ do s3 = 1, 2
+ do i = 1, N_particles(s3)
bannedOrb(particle_list(i,s3), s3) = .false.
enddo
enddo
if(s1 /= s2) then
if(monoBdo) then
bannedOrb(h1,s1) = .false.
- end if
+ endif
if(monoAdo) then
bannedOrb(h2,s2) = .false.
monoAdo = .false.
- end if
- end if
+ endif
+ endif
maskInd = maskInd + 1
if(mod(maskInd, csubset) == (subset-1)) then
@@ -522,12 +516,18 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
if(fullMatch) cycle
call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting)
+
call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2_data, mat, buf)
end if
+
+
enddo
+
if(s1 /= s2) monoBdo = .false.
enddo
- deallocate(fullminilist,minilist)
+
+ deallocate(fullminilist, minilist)
+
enddo
enddo
deallocate(preinteresting, prefullinteresting, interesting, fullinteresting)
@@ -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
@@ -845,7 +850,13 @@ subroutine fill_buffer_$DOUBLE(i_generator, sp, h1, h2, bannedOrb, banned, fock_
if (h0_type == 'CFG') then
w = min(w, e_pert(istate) * s_weight(istate,istate)) / c0_weight(istate)
else
+! if(dabs(e_pert(istate) * s_weight(istate,istate)).gt.1.d-5)then
+! print*,w,e_pert(istate) * s_weight(istate,istate)
+! endif
w = min(w, e_pert(istate) * s_weight(istate,istate))
+! if(dabs(e_pert(istate) * s_weight(istate,istate)).gt.1.d-5)then
+! print*,w
+! endif
endif
end select
@@ -883,6 +894,10 @@ subroutine fill_buffer_$DOUBLE(i_generator, sp, h1, h2, bannedOrb, banned, fock_
w *= dsqrt(dble(n))
endif
+! if(dabs(w).gt.1.d-5)then
+! print*,w,buf%mini
+! endif
+
if(w <= buf%mini) then
call add_to_selection_buffer(buf, det, w)
end if
diff --git a/src/cipsi/selection_types.f90 b/src/cipsi/selection_types.f90
deleted file mode 100644
index 58ce0e03..00000000
--- a/src/cipsi/selection_types.f90
+++ /dev/null
@@ -1,25 +0,0 @@
-module selection_types
- type selection_buffer
- integer :: N, cur
- integer(8) , pointer :: det(:,:,:)
- double precision, pointer :: val(:)
- double precision :: mini
- endtype
-
- type pt2_type
- double precision, allocatable :: pt2(:)
- double precision, allocatable :: rpt2(:)
- double precision, allocatable :: variance(:)
- double precision, allocatable :: overlap(:,:)
- endtype
-
- contains
-
- integer function pt2_type_size(N)
- implicit none
- integer, intent(in) :: N
- pt2_type_size = (3*n + n*n)
- end function
-
-end module
-
diff --git a/src/cipsi_utils/NEED b/src/cipsi_utils/NEED
new file mode 100644
index 00000000..d3d4d2c7
--- /dev/null
+++ b/src/cipsi_utils/NEED
@@ -0,0 +1 @@
+determinants
diff --git a/src/cipsi_utils/README.rst b/src/cipsi_utils/README.rst
new file mode 100644
index 00000000..8e98e3ac
--- /dev/null
+++ b/src/cipsi_utils/README.rst
@@ -0,0 +1,5 @@
+===========
+cipsi_utils
+===========
+
+Common functions for CIPSI and TC-CIPSI
diff --git a/src/cipsi_utils/pt2_stoch_routines.irp.f b/src/cipsi_utils/pt2_stoch_routines.irp.f
new file mode 100644
index 00000000..100335f6
--- /dev/null
+++ b/src/cipsi_utils/pt2_stoch_routines.irp.f
@@ -0,0 +1,926 @@
+BEGIN_PROVIDER [ integer, pt2_stoch_istate ]
+ implicit none
+ BEGIN_DOC
+ ! State for stochatsic PT2
+ END_DOC
+ pt2_stoch_istate = 1
+END_PROVIDER
+
+ BEGIN_PROVIDER [ integer, pt2_F, (N_det_generators) ]
+&BEGIN_PROVIDER [ integer, pt2_n_tasks_max ]
+ implicit none
+ logical, external :: testTeethBuilding
+ integer :: i,j
+ pt2_n_tasks_max = elec_alpha_num*elec_alpha_num + elec_alpha_num*elec_beta_num - n_core_orb*2
+ pt2_n_tasks_max = min(pt2_n_tasks_max,1+N_det_generators/10000)
+ call write_int(6,pt2_n_tasks_max,'pt2_n_tasks_max')
+
+ pt2_F(:) = max(int(sqrt(float(pt2_n_tasks_max))),1)
+ do i=1,pt2_n_0(1+pt2_N_teeth/4)
+ pt2_F(i) = pt2_n_tasks_max*pt2_min_parallel_tasks
+ enddo
+ do i=1+pt2_n_0(pt2_N_teeth-pt2_N_teeth/4), pt2_n_0(pt2_N_teeth-pt2_N_teeth/10)
+ pt2_F(i) = pt2_min_parallel_tasks
+ enddo
+ do i=1+pt2_n_0(pt2_N_teeth-pt2_N_teeth/10), N_det_generators
+ pt2_F(i) = 1
+ enddo
+
+END_PROVIDER
+
+ BEGIN_PROVIDER [ integer, pt2_N_teeth ]
+&BEGIN_PROVIDER [ integer, pt2_minDetInFirstTeeth ]
+ implicit none
+ logical, external :: testTeethBuilding
+
+ if(N_det_generators < 1024) then
+ pt2_minDetInFirstTeeth = 1
+ pt2_N_teeth = 1
+ else
+ pt2_minDetInFirstTeeth = min(5, N_det_generators)
+ do pt2_N_teeth=100,2,-1
+ if(testTeethBuilding(pt2_minDetInFirstTeeth, pt2_N_teeth)) exit
+ end do
+ end if
+ call write_int(6,pt2_N_teeth,'Number of comb teeth')
+END_PROVIDER
+
+
+logical function testTeethBuilding(minF, N)
+ implicit none
+ integer, intent(in) :: minF, N
+ integer :: n0, i
+ double precision :: u0, Wt, r
+
+ double precision, allocatable :: tilde_w(:), tilde_cW(:)
+ integer, external :: dress_find_sample
+
+ double precision :: rss
+ double precision, external :: memory_of_double, memory_of_int
+
+ rss = memory_of_double(2*N_det_generators+1)
+ call check_mem(rss,irp_here)
+
+ allocate(tilde_w(N_det_generators), tilde_cW(0:N_det_generators))
+
+ double precision :: norm2
+ norm2 = 0.d0
+ do i=N_det_generators,1,-1
+ tilde_w(i) = psi_coef_sorted_gen(i,pt2_stoch_istate) * &
+ psi_coef_sorted_gen(i,pt2_stoch_istate)
+ norm2 = norm2 + tilde_w(i)
+ enddo
+
+ f = 1.d0/norm2
+ tilde_w(:) = tilde_w(:) * f
+
+ tilde_cW(0) = -1.d0
+ do i=1,N_det_generators
+ tilde_cW(i) = tilde_cW(i-1) + tilde_w(i)
+ enddo
+ tilde_cW(:) = tilde_cW(:) + 1.d0
+ deallocate(tilde_w)
+
+ n0 = 0
+ testTeethBuilding = .false.
+ double precision :: f
+ integer :: minFN
+ minFN = N_det_generators - minF * N
+ f = 1.d0/dble(N)
+ do
+ u0 = tilde_cW(n0)
+ r = tilde_cW(n0 + minF)
+ Wt = (1d0 - u0) * f
+ if (dabs(Wt) <= 1.d-3) then
+ exit
+ endif
+ if(Wt >= r - u0) then
+ testTeethBuilding = .true.
+ exit
+ end if
+ n0 += 1
+ if(n0 > minFN) then
+ exit
+ end if
+ end do
+ deallocate(tilde_cW)
+
+end function
+
+
+!subroutine provide_for_zmq_pt2
+! PROVIDE psi_det_sorted_order psi_selectors_coef_transp psi_det_sorted
+!end
+
+subroutine ZMQ_pt2(E, pt2_data, pt2_data_err, relative_error, N_in)
+ use f77_zmq
+ 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
+ double precision, intent(in) :: relative_error, E(N_states)
+ type(pt2_type), intent(inout) :: pt2_data, pt2_data_err
+!
+ integer :: i, N
+
+ double precision :: state_average_weight_save(N_states), w(N_states,4)
+ integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket
+ type(selection_buffer) :: b
+
+ PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
+ PROVIDE psi_bilinear_matrix_rows psi_bilinear_matrix_order
+ PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
+ PROVIDE psi_bilinear_matrix_transp_order
+ PROVIDE psi_det_hii selection_weight pseudo_sym
+ PROVIDE n_act_orb n_inact_orb n_core_orb n_virt_orb n_del_orb seniority_max
+ PROVIDE excitation_beta_max excitation_alpha_max excitation_max
+
+ call provide_for_zmq_pt2
+
+ if (h0_type == 'CFG') then
+ PROVIDE psi_configuration_hii det_to_configuration
+ endif
+
+ if (N_det <= max(4,N_states) .or. pt2_N_teeth < 2) then
+ call ZMQ_selection(N_in, pt2_data)
+ else
+
+ N = max(N_in,1) * N_states
+ state_average_weight_save(:) = state_average_weight(:)
+ if (int(N,8)*2_8 > huge(1)) then
+ print *, irp_here, ': integer too large'
+ stop -1
+ endif
+ call create_selection_buffer(N, N*2, b)
+ ASSERT (associated(b%det))
+ ASSERT (associated(b%val))
+
+ do pt2_stoch_istate=1,N_states
+ state_average_weight(:) = 0.d0
+ state_average_weight(pt2_stoch_istate) = 1.d0
+ TOUCH state_average_weight pt2_stoch_istate selection_weight
+
+ PROVIDE nproc pt2_F mo_two_e_integrals_in_map mo_one_e_integrals pt2_w
+ PROVIDE psi_selectors pt2_u pt2_J pt2_R
+ call new_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'pt2')
+
+ integer, external :: zmq_put_psi
+ integer, external :: zmq_put_N_det_generators
+ integer, external :: zmq_put_N_det_selectors
+ integer, external :: zmq_put_dvector
+ integer, external :: zmq_put_ivector
+ if (zmq_put_psi(zmq_to_qp_run_socket,1) == -1) then
+ stop 'Unable to put psi on ZMQ server'
+ endif
+ if (zmq_put_N_det_generators(zmq_to_qp_run_socket, 1) == -1) then
+ stop 'Unable to put N_det_generators on ZMQ server'
+ endif
+ if (zmq_put_N_det_selectors(zmq_to_qp_run_socket, 1) == -1) then
+ stop 'Unable to put N_det_selectors on ZMQ server'
+ endif
+ if (zmq_put_dvector(zmq_to_qp_run_socket,1,'energy',pt2_e0_denominator,size(pt2_e0_denominator)) == -1) then
+ stop 'Unable to put energy on ZMQ server'
+ endif
+ if (zmq_put_dvector(zmq_to_qp_run_socket,1,'state_average_weight',state_average_weight,N_states) == -1) then
+ stop 'Unable to put state_average_weight on ZMQ server'
+ endif
+ if (zmq_put_dvector(zmq_to_qp_run_socket,1,'selection_weight',selection_weight,N_states) == -1) then
+ stop 'Unable to put selection_weight on ZMQ server'
+ endif
+ if (zmq_put_ivector(zmq_to_qp_run_socket,1,'pt2_stoch_istate',pt2_stoch_istate,1) == -1) then
+ stop 'Unable to put pt2_stoch_istate on ZMQ server'
+ endif
+ if (zmq_put_dvector(zmq_to_qp_run_socket,1,'threshold_generators',(/threshold_generators/),1) == -1) then
+ stop 'Unable to put threshold_generators on ZMQ server'
+ endif
+
+
+ integer, external :: add_task_to_taskserver
+ character(300000) :: task
+
+ integer :: j,k,ipos,ifirst
+ ifirst=0
+
+ ipos=0
+ do i=1,N_det_generators
+ if (pt2_F(i) > 1) then
+ ipos += 1
+ endif
+ enddo
+ call write_int(6,sum(pt2_F),'Number of tasks')
+ call write_int(6,ipos,'Number of fragmented tasks')
+
+ ipos=1
+ do i= 1, N_det_generators
+ do j=1,pt2_F(pt2_J(i))
+ write(task(ipos:ipos+30),'(I9,1X,I9,1X,I9,''|'')') j, pt2_J(i), N_in
+ ipos += 30
+ if (ipos > 300000-30) then
+ if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
+ stop 'Unable to add task to task server'
+ endif
+ ipos=1
+ if (ifirst == 0) then
+ ifirst=1
+ if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
+ print *, irp_here, ': Failed in zmq_set_running'
+ endif
+ endif
+ endif
+ end do
+ enddo
+ if (ipos > 1) then
+ if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
+ stop 'Unable to add task to task server'
+ endif
+ endif
+
+ integer, external :: zmq_set_running
+ if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
+ print *, irp_here, ': Failed in zmq_set_running'
+ endif
+
+
+ double precision :: mem_collector, mem, rss
+
+ call resident_memory(rss)
+
+ mem_collector = 8.d0 * & ! bytes
+ ( 1.d0*pt2_n_tasks_max & ! task_id, index
+ + 0.635d0*N_det_generators & ! f,d
+ + pt2_n_tasks_max*pt2_type_size(N_states) & ! pt2_data_task
+ + N_det_generators*pt2_type_size(N_states) & ! pt2_data_I
+ + 4.d0*(pt2_N_teeth+1) & ! S, S2, T2, T3
+ + 1.d0*(N_int*2.d0*N + N) & ! selection buffer
+ + 1.d0*(N_int*2.d0*N + N) & ! sort selection buffer
+ ) / 1024.d0**3
+
+ integer :: nproc_target, ii
+ nproc_target = nthreads_pt2
+ ii = min(N_det, (elec_alpha_num*(mo_num-elec_alpha_num))**2)
+
+ do
+ mem = mem_collector + & !
+ nproc_target * 8.d0 * & ! bytes
+ ( 0.5d0*pt2_n_tasks_max & ! task_id
+ + 64.d0*pt2_n_tasks_max & ! task
+ + pt2_type_size(N_states)*pt2_n_tasks_max*N_states & ! pt2, variance, overlap
+ + 1.d0*pt2_n_tasks_max & ! i_generator, subset
+ + 1.d0*(N_int*2.d0*ii+ ii) & ! selection buffer
+ + 1.d0*(N_int*2.d0*ii+ ii) & ! sort selection buffer
+ + 2.0d0*(ii) & ! preinteresting, interesting,
+ ! prefullinteresting, fullinteresting
+ + 2.0d0*(N_int*2*ii) & ! minilist, fullminilist
+ + 1.0d0*(N_states*mo_num*mo_num) & ! mat
+ ) / 1024.d0**3
+
+ if (nproc_target == 0) then
+ call check_mem(mem,irp_here)
+ nproc_target = 1
+ exit
+ endif
+
+ if (mem+rss < qp_max_mem) then
+ exit
+ endif
+
+ nproc_target = nproc_target - 1
+
+ enddo
+ call write_int(6,nproc_target,'Number of threads for PT2')
+ call write_double(6,mem,'Memory (Gb)')
+
+ call set_multiple_levels_omp(.False.)
+
+
+ print '(A)', '========== ==================== ================ ================ ================ ============= ==========='
+ print '(A)', ' Samples Energy PT2 Variance Norm^2 Convergence Seconds'
+ print '(A)', '========== ==================== ================ ================ ================ ============= ==========='
+
+ PROVIDE global_selection_buffer
+
+ !$OMP PARALLEL DEFAULT(shared) NUM_THREADS(nproc_target+1) &
+ !$OMP PRIVATE(i)
+ i = omp_get_thread_num()
+ if (i==0) then
+
+ call pt2_collector(zmq_socket_pull, E(pt2_stoch_istate),relative_error, pt2_data, pt2_data_err, b, N)
+ pt2_data % rpt2(pt2_stoch_istate) = &
+ pt2_data % pt2(pt2_stoch_istate)/(1.d0+pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate))
+
+ !TODO : We should use here the correct formula for the error of X/Y
+ pt2_data_err % rpt2(pt2_stoch_istate) = &
+ pt2_data_err % pt2(pt2_stoch_istate)/(1.d0 + pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate))
+
+ else
+ call pt2_slave_inproc(i)
+ endif
+ !$OMP END PARALLEL
+ call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'pt2')
+ call set_multiple_levels_omp(.True.)
+
+ print '(A)', '========== ==================== ================ ================ ================ ============= ==========='
+
+
+ do k=1,N_states
+ pt2_overlap(pt2_stoch_istate,k) = pt2_data % overlap(k,pt2_stoch_istate)
+ enddo
+ SOFT_TOUCH pt2_overlap
+
+ enddo
+ FREE pt2_stoch_istate
+
+ ! Symmetrize overlap
+ do j=2,N_states
+ do i=1,j-1
+ pt2_overlap(i,j) = 0.5d0 * (pt2_overlap(i,j) + pt2_overlap(j,i))
+ pt2_overlap(j,i) = pt2_overlap(i,j)
+ enddo
+ enddo
+
+ print *, 'Overlap of perturbed states:'
+ do k=1,N_states
+ print *, pt2_overlap(k,:)
+ enddo
+ print *, '-------'
+
+ if (N_in > 0) then
+ b%cur = min(N_in,b%cur)
+ if (s2_eig) then
+ call make_selection_buffer_s2(b)
+ else
+ call remove_duplicates_in_selection_buffer(b)
+ endif
+ call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0)
+ endif
+ call delete_selection_buffer(b)
+
+ state_average_weight(:) = state_average_weight_save(:)
+ TOUCH state_average_weight
+ call update_pt2_and_variance_weights(pt2_data, N_states)
+ endif
+
+
+end subroutine
+
+
+subroutine pt2_slave_inproc(i)
+ implicit none
+ integer, intent(in) :: i
+
+ PROVIDE global_selection_buffer
+ call run_pt2_slave(1,i,pt2_e0_denominator)
+end
+
+
+subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2_data, pt2_data_err, b, N_)
+ use f77_zmq
+ use selection_types
+ use bitmasks
+ implicit none
+
+
+ integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
+ double precision, intent(in) :: relative_error, E
+ type(pt2_type), intent(inout) :: pt2_data, pt2_data_err
+ type(selection_buffer), intent(inout) :: b
+ integer, intent(in) :: N_
+
+ type(pt2_type), allocatable :: pt2_data_task(:)
+ type(pt2_type), allocatable :: pt2_data_I(:)
+ type(pt2_type), allocatable :: pt2_data_S(:)
+ type(pt2_type), allocatable :: pt2_data_S2(:)
+ type(pt2_type) :: pt2_data_teeth
+ integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
+ integer(ZMQ_PTR) :: zmq_to_qp_run_socket
+ integer, external :: zmq_delete_tasks_async_send
+ integer, external :: zmq_delete_tasks_async_recv
+ integer, external :: zmq_abort
+ integer, external :: pt2_find_sample_lr
+
+ PROVIDE pt2_stoch_istate
+
+ integer :: more, n, i, p, c, t, n_tasks, U
+ integer, allocatable :: task_id(:)
+ integer, allocatable :: index(:)
+
+ double precision :: v, x, x2, x3, avg, avg2, avg3(N_states), eqt, E0, v0, n0(N_states)
+ double precision :: eqta(N_states)
+ double precision :: time, time1, time0
+
+ integer, allocatable :: f(:)
+ logical, allocatable :: d(:)
+ logical :: do_exit, stop_now, sending
+ logical, external :: qp_stop
+ type(selection_buffer) :: b2
+
+
+ double precision :: rss
+ double precision, external :: memory_of_double, memory_of_int
+
+ character(len=20) :: format_str1, str_error1, format_str2, str_error2
+ character(len=20) :: format_str3, str_error3, format_str4, str_error4
+ character(len=20) :: format_value1, format_value2, format_value3, format_value4
+ character(len=20) :: str_value1, str_value2, str_value3, str_value4
+ character(len=20) :: str_conv
+ double precision :: value1, value2, value3, value4
+ double precision :: error1, error2, error3, error4
+ integer :: size1,size2,size3,size4
+
+ double precision :: conv_crit
+
+ sending =.False.
+
+ rss = memory_of_int(pt2_n_tasks_max*2+N_det_generators*2)
+ rss += memory_of_double(N_states*N_det_generators)*3.d0
+ rss += memory_of_double(N_states*pt2_n_tasks_max)*3.d0
+ rss += memory_of_double(pt2_N_teeth+1)*4.d0
+ call check_mem(rss,irp_here)
+
+ ! If an allocation is added here, the estimate of the memory should also be
+ ! updated in ZMQ_pt2
+ allocate(task_id(pt2_n_tasks_max), index(pt2_n_tasks_max), f(N_det_generators))
+ allocate(d(N_det_generators+1))
+ allocate(pt2_data_task(pt2_n_tasks_max))
+ allocate(pt2_data_I(N_det_generators))
+ allocate(pt2_data_S(pt2_N_teeth+1))
+ allocate(pt2_data_S2(pt2_N_teeth+1))
+
+
+
+ zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
+ call create_selection_buffer(N_, N_*2, b2)
+
+
+ pt2_data % pt2(pt2_stoch_istate) = -huge(1.)
+ pt2_data_err % pt2(pt2_stoch_istate) = huge(1.)
+ pt2_data % variance(pt2_stoch_istate) = huge(1.)
+ pt2_data_err % variance(pt2_stoch_istate) = huge(1.)
+ pt2_data % overlap(:,pt2_stoch_istate) = 0.d0
+ pt2_data_err % overlap(:,pt2_stoch_istate) = huge(1.)
+ n = 1
+ t = 0
+ U = 0
+ do i=1,pt2_n_tasks_max
+ call pt2_alloc(pt2_data_task(i),N_states)
+ enddo
+ do i=1,pt2_N_teeth+1
+ call pt2_alloc(pt2_data_S(i),N_states)
+ call pt2_alloc(pt2_data_S2(i),N_states)
+ enddo
+ do i=1,N_det_generators
+ call pt2_alloc(pt2_data_I(i),N_states)
+ enddo
+ f(:) = pt2_F(:)
+ d(:) = .false.
+ n_tasks = 0
+ E0 = E
+ v0 = 0.d0
+ n0(:) = 0.d0
+ more = 1
+ call wall_time(time0)
+ time1 = time0
+
+ do_exit = .false.
+ stop_now = .false.
+ do while (n <= N_det_generators)
+ if(f(pt2_J(n)) == 0) then
+ d(pt2_J(n)) = .true.
+ do while(d(U+1))
+ U += 1
+ end do
+
+ ! Deterministic part
+ do while(t <= pt2_N_teeth)
+ if(U >= pt2_n_0(t+1)) then
+ t=t+1
+ E0 = 0.d0
+ v0 = 0.d0
+ n0(:) = 0.d0
+ do i=pt2_n_0(t),1,-1
+ E0 += pt2_data_I(i) % pt2(pt2_stoch_istate)
+ v0 += pt2_data_I(i) % variance(pt2_stoch_istate)
+ n0(:) += pt2_data_I(i) % overlap(:,pt2_stoch_istate)
+ end do
+ else
+ exit
+ end if
+ end do
+
+ ! Add Stochastic part
+ c = pt2_R(n)
+ if(c > 0) then
+
+ call pt2_alloc(pt2_data_teeth,N_states)
+ do p=pt2_N_teeth, 1, -1
+ v = pt2_u_0 + pt2_W_T * (pt2_u(c) + dble(p-1))
+ i = pt2_find_sample_lr(v, pt2_cW,pt2_n_0(p),pt2_n_0(p+1))
+ v = pt2_W_T / pt2_w(i)
+ call pt2_add ( pt2_data_teeth, v, pt2_data_I(i) )
+ call pt2_add ( pt2_data_S(p), 1.d0, pt2_data_teeth )
+ call pt2_add2( pt2_data_S2(p), 1.d0, pt2_data_teeth )
+ enddo
+ call pt2_dealloc(pt2_data_teeth)
+
+ avg = E0 + pt2_data_S(t) % pt2(pt2_stoch_istate) / dble(c)
+ avg2 = v0 + pt2_data_S(t) % variance(pt2_stoch_istate) / dble(c)
+ avg3(:) = n0(:) + pt2_data_S(t) % overlap(:,pt2_stoch_istate) / dble(c)
+ if ((avg /= 0.d0) .or. (n == N_det_generators) ) then
+ do_exit = .true.
+ endif
+ if (qp_stop()) then
+ stop_now = .True.
+ endif
+ pt2_data % pt2(pt2_stoch_istate) = avg
+ pt2_data % variance(pt2_stoch_istate) = avg2
+ pt2_data % overlap(:,pt2_stoch_istate) = avg3(:)
+ call wall_time(time)
+ ! 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 = 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 = 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(:) = 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
+
+ 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)) / &
+ (1.d-20 + dabs(pt2_data % pt2(pt2_stoch_istate)) ) <= relative_error))) ) then
+ if (zmq_abort(zmq_to_qp_run_socket) == -1) then
+ call sleep(10)
+ if (zmq_abort(zmq_to_qp_run_socket) == -1) then
+ print *, irp_here, ': Error in sending abort signal (2)'
+ endif
+ endif
+ endif
+ endif
+ endif
+ end if
+ n += 1
+ else if(more == 0) then
+ exit
+ else
+ call pull_pt2_results(zmq_socket_pull, index, pt2_data_task, task_id, n_tasks, b2)
+ if(n_tasks > pt2_n_tasks_max)then
+ print*,'PB !!!'
+ print*,'If you see this, send a bug report with the following content'
+ print*,irp_here
+ print*,'n_tasks,pt2_n_tasks_max = ',n_tasks,pt2_n_tasks_max
+ stop -1
+ endif
+ if (zmq_delete_tasks_async_send(zmq_to_qp_run_socket,task_id,n_tasks,sending) == -1) then
+ stop 'PT2: Unable to delete tasks (send)'
+ endif
+ do i=1,n_tasks
+ if(index(i).gt.size(pt2_data_I,1).or.index(i).lt.1)then
+ print*,'PB !!!'
+ print*,'If you see this, send a bug report with the following content'
+ print*,irp_here
+ print*,'i,index(i),size(pt2_data_I,1) = ',i,index(i),size(pt2_data_I,1)
+ stop -1
+ endif
+ call pt2_add(pt2_data_I(index(i)),1.d0,pt2_data_task(i))
+ f(index(i)) -= 1
+ end do
+ do i=1, b2%cur
+ ! We assume the pulled buffer is sorted
+ if (b2%val(i) > b%mini) exit
+ call add_to_selection_buffer(b, b2%det(1,1,i), b2%val(i))
+ end do
+ if (zmq_delete_tasks_async_recv(zmq_to_qp_run_socket,more,sending) == -1) then
+ stop 'PT2: Unable to delete tasks (recv)'
+ endif
+ end if
+ end do
+ do i=1,N_det_generators
+ call pt2_dealloc(pt2_data_I(i))
+ enddo
+ do i=1,pt2_N_teeth+1
+ call pt2_dealloc(pt2_data_S(i))
+ call pt2_dealloc(pt2_data_S2(i))
+ enddo
+ do i=1,pt2_n_tasks_max
+ call pt2_dealloc(pt2_data_task(i))
+ enddo
+!print *, 'deleting b2'
+ call delete_selection_buffer(b2)
+!print *, 'sorting b'
+ call sort_selection_buffer(b)
+!print *, 'done'
+ call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
+
+end subroutine
+
+
+integer function pt2_find_sample(v, w)
+ implicit none
+ double precision, intent(in) :: v, w(0:N_det_generators)
+ integer, external :: pt2_find_sample_lr
+
+ pt2_find_sample = pt2_find_sample_lr(v, w, 0, N_det_generators)
+end function
+
+
+integer function pt2_find_sample_lr(v, w, l_in, r_in)
+ implicit none
+ double precision, intent(in) :: v, w(0:N_det_generators)
+ integer, intent(in) :: l_in,r_in
+ integer :: i,l,r
+
+ l=l_in
+ r=r_in
+
+ do while(r-l > 1)
+ i = shiftr(r+l,1)
+ if(w(i) < v) then
+ l = i
+ else
+ r = i
+ end if
+ end do
+ i = r
+ do r=i+1,N_det_generators
+ if (w(r) /= w(i)) then
+ exit
+ endif
+ enddo
+ pt2_find_sample_lr = r-1
+end function
+
+
+BEGIN_PROVIDER [ integer, pt2_n_tasks ]
+ implicit none
+ BEGIN_DOC
+ ! Number of parallel tasks for the Monte Carlo
+ END_DOC
+ pt2_n_tasks = N_det_generators
+END_PROVIDER
+
+BEGIN_PROVIDER[ double precision, pt2_u, (N_det_generators)]
+ implicit none
+ integer, allocatable :: seed(:)
+ integer :: m,i
+ call random_seed(size=m)
+ allocate(seed(m))
+ do i=1,m
+ seed(i) = i
+ enddo
+ call random_seed(put=seed)
+ deallocate(seed)
+
+ call RANDOM_NUMBER(pt2_u)
+ END_PROVIDER
+
+ BEGIN_PROVIDER[ integer, pt2_J, (N_det_generators)]
+&BEGIN_PROVIDER[ integer, pt2_R, (N_det_generators)]
+ implicit none
+ BEGIN_DOC
+! pt2_J contains the list of generators after ordering them according to the
+! Monte Carlo sampling.
+!
+! pt2_R(i) is the number of combs drawn when determinant i is computed.
+ END_DOC
+ integer :: N_c, N_j
+ integer :: U, t, i
+ double precision :: v
+ integer, external :: pt2_find_sample_lr
+
+ logical, allocatable :: pt2_d(:)
+ integer :: m,l,r,k
+ integer :: ncache
+ integer, allocatable :: ii(:,:)
+ double precision :: dt
+
+ ncache = min(N_det_generators,10000)
+
+ double precision :: rss
+ double precision, external :: memory_of_double, memory_of_int
+ rss = memory_of_int(ncache)*dble(pt2_N_teeth) + memory_of_int(N_det_generators)
+ call check_mem(rss,irp_here)
+
+ allocate(ii(pt2_N_teeth,ncache),pt2_d(N_det_generators))
+
+ pt2_R(:) = 0
+ pt2_d(:) = .false.
+ N_c = 0
+ N_j = pt2_n_0(1)
+ do i=1,N_j
+ pt2_d(i) = .true.
+ pt2_J(i) = i
+ end do
+
+ U = 0
+ do while(N_j < pt2_n_tasks)
+
+ if (N_c+ncache > N_det_generators) then
+ ncache = N_det_generators - N_c
+ endif
+
+ !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(dt,v,t,k)
+ do k=1, ncache
+ dt = pt2_u_0
+ do t=1, pt2_N_teeth
+ v = dt + pt2_W_T *pt2_u(N_c+k)
+ dt = dt + pt2_W_T
+ ii(t,k) = pt2_find_sample_lr(v, pt2_cW,pt2_n_0(t),pt2_n_0(t+1))
+ end do
+ enddo
+ !$OMP END PARALLEL DO
+
+ do k=1,ncache
+ !ADD_COMB
+ N_c = N_c+1
+ do t=1, pt2_N_teeth
+ i = ii(t,k)
+ if(.not. pt2_d(i)) then
+ N_j += 1
+ pt2_J(N_j) = i
+ pt2_d(i) = .true.
+ end if
+ end do
+
+ pt2_R(N_j) = N_c
+
+ !FILL_TOOTH
+ do while(U < N_det_generators)
+ U += 1
+ if(.not. pt2_d(U)) then
+ N_j += 1
+ pt2_J(N_j) = U
+ pt2_d(U) = .true.
+ exit
+ end if
+ end do
+ if (N_j >= pt2_n_tasks) exit
+ end do
+ enddo
+
+ if(N_det_generators > 1) then
+ pt2_R(N_det_generators-1) = 0
+ pt2_R(N_det_generators) = N_c
+ end if
+
+ deallocate(ii,pt2_d)
+
+END_PROVIDER
+
+
+
+ BEGIN_PROVIDER [ double precision, pt2_w, (N_det_generators) ]
+&BEGIN_PROVIDER [ double precision, pt2_cW, (0:N_det_generators) ]
+&BEGIN_PROVIDER [ double precision, pt2_W_T ]
+&BEGIN_PROVIDER [ double precision, pt2_u_0 ]
+&BEGIN_PROVIDER [ integer, pt2_n_0, (pt2_N_teeth+1) ]
+ implicit none
+ integer :: i, t
+ double precision, allocatable :: tilde_w(:), tilde_cW(:)
+ double precision :: r, tooth_width
+ integer, external :: pt2_find_sample
+
+ double precision :: rss
+ double precision, external :: memory_of_double, memory_of_int
+ rss = memory_of_double(2*N_det_generators+1)
+ call check_mem(rss,irp_here)
+
+ if (N_det_generators == 1) then
+
+ pt2_w(1) = 1.d0
+ pt2_cw(1) = 1.d0
+ pt2_u_0 = 1.d0
+ pt2_W_T = 0.d0
+ pt2_n_0(1) = 0
+ pt2_n_0(2) = 1
+
+ else
+
+ allocate(tilde_w(N_det_generators), tilde_cW(0:N_det_generators))
+
+ tilde_cW(0) = 0d0
+
+ do i=1,N_det_generators
+ tilde_w(i) = psi_coef_sorted_gen(i,pt2_stoch_istate)**2 !+ 1.d-20
+ enddo
+
+ double precision :: norm2
+ norm2 = 0.d0
+ do i=N_det_generators,1,-1
+ norm2 += tilde_w(i)
+ enddo
+
+ tilde_w(:) = tilde_w(:) / norm2
+
+ tilde_cW(0) = -1.d0
+ do i=1,N_det_generators
+ tilde_cW(i) = tilde_cW(i-1) + tilde_w(i)
+ enddo
+ tilde_cW(:) = tilde_cW(:) + 1.d0
+
+ pt2_n_0(1) = 0
+ do
+ pt2_u_0 = tilde_cW(pt2_n_0(1))
+ r = tilde_cW(pt2_n_0(1) + pt2_minDetInFirstTeeth)
+ pt2_W_T = (1d0 - pt2_u_0) / dble(pt2_N_teeth)
+ if(pt2_W_T >= r - pt2_u_0) then
+ exit
+ end if
+ pt2_n_0(1) += 1
+ if(N_det_generators - pt2_n_0(1) < pt2_minDetInFirstTeeth * pt2_N_teeth) then
+ print *, "teeth building failed"
+ stop -1
+ end if
+ end do
+
+ do t=2, pt2_N_teeth
+ r = pt2_u_0 + pt2_W_T * dble(t-1)
+ pt2_n_0(t) = pt2_find_sample(r, tilde_cW)
+ end do
+ pt2_n_0(pt2_N_teeth+1) = N_det_generators
+
+ pt2_w(:pt2_n_0(1)) = tilde_w(:pt2_n_0(1))
+ do t=1, pt2_N_teeth
+ tooth_width = tilde_cW(pt2_n_0(t+1)) - tilde_cW(pt2_n_0(t))
+ if (tooth_width == 0.d0) then
+ tooth_width = sum(tilde_w(pt2_n_0(t):pt2_n_0(t+1)))
+ endif
+ ASSERT(tooth_width > 0.d0)
+ do i=pt2_n_0(t)+1, pt2_n_0(t+1)
+ pt2_w(i) = tilde_w(i) * pt2_W_T / tooth_width
+ end do
+ end do
+
+ pt2_cW(0) = 0d0
+ do i=1,N_det_generators
+ pt2_cW(i) = pt2_cW(i-1) + pt2_w(i)
+ end do
+ pt2_n_0(pt2_N_teeth+1) = N_det_generators
+
+ endif
+END_PROVIDER
+
+
+
+
+
+BEGIN_PROVIDER [ double precision, pt2_overlap, (N_states, N_states) ]
+ implicit none
+ BEGIN_DOC
+ ! Overlap between the perturbed wave functions
+ END_DOC
+ pt2_overlap(1:N_states,1:N_states) = 0.d0
+END_PROVIDER
+
+
diff --git a/plugins/local/cipsi_tc_bi_ortho/pt2_type.irp.f b/src/cipsi_utils/pt2_type.irp.f
similarity index 100%
rename from plugins/local/cipsi_tc_bi_ortho/pt2_type.irp.f
rename to src/cipsi_utils/pt2_type.irp.f
diff --git a/src/cipsi/run_pt2_slave.irp.f b/src/cipsi_utils/run_pt2_slave.irp.f
similarity index 99%
rename from src/cipsi/run_pt2_slave.irp.f
rename to src/cipsi_utils/run_pt2_slave.irp.f
index debae596..cb1dd1f5 100644
--- a/src/cipsi/run_pt2_slave.irp.f
+++ b/src/cipsi_utils/run_pt2_slave.irp.f
@@ -186,6 +186,7 @@ subroutine run_pt2_slave_large(thread,iproc,energy)
type(pt2_type) :: pt2_data
integer :: n_tasks, k, N
integer :: i_generator, subset
+ integer :: ifirst
integer :: bsize ! Size of selection buffers
logical :: sending
@@ -202,6 +203,7 @@ subroutine run_pt2_slave_large(thread,iproc,energy)
zmq_socket_push = new_zmq_push_socket(thread)
+ ifirst = 0
b%N = 0
buffer_ready = .False.
n_tasks = 1
@@ -250,7 +252,11 @@ subroutine run_pt2_slave_large(thread,iproc,energy)
call omp_set_lock(global_selection_buffer_lock)
global_selection_buffer%mini = b%mini
call merge_selection_buffers(b,global_selection_buffer)
- b%cur=0
+ if (ifirst /= 0 ) then
+ b%cur=0
+ else
+ ifirst = 1
+ endif
call omp_unset_lock(global_selection_buffer_lock)
if ( iproc == 1 ) then
call omp_set_lock(global_selection_buffer_lock)
diff --git a/src/cipsi_utils/run_selection_slave.irp.f b/src/cipsi_utils/run_selection_slave.irp.f
new file mode 100644
index 00000000..783bed0f
--- /dev/null
+++ b/src/cipsi_utils/run_selection_slave.irp.f
@@ -0,0 +1,257 @@
+subroutine run_selection_slave(thread,iproc,energy)
+ use f77_zmq
+ use selection_types
+ implicit none
+
+ double precision, intent(in) :: energy(N_states)
+ integer, intent(in) :: thread, iproc
+ integer :: rc, i
+
+ integer :: worker_id, task_id(1), ctask, ltask
+ character*(512) :: task
+
+ integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
+ integer(ZMQ_PTR) :: zmq_to_qp_run_socket
+
+ integer(ZMQ_PTR), external :: new_zmq_push_socket
+ integer(ZMQ_PTR) :: zmq_socket_push
+
+ type(selection_buffer) :: buf, buf2
+ logical :: done, buffer_ready
+ type(pt2_type) :: pt2_data
+
+ PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
+ PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
+ PROVIDE psi_bilinear_matrix_transp_order N_int pt2_F pseudo_sym
+ PROVIDE psi_bilinear_matrix_rows psi_bilinear_matrix_order weight_selection
+
+ call provide_for_selection_slave
+
+ call pt2_alloc(pt2_data,N_states)
+
+ zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
+
+ integer, external :: connect_to_taskserver
+ if (connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) == -1) then
+ call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
+ return
+ endif
+
+ zmq_socket_push = new_zmq_push_socket(thread)
+
+ buf%N = 0
+ buffer_ready = .False.
+ ctask = 1
+
+ do
+ integer, external :: get_task_from_taskserver
+ if (get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id(ctask), task) == -1) then
+ exit
+ endif
+ done = task_id(ctask) == 0
+ if (done) then
+ ctask = ctask - 1
+ else
+ integer :: i_generator, N, subset, bsize
+ call sscanf_ddd(task, subset, i_generator, N)
+ if(buf%N == 0) then
+ ! Only first time
+ call create_selection_buffer(N, N*2, buf)
+ buffer_ready = .True.
+ else
+ if (N /= buf%N) then
+ print *, 'N=', N
+ print *, 'buf%N=', buf%N
+ print *, 'bug in ', irp_here
+ stop '-1'
+ end if
+ end if
+ call select_connected(i_generator, energy, pt2_data, buf, subset, pt2_F(i_generator))
+ endif
+
+ integer, external :: task_done_to_taskserver
+
+ if(done .or. ctask == size(task_id)) then
+ do i=1, ctask
+ if (task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i)) == -1) then
+ call usleep(100)
+ if (task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i)) == -1) then
+ ctask = 0
+ done = .true.
+ exit
+ endif
+ endif
+ end do
+ if(ctask > 0) then
+ call sort_selection_buffer(buf)
+! call merge_selection_buffers(buf,buf2)
+ call push_selection_results(zmq_socket_push, pt2_data, buf, task_id(1), ctask)
+ call pt2_dealloc(pt2_data)
+ call pt2_alloc(pt2_data,N_states)
+! buf%mini = buf2%mini
+ buf%cur = 0
+ end if
+ ctask = 0
+ end if
+
+ if(done) exit
+ ctask = ctask + 1
+ end do
+
+ if(ctask > 0) then
+ call sort_selection_buffer(buf)
+! call merge_selection_buffers(buf,buf2)
+ call push_selection_results(zmq_socket_push, pt2_data, buf, task_id(1), ctask)
+! buf%mini = buf2%mini
+ buf%cur = 0
+ end if
+ ctask = 0
+ call pt2_dealloc(pt2_data)
+
+ integer, external :: disconnect_from_taskserver
+ if (disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id) == -1) then
+ continue
+ endif
+
+ call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
+ call end_zmq_push_socket(zmq_socket_push,thread)
+ if (buffer_ready) then
+ call delete_selection_buffer(buf)
+! call delete_selection_buffer(buf2)
+ endif
+end subroutine
+
+
+subroutine push_selection_results(zmq_socket_push, pt2_data, b, task_id, ntasks)
+ use f77_zmq
+ use selection_types
+ implicit none
+
+ integer(ZMQ_PTR), intent(in) :: zmq_socket_push
+ type(pt2_type), intent(in) :: pt2_data
+ type(selection_buffer), intent(inout) :: b
+ integer, intent(in) :: ntasks, task_id(*)
+ integer :: rc
+ double precision, allocatable :: pt2_serialized(:)
+
+ rc = f77_zmq_send( zmq_socket_push, b%cur, 4, ZMQ_SNDMORE)
+ if(rc /= 4) then
+ print *, 'f77_zmq_send( zmq_socket_push, b%cur, 4, ZMQ_SNDMORE)'
+ endif
+
+
+ allocate(pt2_serialized (pt2_type_size(N_states)) )
+ call pt2_serialize(pt2_data,N_states,pt2_serialized)
+
+ rc = f77_zmq_send( zmq_socket_push, pt2_serialized, size(pt2_serialized)*8, ZMQ_SNDMORE)
+ if (rc == -1) then
+ print *, irp_here, ': error sending result'
+ stop 3
+ return
+ else if(rc /= size(pt2_serialized)*8) then
+ stop 'push'
+ endif
+ deallocate(pt2_serialized)
+
+ if (b%cur > 0) then
+
+ rc = f77_zmq_send( zmq_socket_push, b%val(1), 8*b%cur, ZMQ_SNDMORE)
+ if(rc /= 8*b%cur) then
+ print *, 'f77_zmq_send( zmq_socket_push, b%val(1), 8*b%cur, ZMQ_SNDMORE)'
+ endif
+
+ rc = f77_zmq_send( zmq_socket_push, b%det(1,1,1), bit_kind*N_int*2*b%cur, ZMQ_SNDMORE)
+ if(rc /= bit_kind*N_int*2*b%cur) then
+ print *, 'f77_zmq_send( zmq_socket_push, b%det(1,1,1), bit_kind*N_int*2*b%cur, ZMQ_SNDMORE)'
+ endif
+
+ endif
+
+ rc = f77_zmq_send( zmq_socket_push, ntasks, 4, ZMQ_SNDMORE)
+ if(rc /= 4) then
+ print *, 'f77_zmq_send( zmq_socket_push, ntasks, 4, ZMQ_SNDMORE)'
+ endif
+
+ rc = f77_zmq_send( zmq_socket_push, task_id(1), ntasks*4, 0)
+ if(rc /= 4*ntasks) then
+ print *, 'f77_zmq_send( zmq_socket_push, task_id(1), ntasks*4, 0)'
+ endif
+
+! Activate is zmq_socket_push is a REQ
+IRP_IF ZMQ_PUSH
+IRP_ELSE
+ character*(2) :: ok
+ rc = f77_zmq_recv( zmq_socket_push, ok, 2, 0)
+ if ((rc /= 2).and.(ok(1:2) /= 'ok')) then
+ print *, irp_here//': error in receiving ok'
+ stop -1
+ endif
+IRP_ENDIF
+
+end subroutine
+
+
+subroutine pull_selection_results(zmq_socket_pull, pt2_data, val, det, N, task_id, ntasks)
+ use f77_zmq
+ use selection_types
+ implicit none
+ integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
+ type(pt2_type), intent(inout) :: pt2_data
+ double precision, intent(out) :: val(*)
+ integer(bit_kind), intent(out) :: det(N_int, 2, *)
+ integer, intent(out) :: N, ntasks, task_id(*)
+ integer :: rc, rn, i
+ double precision, allocatable :: pt2_serialized(:)
+
+ rc = f77_zmq_recv( zmq_socket_pull, N, 4, 0)
+ if(rc /= 4) then
+ print *, 'f77_zmq_recv( zmq_socket_pull, N, 4, 0)'
+ endif
+
+ allocate(pt2_serialized (pt2_type_size(N_states)) )
+ rc = f77_zmq_recv( zmq_socket_pull, pt2_serialized, 8*size(pt2_serialized), 0)
+ if (rc == -1) then
+ ntasks = 1
+ task_id(1) = 0
+ else if(rc /= 8*size(pt2_serialized)) then
+ stop 'pull'
+ endif
+
+ call pt2_deserialize(pt2_data,N_states,pt2_serialized)
+ deallocate(pt2_serialized)
+
+ if (N>0) then
+ rc = f77_zmq_recv( zmq_socket_pull, val(1), 8*N, 0)
+ if(rc /= 8*N) then
+ print *, 'f77_zmq_recv( zmq_socket_pull, val(1), 8*N, 0)'
+ endif
+
+ rc = f77_zmq_recv( zmq_socket_pull, det(1,1,1), bit_kind*N_int*2*N, 0)
+ if(rc /= bit_kind*N_int*2*N) then
+ print *, 'f77_zmq_recv( zmq_socket_pull, det(1,1,1), bit_kind*N_int*2*N, 0)'
+ endif
+ endif
+
+ rc = f77_zmq_recv( zmq_socket_pull, ntasks, 4, 0)
+ if(rc /= 4) then
+ print *, 'f77_zmq_recv( zmq_socket_pull, ntasks, 4, 0)'
+ endif
+
+ rc = f77_zmq_recv( zmq_socket_pull, task_id(1), ntasks*4, 0)
+ if(rc /= 4*ntasks) then
+ print *, 'f77_zmq_recv( zmq_socket_pull, task_id(1), ntasks*4, 0)'
+ endif
+
+! Activate is zmq_socket_pull is a REP
+IRP_IF ZMQ_PUSH
+IRP_ELSE
+ rc = f77_zmq_send( zmq_socket_pull, 'ok', 2, 0)
+ if (rc /= 2) then
+ print *, irp_here//': error in sending ok'
+ stop -1
+ endif
+IRP_ENDIF
+end subroutine
+
+
+
diff --git a/src/cipsi/selection_buffer.irp.f b/src/cipsi_utils/selection_buffer.irp.f
similarity index 100%
rename from src/cipsi/selection_buffer.irp.f
rename to src/cipsi_utils/selection_buffer.irp.f
diff --git a/plugins/local/cipsi_tc_bi_ortho/selection_types.f90 b/src/cipsi_utils/selection_types.f90
similarity index 100%
rename from plugins/local/cipsi_tc_bi_ortho/selection_types.f90
rename to src/cipsi_utils/selection_types.f90
diff --git a/src/cipsi/selection_weight.irp.f b/src/cipsi_utils/selection_weight.irp.f
similarity index 100%
rename from src/cipsi/selection_weight.irp.f
rename to src/cipsi_utils/selection_weight.irp.f
diff --git a/src/cipsi/slave_cipsi.irp.f b/src/cipsi_utils/slave_cipsi.irp.f
similarity index 98%
rename from src/cipsi/slave_cipsi.irp.f
rename to src/cipsi_utils/slave_cipsi.irp.f
index ddfc050e..3e778270 100644
--- a/src/cipsi/slave_cipsi.irp.f
+++ b/src/cipsi_utils/slave_cipsi.irp.f
@@ -303,10 +303,11 @@ subroutine run_slave_main
PROVIDE global_selection_buffer pt2_N_teeth pt2_F N_det_generators
PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
- PROVIDE psi_bilinear_matrix_rows psi_det_sorted_order psi_bilinear_matrix_order
+ PROVIDE psi_bilinear_matrix_rows psi_bilinear_matrix_order
PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
- PROVIDE psi_bilinear_matrix_transp_order psi_selectors_coef_transp psi_det_sorted
- PROVIDE psi_det_hii selection_weight pseudo_sym pt2_min_parallel_tasks
+ PROVIDE psi_bilinear_matrix_transp_order psi_selectors_coef_transp
+ PROVIDE selection_weight pseudo_sym pt2_min_parallel_tasks
+ call provide_for_zmq_pt2
if (mpi_master) then
print *, 'Running PT2'
diff --git a/src/cipsi/zmq_selection.irp.f b/src/cipsi_utils/zmq_selection.irp.f
similarity index 99%
rename from src/cipsi/zmq_selection.irp.f
rename to src/cipsi_utils/zmq_selection.irp.f
index 1bfe87c0..5c2f8fc8 100644
--- a/src/cipsi/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/davidson/u0_wee_u0.irp.f b/src/davidson/u0_wee_u0.irp.f
index 0c543aca..bd3525e1 100644
--- a/src/davidson/u0_wee_u0.irp.f
+++ b/src/davidson/u0_wee_u0.irp.f
@@ -492,3 +492,25 @@ subroutine u_0_H_u_0_two_e(e_0,u_0,n,keys_tmp,Nint,N_st,sze)
deallocate (s_0, v_0)
end
+BEGIN_PROVIDER [double precision, psi_energy_two_e_trans, (N_states, N_states)]
+ implicit none
+ BEGIN_DOC
+! psi_energy_two_e_trans(istate,jstate) =
+ END_dOC
+ integer :: i,j,istate,jstate
+ double precision :: hij, coef_i, coef_j
+ psi_energy_two_e_trans = 0.d0
+ do i = 1, N_det
+ do j = 1, N_det
+ call i_H_j_two_e(psi_det(1,1,i),psi_det(1,1,j),N_int,hij)
+ do istate = 1, N_states
+ coef_i = psi_coef(i,istate)
+ do jstate = 1, N_states
+ coef_j = psi_coef(j,jstate)
+ psi_energy_two_e_trans(jstate,istate) += coef_i * coef_j * hij
+ enddo
+ enddo
+ enddo
+ enddo
+
+END_PROVIDER
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/environment.irp.f b/src/ezfio_files/environment.irp.f
similarity index 100%
rename from src/cipsi/environment.irp.f
rename to src/ezfio_files/environment.irp.f
diff --git a/src/generators_full_tc/NEED b/src/generators_full_tc/NEED
new file mode 100644
index 00000000..0cf7d3aa
--- /dev/null
+++ b/src/generators_full_tc/NEED
@@ -0,0 +1,2 @@
+determinants
+hartree_fock
diff --git a/src/generators_full_tc/README.rst b/src/generators_full_tc/README.rst
new file mode 100644
index 00000000..4e59ee3b
--- /dev/null
+++ b/src/generators_full_tc/README.rst
@@ -0,0 +1,9 @@
+===============
+generators_full
+===============
+
+Module defining the generator determinants as all the determinants of the
+variational space.
+
+This module is intended to be included in the :file:`NEED` file to define
+a full set of generators.
diff --git a/plugins/local/fci_tc_bi/generators.irp.f b/src/generators_full_tc/generators.irp.f
similarity index 51%
rename from plugins/local/fci_tc_bi/generators.irp.f
rename to src/generators_full_tc/generators.irp.f
index bf972423..a9da7dbc 100644
--- a/plugins/local/fci_tc_bi/generators.irp.f
+++ b/src/generators_full_tc/generators.irp.f
@@ -34,23 +34,49 @@ END_PROVIDER
END_PROVIDER
- BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_tc_gen, (N_int,2,psi_det_size) ]
-&BEGIN_PROVIDER [ double precision, psi_coef_sorted_tc_gen, (psi_det_size,N_states) ]
-&BEGIN_PROVIDER [ integer, psi_det_sorted_tc_gen_order, (psi_det_size) ]
+ BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_gen, (N_int,2,psi_det_size) ]
+&BEGIN_PROVIDER [ double precision, psi_coef_sorted_gen, (psi_det_size,N_states) ]
+&BEGIN_PROVIDER [ integer, psi_det_sorted_gen_order, (psi_det_size) ]
implicit none
BEGIN_DOC
! For Single reference wave functions, the generator is the
! Hartree-Fock determinant
END_DOC
- psi_det_sorted_tc_gen = psi_det_sorted_tc
- psi_coef_sorted_tc_gen = psi_coef_sorted_tc
- psi_det_sorted_tc_gen_order = psi_det_sorted_tc_order
- integer :: i
-! do i = 1,N_det
-! print*,'i = ',i
-! call debug_det(psi_det_sorted_tc(1,1,i),N_int)
-! enddo
+ psi_det_sorted_gen = psi_det_sorted_tc
+ psi_coef_sorted_gen = psi_coef_sorted_tc
+ psi_det_sorted_gen_order = psi_det_sorted_tc_order
END_PROVIDER
+BEGIN_PROVIDER [integer, degree_max_generators]
+ implicit none
+ BEGIN_DOC
+! Max degree of excitation (respect to HF) of the generators
+ END_DOC
+ integer :: i,degree
+ degree_max_generators = 0
+ do i = 1, N_det_generators
+ call get_excitation_degree(HF_bitmask,psi_det_generators(1,1,i),degree,N_int)
+ if(degree .gt. degree_max_generators)then
+ degree_max_generators = degree
+ endif
+ enddo
+END_PROVIDER
+
+BEGIN_PROVIDER [ integer, size_select_max]
+ implicit none
+ BEGIN_DOC
+ ! Size of the select_max array
+ END_DOC
+ size_select_max = 10000
+END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, select_max, (size_select_max) ]
+ implicit none
+ BEGIN_DOC
+ ! Memo to skip useless selectors
+ END_DOC
+ select_max = huge(1.d0)
+END_PROVIDER
+
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/iterations/summary_tc.irp.f b/src/iterations/summary_tc.irp.f
new file mode 100644
index 00000000..00c2ba38
--- /dev/null
+++ b/src/iterations/summary_tc.irp.f
@@ -0,0 +1,125 @@
+subroutine print_summary_tc(e_,pt2_data,pt2_data_err,n_det_,n_configuration_,n_st,s2_)
+ use selection_types
+ implicit none
+ BEGIN_DOC
+! Print the extrapolated energy in the output
+ END_DOC
+
+ integer, intent(in) :: n_det_, n_configuration_, n_st
+ double precision, intent(in) :: e_(n_st), s2_(n_st)
+ type(pt2_type) , intent(in) :: pt2_data, pt2_data_err
+ integer :: i, k
+ integer :: N_states_p
+ character*(9) :: pt2_string
+ character*(512) :: fmt
+ double precision, allocatable :: pt2_minus(:),pt2_plus(:),pt2_tot(:), pt2_abs(:),pt1_norm(:),rpt2_tot(:)
+ double precision, allocatable :: error_pt2_minus(:), error_pt2_plus(:), error_pt2_tot(:), error_pt2_abs(:)
+
+ if (do_pt2) then
+ pt2_string = ' '
+ else
+ pt2_string = '(approx)'
+ endif
+
+ N_states_p = min(N_det_,n_st)
+
+ allocate(pt2_minus(N_states_p),pt2_plus(N_states_p),pt2_tot(N_states_p), pt2_abs(N_states_p),pt1_norm(N_states_p),rpt2_tot(N_states_p))
+ allocate(error_pt2_minus(N_states_p), error_pt2_plus(N_states_p), error_pt2_tot(N_states_p), error_pt2_abs(N_states_p))
+ do k = 1, N_states_p
+ pt2_plus(k) = pt2_data % variance(k)
+ pt2_minus(k) = pt2_data % pt2(k)
+ pt2_abs(k) = pt2_plus(k) - pt2_minus(k)
+ pt2_tot(k) = pt2_plus(k) + pt2_minus(k)
+ pt1_norm(k) = pt2_data % overlap(k,k)
+ rpt2_tot(k) = pt2_tot(k) / (1.d0 + pt1_norm(k))
+ error_pt2_minus(k) = pt2_data_err % pt2(k)
+ error_pt2_plus(k) = pt2_data_err % variance(k)
+ error_pt2_tot(k) = dsqrt(error_pt2_minus(k)**2+error_pt2_plus(k)**2)
+ error_pt2_abs(k) = error_pt2_tot(k) ! same variance because independent variables
+ enddo
+ k=1
+ write(*,'(A40,X,I10,X,100(F16.8,X))')'Ndet,E,E+PT2,pt2_minus,pt2_plus,pt2_abs=',n_det_,e_(k),e_(k) + pt2_tot(k),e_(k) + rpt2_tot(k),pt2_minus(k), pt2_plus(k),pt2_abs(k)
+
+ print *, ''
+ print '(A,I12)', 'Summary at N_det = ', N_det_
+ print '(A)', '-----------------------------------'
+ print *, ''
+
+ write(fmt,*) '(''# ============'',', N_states_p, '(1X,''=============================''))'
+ write(*,fmt)
+ write(fmt,*) '(13X,', N_states_p, '(6X,A7,1X,I6,10X))'
+ write(*,fmt) ('State',k, k=1,N_states_p)
+ write(fmt,*) '(''# ============'',', N_states_p, '(1X,''=============================''))'
+ write(*,fmt)
+ write(fmt,*) '(A13,', N_states_p, '(1X,F14.8,15X))'
+ write(*,fmt) '# E ', e_(1:N_states_p)
+ if (N_states_p > 1) then
+ write(*,fmt) '# Excit. (au)', e_(1:N_states_p)-e_(1)
+ write(*,fmt) '# Excit. (eV)', (e_(1:N_states_p)-e_(1))*27.211396641308d0
+ endif
+ write(fmt,*) '(A13,', 2*N_states_p, '(1X,F14.8))'
+ write(*,fmt) '# PT2 '//pt2_string, (pt2_tot(k), error_pt2_tot(k), k=1,N_states_p)
+ write(*,fmt) '# rPT2'//pt2_string, (rpt2_tot(k), error_pt2_tot(k), k=1,N_states_p)
+ write(*,'(A)') '#'
+ write(*,fmt) '# E+PT2 ', (e_(k)+pt2_tot(k) ,error_pt2_tot(k), k=1,N_states_p)
+ write(*,fmt) '# E+rPT2 ', (e_(k)+rpt2_tot(k),error_pt2_tot(k), k=1,N_states_p)
+ if (N_states_p > 1) then
+ write(*,fmt) '# Excit. (au)', ( (e_(k)+pt2_tot(k)-e_(1)-pt2_tot(1)), &
+ dsqrt(error_pt2_tot(k)*error_pt2_tot(k)+error_pt2_tot(1)*error_pt2_tot(1)), k=1,N_states_p)
+ write(*,fmt) '# Excit. (eV)', ( (e_(k)+pt2_tot(k)-e_(1)-pt2_tot(1))*27.211396641308d0, &
+ dsqrt(error_pt2_tot(k)*error_pt2_tot(k)+error_pt2_tot(1)*error_pt2_tot(1))*27.211396641308d0, k=1,N_states_p)
+ endif
+ write(fmt,*) '(''# ============'',', N_states_p, '(1X,''=============================''))'
+ write(*,fmt)
+ print *, ''
+
+ print *, 'N_det = ', N_det_
+ print *, 'N_states = ', n_st
+ if (s2_eig) then
+ print *, 'N_cfg = ', N_configuration_
+ if (only_expected_s2) then
+ print *, 'N_csf = ', N_csf
+ endif
+ endif
+ print *, ''
+
+ do k=1, N_states_p
+ print*,'* State ',k
+ print *, '< S^2 > = ', s2_(k)
+ print *, 'E = ', e_(k)
+ print *, 'PT norm = ', pt1_norm(k)
+ print *, 'PT2 = ', pt2_tot(k), ' +/- ', error_pt2_tot(k)
+ print *, 'rPT2 = ', rpt2_tot(k), ' +/- ', error_pt2_tot(k)
+ print *, 'E+PT2 '//pt2_string//' = ', e_(k)+pt2_tot(k) , ' +/- ', error_pt2_tot(k)
+ print *, 'E+rPT2'//pt2_string//' = ', e_(k)+rpt2_tot(k), ' +/- ', error_pt2_tot(k)
+ print *, 'Positive PT2 = ',pt2_plus(k),' +/- ',error_pt2_plus(k)
+ print *, 'Negative PT2 = ',pt2_minus(k),' +/- ',error_pt2_minus(k)
+ print *, 'Abs PT2 = ',pt2_abs(k), ' +/- ',error_pt2_abs(k)
+ print *, ''
+ enddo
+
+ print *, '-----'
+ if(n_st.gt.1)then
+ print *, 'Variational Energy difference (au | eV)'
+ do i=2, N_states_p
+ print*,'Delta E = ', (e_(i) - e_(1)), &
+ (e_(i) - e_(1)) * 27.211396641308d0
+ enddo
+ print *, '-----'
+ print*, 'Variational + perturbative Energy difference (au | eV)'
+ do i=2, N_states_p
+ print*,'Delta E = ', (e_(i)+ pt2_tot(i) - (e_(1) + pt2_tot(1))), &
+ (e_(i)+ pt2_tot(i) - (e_(1) + pt2_tot(1))) * 27.211396641308d0
+ enddo
+ print *, '-----'
+ print*, 'Variational + renormalized perturbative Energy difference (au | eV)'
+ do i=2, N_states_p
+ print*,'Delta E = ', (e_(i)+ rpt2_tot(i) - (e_(1) + rpt2_tot(1))), &
+ (e_(i)+ rpt2_tot(i) - (e_(1) + rpt2_tot(1))) * 27.211396641308d0
+ enddo
+ endif
+
+! call print_energy_components()
+
+end subroutine
+
diff --git a/src/mo_basis/EZFIO.cfg b/src/mo_basis/EZFIO.cfg
index 4c4f1eca..8349c006 100644
--- a/src/mo_basis/EZFIO.cfg
+++ b/src/mo_basis/EZFIO.cfg
@@ -32,6 +32,12 @@ doc: |MO| occupation numbers
interface: ezfio
size: (mo_basis.mo_num)
+[mo_symmetry]
+type: integer
+doc: MOs with the same integer belong to the same irrep.
+interface: ezfio
+size: (mo_basis.mo_num)
+
[mo_class]
type: MO_class
doc: [ Core | Inactive | Active | Virtual | Deleted ], as defined by :ref:`qp_set_mo_class`
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_one_e_ints/spread_dipole_mo.irp.f b/src/mo_one_e_ints/spread_dipole_mo.irp.f
index e4484433..b0a7198b 100644
--- a/src/mo_one_e_ints/spread_dipole_mo.irp.f
+++ b/src/mo_one_e_ints/spread_dipole_mo.irp.f
@@ -58,3 +58,21 @@ END_PROVIDER
)
END_PROVIDER
+ BEGIN_PROVIDER [double precision, mo_spread_centered_x, (mo_num, mo_num) ]
+&BEGIN_PROVIDER [double precision, mo_spread_centered_y, (mo_num, mo_num) ]
+&BEGIN_PROVIDER [double precision, mo_spread_centered_z, (mo_num, mo_num) ]
+ BEGIN_DOC
+ ! array of the integrals of MO_i * (x^2 - ^2) MO_j = MO_i x^2 MO_j - (MO_i x MO_j)^2
+ ! array of the integrals of MO_i * (y^2 - ^2) MO_j = MO_i y^2 MO_j - (MO_i y MO_j)^2
+ ! array of the integrals of MO_i * (z^2 - ^2) MO_j = MO_i z^2 MO_j - (MO_i z MO_j)^2
+ END_DOC
+ implicit none
+ integer :: i,j
+ do i = 1, mo_num
+ do j = 1, mo_num
+ mo_spread_centered_x(j,i) = mo_spread_x(j,i) - mo_dipole_x(j,i)**2
+ mo_spread_centered_y(j,i) = mo_spread_y(j,i) - mo_dipole_y(j,i)**2
+ mo_spread_centered_z(j,i) = mo_spread_z(j,i) - mo_dipole_z(j,i)**2
+ enddo
+ enddo
+END_PROVIDER
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/EZFIO.cfg b/src/mol_properties/EZFIO.cfg
index 35a095fb..3ddba227 100644
--- a/src/mol_properties/EZFIO.cfg
+++ b/src/mol_properties/EZFIO.cfg
@@ -21,3 +21,10 @@ type: logical
doc: If true and N_states > 1, the oscillator strength will be computed
interface: ezfio,provider,ocaml
default: false
+
+[calc_energy_components]
+type: logical
+doc: If true, the components of the energy (1e, 2e, kinetic) will be computed
+interface: ezfio,provider,ocaml
+default: false
+
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/two_body_rdm/print_e_components.irp.f b/src/mol_properties/print_e_components.irp.f
similarity index 100%
rename from src/two_body_rdm/print_e_components.irp.f
rename to src/mol_properties/print_e_components.irp.f
diff --git a/src/mol_properties/print_mol_properties.irp.f b/src/mol_properties/print_mol_properties.irp.f
index 3753a3dd..00ccb826 100644
--- a/src/mol_properties/print_mol_properties.irp.f
+++ b/src/mol_properties/print_mol_properties.irp.f
@@ -6,6 +6,11 @@ subroutine print_mol_properties()
! Run the propertie calculations
END_DOC
+ ! Energy components
+ if (calc_energy_components) then
+ call print_energy_components
+ endif
+
! Electric dipole moment
if (calc_dipole_moment) then
call print_dipole_moment
@@ -18,7 +23,7 @@ subroutine print_mol_properties()
! Oscillator strength
if (calc_osc_str .and. N_states > 1) then
- call print_oscillator_strength
+ call print_oscillator_strength
endif
end
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/diagonalize_h.irp.f b/src/tools/diagonalize_h.irp.f
index c9ae2033..ffc53aa2 100644
--- a/src/tools/diagonalize_h.irp.f
+++ b/src/tools/diagonalize_h.irp.f
@@ -20,4 +20,5 @@ subroutine routine
call diagonalize_CI
print*,'N_det = ',N_det
call save_wavefunction_general(N_det,N_states,psi_det_sorted,size(psi_coef_sorted,1),psi_coef_sorted)
+ call print_mol_properties
end
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/tools/print_energy.irp.f b/src/tools/print_energy.irp.f
index 4fe1572c..0e67828e 100644
--- a/src/tools/print_energy.irp.f
+++ b/src/tools/print_energy.irp.f
@@ -14,5 +14,6 @@ end
subroutine run
implicit none
- print *, psi_energy + nuclear_repulsion
+ call print_mol_properties
+ print *, psi_energy + nuclear_repulsion
end
diff --git a/src/trexio/export_trexio.irp.f b/src/trexio/export_trexio.irp.f
index f9ecc17f..ff12aebb 100644
--- a/src/trexio/export_trexio.irp.f
+++ b/src/trexio/export_trexio.irp.f
@@ -2,6 +2,6 @@ program export_trexio_prog
implicit none
read_wf = .True.
SOFT_TOUCH read_wf
- call export_trexio(.False.)
+ call export_trexio(.False.,.False.)
end
diff --git a/src/trexio/export_trexio_routines.irp.f b/src/trexio/export_trexio_routines.irp.f
index f25ae370..63630243 100644
--- a/src/trexio/export_trexio_routines.irp.f
+++ b/src/trexio/export_trexio_routines.irp.f
@@ -1,18 +1,28 @@
-subroutine export_trexio(update)
+subroutine export_trexio(update,full_path)
use trexio
implicit none
BEGIN_DOC
! Exports the wave function in TREXIO format
END_DOC
- logical, intent(in) :: update
+ logical, intent(in) :: update, full_path
integer(trexio_t) :: f(N_states) ! TREXIO file handle
integer(trexio_exit_code) :: rc
- integer :: k
+ integer :: k, iunit
double precision, allocatable :: factor(:)
- character*(256) :: filenames(N_states)
+ character*(256) :: filenames(N_states), fp
character :: rw
+ integer, external :: getunitandopen
+
+ if (full_path) then
+ fp = trexio_filename
+ call system('realpath '//trim(fp)//' > '//trim(fp)//'.tmp')
+ iunit = getunitandopen(trim(fp)//'.tmp','r')
+ read(iunit,'(A)') trexio_filename
+ close(iunit, status='delete')
+ endif
+
filenames(1) = trexio_filename
do k=2,N_states
write(filenames(k),'(A,I3.3)') trim(trexio_filename)//'.', k-1
@@ -49,6 +59,60 @@ subroutine export_trexio(update)
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
+
! ------------------------------------------------------------------------------
! Electrons
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/two_body_rdm/act_2_transition_rdm.irp.f b/src/two_body_rdm/act_2_transition_rdm.irp.f
new file mode 100644
index 00000000..612213e2
--- /dev/null
+++ b/src/two_body_rdm/act_2_transition_rdm.irp.f
@@ -0,0 +1,39 @@
+ BEGIN_PROVIDER [double precision, act_2_rdm_trans_spin_trace_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states,N_states)]
+ implicit none
+ BEGIN_DOC
+! act_2_rdm_trans_spin_trace_mo(i,j,k,l,istate,jstate) = STATE SPECIFIC physicist notation for 2rdm_trans
+!
+! \sum_{\sigma,\sigma'}
+!
+! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO AN ACTIVE SPACE DEFINED BY "list_act"
+!
+! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{elec}^{act} * (N_{elec}^{act} - 1)
+!
+! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act"
+ END_DOC
+ integer :: ispin
+ double precision :: wall_1, wall_2
+ ! condition for beta/beta spin
+ print*,''
+ print*,'Providing act_2_rdm_trans_spin_trace_mo '
+ character*(128) :: name_file
+ name_file = 'act_2_rdm_trans_spin_trace_mo'
+ ispin = 4
+ act_2_rdm_trans_spin_trace_mo = 0.d0
+ call wall_time(wall_1)
+! if(read_two_body_rdm_trans_spin_trace)then
+! print*,'Reading act_2_rdm_trans_spin_trace_mo from disk ...'
+! call read_array_two_rdm_trans(n_act_orb,N_states,act_2_rdm_trans_spin_trace_mo,name_file)
+! else
+ call orb_range_2_trans_rdm_openmp(act_2_rdm_trans_spin_trace_mo,n_act_orb,n_act_orb,list_act,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
+! endif
+! if(write_two_body_rdm_trans_spin_trace)then
+! print*,'Writing act_2_rdm_trans_spin_trace_mo on disk ...'
+! call write_array_two_rdm_trans(n_act_orb,n_states,act_2_rdm_trans_spin_trace_mo,name_file)
+! call ezfio_set_two_body_rdm_trans_io_two_body_rdm_trans_spin_trace("Read")
+! endif
+
+ act_2_rdm_trans_spin_trace_mo *= 2.d0
+ call wall_time(wall_2)
+ print*,'Wall time to provide act_2_rdm_trans_spin_trace_mo',wall_2 - wall_1
+ END_PROVIDER
diff --git a/src/two_body_rdm/example.irp.f b/src/two_body_rdm/example.irp.f
index 30e2685a..38510fe9 100644
--- a/src/two_body_rdm/example.irp.f
+++ b/src/two_body_rdm/example.irp.f
@@ -365,3 +365,91 @@ subroutine routine_full_mos
end
+
+subroutine routine_active_only_trans
+ implicit none
+ integer :: i,j,k,l,iorb,jorb,korb,lorb,istate,jstate
+ BEGIN_DOC
+! This routine computes the two electron repulsion within the active space using various providers
+!
+ END_DOC
+
+ double precision :: vijkl,get_two_e_integral
+ double precision :: wee_tot(N_states,N_states),rdm_transtot
+ double precision :: spin_trace
+ double precision :: accu_tot
+
+ wee_tot = 0.d0
+
+
+ iorb = 1
+ jorb = 1
+ korb = 1
+ lorb = 1
+ vijkl = get_two_e_integral(lorb,korb,jorb,iorb,mo_integrals_map)
+ provide act_2_rdm_trans_spin_trace_mo
+ i = 1
+ j = 2
+
+ print*,'**************************'
+ print*,'**************************'
+ do jstate = 1, N_states
+ do istate = 1, N_states
+ !! PURE ACTIVE PART
+ !!
+ accu_tot = 0.d0
+ do i = 1, n_act_orb
+ iorb = list_act(i)
+ do j = 1, n_act_orb
+ jorb = list_act(j)
+ do k = 1, n_act_orb
+ korb = list_act(k)
+ do l = 1, n_act_orb
+ lorb = list_act(l)
+ ! 1 2 1 2 2 1 2 1
+! if(dabs(act_2_rdm_trans_spin_trace_mo(i,j,k,l,istate,jstate) - act_2_rdm_trans_spin_trace_mo(j,i,l,k,istate,jstate)).gt.1.d-10)then
+! print*,'Error in act_2_rdm_trans_spin_trace_mo'
+! print*,"dabs(act_2_rdm_trans_spin_trace_mo(i,j,k,l) - act_2_rdm_trans_spin_trace_mo(j,i,l,k)).gt.1.d-10"
+! print*,i,j,k,l
+! print*,act_2_rdm_trans_spin_trace_mo(i,j,k,l,istate,jstate),act_2_rdm_trans_spin_trace_mo(j,i,l,k,istate,jstate),dabs(act_2_rdm_trans_spin_trace_mo(i,j,k,l,istate,jstate) - act_2_rdm_trans_spin_trace_mo(j,i,l,k,istate,jstate))
+! endif
+
+ ! 1 2 1 2 1 2 1 2
+! if(dabs(act_2_rdm_trans_spin_trace_mo(i,j,k,l,istate,jstate) - act_2_rdm_trans_spin_trace_mo(k,l,i,j,istate,jstate)).gt.1.d-10)then
+! print*,'Error in act_2_rdm_trans_spin_trace_mo'
+! print*,"dabs(act_2_rdm_trans_spin_trace_mo(i,j,k,l,istate,jstate) - act_2_rdm_trans_spin_trace_mo(k,l,i,j,istate,jstate)).gt.1.d-10"
+! print*,i,j,k,l
+! print*,act_2_rdm_trans_spin_trace_mo(i,j,k,l,istate,jstate),act_2_rdm_trans_spin_trace_mo(k,l,i,j,istate,jstate),dabs(act_2_rdm_trans_spin_trace_mo(i,j,k,l,istate,jstate) - act_2_rdm_trans_spin_trace_mo(k,l,i,j,istate,jstate))
+! endif
+
+ vijkl = get_two_e_integral(lorb,korb,jorb,iorb,mo_integrals_map)
+
+
+ rdm_transtot = act_2_rdm_trans_spin_trace_mo(l,k,j,i,istate,jstate)
+
+ wee_tot(istate,jstate) += 0.5d0 * vijkl * rdm_transtot
+
+ enddo
+ enddo
+ enddo
+ enddo
+ print*,''
+ print*,''
+ print*,'Active space only energy for state ',istate,jstate
+ print*,'wee_tot = ',wee_tot(istate,jstate)
+ print*,'Full energy '
+ print*,'psi_energy_two_e(istate,jstate)= ',psi_energy_two_e_trans(istate,jstate)
+ print*,'--------------------------'
+ enddo
+ enddo
+ print*,'Wee from DM '
+ do istate = 1,N_states
+ write(*,'(100(F16.10,X))')wee_tot(1:N_states,istate)
+ enddo
+ print*,'Wee from Psi det'
+ do istate = 1,N_states
+ write(*,'(100(F16.10,X))')psi_energy_two_e_trans(1:N_states,istate)
+ enddo
+
+end
+
diff --git a/src/two_body_rdm/io_two_rdm.irp.f b/src/two_body_rdm/io_two_rdm.irp.f
index bdd8a4f9..0b30d76f 100644
--- a/src/two_body_rdm/io_two_rdm.irp.f
+++ b/src/two_body_rdm/io_two_rdm.irp.f
@@ -31,3 +31,37 @@ subroutine read_array_two_rdm(n_orb,nstates,array_tmp,name_file)
close(unit=i_unit_output)
end
+
+subroutine write_array_two_trans_rdm(n_orb,nstates,array_tmp,name_file)
+ implicit none
+ integer, intent(in) :: n_orb,nstates
+ character*(128), intent(in) :: name_file
+ double precision, intent(in) :: array_tmp(n_orb,n_orb,n_orb,n_orb,nstates,nstates)
+
+ character*(128) :: output
+ integer :: i_unit_output,getUnitAndOpen
+ PROVIDE ezfio_filename
+ output=trim(ezfio_filename)//'/work/'//trim(name_file)
+ i_unit_output = getUnitAndOpen(output,'W')
+ call lock_io()
+ write(i_unit_output)array_tmp
+ call unlock_io()
+ close(unit=i_unit_output)
+end
+
+subroutine read_array_two_trans_rdm(n_orb,nstates,array_tmp,name_file)
+ implicit none
+ character*(128) :: output
+ integer :: i_unit_output,getUnitAndOpen
+ integer, intent(in) :: n_orb,nstates
+ character*(128), intent(in) :: name_file
+ double precision, intent(out) :: array_tmp(n_orb,n_orb,n_orb,n_orb,N_states,nstates)
+ PROVIDE ezfio_filename
+ output=trim(ezfio_filename)//'/work/'//trim(name_file)
+ i_unit_output = getUnitAndOpen(output,'R')
+ call lock_io()
+ read(i_unit_output)array_tmp
+ call unlock_io()
+ close(unit=i_unit_output)
+end
+
diff --git a/src/two_body_rdm/test_2_rdm.irp.f b/src/two_body_rdm/test_2_rdm.irp.f
index 123261d8..de2606a7 100644
--- a/src/two_body_rdm/test_2_rdm.irp.f
+++ b/src/two_body_rdm/test_2_rdm.irp.f
@@ -4,5 +4,6 @@ program test_2_rdm
touch read_wf
call routine_active_only
call routine_full_mos
+ call routine_active_only_trans
end
diff --git a/src/two_rdm_routines/davidson_like_trans_2rdm.irp.f b/src/two_rdm_routines/davidson_like_trans_2rdm.irp.f
new file mode 100644
index 00000000..9e68a0e1
--- /dev/null
+++ b/src/two_rdm_routines/davidson_like_trans_2rdm.irp.f
@@ -0,0 +1,585 @@
+subroutine orb_range_2_trans_rdm_openmp(big_array,dim1,norb,list_orb,ispin,u_0,N_st,sze)
+ use bitmasks
+ implicit none
+ BEGIN_DOC
+ ! if ispin == 1 :: alpha/alpha 2_rdm
+ ! == 2 :: beta /beta 2_rdm
+ ! == 3 :: alpha/beta + beta/alpha 2trans_rdm
+ ! == 4 :: spin traced 2_rdm :: aa + bb + ab + ba
+ !
+ ! notice that here it is the TRANSITION RDM THAT IS COMPUTED
+ !
+ ! THE DIAGONAL PART IS THE USUAL ONE FOR A GIVEN STATE
+ ! Assumes that the determinants are in psi_det
+ !
+ ! istart, iend, ishift, istep are used in ZMQ parallelization.
+ END_DOC
+ integer, intent(in) :: N_st,sze
+ integer, intent(in) :: dim1,norb,list_orb(norb),ispin
+ double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st,N_st)
+ double precision, intent(in) :: u_0(sze,N_st)
+
+ integer :: k
+ double precision, allocatable :: u_t(:,:)
+ !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t
+ PROVIDE mo_two_e_integrals_in_map
+ allocate(u_t(N_st,N_det))
+ do k=1,N_st
+ call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det)
+ enddo
+ call dtranspose( &
+ u_0, &
+ size(u_0, 1), &
+ u_t, &
+ size(u_t, 1), &
+ N_det, N_st)
+
+ call orb_range_2_trans_rdm_openmp_work(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,1,N_det,0,1)
+ deallocate(u_t)
+
+ do k=1,N_st
+ call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det)
+ enddo
+
+end
+
+subroutine orb_range_2_trans_rdm_openmp_work(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
+ use bitmasks
+ implicit none
+ BEGIN_DOC
+ ! Computes two-trans_rdm
+ !
+ ! Default should be 1,N_det,0,1
+ END_DOC
+ integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
+ integer, intent(in) :: dim1,norb,list_orb(norb),ispin
+ double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st,N_st)
+ double precision, intent(in) :: u_t(N_st,N_det)
+
+ integer :: k
+
+ PROVIDE N_int
+
+ select case (N_int)
+ case (1)
+ call orb_range_2_trans_rdm_openmp_work_1(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
+ case (2)
+ call orb_range_2_trans_rdm_openmp_work_2(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
+ case (3)
+ call orb_range_2_trans_rdm_openmp_work_3(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
+ case (4)
+ call orb_range_2_trans_rdm_openmp_work_4(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
+ case default
+ call orb_range_2_trans_rdm_openmp_work_N_int(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
+ end select
+end
+
+
+ BEGIN_TEMPLATE
+subroutine orb_range_2_trans_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
+ use bitmasks
+ use omp_lib
+ implicit none
+ BEGIN_DOC
+ ! Computes the two trans_rdm for the N_st vectors |u_t>
+ ! if ispin == 1 :: alpha/alpha 2trans_rdm
+ ! == 2 :: beta /beta 2trans_rdm
+ ! == 3 :: alpha/beta 2trans_rdm
+ ! == 4 :: spin traced 2trans_rdm :: aa + bb + 0.5 (ab + ba))
+ ! The 2trans_rdm will be computed only on the list of orbitals list_orb, which contains norb
+ ! Default should be 1,N_det,0,1 for istart,iend,ishift,istep
+ END_DOC
+ integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
+ double precision, intent(in) :: u_t(N_st,N_det)
+ integer, intent(in) :: dim1,norb,list_orb(norb),ispin
+ double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st,N_st)
+
+ integer(omp_lock_kind) :: lock_2trans_rdm
+ integer :: i,j,k,l
+ integer :: k_a, k_b, l_a, l_b
+ integer :: krow, kcol
+ integer :: lrow, lcol
+ integer(bit_kind) :: spindet($N_int)
+ integer(bit_kind) :: tmp_det($N_int,2)
+ integer(bit_kind) :: tmp_det2($N_int,2)
+ integer(bit_kind) :: tmp_det3($N_int,2)
+ integer(bit_kind), allocatable :: buffer(:,:)
+ integer :: n_doubles
+ integer, allocatable :: doubles(:)
+ integer, allocatable :: singles_a(:)
+ integer, allocatable :: singles_b(:)
+ integer, allocatable :: idx(:), idx0(:)
+ integer :: maxab, n_singles_a, n_singles_b, kcol_prev
+
+ logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
+ integer(bit_kind) :: orb_bitmask($N_int)
+ integer :: list_orb_reverse(mo_num)
+ integer, allocatable :: keys(:,:)
+ double precision, allocatable :: values(:,:,:)
+ integer :: nkeys,sze_buff
+ integer :: ll
+ alpha_alpha = .False.
+ beta_beta = .False.
+ alpha_beta = .False.
+ spin_trace = .False.
+ if( ispin == 1)then
+ alpha_alpha = .True.
+ else if(ispin == 2)then
+ beta_beta = .True.
+ else if(ispin == 3)then
+ alpha_beta = .True.
+ else if(ispin == 4)then
+ spin_trace = .True.
+ else
+ print*,'Wrong parameter for ispin in general_2_trans_rdm_state_av_openmp_work'
+ print*,'ispin = ',ispin
+ stop
+ endif
+
+
+ PROVIDE N_int
+
+ call list_to_bitstring( orb_bitmask, list_orb, norb, N_int)
+ sze_buff = 6 * norb + elec_alpha_num * elec_alpha_num * 60
+ list_orb_reverse = -1000
+ do i = 1, norb
+ list_orb_reverse(list_orb(i)) = i
+ enddo
+ maxab = max(N_det_alpha_unique, N_det_beta_unique)+1
+ allocate(idx0(maxab))
+
+ do i=1,maxab
+ idx0(i) = i
+ enddo
+ call omp_init_lock(lock_2trans_rdm)
+
+ ! Prepare the array of all alpha single excitations
+ ! -------------------------------------------------
+
+ PROVIDE N_int nthreads_davidson elec_alpha_num
+ !$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson) &
+ !$OMP SHARED(psi_bilinear_matrix_rows, N_det,lock_2trans_rdm,&
+ !$OMP psi_bilinear_matrix_columns, &
+ !$OMP psi_det_alpha_unique, psi_det_beta_unique,&
+ !$OMP n_det_alpha_unique, n_det_beta_unique, N_int,&
+ !$OMP psi_bilinear_matrix_transp_rows, &
+ !$OMP psi_bilinear_matrix_transp_columns, &
+ !$OMP psi_bilinear_matrix_transp_order, N_st, &
+ !$OMP psi_bilinear_matrix_order_transp_reverse, &
+ !$OMP psi_bilinear_matrix_columns_loc, &
+ !$OMP psi_bilinear_matrix_transp_rows_loc,elec_alpha_num, &
+ !$OMP istart, iend, istep, irp_here,list_orb_reverse, n_states, dim1, &
+ !$OMP ishift, idx0, u_t, maxab, alpha_alpha,beta_beta,alpha_beta,spin_trace,ispin,big_array,sze_buff,orb_bitmask) &
+ !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i,c_1, &
+ !$OMP lcol, lrow, l_a, l_b, &
+ !$OMP buffer, doubles, n_doubles, &
+ !$OMP tmp_det2, idx, l, kcol_prev, &
+ !$OMP singles_a, n_singles_a, singles_b, &
+ !$OMP n_singles_b, nkeys, keys, values)
+
+ ! Alpha/Beta double excitations
+ ! =============================
+ nkeys = 0
+ allocate( keys(4,sze_buff), values(n_st,n_st,sze_buff))
+ allocate( buffer($N_int,maxab), &
+ singles_a(maxab), &
+ singles_b(maxab), &
+ doubles(maxab), &
+ idx(maxab))
+
+ kcol_prev=-1
+
+ ASSERT (iend <= N_det)
+ ASSERT (istart > 0)
+ ASSERT (istep > 0)
+
+ !$OMP DO SCHEDULE(dynamic,64)
+ do k_a=istart+ishift,iend,istep
+
+ krow = psi_bilinear_matrix_rows(k_a)
+ ASSERT (krow <= N_det_alpha_unique)
+
+ kcol = psi_bilinear_matrix_columns(k_a)
+ ASSERT (kcol <= N_det_beta_unique)
+
+ tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
+ tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
+
+ if (kcol /= kcol_prev) then
+ call get_all_spin_singles_$N_int( &
+ psi_det_beta_unique, idx0, &
+ tmp_det(1,2), N_det_beta_unique, &
+ singles_b, n_singles_b)
+ endif
+ kcol_prev = kcol
+
+ ! Loop over singly excited beta columns
+ ! -------------------------------------
+
+ do i=1,n_singles_b
+ lcol = singles_b(i)
+
+ tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol)
+
+ l_a = psi_bilinear_matrix_columns_loc(lcol)
+ ASSERT (l_a <= N_det)
+
+ do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - l_a
+ lrow = psi_bilinear_matrix_rows(l_a)
+ ASSERT (lrow <= N_det_alpha_unique)
+
+ buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow)
+
+ ASSERT (l_a <= N_det)
+ idx(j) = l_a
+ l_a = l_a+1
+ enddo
+ j = j-1
+
+ call get_all_spin_singles_$N_int( &
+ buffer, idx, tmp_det(1,1), j, &
+ singles_a, n_singles_a )
+
+ ! Loop over alpha singles
+ ! -----------------------
+
+ if(alpha_beta.or.spin_trace)then
+ do k = 1,n_singles_a
+ l_a = singles_a(k)
+ ASSERT (l_a <= N_det)
+
+ lrow = psi_bilinear_matrix_rows(l_a)
+ ASSERT (lrow <= N_det_alpha_unique)
+
+ tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
+! print*,'nkeys before = ',nkeys
+ do ll = 1, N_states
+ do l= 1, N_states
+ c_1(l,ll) = u_t(ll,l_a) * u_t(l,k_a)
+ enddo
+ enddo
+ if(alpha_beta)then
+ ! only ONE contribution
+ if (nkeys+1 .ge. sze_buff) then
+ call update_keys_values_n_states_trans(keys,values,nkeys,dim1,n_st,big_array,lock_2trans_rdm)
+ nkeys = 0
+ endif
+ else if (spin_trace)then
+ ! TWO contributions
+ if (nkeys+2 .ge. sze_buff) then
+ call update_keys_values_n_states_trans(keys,values,nkeys,dim1,n_st,big_array,lock_2trans_rdm)
+ nkeys = 0
+ endif
+ endif
+ call orb_range_off_diag_double_to_all_states_ab_trans_rdm_buffer(tmp_det,tmp_det2,c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
+
+ enddo
+ endif
+
+ call update_keys_values_n_states_trans(keys,values,nkeys,dim1,n_st,big_array,lock_2trans_rdm)
+ nkeys = 0
+ enddo
+
+ enddo
+ !$OMP END DO
+
+ !$OMP DO SCHEDULE(dynamic,64)
+ do k_a=istart+ishift,iend,istep
+
+
+ ! Single and double alpha exitations
+ ! ===================================
+
+
+ ! Initial determinant is at k_a in alpha-major representation
+ ! -----------------------------------------------------------------------
+
+ krow = psi_bilinear_matrix_rows(k_a)
+ ASSERT (krow <= N_det_alpha_unique)
+
+ kcol = psi_bilinear_matrix_columns(k_a)
+ ASSERT (kcol <= N_det_beta_unique)
+
+ tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
+ tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
+
+ ! Initial determinant is at k_b in beta-major representation
+ ! ----------------------------------------------------------------------
+
+ k_b = psi_bilinear_matrix_order_transp_reverse(k_a)
+ ASSERT (k_b <= N_det)
+
+ spindet(1:$N_int) = tmp_det(1:$N_int,1)
+
+ ! Loop inside the beta column to gather all the connected alphas
+ lcol = psi_bilinear_matrix_columns(k_a)
+ l_a = psi_bilinear_matrix_columns_loc(lcol)
+ do i=1,N_det_alpha_unique
+ if (l_a > N_det) exit
+ lcol = psi_bilinear_matrix_columns(l_a)
+ if (lcol /= kcol) exit
+ lrow = psi_bilinear_matrix_rows(l_a)
+ ASSERT (lrow <= N_det_alpha_unique)
+
+ buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow)
+ idx(i) = l_a
+ l_a = l_a+1
+ enddo
+ i = i-1
+
+ call get_all_spin_singles_and_doubles_$N_int( &
+ buffer, idx, spindet, i, &
+ singles_a, doubles, n_singles_a, n_doubles )
+
+ ! Compute Hij for all alpha singles
+ ! ----------------------------------
+
+ tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
+ do i=1,n_singles_a
+ l_a = singles_a(i)
+ ASSERT (l_a <= N_det)
+
+ lrow = psi_bilinear_matrix_rows(l_a)
+ ASSERT (lrow <= N_det_alpha_unique)
+
+ tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
+ do ll= 1, N_states
+ do l= 1, N_states
+ c_1(l,ll) = u_t(ll,l_a) * u_t(l,k_a)
+ enddo
+ enddo
+ if(alpha_beta.or.spin_trace.or.alpha_alpha)then
+ ! increment the alpha/beta part for single excitations
+ if (nkeys+ 2 * elec_alpha_num .ge. sze_buff) then
+ call update_keys_values_n_states_trans(keys,values,nkeys,dim1,n_st,big_array,lock_2trans_rdm)
+ nkeys = 0
+ endif
+ call orb_range_off_diag_single_to_all_states_ab_trans_rdm_buffer(tmp_det, tmp_det2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
+ ! increment the alpha/alpha part for single excitations
+ if (nkeys+4 * elec_alpha_num .ge. sze_buff ) then
+ call update_keys_values_n_states_trans(keys,values,nkeys,dim1,n_st,big_array,lock_2trans_rdm)
+ nkeys = 0
+ endif
+ call orb_range_off_diag_single_to_all_states_aa_trans_rdm_buffer(tmp_det,tmp_det2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
+ endif
+
+ enddo
+
+ call update_keys_values_n_states_trans(keys,values,nkeys,dim1,n_st,big_array,lock_2trans_rdm)
+ nkeys = 0
+
+ ! Compute Hij for all alpha doubles
+ ! ----------------------------------
+
+ if(alpha_alpha.or.spin_trace)then
+ do i=1,n_doubles
+ l_a = doubles(i)
+ ASSERT (l_a <= N_det)
+
+ lrow = psi_bilinear_matrix_rows(l_a)
+ ASSERT (lrow <= N_det_alpha_unique)
+
+ do ll= 1, N_states
+ do l= 1, N_states
+ c_1(l,ll) = u_t(ll,l_a) * u_t(l,k_a)
+ enddo
+ enddo
+ if (nkeys+4 .ge. sze_buff) then
+ call update_keys_values_n_states_trans(keys,values,nkeys,dim1,n_st,big_array,lock_2trans_rdm)
+ nkeys = 0
+ endif
+ call orb_range_off_diag_double_to_all_states_aa_trans_rdm_buffer(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
+ enddo
+ endif
+ call update_keys_values_n_states_trans(keys,values,nkeys,dim1,n_st,big_array,lock_2trans_rdm)
+ nkeys = 0
+
+
+ ! Single and double beta excitations
+ ! ==================================
+
+
+ ! Initial determinant is at k_a in alpha-major representation
+ ! -----------------------------------------------------------------------
+
+ krow = psi_bilinear_matrix_rows(k_a)
+ kcol = psi_bilinear_matrix_columns(k_a)
+
+ tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
+ tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
+
+ spindet(1:$N_int) = tmp_det(1:$N_int,2)
+
+ ! Initial determinant is at k_b in beta-major representation
+ ! -----------------------------------------------------------------------
+
+ k_b = psi_bilinear_matrix_order_transp_reverse(k_a)
+ ASSERT (k_b <= N_det)
+
+ ! Loop inside the alpha row to gather all the connected betas
+ lrow = psi_bilinear_matrix_transp_rows(k_b)
+ l_b = psi_bilinear_matrix_transp_rows_loc(lrow)
+ do i=1,N_det_beta_unique
+ if (l_b > N_det) exit
+ lrow = psi_bilinear_matrix_transp_rows(l_b)
+ if (lrow /= krow) exit
+ lcol = psi_bilinear_matrix_transp_columns(l_b)
+ ASSERT (lcol <= N_det_beta_unique)
+
+ buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol)
+ idx(i) = l_b
+ l_b = l_b+1
+ enddo
+ i = i-1
+
+ call get_all_spin_singles_and_doubles_$N_int( &
+ buffer, idx, spindet, i, &
+ singles_b, doubles, n_singles_b, n_doubles )
+
+ ! Compute Hij for all beta singles
+ ! ----------------------------------
+
+ tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
+ do i=1,n_singles_b
+ l_b = singles_b(i)
+ ASSERT (l_b <= N_det)
+
+ lcol = psi_bilinear_matrix_transp_columns(l_b)
+ ASSERT (lcol <= N_det_beta_unique)
+
+ tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol)
+ l_a = psi_bilinear_matrix_transp_order(l_b)
+ do ll= 1, N_states
+ do l= 1, N_states
+ c_1(l,ll) = u_t(ll,l_a) * u_t(l,k_a)
+ enddo
+ enddo
+ if(alpha_beta.or.spin_trace.or.beta_beta)then
+ ! increment the alpha/beta part for single excitations
+ if (nkeys+2 * elec_alpha_num .ge. sze_buff ) then
+ call update_keys_values_n_states_trans(keys,values,nkeys,dim1,n_st,big_array,lock_2trans_rdm)
+ nkeys = 0
+ endif
+ call orb_range_off_diag_single_to_all_states_ab_trans_rdm_buffer(tmp_det, tmp_det2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
+ ! increment the beta /beta part for single excitations
+ if (nkeys+4 * elec_alpha_num .ge. sze_buff) then
+ call update_keys_values_n_states_trans(keys,values,nkeys,dim1,n_st,big_array,lock_2trans_rdm)
+ nkeys = 0
+ endif
+ call orb_range_off_diag_single_to_all_states_bb_trans_rdm_buffer(tmp_det, tmp_det2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
+ endif
+ enddo
+ call update_keys_values_n_states_trans(keys,values,nkeys,dim1,n_st,big_array,lock_2trans_rdm)
+ nkeys = 0
+
+ ! Compute Hij for all beta doubles
+ ! ----------------------------------
+
+ if(beta_beta.or.spin_trace)then
+ do i=1,n_doubles
+ l_b = doubles(i)
+ ASSERT (l_b <= N_det)
+
+ lcol = psi_bilinear_matrix_transp_columns(l_b)
+ ASSERT (lcol <= N_det_beta_unique)
+
+ l_a = psi_bilinear_matrix_transp_order(l_b)
+ do ll= 1, N_states
+ do l= 1, N_states
+ c_1(l,ll) = u_t(ll,l_a) * u_t(l,k_a)
+ enddo
+ enddo
+ if (nkeys+4 .ge. sze_buff) then
+ call update_keys_values_n_states_trans(keys,values,nkeys,dim1,n_st,big_array,lock_2trans_rdm)
+ nkeys = 0
+ endif
+ call orb_range_off_diag_double_to_all_states_trans_rdm_bb_buffer(tmp_det(1,2),psi_det_beta_unique(1, lcol),c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
+! print*,'to do orb_range_off_diag_double_to_2_trans_rdm_bb_dm_buffer'
+ ASSERT (l_a <= N_det)
+
+ enddo
+ endif
+ call update_keys_values_n_states_trans(keys,values,nkeys,dim1,n_st,big_array,lock_2trans_rdm)
+ nkeys = 0
+
+
+ ! Diagonal contribution
+ ! =====================
+
+
+ ! Initial determinant is at k_a in alpha-major representation
+ ! -----------------------------------------------------------------------
+
+ krow = psi_bilinear_matrix_rows(k_a)
+ ASSERT (krow <= N_det_alpha_unique)
+
+ kcol = psi_bilinear_matrix_columns(k_a)
+ ASSERT (kcol <= N_det_beta_unique)
+
+ tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
+ tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
+
+ double precision, external :: diag_wee_mat_elem, diag_S_mat_elem
+
+ double precision :: c_1(N_states,N_states)
+ do ll = 1, N_states
+ do l = 1, N_states
+ c_1(l,ll) = u_t(ll,k_a) * u_t(l,k_a)
+ enddo
+ enddo
+
+ call update_keys_values_n_states_trans(keys,values,nkeys,dim1,n_st,big_array,lock_2trans_rdm)
+ nkeys = 0
+ call orb_range_diag_to_all_states_2_rdm_trans_buffer(tmp_det,c_1,N_states,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
+ call update_keys_values_n_states_trans(keys,values,nkeys,dim1,n_st,big_array,lock_2trans_rdm)
+ nkeys = 0
+
+ end do
+ !$OMP END DO
+ deallocate(buffer, singles_a, singles_b, doubles, idx, keys, values)
+ !$OMP END PARALLEL
+
+end
+
+ SUBST [ N_int ]
+
+ 1;;
+ 2;;
+ 3;;
+ 4;;
+ N_int;;
+
+ END_TEMPLATE
+
+subroutine update_keys_values_n_states_trans(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
+ use omp_lib
+ implicit none
+ integer, intent(in) :: n_st,nkeys,dim1
+ integer, intent(in) :: keys(4,nkeys)
+ double precision, intent(in) :: values(n_st,n_st,nkeys)
+ double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,n_st,n_st)
+
+ integer(omp_lock_kind),intent(inout):: lock_2rdm
+
+ integer :: i,h1,h2,p1,p2,istate,jstate
+ call omp_set_lock(lock_2rdm)
+
+! print*,'*************'
+! print*,'updating'
+! print*,'nkeys',nkeys
+ do i = 1, nkeys
+ h1 = keys(1,i)
+ h2 = keys(2,i)
+ p1 = keys(3,i)
+ p2 = keys(4,i)
+ do jstate = 1, N_st
+ do istate = 1, N_st
+!! print*,h1,h2,p1,p2,values(istate,i)
+ big_array(h1,h2,p1,p2,istate,jstate) += values(istate,jstate,i)
+ enddo
+ enddo
+ enddo
+ call omp_unset_lock(lock_2rdm)
+
+end
+
diff --git a/src/two_rdm_routines/update_trans_rdm.irp.f b/src/two_rdm_routines/update_trans_rdm.irp.f
new file mode 100644
index 00000000..9f7077a2
--- /dev/null
+++ b/src/two_rdm_routines/update_trans_rdm.irp.f
@@ -0,0 +1,1002 @@
+ subroutine orb_range_diag_to_all_states_2_rdm_trans_buffer(det_1,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
+ use bitmasks
+ BEGIN_DOC
+ ! routine that update the DIAGONAL PART of the two body trans_rdms in a specific range of orbitals for a given determinant det_1
+ !
+ ! c_1 is the array of the contributions to the trans_rdm for all states
+ !
+ ! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
+ !
+ ! ispin determines which spin-spin component of the two-trans_rdm you will update
+ !
+ ! ispin == 1 :: alpha/ alpha
+ ! ispin == 2 :: beta / beta
+ ! ispin == 3 :: alpha/ beta
+ ! ispin == 4 :: spin traced <=> total two-trans_rdm
+ END_DOC
+ implicit none
+ integer, intent(in) :: ispin,sze_buff,N_st
+ integer, intent(in) :: list_orb_reverse(mo_num)
+ integer(bit_kind), intent(in) :: det_1(N_int,2)
+ integer(bit_kind), intent(in) :: orb_bitmask(N_int)
+ double precision, intent(in) :: c_1(N_st,N_st)
+ double precision, intent(out) :: values(N_st,N_st,sze_buff)
+ integer , intent(out) :: keys(4,sze_buff)
+ integer , intent(inout):: nkeys
+
+ integer :: occ(N_int*bit_kind_size,2)
+ integer :: n_occ_ab(2)
+ integer :: i,j,h1,h2
+ integer(bit_kind) :: det_1_act(N_int,2)
+ logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
+ do i = 1, N_int
+ det_1_act(i,1) = iand(det_1(i,1),orb_bitmask(i))
+ det_1_act(i,2) = iand(det_1(i,2),orb_bitmask(i))
+ enddo
+
+ alpha_alpha = .False.
+ beta_beta = .False.
+ alpha_beta = .False.
+ spin_trace = .False.
+ if( ispin == 1)then
+ alpha_alpha = .True.
+ else if(ispin == 2)then
+ beta_beta = .True.
+ else if(ispin == 3)then
+ alpha_beta = .True.
+ else if(ispin == 4)then
+ spin_trace = .True.
+ endif
+ call bitstring_to_list_ab(det_1_act, occ, n_occ_ab, N_int)
+ logical :: is_integer_in_string
+ integer :: i1,i2,istate
+ integer :: jstate
+ if(alpha_beta)then
+ do i = 1, n_occ_ab(1)
+ i1 = occ(i,1)
+ do j = 1, n_occ_ab(2)
+ i2 = occ(j,2)
+ h1 = list_orb_reverse(i1)
+ h2 = list_orb_reverse(i2)
+ ! If alpha/beta, electron 1 is alpha, electron 2 is beta
+ ! Therefore you don't necessayr have symmetry between electron 1 and 2
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate)
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = h1
+ keys(4,nkeys) = h2
+
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate)
+ enddo
+ enddo
+ keys(1,nkeys) = h2
+ keys(2,nkeys) = h1
+ keys(3,nkeys) = h2
+ keys(4,nkeys) = h1
+ enddo
+ enddo
+
+ else if (alpha_alpha)then
+ do i = 1, n_occ_ab(1)
+ i1 = occ(i,1)
+ do j = 1, n_occ_ab(1)
+ i2 = occ(j,1)
+ h1 = list_orb_reverse(i1)
+ h2 = list_orb_reverse(i2)
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate)
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = h1
+ keys(4,nkeys) = h2
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = -0.5d0 * c_1(istate,jstate)
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = h2
+ keys(4,nkeys) = h1
+ enddo
+ enddo
+ else if (beta_beta)then
+ do i = 1, n_occ_ab(2)
+ i1 = occ(i,2)
+ do j = 1, n_occ_ab(2)
+ i2 = occ(j,2)
+ h1 = list_orb_reverse(i1)
+ h2 = list_orb_reverse(i2)
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate)
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = h1
+ keys(4,nkeys) = h2
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = -0.5d0 * c_1(istate,jstate)
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = h2
+ keys(4,nkeys) = h1
+ enddo
+ enddo
+ else if(spin_trace)then
+ ! 0.5 * (alpha beta + beta alpha)
+ do i = 1, n_occ_ab(1)
+ i1 = occ(i,1)
+ do j = 1, n_occ_ab(2)
+ i2 = occ(j,2)
+ h1 = list_orb_reverse(i1)
+ h2 = list_orb_reverse(i2)
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate)
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = h1
+ keys(4,nkeys) = h2
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate)
+ enddo
+ enddo
+ keys(1,nkeys) = h2
+ keys(2,nkeys) = h1
+ keys(3,nkeys) = h2
+ keys(4,nkeys) = h1
+ enddo
+ enddo
+ do i = 1, n_occ_ab(1)
+ i1 = occ(i,1)
+ do j = 1, n_occ_ab(1)
+ i2 = occ(j,1)
+ h1 = list_orb_reverse(i1)
+ h2 = list_orb_reverse(i2)
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate)
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = h1
+ keys(4,nkeys) = h2
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = -0.5d0 * c_1(istate,jstate)
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = h2
+ keys(4,nkeys) = h1
+ enddo
+ enddo
+ do i = 1, n_occ_ab(2)
+ i1 = occ(i,2)
+ do j = 1, n_occ_ab(2)
+ i2 = occ(j,2)
+ h1 = list_orb_reverse(i1)
+ h2 = list_orb_reverse(i2)
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate)
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = h1
+ keys(4,nkeys) = h2
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = -0.5d0 * c_1(istate,jstate)
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = h2
+ keys(4,nkeys) = h1
+ enddo
+ enddo
+ endif
+ end
+
+
+ subroutine orb_range_off_diag_double_to_all_states_ab_trans_rdm_buffer(det_1,det_2,c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
+ use bitmasks
+ BEGIN_DOC
+! routine that update the OFF DIAGONAL PART of the two body trans_rdms in a specific range of orbitals for
+!
+! a given couple of determinant det_1, det_2 being a alpha/beta DOUBLE excitation with respect to one another
+!
+! c_1 is the array of the contributions to the trans_rdm for all states
+!
+! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
+!
+! ispin determines which spin-spin component of the two-trans_rdm you will update
+!
+! ispin == 1 :: alpha/ alpha
+! ispin == 2 :: beta / beta
+! ispin == 3 :: alpha/ beta
+! ispin == 4 :: spin traced <=> total two-trans_rdm
+!
+! here, only ispin == 3 or 4 will do something
+ END_DOC
+ implicit none
+ integer, intent(in) :: ispin,sze_buff,N_st
+ integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
+ integer, intent(in) :: list_orb_reverse(mo_num)
+ double precision, intent(in) :: c_1(N_st,N_st)
+ double precision, intent(out) :: values(N_st,N_st,sze_buff)
+ integer , intent(out) :: keys(4,sze_buff)
+ integer , intent(inout):: nkeys
+ integer :: i,j,h1,h2,p1,p2,istate
+ integer :: exc(0:2,2,2)
+ double precision :: phase
+ logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
+ logical :: is_integer_in_string
+ integer :: jstate
+ alpha_alpha = .False.
+ beta_beta = .False.
+ alpha_beta = .False.
+ spin_trace = .False.
+ if( ispin == 1)then
+ alpha_alpha = .True.
+ else if(ispin == 2)then
+ beta_beta = .True.
+ else if(ispin == 3)then
+ alpha_beta = .True.
+ else if(ispin == 4)then
+ spin_trace = .True.
+ endif
+ call get_double_excitation(det_1,det_2,exc,phase,N_int)
+ h1 = exc(1,1,1)
+ if(list_orb_reverse(h1).lt.0)return
+ h1 = list_orb_reverse(h1)
+ h2 = exc(1,1,2)
+ if(list_orb_reverse(h2).lt.0)return
+ h2 = list_orb_reverse(h2)
+ p1 = exc(1,2,1)
+ if(list_orb_reverse(p1).lt.0)return
+ p1 = list_orb_reverse(p1)
+ p2 = exc(1,2,2)
+ if(list_orb_reverse(p2).lt.0)return
+ p2 = list_orb_reverse(p2)
+ if(alpha_beta)then
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = p1
+ keys(4,nkeys) = p2
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h2
+ keys(2,nkeys) = h1
+ keys(3,nkeys) = p2
+ keys(4,nkeys) = p1
+ else if(spin_trace)then
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = p1
+ keys(4,nkeys) = p2
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h2
+ keys(2,nkeys) = h1
+ keys(3,nkeys) = p2
+ keys(4,nkeys) = p1
+ endif
+ end
+
+ subroutine orb_range_off_diag_single_to_all_states_ab_trans_rdm_buffer(det_1,det_2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
+ use bitmasks
+ BEGIN_DOC
+ ! routine that update the OFF DIAGONAL PART of the two body trans_rdms in a specific range of orbitals for
+ !
+ ! a given couple of determinant det_1, det_2 being a SINGLE excitation with respect to one another
+ !
+ ! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
+ !
+ ! big_array(dim1,dim1,dim1,dim1) is the two-body trans_rdm to be updated in physicist notation
+ !
+ ! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
+ !
+ ! ispin determines which spin-spin component of the two-trans_rdm you will update
+ !
+ ! ispin == 1 :: alpha/ alpha
+ ! ispin == 2 :: beta / beta
+ ! ispin == 3 :: alpha/ beta
+ ! ispin == 4 :: spin traced <=> total two-trans_rdm
+ !
+ ! here, only ispin == 3 or 4 will do something
+ END_DOC
+ implicit none
+ integer, intent(in) :: ispin,sze_buff,N_st
+ integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
+ integer, intent(in) :: list_orb_reverse(mo_num)
+ integer(bit_kind), intent(in) :: orb_bitmask(N_int)
+ double precision, intent(in) :: c_1(N_st,N_st)
+ double precision, intent(out) :: values(N_st,N_st,sze_buff)
+ integer , intent(out) :: keys(4,sze_buff)
+ integer , intent(inout):: nkeys
+
+ integer :: jstate
+ integer :: occ(N_int*bit_kind_size,2)
+ integer :: n_occ_ab(2)
+ integer :: i,j,h1,h2,p1,istate
+ integer :: exc(0:2,2,2)
+ double precision :: phase
+
+ logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
+ logical :: is_integer_in_string
+ alpha_alpha = .False.
+ beta_beta = .False.
+ alpha_beta = .False.
+ spin_trace = .False.
+ if( ispin == 1)then
+ alpha_alpha = .True.
+ else if(ispin == 2)then
+ beta_beta = .True.
+ else if(ispin == 3)then
+ alpha_beta = .True.
+ else if(ispin == 4)then
+ spin_trace = .True.
+ endif
+
+ call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
+ call get_single_excitation(det_1,det_2,exc,phase,N_int)
+ if(alpha_beta)then
+ if (exc(0,1,1) == 1) then
+ ! Mono alpha
+ h1 = exc(1,1,1)
+ if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
+ h1 = list_orb_reverse(h1)
+ p1 = exc(1,2,1)
+ if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
+ p1 = list_orb_reverse(p1)
+ do i = 1, n_occ_ab(2)
+ h2 = occ(i,2)
+ if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
+ h2 = list_orb_reverse(h2)
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = p1
+ keys(4,nkeys) = h2
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h2
+ keys(2,nkeys) = h1
+ keys(3,nkeys) = h2
+ keys(4,nkeys) = p1
+ enddo
+ else
+ ! Mono beta
+ h1 = exc(1,1,2)
+ if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
+ h1 = list_orb_reverse(h1)
+ p1 = exc(1,2,2)
+ if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
+ p1 = list_orb_reverse(p1)
+ do i = 1, n_occ_ab(1)
+ h2 = occ(i,1)
+ if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
+ h2 = list_orb_reverse(h2)
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = p1
+ keys(4,nkeys) = h2
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h2
+ keys(2,nkeys) = h1
+ keys(3,nkeys) = h2
+ keys(4,nkeys) = p1
+ enddo
+ endif
+ else if(spin_trace)then
+ if (exc(0,1,1) == 1) then
+ ! Mono alpha
+ h1 = exc(1,1,1)
+ if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
+ h1 = list_orb_reverse(h1)
+ p1 = exc(1,2,1)
+ if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
+ p1 = list_orb_reverse(p1)
+ do i = 1, n_occ_ab(2)
+ h2 = occ(i,2)
+ if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
+ h2 = list_orb_reverse(h2)
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = p1
+ keys(4,nkeys) = h2
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h2
+ keys(2,nkeys) = h1
+ keys(3,nkeys) = h2
+ keys(4,nkeys) = p1
+ enddo
+ else
+ ! Mono beta
+ h1 = exc(1,1,2)
+ if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
+ h1 = list_orb_reverse(h1)
+ p1 = exc(1,2,2)
+ if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
+ p1 = list_orb_reverse(p1)
+ do i = 1, n_occ_ab(1)
+ h2 = occ(i,1)
+ if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
+ h2 = list_orb_reverse(h2)
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = p1
+ keys(4,nkeys) = h2
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h2
+ keys(2,nkeys) = h1
+ keys(3,nkeys) = h2
+ keys(4,nkeys) = p1
+ enddo
+ endif
+ endif
+ end
+
+ subroutine orb_range_off_diag_single_to_all_states_aa_trans_rdm_buffer(det_1,det_2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
+ BEGIN_DOC
+ ! routine that update the OFF DIAGONAL PART of the two body trans_rdms in a specific range of orbitals for
+ !
+ ! a given couple of determinant det_1, det_2 being a ALPHA SINGLE excitation with respect to one another
+ !
+ ! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
+ !
+ ! big_array(dim1,dim1,dim1,dim1) is the two-body trans_rdm to be updated in physicist notation
+ !
+ ! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
+ !
+ ! ispin determines which spin-spin component of the two-trans_rdm you will update
+ !
+ ! ispin == 1 :: alpha/ alpha
+ ! ispin == 2 :: beta / beta
+ ! ispin == 3 :: alpha/ beta
+ ! ispin == 4 :: spin traced <=> total two-trans_rdm
+ !
+ ! here, only ispin == 1 or 4 will do something
+ END_DOC
+ use bitmasks
+ implicit none
+ integer, intent(in) :: ispin,sze_buff,N_st
+ integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
+ integer, intent(in) :: list_orb_reverse(mo_num)
+ integer(bit_kind), intent(in) :: orb_bitmask(N_int)
+ double precision, intent(in) :: c_1(N_st,N_st)
+ double precision, intent(out) :: values(N_st,N_st,sze_buff)
+ integer , intent(out) :: keys(4,sze_buff)
+ integer , intent(inout):: nkeys
+
+ integer :: jstate
+ integer :: occ(N_int*bit_kind_size,2)
+ integer :: n_occ_ab(2)
+ integer :: i,j,h1,h2,p1,istate
+ integer :: exc(0:2,2,2)
+ double precision :: phase
+
+ logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
+ logical :: is_integer_in_string
+ alpha_alpha = .False.
+ beta_beta = .False.
+ alpha_beta = .False.
+ spin_trace = .False.
+ if( ispin == 1)then
+ alpha_alpha = .True.
+ else if(ispin == 2)then
+ beta_beta = .True.
+ else if(ispin == 3)then
+ alpha_beta = .True.
+ else if(ispin == 4)then
+ spin_trace = .True.
+ endif
+
+ call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
+ call get_single_excitation(det_1,det_2,exc,phase,N_int)
+ if(alpha_alpha.or.spin_trace)then
+ if (exc(0,1,1) == 1) then
+ ! Mono alpha
+ h1 = exc(1,1,1)
+ if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
+ h1 = list_orb_reverse(h1)
+ p1 = exc(1,2,1)
+ if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
+ p1 = list_orb_reverse(p1)
+ do i = 1, n_occ_ab(1)
+ h2 = occ(i,1)
+ if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
+ h2 = list_orb_reverse(h2)
+
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = p1
+ keys(4,nkeys) = h2
+
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = - 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = h2
+ keys(4,nkeys) = p1
+
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h2
+ keys(2,nkeys) = h1
+ keys(3,nkeys) = h2
+ keys(4,nkeys) = p1
+
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = - 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h2
+ keys(2,nkeys) = h1
+ keys(3,nkeys) = p1
+ keys(4,nkeys) = h2
+ enddo
+ else
+ return
+ endif
+ endif
+ end
+
+ subroutine orb_range_off_diag_single_to_all_states_bb_trans_rdm_buffer(det_1,det_2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
+ use bitmasks
+ BEGIN_DOC
+ ! routine that update the OFF DIAGONAL PART of the two body trans_rdms in a specific range of orbitals for
+ !
+ ! a given couple of determinant det_1, det_2 being a BETA SINGLE excitation with respect to one another
+ !
+ ! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
+ !
+ ! big_array(dim1,dim1,dim1,dim1) is the two-body trans_rdm to be updated in physicist notation
+ !
+ ! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
+ !
+ ! ispin determines which spin-spin component of the two-trans_rdm you will update
+ !
+ ! ispin == 1 :: alpha/ alpha
+ ! ispin == 2 :: beta / beta
+ ! ispin == 3 :: alpha/ beta
+ ! ispin == 4 :: spin traced <=> total two-trans_rdm
+ !
+ ! here, only ispin == 2 or 4 will do something
+ END_DOC
+ implicit none
+ integer, intent(in) :: ispin,sze_buff,N_st
+ integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
+ integer, intent(in) :: list_orb_reverse(mo_num)
+ integer(bit_kind), intent(in) :: orb_bitmask(N_int)
+ double precision, intent(in) :: c_1(N_st,N_st)
+ double precision, intent(out) :: values(N_st,N_st,sze_buff)
+ integer , intent(out) :: keys(4,sze_buff)
+ integer , intent(inout):: nkeys
+
+ integer :: jstate
+ integer :: occ(N_int*bit_kind_size,2)
+ integer :: n_occ_ab(2)
+ integer :: i,j,h1,h2,p1,istate
+ integer :: exc(0:2,2,2)
+ double precision :: phase
+ logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
+ logical :: is_integer_in_string
+ alpha_alpha = .False.
+ beta_beta = .False.
+ alpha_beta = .False.
+ spin_trace = .False.
+ if( ispin == 1)then
+ alpha_alpha = .True.
+ else if(ispin == 2)then
+ beta_beta = .True.
+ else if(ispin == 3)then
+ alpha_beta = .True.
+ else if(ispin == 4)then
+ spin_trace = .True.
+ endif
+
+
+ call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
+ call get_single_excitation(det_1,det_2,exc,phase,N_int)
+ if(beta_beta.or.spin_trace)then
+ if (exc(0,1,1) == 1) then
+ return
+ else
+ ! Mono beta
+ h1 = exc(1,1,2)
+ if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
+ h1 = list_orb_reverse(h1)
+ p1 = exc(1,2,2)
+ if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
+ p1 = list_orb_reverse(p1)
+ do i = 1, n_occ_ab(2)
+ h2 = occ(i,2)
+ if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
+ h2 = list_orb_reverse(h2)
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = p1
+ keys(4,nkeys) = h2
+
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = - 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = h2
+ keys(4,nkeys) = p1
+
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h2
+ keys(2,nkeys) = h1
+ keys(3,nkeys) = h2
+ keys(4,nkeys) = p1
+
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = - 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h2
+ keys(2,nkeys) = h1
+ keys(3,nkeys) = p1
+ keys(4,nkeys) = h2
+ enddo
+ endif
+ endif
+ end
+
+
+ subroutine orb_range_off_diag_double_to_all_states_aa_trans_rdm_buffer(det_1,det_2,c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
+ use bitmasks
+ BEGIN_DOC
+ ! routine that update the OFF DIAGONAL PART of the two body trans_rdms in a specific range of orbitals for
+ !
+ ! a given couple of determinant det_1, det_2 being a ALPHA/ALPHA DOUBLE excitation with respect to one another
+ !
+ ! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
+ !
+ ! big_array(dim1,dim1,dim1,dim1) is the two-body trans_rdm to be updated in physicist notation
+ !
+ ! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
+ !
+ ! ispin determines which spin-spin component of the two-trans_rdm you will update
+ !
+ ! ispin == 1 :: alpha/ alpha
+ ! ispin == 2 :: beta / beta
+ ! ispin == 3 :: alpha/ beta
+ ! ispin == 4 :: spin traced <=> total two-trans_rdm
+ !
+ ! here, only ispin == 1 or 4 will do something
+ END_DOC
+ implicit none
+ integer, intent(in) :: ispin,sze_buff,N_st
+ integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int)
+ integer, intent(in) :: list_orb_reverse(mo_num)
+ double precision, intent(in) :: c_1(N_st,N_st)
+ double precision, intent(out) :: values(N_st,N_st,sze_buff)
+ integer , intent(out) :: keys(4,sze_buff)
+ integer , intent(inout):: nkeys
+
+
+ integer :: i,j,h1,h2,p1,p2,istate
+ integer :: exc(0:2,2)
+ double precision :: phase
+
+ integer :: jstate
+ logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
+ logical :: is_integer_in_string
+ alpha_alpha = .False.
+ beta_beta = .False.
+ alpha_beta = .False.
+ spin_trace = .False.
+ if( ispin == 1)then
+ alpha_alpha = .True.
+ else if(ispin == 2)then
+ beta_beta = .True.
+ else if(ispin == 3)then
+ alpha_beta = .True.
+ else if(ispin == 4)then
+ spin_trace = .True.
+ endif
+ call get_double_excitation_spin(det_1,det_2,exc,phase,N_int)
+ h1 =exc(1,1)
+ if(list_orb_reverse(h1).lt.0)return
+ h1 = list_orb_reverse(h1)
+ h2 =exc(2,1)
+ if(list_orb_reverse(h2).lt.0)return
+ h2 = list_orb_reverse(h2)
+ p1 =exc(1,2)
+ if(list_orb_reverse(p1).lt.0)return
+ p1 = list_orb_reverse(p1)
+ p2 =exc(2,2)
+ if(list_orb_reverse(p2).lt.0)return
+ p2 = list_orb_reverse(p2)
+ if(alpha_alpha.or.spin_trace)then
+ nkeys += 1
+
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = p1
+ keys(4,nkeys) = p2
+
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = - 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = p2
+ keys(4,nkeys) = p1
+
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h2
+ keys(2,nkeys) = h1
+ keys(3,nkeys) = p2
+ keys(4,nkeys) = p1
+
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = - 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h2
+ keys(2,nkeys) = h1
+ keys(3,nkeys) = p1
+ keys(4,nkeys) = p2
+ endif
+ end
+
+ subroutine orb_range_off_diag_double_to_all_states_trans_rdm_bb_buffer(det_1,det_2,c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
+ use bitmasks
+ BEGIN_DOC
+ ! routine that update the OFF DIAGONAL PART of the two body trans_rdms in a specific range of orbitals for
+ !
+ ! a given couple of determinant det_1, det_2 being a BETA /BETA DOUBLE excitation with respect to one another
+ !
+ ! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
+ !
+ ! big_array(dim1,dim1,dim1,dim1) is the two-body trans_rdm to be updated in physicist notation
+ !
+ ! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
+ !
+ ! ispin determines which spin-spin component of the two-trans_rdm you will update
+ !
+ ! ispin == 1 :: alpha/ alpha
+ ! ispin == 2 :: beta / beta
+ ! ispin == 3 :: alpha/ beta
+ ! ispin == 4 :: spin traced <=> total two-trans_rdm
+ !
+ ! here, only ispin == 2 or 4 will do something
+ END_DOC
+ implicit none
+
+ integer, intent(in) :: ispin,sze_buff,N_st
+ integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int)
+ integer, intent(in) :: list_orb_reverse(mo_num)
+ double precision, intent(in) :: c_1(N_st,N_st)
+ double precision, intent(out) :: values(N_st,N_st,sze_buff)
+ integer , intent(out) :: keys(4,sze_buff)
+ integer , intent(inout):: nkeys
+
+ integer :: jstate
+ integer :: i,j,h1,h2,p1,p2,istate
+ integer :: exc(0:2,2)
+ double precision :: phase
+ logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
+ logical :: is_integer_in_string
+ alpha_alpha = .False.
+ beta_beta = .False.
+ alpha_beta = .False.
+ spin_trace = .False.
+ if( ispin == 1)then
+ alpha_alpha = .True.
+ else if(ispin == 2)then
+ beta_beta = .True.
+ else if(ispin == 3)then
+ alpha_beta = .True.
+ else if(ispin == 4)then
+ spin_trace = .True.
+ endif
+
+ call get_double_excitation_spin(det_1,det_2,exc,phase,N_int)
+ h1 =exc(1,1)
+ if(list_orb_reverse(h1).lt.0)return
+ h1 = list_orb_reverse(h1)
+ h2 =exc(2,1)
+ if(list_orb_reverse(h2).lt.0)return
+ h2 = list_orb_reverse(h2)
+ p1 =exc(1,2)
+ if(list_orb_reverse(p1).lt.0)return
+ p1 = list_orb_reverse(p1)
+ p2 =exc(2,2)
+ if(list_orb_reverse(p2).lt.0)return
+ p2 = list_orb_reverse(p2)
+ if(beta_beta.or.spin_trace)then
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = p1
+ keys(4,nkeys) = p2
+
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = - 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = p2
+ keys(4,nkeys) = p1
+
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h2
+ keys(2,nkeys) = h1
+ keys(3,nkeys) = p2
+ keys(4,nkeys) = p1
+
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = - 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h2
+ keys(2,nkeys) = h1
+ keys(3,nkeys) = p1
+ keys(4,nkeys) = p2
+ endif
+ 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 314ad4f6..20386b30 100644
--- a/src/utils/linear_algebra.irp.f
+++ b/src/utils/linear_algebra.irp.f
@@ -652,6 +652,7 @@ subroutine get_pseudo_inverse_complex(A,LDA,m,n,C,LDC,cutoff)
complex*16, allocatable :: U(:,:), Vt(:,:), work(:), A_tmp(:,:)
integer :: info, lwork
integer :: i,j,k
+ double precision :: d1
allocate (D(n),U(m,n),Vt(n,n),work(1),A_tmp(m,n),rwork(5*n))
do j=1,n
do i=1,m
@@ -673,8 +674,9 @@ subroutine get_pseudo_inverse_complex(A,LDA,m,n,C,LDC,cutoff)
stop 1
endif
+ d1 = D(1)
do i=1,n
- if (D(i) > cutoff*D(1)) then
+ if (D(i) > cutoff*d1) then
D(i) = 1.d0/D(i)
else
D(i) = 0.d0
@@ -1321,19 +1323,23 @@ subroutine get_inverse(A,LDA,m,C,LDC)
deallocate(ipiv,work)
end
-subroutine get_pseudo_inverse(A,LDA,m,n,C,LDC,cutoff)
- implicit none
+subroutine get_pseudo_inverse(A, LDA, m, n, C, LDC, cutoff)
+
BEGIN_DOC
! Find C = A^-1
END_DOC
- integer, intent(in) :: m,n, LDA, LDC
- double precision, intent(in) :: A(LDA,n)
- double precision, intent(in) :: cutoff
- double precision, intent(out) :: C(LDC,m)
- double precision, allocatable :: U(:,:), D(:), Vt(:,:), work(:), A_tmp(:,:)
- integer :: info, lwork
- integer :: i,j,k
+ implicit none
+ integer, intent(in) :: m, n, LDA, LDC
+ double precision, intent(in) :: A(LDA,n)
+ double precision, intent(in) :: cutoff
+ double precision, intent(out) :: C(LDC,m)
+
+ integer :: info, lwork
+ integer :: i, j, k, n_svd
+ double precision :: D1_inv
+ double precision, allocatable :: U(:,:), D(:), Vt(:,:), work(:), A_tmp(:,:)
+
allocate (D(n),U(m,n),Vt(n,n),work(1),A_tmp(m,n))
do j=1,n
do i=1,m
@@ -1355,22 +1361,45 @@ subroutine get_pseudo_inverse(A,LDA,m,n,C,LDC,cutoff)
stop 1
endif
- do i=1,n
- if (D(i)/D(1) > cutoff) then
- D(i) = 1.d0/D(i)
- else
- D(i) = 0.d0
- endif
- enddo
+ if(D(1) .lt. 1d-14) then
+ print*, ' largest singular value is very small:', D(1)
+ n_svd = 1
+ else
+ n_svd = 0
+ D1_inv = 1.d0 / D(1)
+ do i = 1, n
+ if(D(i)*D1_inv > cutoff) then
+ D(i) = 1.d0 / D(i)
+ n_svd = n_svd + 1
+ else
+ D(i) = 0.d0
+ endif
+ enddo
+ endif
- C = 0.d0
- do i=1,m
- do j=1,n
- do k=1,n
- C(j,i) = C(j,i) + U(i,k) * D(k) * Vt(k,j)
- enddo
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i, j) &
+ !$OMP SHARED (n, n_svd, D, Vt)
+ !$OMP DO
+ do j = 1, n
+ do i = 1, n_svd
+ Vt(i,j) = D(i) * Vt(i,j)
enddo
enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ call dgemm('T', 'T', n, m, n_svd, 1.d0, Vt, size(Vt,1), U, size(U,1), 0.d0, C, size(C,1))
+
+! C = 0.d0
+! do i=1,m
+! do j=1,n
+! do k=1,n_svd
+! C(j,i) = C(j,i) + U(i,k) * D(k) * Vt(k,j)
+! enddo
+! enddo
+! enddo
deallocate(U,D,Vt,work,A_tmp)
@@ -1868,3 +1897,166 @@ end do
end subroutine pivoted_cholesky
+subroutine exp_matrix(X,n,exp_X)
+ implicit none
+ double precision, intent(in) :: X(n,n)
+ integer, intent(in):: n
+ double precision, intent(out):: exp_X(n,n)
+ BEGIN_DOC
+ ! exponential of the matrix X: X has to be ANTI HERMITIAN !!
+ !
+ ! taken from Hellgaker, jorgensen, Olsen book
+ !
+ ! section evaluation of matrix exponential (Eqs. 3.1.29 to 3.1.31)
+ END_DOC
+ integer :: i
+ double precision, allocatable :: r2_mat(:,:),eigvalues(:),eigvectors(:,:)
+ double precision, allocatable :: matrix_tmp1(:,:),eigvalues_mat(:,:),matrix_tmp2(:,:)
+ include 'constants.include.F'
+ allocate(r2_mat(n,n),eigvalues(n),eigvectors(n,n))
+ allocate(eigvalues_mat(n,n),matrix_tmp1(n,n),matrix_tmp2(n,n))
+
+ ! r2_mat = X^2 in the 3.1.30
+ call get_A_squared(X,n,r2_mat)
+ call lapack_diagd(eigvalues,eigvectors,r2_mat,n,n)
+ eigvalues=-eigvalues
+ do i = 1,n
+ ! t = dsqrt(t^2) where t^2 are eigenvalues of X^2
+ eigvalues(i) = dsqrt(eigvalues(i))
+ enddo
+
+ if(.false.)then
+ !!! For debugging and following the book intermediate
+ ! rebuilding the matrix : X^2 = -W t^2 W^T as in 3.1.30
+ ! matrix_tmp1 = W t^2
+ print*,'eigvalues = '
+ do i = 1, n
+ print*,i,eigvalues(i)
+ write(*,'(100(F16.10,X))')eigvectors(:,i)
+ enddo
+ eigvalues_mat=0.d0
+ do i = 1,n
+ eigvalues_mat(i,i) = eigvalues(i)*eigvalues(i)
+ enddo
+ call dgemm('N','N',n,n,n,1.d0,eigvectors,size(eigvectors,1), &
+ eigvalues_mat,size(eigvalues_mat,1),0.d0,matrix_tmp1,size(matrix_tmp1,1))
+ call dgemm('N','T',n,n,n,-1.d0,matrix_tmp1,size(matrix_tmp1,1), &
+ eigvectors,size(eigvectors,1),0.d0,matrix_tmp2,size(matrix_tmp2,1))
+ print*,'r2_mat = '
+ do i = 1, n
+ write(*,'(100(F16.10,X))')r2_mat(:,i)
+ enddo
+ print*,'r2_mat new = '
+ do i = 1, n
+ write(*,'(100(F16.10,X))')matrix_tmp2(:,i)
+ enddo
+ endif
+
+ ! building the exponential
+ ! exp(X) = W cos(t) W^T + W t^-1 sin(t) W^T X as in Eq. 3.1.31
+ ! matrix_tmp1 = W cos(t)
+ do i = 1,n
+ eigvalues_mat(i,i) = dcos(eigvalues(i))
+ enddo
+ ! matrix_tmp2 = W cos(t)
+ call dgemm('N','N',n,n,n,1.d0,eigvectors,size(eigvectors,1), &
+ eigvalues_mat,size(eigvalues_mat,1),0.d0,matrix_tmp1,size(matrix_tmp1,1))
+ ! matrix_tmp2 = W cos(t) W^T
+ call dgemm('N','T',n,n,n,-1.d0,matrix_tmp1,size(matrix_tmp1,1), &
+ eigvectors,size(eigvectors,1),0.d0,matrix_tmp2,size(matrix_tmp2,1))
+ exp_X = matrix_tmp2
+ ! matrix_tmp2 = W t^-1 sin(t) W^T X
+ do i = 1,n
+ if(dabs(eigvalues(i)).gt.1.d-4)then
+ eigvalues_mat(i,i) = dsin(eigvalues(i))/eigvalues(i)
+ else ! Taylor development of sin(x)/x near x=0 = 1 - x^2/6
+ eigvalues_mat(i,i) = 1.d0 - eigvalues(i)*eigvalues(i)*c_1_3*0.5d0 &
+ + eigvalues(i)*eigvalues(i)*eigvalues(i)*eigvalues(i)*c_1_3*0.025d0
+ endif
+ enddo
+ ! matrix_tmp1 = W t^-1 sin(t)
+ call dgemm('N','N',n,n,n,1.d0,eigvectors,size(eigvectors,1), &
+ eigvalues_mat,size(eigvalues_mat,1),0.d0,matrix_tmp1,size(matrix_tmp1,1))
+ ! matrix_tmp2 = W t^-1 sin(t) W^T
+ call dgemm('N','T',n,n,n,-1.d0,matrix_tmp1,size(matrix_tmp1,1), &
+ eigvectors,size(eigvectors,1),0.d0,matrix_tmp2,size(matrix_tmp2,1))
+ ! exp_X += matrix_tmp2 X
+ call dgemm('N','N',n,n,n,1.d0,matrix_tmp2,size(matrix_tmp2,1), &
+ X,size(X,1),1.d0,exp_X,size(exp_X,1))
+
+end
+
+
+subroutine exp_matrix_taylor(X,n,exp_X,converged)
+ implicit none
+ BEGIN_DOC
+ ! exponential of a general real matrix X using the Taylor expansion of exp(X)
+ !
+ ! returns the logical converged which checks the convergence
+ END_DOC
+ double precision, intent(in) :: X(n,n)
+ integer, intent(in):: n
+ double precision, intent(out):: exp_X(n,n)
+ logical :: converged
+ double precision :: f
+ integer :: i,iter
+ double precision, allocatable :: Tpotmat(:,:),Tpotmat2(:,:)
+ allocate(Tpotmat(n,n),Tpotmat2(n,n))
+ BEGIN_DOC
+ ! exponential of X using Taylor expansion
+ END_DOC
+ Tpotmat(:,:)=0.D0
+ exp_X(:,:) =0.D0
+ do i=1,n
+ Tpotmat(i,i)=1.D0
+ exp_X(i,i) =1.d0
+ end do
+ iter=0
+ converged=.false.
+ do while (.not.converged)
+ iter+=1
+ f = 1.d0 / dble(iter)
+ Tpotmat2(:,:) = Tpotmat(:,:) * f
+ call dgemm('N','N', n,n,n,1.d0, &
+ Tpotmat2, size(Tpotmat2,1), &
+ X, size(X,1), 0.d0, &
+ Tpotmat, size(Tpotmat,1))
+ exp_X(:,:) = exp_X(:,:) + Tpotmat(:,:)
+
+ converged = ( sum(abs(Tpotmat(:,:))) < 1.d-6).or.(iter>30)
+ end do
+ if(.not.converged)then
+ print*,'Warning !! exp_matrix_taylor did not converge !'
+ endif
+
+end
+
+subroutine get_A_squared(A,n,A2)
+ implicit none
+ BEGIN_DOC
+! A2 = A A where A is n x n matrix. Use the dgemm routine
+ END_DOC
+ double precision, intent(in) :: A(n,n)
+ integer, intent(in) :: n
+ 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
! ---