PTEROSOR/QuantumPackage
10
0
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-12-31 08:35:53 +01:00
Code Releases Activity

removed prints in plugins/local/tc_bi_ortho/tc_h_eigvectors.irp.f

Browse Source
This commit is contained in:
Emmanuel Giner LCT 2024-05-22 17:32:56 +02:00
commit 957dc8b502
292 changed files with 14260 additions and 14968 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
.readthedocs.yaml Normal file
View File

@ -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

2
Makefile
View File

@ -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

7
README.md
View File

@ -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
<!--- img src="https://raw.githubusercontent.com/QuantumPackage/qp2/master/data/qp2.png" width="250" --->

20
bin/qp_convert_output_to_ezfio
View File

@ -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")

2
bin/qp_plugins
View File

@ -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)

1
bin/qp_set_frozen_core
View File

@ -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

23
bin/zcat
View File

@ -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

62
config/gfortran_mkl.cfg Normal file
View File

@ -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

2
config/ifort_2021_avx.cfg
View File

@ -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

2
config/ifort_2021_avx_mpi.cfg
View File

@ -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

2
config/ifort_2021_avx_notz.cfg
View File

@ -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

2
config/ifort_2021_debug.cfg
View File

@ -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

2
config/ifort_2021_mpi_rome.cfg
View File

@ -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

2
config/ifort_2021_rome.cfg
View File

@ -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

2
config/ifort_2021_sse4.cfg
View File

@ -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

2
config/ifort_2021_sse4_mpi.cfg
View File

@ -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

2
config/ifort_2021_xHost.cfg
View File

@ -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

10
configure vendored
View File

@ -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

2
docs/ref
View File

@ -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

4
docs/requirements.txt
View File

@ -1,2 +1,2 @@
sphinxcontrib-bibtex==0.4.0
sphinx-rtd-theme==0.4.2
sphinxcontrib-bibtex
sphinx-rtd-theme

26
docs/source/appendix/contributors.rst
View File

@ -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 <http://www.lcpq.ups-tlse.fr/>`_,
| 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 <http://www.alcf.anl.gov/>`_
| 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.

8
docs/source/appendix/references.rst Normal file
View File

@ -0,0 +1,8 @@
References
==========
.. bibliography:: /references.bib
:style: unsrt
:all:

8
docs/source/appendix/research.rst
View File

@ -1,8 +0,0 @@
Some research made with the |qp|
================================
.. bibliography:: /research.bib
:style: unsrt
:all:

3
docs/source/auto_generate.py
View File

@ -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"

4
docs/source/conf.py
View File

@ -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" ]

4
docs/source/index.rst
View File

@ -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

32
docs/source/intro/intro.rst
View File

@ -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 <https://en.wikipedia.org/wiki/Ab_initio_quantum_chemistry_methods>`_ (|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 <https://en.wikipedia.org/wiki/Ab_initio_quantum_chemistry_methods>`_ (|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 <https://en.wikipedia.org/wiki/Density_functional_theory>`_ |KS-DFT| and `range-separated hybrids <https://aip.scitation.org/doi/10.1063/1.1383587>`_ |RSH|.
determinant-driven paradigm. It also contains the very basics of Kohn-Sham `density functional theory <https://en.wikipedia.org/wiki/Density_functional_theory>`_ |KS-DFT| and `range-separated hybrids <https://aip.scitation.org/doi/10.1063/1.1383587>`_ |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 `<https://gitlab.com/eginer/qp_plugins_eginer>`_).
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 `<https://gitlab.com/eginer/qp_plugins_eginer>`_).
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|.

182
docs/source/intro/selected.bib
View File

@ -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}
}

770
docs/source/modules/becke_numerical_grid.rst
View File

@ -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 :

2
docs/source/modules/cipsi.rst
View File

@ -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}`

1
docs/source/programmers_guide/plugins_tuto_I.rst Normal file
View File

@ -0,0 +1 @@
.. include:: ../../../plugins/local/tuto_plugins/tuto_I/tuto_I.rst

1
docs/source/programmers_guide/plugins_tuto_intro.rst Normal file
View File

@ -0,0 +1 @@
.. include:: ../../../plugins/README.rst

847
docs/source/references.bib Normal file
View File

@ -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}
}

2
etc/qp.rc
View File

@ -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

2
external/irpf90 vendored

@ -1 +1 @@
Subproject commit 4ab1b175fc7ed0d96c1912f13dc53579b24157a6
Subproject commit 0007f72f677fe7d61c5e1ed461882cb239517102

3
ocaml/Angmom.ml
View File

@ -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

13
ocaml/Atom.ml
View File

@ -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)

2
ocaml/Basis.ml
View File

@ -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

38
ocaml/Element.ml
View File

@ -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

12
ocaml/Molecule.ml
View File

@ -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

4
ocaml/Point3d.ml
View File

@ -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 ;

42
ocaml/qp_create_ezfio.ml
View File

@ -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 "<int>";
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 "<float>";
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 "<int>";
@ -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 *)

131
plugins/README.rst Normal file
View File

@ -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.

8
plugins/local/basis_correction/51.basis_c.bats
View File

@ -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

15
plugins/local/bi_ort_ints/no_dressing.irp.f
View File

@ -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
! ---

68
plugins/local/bi_ort_ints/semi_num_ints_mo.irp.f
View File

@ -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

4
plugins/local/bi_ort_ints/three_body_ints_bi_ort.irp.f
View File

@ -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
! ---

168
plugins/local/bi_ort_ints/total_twoe_pot.irp.f
View File

@ -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) = <k l| V(r_12) |i j> = 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) = <jk|ji>
! tc_2e_3idx_exchange_integrals_transp(j,k,i) = <kj|ji>
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

8
plugins/local/bi_ortho_mos/overlap.irp.f
View File

@ -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

1
plugins/local/cipsi_tc_bi_ortho/NEED
View File

@ -1,3 +1,4 @@
cipsi_utils
json
mpi
perturbation

2
plugins/local/cipsi_tc_bi_ortho/cipsi.irp.f
View File

@ -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

32
plugins/local/cipsi_tc_bi_ortho/energy.irp.f
View File

@ -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

14
plugins/local/cipsi_tc_bi_ortho/environment.irp.f
View File

@ -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

108
plugins/local/cipsi_tc_bi_ortho/get_d0_transp.irp.f Normal file
View File

@ -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
!!!!!!!!!! <alpha|H|psi>
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
!!!!!!!!!! <alpha|H|psi>
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

358
plugins/local/cipsi_tc_bi_ortho/get_d1_transp.irp.f Normal file
View File

@ -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
!! <alpha|H|psi>
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
!! <alpha|H|psi>
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
!! <alpha|H|psi>
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
!! <alpha|H|psi>
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 <psi|H|alpha>
! 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 <alpha|H|psi> instead of <psi|H|alpha>
! 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

3
plugins/local/cipsi_tc_bi_ortho/get_d2_good.irp.f
View File

@ -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

235
plugins/local/cipsi_tc_bi_ortho/get_d2_transp.irp.f Normal file
View File

@ -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)
!! <alpha|H|psi>
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 = <psi_{selectors,i}|H|alpha>
! |alpha> = t_{p1,p2}^{h1,h2}|psi_{selectors,i}>
!todo: <i|H|j> = (<h1,h2|p1,p2> - <h1,h2|p2,p1>) * phase
! <psi|H|j> += dconjg(c_i) * <i|H|j>
! <j|H|i> = (<p1,p2|h1,h2> - <p2,p1|h1,h2>) * phase
! <j|H|psi> += <j|H|i> * 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 <alpha|H|psi> instead of <psi|H|alpha>
! 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)
!! <alpha|H|psi>
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 = <psi_{selectors,i}|H|alpha>
! 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 <alpha|H|psi> instead of <psi|H|alpha>
! 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)
!! <alpha|H|psi>
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 <alpha|H|psi> instead of <psi|H|alpha>
! 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)
!! <alpha|H|psi>
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 <alpha|H|psi> instead of <psi|H|alpha>
! 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)
!! <alpha|H|psi>
! 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 <alpha|H|psi> instead of <psi|H|alpha>
! 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

0
plugins/local/cipsi_tc_bi_ortho/lock_2rdm.irp.f
View File

4
plugins/local/cipsi_tc_bi_ortho/pt2.irp.f
View File

@ -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

869
plugins/local/cipsi_tc_bi_ortho/pt2_stoch_routines.irp.f
View File

@ -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

549
plugins/local/cipsi_tc_bi_ortho/run_pt2_slave.irp.f
View File

@ -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

258
plugins/local/cipsi_tc_bi_ortho/run_selection_slave.irp.f
View File

@ -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

258
plugins/local/cipsi_tc_bi_ortho/selection.irp.f
View File

@ -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)

424
plugins/local/cipsi_tc_bi_ortho/selection_buffer.irp.f
View File

@ -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

134
plugins/local/cipsi_tc_bi_ortho/selection_weight.irp.f
View File

@ -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

348
plugins/local/cipsi_tc_bi_ortho/slave_cipsi.irp.f
View File

@ -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

66
plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f
View File

@ -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

29
plugins/local/cipsi_tc_bi_ortho/write_cipsi_json.irp.f
View File

@ -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)

235
plugins/local/cipsi_tc_bi_ortho/zmq_selection.irp.f
View File

@ -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

1
plugins/local/fci_tc_bi/NEED
View File

@ -1,3 +1,4 @@
generators_full_tc
json
tc_bi_ortho
davidson_undressed

94
plugins/local/fci_tc_bi/diagonalize_ci.irp.f
View File

@ -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
! ---

2
plugins/local/fci_tc_bi/pt2_tc.irp.f
View File

@ -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

85
plugins/local/fci_tc_bi/script_tc_bh_h2o_gd_exc.sh Executable file
View File

@ -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

84
plugins/local/fci_tc_bi/script_tc_jmu_h2o_gd_exc.sh Executable file
View File

@ -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

2
plugins/local/fci_tc_bi/selectors.irp.f
View File

@ -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

55
plugins/local/jastrow/EZFIO.cfg
View File

@ -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)

6
plugins/local/jastrow/README.md
View File

@ -20,6 +20,12 @@ The main keywords are:
<img src="https://latex.codecogs.com/png.image?%5Cinline%20%5Clarge%20%5Cdpi%7B200%7D%5Cbg%7Bwhite%7D%20u(%5Cmathbf%7Br%7D_1,%5Cmathbf%7Br%7D_2)=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">
</p>
3. **Mu_Nu:** A valence and a core correlation terms are used
<p align="center">
<img src="https://latex.codecogs.com/png.image?\inline&space;\large&space;\dpi{110}\bg{white}&space;u(\mathbf{r}_1,\mathbf{r}_2)=u(\mu;r_{12})\,v(\mathbf{r}_1)\,v(\mathbf{r}_2)&plus;u(\nu;r_{12})[1-v(\mathbf{r}_1)\,v(\mathbf{r}_2)]">
</p>
with envelop \(v\).
## env_type Options

252
plugins/local/jastrow/bh_param.irp.f Normal file
View File

@ -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
! ---

2
plugins/local/mo_localization/README.md
View File

@ -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

1
plugins/local/non_h_ints_mu/NEED
View File

@ -3,3 +3,4 @@ hamiltonian
jastrow
ao_tc_eff_map
bi_ortho_mos
trexio

45
plugins/local/non_h_ints_mu/deb_aos.irp.f
View File

@ -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

159
plugins/local/non_h_ints_mu/jast_1e.irp.f
View File

@ -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

179
plugins/local/non_h_ints_mu/jast_1e_utils.irp.f
View File

@ -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

417
plugins/local/non_h_ints_mu/jast_2e_utils.irp.f
View File

@ -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

507
plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
View File

@ -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
! ---

6
plugins/local/non_h_ints_mu/numerical_integ.irp.f
View File

@ -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)

94
plugins/local/non_h_ints_mu/print_j1ecoef_info.irp.f Normal file
View File

@ -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
! ---

104
plugins/local/non_h_ints_mu/qmckl.irp.f
View File

@ -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

175
plugins/local/non_h_ints_mu/tc_integ.irp.f
View File

@ -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

23
plugins/local/non_h_ints_mu/tc_integ_num.irp.f
View File

@ -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

423
plugins/local/non_h_ints_mu/test_non_h_ints.irp.f
View File

@ -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
! ---

242
plugins/local/non_h_ints_mu/total_tc_int.irp.f
View File

@ -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

1071
plugins/local/non_hermit_dav/biorthog.irp.f
View File

File diff suppressed because it is too large Load Diff

119
plugins/local/non_hermit_dav/lapack_diag_non_hermit.irp.f
View File

@ -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

670
plugins/local/non_hermit_dav/new_routines.irp.f
View File

@ -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

1
plugins/local/normal_order_old/NEED Normal file
View File

@ -0,0 +1 @@
tc_scf

4
plugins/local/normal_order_old/README.rst Normal file
View File

@ -0,0 +1,4 @@
================
normal_order_old
================

0
plugins/local/tc_bi_ortho/normal_ordered.irp.f → plugins/local/normal_order_old/normal_ordered.irp.f
View File

0
plugins/local/tc_bi_ortho/normal_ordered_contractions.irp.f → plugins/local/normal_order_old/normal_ordered_contractions.irp.f
View File

0
plugins/local/tc_bi_ortho/normal_ordered_old.irp.f → plugins/local/normal_order_old/normal_ordered_old.irp.f
View File

Some files were not shown because too many files have changed in this diff Show More