LCPQ/quantum_package
10
0
Fork 0
mirror of https://github.com/LCPQ/quantum_package synced 2024-12-22 20:35:19 +01:00
Code Issues Releases Wiki Activity

Merging

Browse Source
This commit is contained in:
TApplencourt 2016-03-04 18:33:04 +01:00
commit f20e735a18
162 changed files with 12705 additions and 2312 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.travis.yml
View File

@ -24,7 +24,7 @@ python:
script:
- ./configure --production ./config/gfortran.cfg
- source ./quantum_package.rc ; qp_module.py install Full_CI Hartree_Fock CAS_SD MRCC_CASSD
- source ./quantum_package.rc ; qp_module.py install Full_CI Hartree_Fock CAS_SD MRCC_CASSD All_singles
- source ./quantum_package.rc ; ninja
- source ./quantum_package.rc ; cd ocaml ; make ; cd -
- source ./quantum_package.rc ; cd tests ; bats bats/qp.bats
- source ./quantum_package.rc ; cd tests ; ./run_tests.sh #-v

23
README.md
View File

@ -11,6 +11,12 @@ Set of quantum chemistry programs and libraries.
For more information, you can visit the [wiki of the project](http://github.com/LCPQ/quantum_package/wiki>), or below for the installation instructions.
Demo
====
[![Full-CI energy of C2 in 2 minutes](https://i.vimeocdn.com/video/555047954_295x166.jpg)](https://vimeo.com/scemama/quantum_package_demo "Quantum Package Demo")
# Installation
@ -142,3 +148,20 @@ You have two or more ezfio configuration files for the same variable. Check file
- rm $QP_ROOT/install/EZFIO/config/*
- ninja
### Error: Seg Fault (139)
```
Segmentation fault (core dumped)
Program exited with code 139.
```
#### Why ?
It's caused when we call the DGEM routine of LAPACK.
##### Fix
Set `ulimit -s unlimited`, before runing `qp_run`. It seem to fix the problem.

4
config/gfortran.cfg
View File

@ -10,7 +10,7 @@
#
#
[COMMON]
FC : gfortran -g -ffree-line-length-none -I . -static-libgcc
FC : gfortran -ffree-line-length-none -I .
LAPACK_LIB : -llapack -lblas
IRPF90 : irpf90
IRPF90_FLAGS : --ninja --align=32
@ -35,7 +35,7 @@ OPENMP : 1 ; Append OpenMP flags
# -ffast-math and the Fortran-specific
# -fno-protect-parens and -fstack-arrays.
[OPT]
FCFLAGS : -Ofast -march=native
FCFLAGS : -Ofast
# Profiling flags
#################

62
config/gfortran_avx.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
LAPACK_LIB : -llapack -lblas
IRPF90 : irpf90
IRPF90_FLAGS : --ninja --align=32
# Global options
################
#
# 1 : Activate
# 0 : Deactivate
#
[OPTION]
MODE : OPT ; [ OPT | PROFILE | DEBUG ] : Chooses the section below
CACHE : 1 ; 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
# 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

62
config/gfortran_debug.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 -g -ffree-line-length-none -I . -static-libgcc
LAPACK_LIB : -llapack -lblas
IRPF90 : irpf90
IRPF90_FLAGS : --ninja --assert --align=32
# Global options
################
#
# 1 : Activate
# 0 : Deactivate
#
[OPTION]
MODE : DEBUG ; [ 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
# Profiling flags
#################
#
[PROFILE]
FC : -p -g
FCFLAGS : -Ofast
# Debugging flags
#################
#
# -fcheck=all : Checks uninitialized variables, array subscripts, etc...
# -g : Extra debugging information
#
[DEBUG]
FCFLAGS : -g -pedantic -msse4.2
# OpenMP flags
#################
#
[OPENMP]
FC : -fopenmp
IRPF90_FLAGS : --openmp

9
configure vendored
View File

@ -144,8 +144,8 @@ zeromq = Info(
f77zmq = Info(
url='{head}/zeromq/f77_zmq/{tail}'.format(**path_github),
description=' F77-ZeroMQ',
default_path=join(QP_ROOT_LIB, "libf77zmq.a") + " " + \
join(QP_ROOT, "src", "ZMQ", "f77zmq.h") )
default_path=join(QP_ROOT_LIB, "libf77zmq.a") )
# join(QP_ROOT, "src", "ZMQ", "f77zmq.h") )
p_graphviz = Info(
url='https://github.com/xflr6/graphviz/archive/master.tar.gz',
@ -328,7 +328,7 @@ def installation(l_install_descendant):
l_rules += [
"rule install_verbose",
" command = ./scripts/install_${target}.sh | tee _build/${target}.log 2>&1",
' command = bash -o pipefail -c "./scripts/install_${target}.sh | tee _build/${target}.log 2>&1" ',
" description = Installing ${descr}", " pool = console", ""
]
@ -482,10 +482,11 @@ def create_ninja_and_rc(l_installed):
l_rc = [
'export QP_ROOT={0}'.format(QP_ROOT),
'#export QP_NIC=ib0 # Choose the correct network inuterface',
'export QP_EZFIO={0}'.format(path_ezfio.replace(QP_ROOT,"${QP_ROOT}")),
'export QP_PYTHON={0}'.format(":".join(l_python)), "",
'export IRPF90={0}'.format(path_irpf90.replace(QP_ROOT,"${QP_ROOT}")),
'export NINJA={0}'.format(path_ninja.replace(QP_ROOT,"${QP_ROOT}")),
'export QP_PYTHON={0}'.format(":".join(l_python)), "",
'export PYTHONPATH="${QP_EZFIO}/Python":"${QP_PYTHON}":"${PYTHONPATH}"',
'export PATH="${QP_PYTHON}":"${QP_ROOT}"/bin:"${QP_ROOT}"/ocaml:"${PATH}"',
'export LD_LIBRARY_PATH="${QP_ROOT}"/lib:"${LD_LIBRARY_PATH}"',

732
data/basis/cc-pcv6z
View File

@ -1,3 +1,735 @@
BORON
S 11
1 210400.0000000 0.00000583
2 31500.0000000 0.00004532
3 7169.0000000 0.00023838
4 2030.0000000 0.00100570
5 662.5000000 0.00364496
6 239.2000000 0.01173628
7 93.2600000 0.03380702
8 38.6400000 0.08556593
9 16.7800000 0.18260322
10 7.5410000 0.30583760
11 3.4820000 0.34080347
S 11
1 210400.0000000 -0.00000118
2 31500.0000000 -0.00000915
3 7169.0000000 -0.00004819
4 2030.0000000 -0.00020306
5 662.5000000 -0.00073917
6 239.2000000 -0.00238603
7 93.2600000 -0.00698654
8 38.6400000 -0.01811594
9 16.7800000 -0.04123129
10 7.5410000 -0.07781353
11 3.4820000 -0.12123181
S 1
1 1.6180000 1.0000000
S 1
1 0.6270000 1.0000000
S 1
1 0.2934000 1.0000000
S 1
1 0.1310000 1.0000000
S 1
1 0.0581500 1.0000000
S 1
1 127.6200000 1.0000000
S 1
1 63.6510000 1.0000000
S 1
1 31.7460000 1.0000000
S 1
1 15.8330000 1.0000000
S 1
1 7.8970000 1.0000000
P 5
1 192.5000000 0.00013490
2 45.6400000 0.00114741
3 14.7500000 0.00584793
4 5.5030000 0.02117091
5 2.2220000 0.06266872
P 1
1 0.9590000 1.0000000
P 1
1 0.4314000 1.0000000
P 1
1 0.1969000 1.0000000
P 1
1 0.0903300 1.0000000
P 1
1 0.0406600 1.0000000
P 1
1 144.2110000 1.0000000
P 1
1 63.6980000 1.0000000
P 1
1 28.1350000 1.0000000
P 1
1 12.4270000 1.0000000
P 1
1 5.4890000 1.0000000
D 1
1 2.8860000 1.0000000
D 1
1 1.2670000 1.0000000
D 1
1 0.5560000 1.0000000
D 1
1 0.2440000 1.0000000
D 1
1 0.1070000 1.0000000
D 1
1 100.3980000 1.0000000
D 1
1 43.1630000 1.0000000
D 1
1 18.5570000 1.0000000
D 1
1 7.9780000 1.0000000
F 1
1 1.6510000 1.0000000
F 1
1 0.8002000 1.0000000
F 1
1 0.3878000 1.0000000
F 1
1 0.1880000 1.0000000
F 1
1 56.0930000 1.0000000
F 1
1 20.3090000 1.0000000
F 1
1 7.3530000 1.0000000
G 1
1 1.6469000 1.0000000
G 1
1 0.7889000 1.0000000
G 1
1 0.3779000 1.0000000
G 1
1 43.0160000 1.0000000
G 1
1 14.4690000 1.0000000
H 1
1 1.3120000 1.0000000
H 1
1 0.5806000 1.0000000
H 1
1 29.5550000 1.0000000
I 1
1 0.9847000 1.0000000
CARBON
S 11
1 312100.0000000 0.00000567
2 46740.0000000 0.00004410
3 10640.0000000 0.00023190
4 3013.0000000 0.00097897
5 982.8000000 0.00355163
6 354.8000000 0.01144061
7 138.4000000 0.03299855
8 57.3500000 0.08405347
9 24.9200000 0.18067613
10 11.2300000 0.30491140
11 5.2010000 0.34141570
S 11
1 312100.0000000 -0.00000121
2 46740.0000000 -0.00000939
3 10640.0000000 -0.00004947
4 3013.0000000 -0.00020857
5 982.8000000 -0.00076015
6 354.8000000 -0.00245469
7 138.4000000 -0.00720153
8 57.3500000 -0.01880742
9 24.9200000 -0.04325001
10 11.2300000 -0.08259733
11 5.2010000 -0.12857592
S 1
1 2.4260000 1.0000000
S 1
1 0.9673000 1.0000000
S 1
1 0.4456000 1.0000000
S 1
1 0.1971000 1.0000000
S 1
1 0.0863500 1.0000000
S 1
1 183.0760000 1.0000000
S 1
1 91.9980000 1.0000000
S 1
1 46.2300000 1.0000000
S 1
1 23.2310000 1.0000000
S 1
1 11.6740000 1.0000000
P 5
1 295.2000000 0.00014249
2 69.9800000 0.00122010
3 22.6400000 0.00633696
4 8.4850000 0.02351875
5 3.4590000 0.06990447
P 1
1 1.5040000 1.0000000
P 1
1 0.6783000 1.0000000
P 1
1 0.3087000 1.0000000
P 1
1 0.1400000 1.0000000
P 1
1 0.0617800 1.0000000
P 1
1 206.5670000 1.0000000
P 1
1 92.5890000 1.0000000
P 1
1 41.5010000 1.0000000
P 1
1 18.6020000 1.0000000
P 1
1 8.3380000 1.0000000
D 1
1 4.5420000 1.0000000
D 1
1 1.9790000 1.0000000
D 1
1 0.8621000 1.0000000
D 1
1 0.3756000 1.0000000
D 1
1 0.1636000 1.0000000
D 1
1 145.5240000 1.0000000
D 1
1 62.9160000 1.0000000
D 1
1 27.2010000 1.0000000
D 1
1 11.7600000 1.0000000
F 1
1 2.6310000 1.0000000
F 1
1 1.2550000 1.0000000
F 1
1 0.5988000 1.0000000
F 1
1 0.2857000 1.0000000
F 1
1 78.5650000 1.0000000
F 1
1 28.0590000 1.0000000
F 1
1 10.0210000 1.0000000
G 1
1 2.6520000 1.0000000
G 1
1 1.2040000 1.0000000
G 1
1 0.5470000 1.0000000
G 1
1 55.1450000 1.0000000
G 1
1 17.6070000 1.0000000
H 1
1 2.0300000 1.0000000
H 1
1 0.8511000 1.0000000
H 1
1 40.7100000 1.0000000
I 1
1 1.4910000 1.0000000
NITROGEN
S 11
1 432300.0000000 0.00000559
2 64700.0000000 0.00004351
3 14720.0000000 0.00022893
4 4170.0000000 0.00096502
5 1361.0000000 0.00350219
6 491.2000000 0.01129212
7 191.6000000 0.03261283
8 79.4100000 0.08329727
9 34.5300000 0.17998566
10 15.5800000 0.30500351
11 7.2320000 0.34115932
S 11
1 432300.0000000 -0.00000123
2 64700.0000000 -0.00000958
3 14720.0000000 -0.00005051
4 4170.0000000 -0.00021264
5 1361.0000000 -0.00077534
6 491.2000000 -0.00250624
7 191.6000000 -0.00736529
8 79.4100000 -0.01930167
9 34.5300000 -0.04471738
10 15.5800000 -0.08606647
11 7.2320000 -0.13329627
S 1
1 3.3820000 1.0000000
S 1
1 1.3690000 1.0000000
S 1
1 0.6248000 1.0000000
S 1
1 0.2747000 1.0000000
S 1
1 0.1192000 1.0000000
S 1
1 246.2620000 1.0000000
S 1
1 124.1870000 1.0000000
S 1
1 62.6260000 1.0000000
S 1
1 31.5810000 1.0000000
S 1
1 15.9260000 1.0000000
P 5
1 415.9000000 0.00014841
2 98.6100000 0.00127634
3 31.9200000 0.00670242
4 12.0000000 0.02526170
5 4.9190000 0.07518943
P 1
1 2.1480000 1.0000000
P 1
1 0.9696000 1.0000000
P 1
1 0.4399000 1.0000000
P 1
1 0.1978000 1.0000000
P 1
1 0.0860300 1.0000000
P 1
1 270.1420000 1.0000000
P 1
1 123.4650000 1.0000000
P 1
1 56.4280000 1.0000000
P 1
1 25.7900000 1.0000000
P 1
1 11.7870000 1.0000000
D 1
1 6.7170000 1.0000000
D 1
1 2.8960000 1.0000000
D 1
1 1.2490000 1.0000000
D 1
1 0.5380000 1.0000000
D 1
1 0.2320000 1.0000000
D 1
1 199.9200000 1.0000000
D 1
1 87.1110000 1.0000000
D 1
1 37.9570000 1.0000000
D 1
1 16.5390000 1.0000000
F 1
1 3.8290000 1.0000000
F 1
1 1.7950000 1.0000000
F 1
1 0.8410000 1.0000000
F 1
1 0.3940000 1.0000000
F 1
1 105.3460000 1.0000000
F 1
1 37.5300000 1.0000000
F 1
1 13.3700000 1.0000000
G 1
1 3.8560000 1.0000000
G 1
1 1.7020000 1.0000000
G 1
1 0.7510000 1.0000000
G 1
1 67.1880000 1.0000000
G 1
1 20.3600000 1.0000000
H 1
1 2.8750000 1.0000000
H 1
1 1.1700000 1.0000000
H 1
1 52.0500000 1.0000000
I 1
1 2.0990000 1.0000000
OXYGEN
S 11
1 570800.0000000 0.00000555
2 85480.0000000 0.00004311
3 19460.0000000 0.00022667
4 5512.0000000 0.00095637
5 1798.0000000 0.00347320
6 648.9000000 0.01119778
7 253.1000000 0.03238766
8 104.9000000 0.08285977
9 45.6500000 0.17958381
10 20.6200000 0.30522110
11 9.5870000 0.34089349
S 11
1 570800.0000000 -0.00000126
2 85480.0000000 -0.00000977
3 19460.0000000 -0.00005148
4 5512.0000000 -0.00021696
5 1798.0000000 -0.00079162
6 648.9000000 -0.00255900
7 253.1000000 -0.00753313
8 104.9000000 -0.01978897
9 45.6500000 -0.04606288
10 20.6200000 -0.08919560
11 9.5870000 -0.13754216
S 1
1 4.4930000 1.0000000
S 1
1 1.8370000 1.0000000
S 1
1 0.8349000 1.0000000
S 1
1 0.3658000 1.0000000
S 1
1 0.1570000 1.0000000
S 1
1 317.0960000 1.0000000
S 1
1 160.3930000 1.0000000
S 1
1 81.1290000 1.0000000
S 1
1 41.0370000 1.0000000
S 1
1 20.7570000 1.0000000
P 5
1 525.6000000 0.00016664
2 124.6000000 0.00143336
3 40.3400000 0.00754762
4 15.1800000 0.02859456
5 6.2450000 0.08438858
P 1
1 2.7320000 1.0000000
P 1
1 1.2270000 1.0000000
P 1
1 0.5492000 1.0000000
P 1
1 0.2418000 1.0000000
P 1
1 0.1025000 1.0000000
P 1
1 358.9110000 1.0000000
P 1
1 161.8180000 1.0000000
P 1
1 72.9570000 1.0000000
P 1
1 32.8930000 1.0000000
P 1
1 14.8300000 1.0000000
D 1
1 8.2530000 1.0000000
D 1
1 3.5970000 1.0000000
D 1
1 1.5680000 1.0000000
D 1
1 0.6840000 1.0000000
D 1
1 0.2980000 1.0000000
D 1
1 250.8300000 1.0000000
D 1
1 108.1630000 1.0000000
D 1
1 46.6420000 1.0000000
D 1
1 20.1130000 1.0000000
F 1
1 5.4300000 1.0000000
F 1
1 2.4160000 1.0000000
F 1
1 1.0750000 1.0000000
F 1
1 0.4780000 1.0000000
F 1
1 136.1110000 1.0000000
F 1
1 48.8550000 1.0000000
F 1
1 17.5360000 1.0000000
G 1
1 5.2110000 1.0000000
G 1
1 2.1900000 1.0000000
G 1
1 0.9200000 1.0000000
G 1
1 81.6280000 1.0000000
G 1
1 24.0650000 1.0000000
H 1
1 3.8720000 1.0000000
H 1
1 1.5050000 1.0000000
H 1
1 62.8500000 1.0000000
I 1
1 2.7730000 1.0000000
FLUORINE
S 11
1 723500.0000000 0.00000556
2 108400.0000000 0.00004318
3 24680.0000000 0.00022700
4 6990.0000000 0.00095803
5 2282.0000000 0.00347015
6 824.6000000 0.01118526
7 321.8000000 0.03232880
8 133.5000000 0.08279545
9 58.1100000 0.17988024
10 26.2800000 0.30557831
11 12.2400000 0.34026839
S 11
1 723500.0000000 -0.00000129
2 108400.0000000 -0.00000999
3 24680.0000000 -0.00005260
4 6990.0000000 -0.00022172
5 2282.0000000 -0.00080692
6 824.6000000 -0.00260817
7 321.8000000 -0.00767402
8 133.5000000 -0.02019353
9 58.1100000 -0.04718752
10 26.2800000 -0.09158009
11 12.2400000 -0.14048558
S 1
1 5.7470000 1.0000000
S 1
1 2.3650000 1.0000000
S 1
1 1.0710000 1.0000000
S 1
1 0.4681000 1.0000000
S 1
1 0.1994000 1.0000000
S 1
1 397.5440000 1.0000000
S 1
1 201.5940000 1.0000000
S 1
1 102.2280000 1.0000000
S 1
1 51.8400000 1.0000000
S 1
1 26.2880000 1.0000000
P 5
1 660.0000000 0.00017721
2 156.4000000 0.00152691
3 50.6400000 0.00807207
4 19.0800000 0.03074021
5 7.8720000 0.09011914
P 1
1 3.4490000 1.0000000
P 1
1 1.5450000 1.0000000
P 1
1 0.6864000 1.0000000
P 1
1 0.2986000 1.0000000
P 1
1 0.1245000 1.0000000
P 1
1 446.5700000 1.0000000
P 1
1 201.3390000 1.0000000
P 1
1 90.7750000 1.0000000
P 1
1 40.9270000 1.0000000
P 1
1 18.4520000 1.0000000
D 1
1 10.5730000 1.0000000
D 1
1 4.6130000 1.0000000
D 1
1 2.0130000 1.0000000
D 1
1 0.8780000 1.0000000
D 1
1 0.3830000 1.0000000
D 1
1 313.7310000 1.0000000
D 1
1 135.4040000 1.0000000
D 1
1 58.4390000 1.0000000
D 1
1 25.2220000 1.0000000
F 1
1 7.5630000 1.0000000
F 1
1 3.3300000 1.0000000
F 1
1 1.4660000 1.0000000
F 1
1 0.6450000 1.0000000
F 1
1 177.2200000 1.0000000
F 1
1 64.3500000 1.0000000
F 1
1 23.3660000 1.0000000
G 1
1 6.7350000 1.0000000
G 1
1 2.7830000 1.0000000
G 1
1 1.1500000 1.0000000
G 1
1 99.3840000 1.0000000
G 1
1 29.5170000 1.0000000
H 1
1 5.0880000 1.0000000
H 1
1 1.9370000 1.0000000
H 1
1 67.8200000 1.0000000
I 1
1 3.5810000 1.0000000
NEON
S 11
1 902400.0000000 0.00000551
2 135100.0000000 0.00004282
3 30750.0000000 0.00022514
4 8710.0000000 0.00095016
5 2842.0000000 0.00344719
6 1026.0000000 0.01112545
7 400.1000000 0.03220568
8 165.9000000 0.08259891
9 72.2100000 0.17990564
10 32.6600000 0.30605208
11 15.2200000 0.34012559
S 11
1 902400.0000000 -0.00000129
2 135100.0000000 -0.00001005
3 30750.0000000 -0.00005293
4 8710.0000000 -0.00022312
5 2842.0000000 -0.00081338
6 1026.0000000 -0.00263230
7 400.1000000 -0.00775910
8 165.9000000 -0.02045277
9 72.2100000 -0.04797505
10 32.6600000 -0.09340086
11 15.2200000 -0.14277215
S 1
1 7.1490000 1.0000000
S 1
1 2.9570000 1.0000000
S 1
1 1.3350000 1.0000000
S 1
1 0.5816000 1.0000000
S 1
1 0.2463000 1.0000000
S 1
1 526.1367000 1.0000000
S 1
1 264.9976000 1.0000000
S 1
1 133.4704000 1.0000000
S 1
1 67.2246200 1.0000000
S 1
1 33.8588000 1.0000000
P 5
1 815.6000000 0.00018376
2 193.3000000 0.00158509
3 62.6000000 0.00841464
4 23.6100000 0.03220033
5 9.7620000 0.09396390
P 1
1 4.2810000 1.0000000
P 1
1 1.9150000 1.0000000
P 1
1 0.8476000 1.0000000
P 1
1 0.3660000 1.0000000
P 1
1 0.1510000 1.0000000
P 1
1 558.8741000 1.0000000
P 1
1 250.2470000 1.0000000
P 1
1 112.0531000 1.0000000
P 1
1 50.1739900 1.0000000
P 1
1 22.4664000 1.0000000
D 1
1 13.3170000 1.0000000
D 1
1 5.8030000 1.0000000
D 1
1 2.5290000 1.0000000
D 1
1 1.1020000 1.0000000
D 1
1 0.4800000 1.0000000
D 1
1 392.7164000 1.0000000
D 1
1 169.5564000 1.0000000
D 1
1 73.2064700 1.0000000
D 1
1 31.6071000 1.0000000
F 1
1 10.3560000 1.0000000
F 1
1 4.5380000 1.0000000
F 1
1 1.9890000 1.0000000
F 1
1 0.8710000 1.0000000
F 1
1 224.9657000 1.0000000
F 1
1 82.4518500 1.0000000
F 1
1 30.2193000 1.0000000
G 1
1 8.3450000 1.0000000
G 1
1 3.4170000 1.0000000
G 1
1 1.3990000 1.0000000
G 1
1 119.8449000 1.0000000
G 1
1 33.5255000 1.0000000
H 1
1 6.5190000 1.0000000
H 1
1 2.4470000 1.0000000
H 1
1 50.9084700 1.0000000
I 1
1 4.4890000 1.0000000
ALUMINUM
S 11
1 3652000.0000000 0.0000019

168
data/basis/chipman-dzp Normal file
View File

@ -0,0 +1,168 @@
HYDROGEN
S 3
1 127.9500000 0.0107360
2 19.2406000 0.1195440
3 2.8992000 0.9264160
S 1
1 0.6534000 1.0000000
S 1
1 0.1776000 1.0000000
S 1
1 0.0483000 1.0000000
P 1
1 1.0000000 1.0000000
BORON
S 5
1 2788.4100000 0.0021220
2 419.0390000 0.0161710
3 96.4683000 0.0783560
4 28.0694000 0.2632500
5 9.3760000 0.5967290
S 1
1 1.3057000 1.0000000
S 1
1 3.4062000 1.0000000
S 1
1 0.3245000 1.0000000
S 1
1 0.1022000 1.0000000
S 1
1 0.0330000 1.0000000
P 4
1 11.3413000 0.0179870
2 2.4360000 0.1103390
3 0.6836000 0.3831110
4 0.2134000 0.6478600
P 1
1 0.0701000 1.0000000
P 1
1 0.0226000 1.0000000
D 1
1 0.1600000 1.0000000
D 1
1 0.6400000 1.0000000
CARBON
S 5
1 5909.4400000 0.0020040
2 887.4510000 0.0153100
3 204.7490000 0.0742930
4 59.8376000 0.2533640
5 19.9981000 0.6005760
S 1
1 2.6860000 1.0000000
S 1
1 7.1927000 1.0000000
S 1
1 0.7000000 1.0000000
S 1
1 0.2133000 1.0000000
S 1
1 0.0667000 1.0000000
P 4
1 26.7860000 0.0182570
2 5.9564000 0.1164070
3 1.7074000 0.3901110
4 0.5314000 0.6372210
P 1
1 0.1654000 1.0000000
P 1
1 0.0517000 1.0000000
D 1
1 0.3700000 1.0000000
D 1
1 1.4800000 1.0000000
NITROGEN
S 5
1 5909.4400000 0.0020040
2 887.4510000 0.0153100
3 204.7490000 0.0742930
4 59.8376000 0.2533640
5 19.9981000 0.6005760
S 1
1 2.6860000 1.0000000
S 1
1 7.1927000 1.0000000
S 1
1 0.7000000 1.0000000
S 1
1 0.2133000 1.0000000
S 1
1 0.0667000 1.0000000
P 4
1 26.7860000 0.0182570
2 5.9564000 0.1164070
3 1.7074000 0.3901110
4 0.5314000 0.6372210
P 1
1 0.1654000 1.0000000
P 1
1 0.0517000 1.0000000
D 1
1 0.3700000 1.0000000
D 1
1 1.4800000 1.0000000
OXYGEN
S 5
1 7816.5400000 0.0020310
2 1175.8200000 0.0154360
3 273.1880000 0.0737710
4 81.1696000 0.2476060
5 27.1836000 0.6118320
S 1
1 3.4136000 1.0000000
S 1
1 9.5322000 1.0000000
S 1
1 0.9398000 1.0000000
S 1
1 0.2846000 1.0000000
S 1
1 0.0862000 1.0000000
P 4
1 35.1832000 0.0195800
2 7.9040000 0.1241890
3 2.3051000 0.3947270
4 0.7171000 0.6273750
P 1
1 0.2137000 1.0000000
P 1
1 0.0648000 1.0000000
D 1
1 0.5500000 1.0000000
D 1
1 2.2000000 1.0000000
FLUORINE
S 5
1 9994.7900000 0.0020170
2 1506.0300000 0.0152950
3 350.2690000 0.0731100
4 104.0530000 0.2464200
5 34.8432000 0.6125930
S 1
1 4.3688000 1.0000000
S 1
1 12.2164000 1.0000000
S 1
1 1.2078000 1.0000000
S 1
1 0.3634000 1.0000000
S 1
1 0.1101000 1.0000000
P 4
1 44.3555000 0.0208680
2 10.0820000 0.1300920
3 2.9959000 0.3962190
4 0.9383000 0.6203680
P 1
1 0.2733000 1.0000000
P 1
1 0.0828000 1.0000000
D 1
1 0.6650000 1.0000000
D 1
1 2.6600000 1.0000000

60
ocaml/.gitignore vendored
View File

@ -1,60 +0,0 @@
_build
ezfio.ml
.gitignore
Git.ml
Input_auto_generated.ml
Input_determinants.ml
Input_hartree_fock.ml
Input_integrals_bielec.ml
Input_perturbation.ml
Input_properties.ml
Input_pseudo.ml
qp_basis_clean
qp_basis_clean.native
qp_create_ezfio_from_xyz
qp_create_ezfio_from_xyz.native
qp_edit
qp_edit.ml
qp_edit.native
qp_print
qp_print_basis
qp_print_basis.native
qp_print.native
qp_run
qp_run.native
qp_set_ddci
qp_set_ddci.native
qp_set_mo_class
qp_set_mo_class.native
qptypes_generator.byte
Qptypes.ml
test_atom
test_atom.byte
test_basis
test_basis.byte
test_bitlist
test_bitlist.byte
test_determinants
test_determinants.byte
test_elements
test_elements.byte
test_excitation
test_excitation.byte
test_gto
test_gto.byte
test_message
test_message.byte
test_mo_label
test_mo_label.byte
test_molecule
test_molecule.byte
test_point3d
test_point3d.byte
test_pseudo
test_pseudo.byte
test_queuing_system
test_queuing_system.byte
test_symmetry
test_symmetry.byte
test_task_server
test_task_server.byte

10
ocaml/Address.ml
View File

@ -4,11 +4,15 @@ module Tcp : sig
type t
val of_string : string -> t
val to_string : t -> string
val create : host:string -> port:int -> t
end = struct
type t = string
let of_string x =
assert (String.is_prefix ~prefix:"tcp://" x);
x
let create ~host ~port =
assert (port > 0);
Printf.sprintf "tcp://%s:%d" host port
let to_string x = x
end
@ -16,11 +20,14 @@ module Ipc : sig
type t
val of_string : string -> t
val to_string : t -> string
val create : string -> t
end = struct
type t = string
let of_string x =
assert (String.is_prefix ~prefix:"ipc://" x);
x
let create name =
Printf.sprintf "ipc://%s" name
let to_string x = x
end
@ -28,11 +35,14 @@ module Inproc : sig
type t
val of_string : string -> t
val to_string : t -> string
val create : string -> t
end = struct
type t = string
let of_string x =
assert (String.is_prefix ~prefix:"inproc://" x);
x
let create name =
Printf.sprintf "ipc://%s" name
let to_string x = x
end

96
ocaml/Bitlist.ml
View File

@ -1,5 +1,5 @@
open Qptypes;;
open Core.Std;;
open Qptypes
open Core.Std
(*
Type for bits strings
@ -19,39 +19,50 @@ let to_string b =
in do_work new_accu tail
in
do_work "" b
;;
let of_string ?(zero='0') ?(one='1') s =
String.to_list s
|> List.rev_map ~f:( fun c ->
if (c = zero) then Bit.Zero
else if (c = one) then Bit.One
else (failwith ("Error in string "^s) ) )
;;
else (failwith ("Error in bitstring ") ) )
let of_string_mp s =
String.to_list s
|> List.rev_map ~f:(function
| '-' -> Bit.Zero
| '+' -> Bit.One
| _ -> failwith ("Error in bitstring ") )
(* Create a bit list from an int64 *)
let of_int64 i =
let rec do_work = function
| 0L -> [ Bit.Zero ]
| 1L -> [ Bit.One ]
| i -> let b =
match (Int64.bit_and i 1L ) with
| 0L -> Bit.Zero
| 1L -> Bit.One
| _ -> raise (Failure "i land 1 not in (0,1)")
in b:: ( do_work (Int64.shift_right_logical i 1) )
let rec do_work accu = function
| 0L -> Bit.Zero :: accu |> List.rev
| 1L -> Bit.One :: accu |> List.rev
| i ->
let b =
match (Int64.bit_and i 1L ) with
| 0L -> Bit.Zero
| 1L -> Bit.One
| _ -> raise (Failure "i land 1 not in (0,1)")
in
do_work (b :: accu) (Int64.shift_right_logical i 1)
in
let adjust_length result =
let rec do_work accu = function
| 64 -> accu
| 64 -> List.rev accu
| i when i>64 -> raise (Failure "Error in of_int64 > 64")
| i when i<0 -> raise (Failure "Error in of_int64 < 0")
| i -> do_work (accu@[Bit.Zero]) (i+1)
| i -> do_work (Bit.Zero :: accu) (i+1)
in
do_work result (List.length result)
do_work (List.rev result) (List.length result)
in
adjust_length (do_work i)
;;
adjust_length (do_work [] i)
(* Create an int64 from a bit list *)
let to_int64 l =
@ -61,26 +72,32 @@ let to_int64 l =
| Bit.Zero::tail -> do_work Int64.(shift_left accu 1) tail
| Bit.One::tail -> do_work Int64.(bit_or one (shift_left accu 1)) tail
in do_work Int64.zero (List.rev l)
;;
(* Create a bit list from a list of int64 *)
let of_int64_list l =
List.map ~f:of_int64 l
|> List.concat
;;
(* Create a bit list from an array of int64 *)
let of_int64_array l =
Array.map ~f:of_int64 l
|> Array.to_list
|> List.concat
(* Compute n_int *)
let n_int_of_mo_tot_num mo_tot_num =
let bit_kind_size = Bit_kind_size.to_int (Lazy.force Qpackage.bit_kind_size) in
N_int_number.of_int ( (mo_tot_num-1)/bit_kind_size + 1 )
;;
(* Create a zero bit list *)
let zero n_int =
let n_int = N_int_number.to_int n_int in
let a = Array.init n_int (fun i-> 0L) in
of_int64_list ( Array.to_list a )
;;
(* Create an int64 list from a bit list *)
let to_int64_list l =
@ -100,7 +117,11 @@ let to_int64_list l =
let l = do_work [] [] 1 l
in
List.rev_map ~f:to_int64 l
;;
(* Create an array of int64 from a bit list *)
let to_int64_array l =
to_int64_list l
|> Array.of_list
(* Create a bit list from a list of MO indices *)
let of_mo_number_list n_int l =
@ -109,7 +130,7 @@ let of_mo_number_list n_int l =
let a = Array.create length (Bit.Zero) in
List.iter ~f:(fun i-> a.((MO_number.to_int i)-1) <- Bit.One) l;
Array.to_list a
;;
let to_mo_number_list l =
let a = Array.of_list l in
@ -127,7 +148,7 @@ let to_mo_number_list l =
end
in
do_work [] (List.length l)
;;
@ -142,7 +163,7 @@ let logical_operator2 op a b =
in do_work_binary (newbit::result) ta tb
in
List.rev (do_work_binary [] a b)
;;
let logical_operator1 op b =
let rec do_work_unary result b =
@ -153,20 +174,19 @@ let logical_operator1 op b =
in do_work_unary (newbit::result) tb
in
List.rev (do_work_unary [] b)
;;
let and_operator a b = logical_operator2 Bit.and_operator a b;;
let xor_operator a b = logical_operator2 Bit.xor_operator a b;;
let or_operator a b = logical_operator2 Bit.or_operator a b;;
let not_operator b = logical_operator1 Bit.not_operator b ;;
let and_operator a b = logical_operator2 Bit.and_operator a b
let xor_operator a b = logical_operator2 Bit.xor_operator a b
let or_operator a b = logical_operator2 Bit.or_operator a b
let not_operator b = logical_operator1 Bit.not_operator b
let popcnt b =
let rec popcnt accu = function
| [] -> accu
| Bit.One::rest -> popcnt (accu+1) rest
| Bit.Zero::rest -> popcnt (accu) rest
in popcnt 0 b
;;
List.fold_left b ~init:0 ~f:(fun accu -> function
| Bit.One -> accu+1
| Bit.Zero -> accu
)

11
ocaml/Bitlist.mli
View File

@ -6,16 +6,21 @@ val zero : Qptypes.N_int_number.t -> t
(** Convert to a string for printing *)
val to_string : t -> string
(** Convert to a string for printing *)
(** Read from a string *)
val of_string : ?zero:char -> ?one:char -> string -> t
(** Read from a string with the ++-- notation *)
val of_string_mp : string -> t
(** int64 conversion functions *)
val of_int64 : int64 -> t
val to_int64 : t -> int64
val of_int64_list : int64 list -> t
val to_int64_list : t -> int64 list
val of_int64_list : int64 list -> t
val of_int64_array : int64 array -> t
val to_int64_list : t -> int64 list
val to_int64_array : t -> int64 array
(** Get the number of needed int64 elements to encode the bit list *)
val n_int_of_mo_tot_num : int -> Qptypes.N_int_number.t

59
ocaml/Determinant.ml
View File

@ -4,33 +4,37 @@ open Qptypes;;
type t = int64 array with sexp
let to_int64_array (x:t) = (x:int64 array)
;;
let to_alpha_beta x =
let x = to_int64_array x in
let n_int = (Array.length x)/2 in
( Array.init n_int ~f:(fun i -> x.(i)) ,
Array.init n_int ~f:(fun i -> x.(i+n_int)) )
;;
let to_bitlist_couple x =
let (xa,xb) = to_alpha_beta x in
let xa = to_int64_array xa
|> Array.to_list
|> Bitlist.of_int64_list
and xb = to_int64_array xb
|> Array.to_list
|> Bitlist.of_int64_list
let xa =
to_int64_array xa
|> Bitlist.of_int64_array
and xb =
to_int64_array xb
|> Bitlist.of_int64_array
in (xa,xb)
;;
let bitlist_to_string ~mo_tot_num x =
List.map x ~f:(fun i -> match i with
| Bit.Zero -> "-"
| Bit.One -> "+" )
let len =
MO_number.to_int mo_tot_num
in
List.map x ~f:(function
| Bit.Zero -> "-"
| Bit.One -> "+"
)
|> String.concat
|> String.sub ~pos:0 ~len:(MO_number.to_int mo_tot_num)
;;
|> String.sub ~pos:0 ~len
let of_int64_array ~n_int ~alpha ~beta x =
@ -54,20 +58,25 @@ let of_int64_array ~n_int ~alpha ~beta x =
%s" beta (bitlist_to_string ~mo_tot_num:mo_tot_num b) )
end;
x
;;
let of_bitlist_couple ~alpha ~beta (xa,xb) =
let ba = Bitlist.to_int64_list xa in
let bb = Bitlist.to_int64_list xb in
let n_int = Bitlist.n_int_of_mo_tot_num (List.length xa) in
of_int64_array ~n_int:n_int ~alpha:alpha ~beta:beta (Array.of_list (ba@bb))
;;
let of_int64_array_no_check x = x
let of_bitlist_couple ?n_int ~alpha ~beta (xa,xb) =
let ba, bb =
Bitlist.to_int64_array xa ,
Bitlist.to_int64_array xb
and n_int =
match n_int with
| Some x -> x
| None -> Bitlist.n_int_of_mo_tot_num (List.length xa)
in
of_int64_array ~n_int ~alpha ~beta (Array.concat [ba;bb])
let to_string ~mo_tot_num x =
let (xa,xb) = to_bitlist_couple x in
[ bitlist_to_string ~mo_tot_num:mo_tot_num xa ;
bitlist_to_string ~mo_tot_num:mo_tot_num xb ]
|> String.concat ~sep:"\n"
;;
[ " " ; bitlist_to_string ~mo_tot_num xa ; "\n" ;
" " ; bitlist_to_string ~mo_tot_num xb ]
|> String.concat

3
ocaml/Determinant.mli
View File

@ -24,7 +24,8 @@ val to_alpha_beta : t -> (int64 array)*(int64 array)
val to_bitlist_couple : t -> Bitlist.t * Bitlist.t
(** Create from a bit list *)
val of_bitlist_couple : alpha:Qptypes.Elec_alpha_number.t ->
val of_bitlist_couple : ?n_int:Qptypes.N_int_number.t ->
alpha:Qptypes.Elec_alpha_number.t ->
beta:Qptypes.Elec_beta_number.t ->
Bitlist.t * Bitlist.t -> t

78
ocaml/Input_determinants_by_hand.ml
View File

@ -16,6 +16,7 @@ module Determinants_by_hand : sig
val to_string : t -> string
val to_rst : t -> Rst_string.t
val of_rst : Rst_string.t -> t option
val read_n_int : unit -> N_int_number.t
end = struct
type t =
{ n_int : N_int_number.t;
@ -29,6 +30,8 @@ end = struct
let get_default = Qpackage.get_ezfio_default "determinants";;
let n_det_read_max = 10_000 ;;
let read_n_int () =
if not (Ezfio.has_determinants_n_int()) then
Ezfio.get_mo_basis_mo_tot_num ()
@ -207,14 +210,20 @@ end = struct
let read () =
if (Ezfio.has_mo_basis_mo_tot_num ()) then
Some
{ n_int = read_n_int () ;
bit_kind = read_bit_kind () ;
n_det = read_n_det () ;
expected_s2 = read_expected_s2 () ;
psi_coef = read_psi_coef () ;
psi_det = read_psi_det () ;
}
let n_det =
read_n_det ()
in
if ( (Det_number.to_int n_det) > n_det_read_max ) then
None
else
Some
{ n_int = read_n_int () ;
bit_kind = read_bit_kind () ;
n_det = read_n_det () ;
expected_s2 = read_expected_s2 () ;
psi_coef = read_psi_coef () ;
psi_det = read_psi_det () ;
}
else
None
;;
@ -236,11 +245,16 @@ end = struct
let to_rst b =
let mo_tot_num = Ezfio.get_mo_basis_mo_tot_num () in
let mo_tot_num = MO_number.of_int mo_tot_num ~max:mo_tot_num in
let max =
Ezfio.get_mo_basis_mo_tot_num ()
in
let mo_tot_num =
MO_number.of_int ~max max
in
let det_text =
let nstates =
read_n_states () |> States_number.to_int
read_n_states ()
|> States_number.to_int
and ndet =
Det_number.to_int b.n_det
in
@ -393,29 +407,47 @@ psi_det = %s
in
let rec read_dets accu = function
| [] -> List.rev accu
| ""::c::alpha::beta::tail ->
| ""::_::alpha::beta::tail ->
begin
let alpha = String.rev alpha |> Bitlist.of_string ~zero:'-' ~one:'+'
and beta = String.rev beta |> Bitlist.of_string ~zero:'-' ~one:'+'
in
let newdet = Determinant.of_bitlist_couple
~alpha:n_alpha ~beta:n_beta (alpha,beta)
|> Determinant.sexp_of_t |> Sexplib.Sexp.to_string
let newdet =
(Bitlist.of_string ~zero:'-' ~one:'+' alpha ,
Bitlist.of_string ~zero:'-' ~one:'+' beta)
|> Determinant.of_bitlist_couple ~alpha:n_alpha ~beta:n_beta
|> Determinant.sexp_of_t
|> Sexplib.Sexp.to_string
in
read_dets (newdet::accu) tail
end
| _::tail -> read_dets accu tail
in
let a = read_dets [] dets
|> String.concat
let dets =
List.map ~f:String.rev dets
in
let sze =
List.fold ~init:0 ~f:(fun accu x -> accu + (String.length x)) dets
in
let control =
Gc.get ()
in
Gc.tune ~minor_heap_size:(sze) ~space_overhead:(sze/10)
~max_overhead:100000 ~major_heap_increment:(sze/10) ();
let a =
read_dets [] dets
|> String.concat
in
Gc.set control;
"(psi_det ("^a^"))"
in
let bitkind = Printf.sprintf "(bit_kind %d)" (Lazy.force Qpackage.bit_kind
let bitkind =
Printf.sprintf "(bit_kind %d)" (Lazy.force Qpackage.bit_kind
|> Bit_kind.to_int)
and n_int = Printf.sprintf "(n_int %d)" (N_int_number.get_max ()) in
let s = String.concat [ header ; bitkind ; n_int ; psi_coef ; psi_det]
and n_int =
Printf.sprintf "(n_int %d)" (N_int_number.get_max ())
in
let s =
String.concat [ header ; bitkind ; n_int ; psi_coef ; psi_det]
in
Generic_input_of_rst.evaluate_sexp t_of_sexp s

401
ocaml/Message.ml
View File

@ -1,4 +1,5 @@
open Core.Std
open Qptypes
(** New job : Request to create a new multi-tasked job *)
@ -32,12 +33,30 @@ end = struct
address_inproc = Address.Inproc.of_string address_inproc ;
}
let to_string t =
Printf.sprintf "newjob %s %s %s"
Printf.sprintf "new_job %s %s %s"
( State.to_string t.state )
( Address.Tcp.to_string t.address_tcp )
( Address.Inproc.to_string t.address_inproc )
end
module Endjob_msg : sig
type t =
{ state: State.t;
}
val create : state:string -> t
val to_string : t -> string
end = struct
type t =
{ state: State.t;
}
let create ~state =
{ state = State.of_string state;
}
let to_string t =
Printf.sprintf "end_job %s"
( State.to_string t.state )
end
(** Connect : connect a new client to the task server *)
@ -108,22 +127,21 @@ end
module DisconnectReply_msg : sig
type t =
{ finished: bool ;
{
state: State.t ;
}
val create : state:State.t -> finished:bool -> t
val create : state:State.t -> t
val to_string : t -> string
end = struct
type t =
{ finished: bool;
{
state: State.t ;
}
let create ~state ~finished =
{ state ; finished }
let create ~state =
{ state }
let to_string x =
Printf.sprintf "disconnect_reply %s %d"
Printf.sprintf "disconnect_reply %s"
(State.to_string x.state)
(if x.finished then 1 else 0)
end
@ -160,6 +178,52 @@ end = struct
end
(** DelTask : Remove a task from the queue *)
module DelTask_msg : sig
type t =
{ state: State.t;
task_id: Id.Task.t
}
val create : state:string -> task_id:string -> t
val to_string : t -> string
end = struct
type t =
{ state: State.t;
task_id: Id.Task.t
}
let create ~state ~task_id =
{ state = State.of_string state ;
task_id = Id.Task.of_string task_id
}
let to_string x =
Printf.sprintf "del_task %s %d"
(State.to_string x.state)
(Id.Task.to_int x.task_id)
end
(** DelTaskReply : Reply to the DelTask message *)
module DelTaskReply_msg : sig
type t
val create : task_id:Id.Task.t -> more:bool -> t
val to_string : t -> string
end = struct
type t = {
task_id : Id.Task.t ;
more : bool;
}
let create ~task_id ~more = { task_id ; more }
let to_string x =
let more =
if x.more then "more"
else "done"
in
Printf.sprintf "del_task_reply %s %d"
more (Id.Task.to_int x.task_id)
end
(** GetTask : get a new task to do *)
module GetTask_msg : sig
type t =
@ -196,14 +260,240 @@ end = struct
Printf.sprintf "get_task_reply %d %s" (Id.Task.to_int x.task_id) x.task
end
(** GetPsi : get the current variational wave function *)
module GetPsi_msg : sig
type t =
{ client_id: Id.Client.t ;
}
val create : client_id:string -> t
val to_string : t -> string
end = struct
type t =
{ client_id: Id.Client.t ;
}
let create ~client_id =
{ client_id = Id.Client.of_string client_id }
let to_string x =
Printf.sprintf "get_psi %d"
(Id.Client.to_int x.client_id)
end
module Psi : sig
type t =
{
n_state : Strictly_positive_int.t ;
n_det : Strictly_positive_int.t ;
psi_det_size : Strictly_positive_int.t ;
n_det_generators : Strictly_positive_int.t option;
n_det_selectors : Strictly_positive_int.t option;
psi_det : string ;
psi_coef : string ;
}
val create : n_state:Strictly_positive_int.t
-> n_det:Strictly_positive_int.t
-> psi_det_size:Strictly_positive_int.t
-> n_det_generators:Strictly_positive_int.t option
-> n_det_selectors:Strictly_positive_int.t option
-> psi_det:string -> psi_coef:string -> t
end = struct
type t =
{
n_state : Strictly_positive_int.t ;
n_det : Strictly_positive_int.t ;
psi_det_size : Strictly_positive_int.t ;
n_det_generators : Strictly_positive_int.t option;
n_det_selectors : Strictly_positive_int.t option;
psi_det : string ;
psi_coef : string ;
}
let create ~n_state ~n_det ~psi_det_size
~n_det_generators ~n_det_selectors ~psi_det ~psi_coef =
assert (Strictly_positive_int.to_int n_det <=
Strictly_positive_int.to_int psi_det_size );
{ n_state; n_det ; psi_det_size ;
n_det_generators ; n_det_selectors ;
psi_det ; psi_coef }
end
(** GetPsiReply_msg : Reply to the GetPsi message *)
module GetPsiReply_msg : sig
type t =
{ client_id : Id.Client.t ;
psi : Psi.t }
val create : client_id:Id.Client.t -> psi:Psi.t -> t
val to_string_list : t -> string list
val to_string : t -> string
end = struct
type t =
{ client_id : Id.Client.t ;
psi : Psi.t }
let create ~client_id ~psi =
{ client_id ; psi }
let to_string_list x =
let g, s =
match x.psi.Psi.n_det_generators, x.psi.Psi.n_det_selectors with
| Some g, Some s -> Strictly_positive_int.to_int g, Strictly_positive_int.to_int s
| _ -> -1, -1
in
[ Printf.sprintf "get_psi_reply %d %d %d %d %d %d"
(Id.Client.to_int x.client_id)
(Strictly_positive_int.to_int x.psi.Psi.n_state)
(Strictly_positive_int.to_int x.psi.Psi.n_det)
(Strictly_positive_int.to_int x.psi.Psi.psi_det_size)
g s ;
x.psi.Psi.psi_det ; x.psi.Psi.psi_coef ]
let to_string x =
let g, s =
match x.psi.Psi.n_det_generators, x.psi.Psi.n_det_selectors with
| Some g, Some s -> Strictly_positive_int.to_int g, Strictly_positive_int.to_int s
| _ -> -1, -1
in
Printf.sprintf "get_psi_reply %d %d %d %d %d %d"
(Id.Client.to_int x.client_id)
(Strictly_positive_int.to_int x.psi.Psi.n_state)
(Strictly_positive_int.to_int x.psi.Psi.n_det)
(Strictly_positive_int.to_int x.psi.Psi.psi_det_size)
g s
end
(** PutPsi : put the current variational wave function *)
module PutPsi_msg : sig
type t =
{ client_id : Id.Client.t ;
n_state : Strictly_positive_int.t ;
n_det : Strictly_positive_int.t ;
psi_det_size : Strictly_positive_int.t ;
n_det_generators : Strictly_positive_int.t option;
n_det_selectors : Strictly_positive_int.t option;
psi : Psi.t option }
val create :
client_id:string ->
n_state:string ->
n_det:string ->
psi_det_size:string ->
psi_det:string option ->
psi_coef:string option ->
n_det_generators: string option ->
n_det_selectors:string option -> t
val to_string_list : t -> string list
val to_string : t -> string
end = struct
type t =
{ client_id : Id.Client.t ;
n_state : Strictly_positive_int.t ;
n_det : Strictly_positive_int.t ;
psi_det_size : Strictly_positive_int.t ;
n_det_generators : Strictly_positive_int.t option;
n_det_selectors : Strictly_positive_int.t option;
psi : Psi.t option }
let create ~client_id ~n_state ~n_det ~psi_det_size ~psi_det ~psi_coef
~n_det_generators ~n_det_selectors =
let n_state, n_det, psi_det_size =
Int.of_string n_state
|> Strictly_positive_int.of_int ,
Int.of_string n_det
|> Strictly_positive_int.of_int ,
Int.of_string psi_det_size
|> Strictly_positive_int.of_int
in
assert (Strictly_positive_int.to_int psi_det_size >=
Strictly_positive_int.to_int n_det);
let n_det_generators, n_det_selectors =
match n_det_generators, n_det_selectors with
| Some x, Some y ->
Some (Strictly_positive_int.of_int @@ Int.of_string x),
Some (Strictly_positive_int.of_int @@ Int.of_string y)
| _ -> None, None
in
let psi =
match (psi_det, psi_coef) with
| (Some psi_det, Some psi_coef) ->
Some (Psi.create ~n_state ~n_det ~psi_det_size ~psi_det
~psi_coef ~n_det_generators ~n_det_selectors)
| _ -> None
in
{ client_id = Id.Client.of_string client_id ;
n_state ; n_det ; psi_det_size ; n_det_generators ;
n_det_selectors ; psi }
let to_string_list x =
match x.n_det_generators, x.n_det_selectors, x.psi with
| Some g, Some s, Some psi ->
[ Printf.sprintf "put_psi %d %d %d %d %d %d"
(Id.Client.to_int x.client_id)
(Strictly_positive_int.to_int x.n_state)
(Strictly_positive_int.to_int x.n_det)
(Strictly_positive_int.to_int x.psi_det_size)
(Strictly_positive_int.to_int g)
(Strictly_positive_int.to_int s) ;
psi.Psi.psi_det ; psi.Psi.psi_coef ]
| Some g, Some s, None ->
[ Printf.sprintf "put_psi %d %d %d %d %d %d"
(Id.Client.to_int x.client_id)
(Strictly_positive_int.to_int x.n_state)
(Strictly_positive_int.to_int x.n_det)
(Strictly_positive_int.to_int x.psi_det_size)
(Strictly_positive_int.to_int g)
(Strictly_positive_int.to_int s) ;
"None" ; "None" ]
| _ ->
[ Printf.sprintf "put_psi %d %d %d %d -1 -1"
(Id.Client.to_int x.client_id)
(Strictly_positive_int.to_int x.n_state)
(Strictly_positive_int.to_int x.n_det)
(Strictly_positive_int.to_int x.psi_det_size) ;
"None" ; "None" ]
let to_string x =
match x.n_det_generators, x.n_det_selectors, x.psi with
| Some g, Some s, Some psi ->
Printf.sprintf "put_psi %d %d %d %d %d %d"
(Id.Client.to_int x.client_id)
(Strictly_positive_int.to_int x.n_state)
(Strictly_positive_int.to_int x.n_det)
(Strictly_positive_int.to_int x.psi_det_size)
(Strictly_positive_int.to_int g)
(Strictly_positive_int.to_int s)
| Some g, Some s, None ->
Printf.sprintf "put_psi %d %d %d %d %d %d"
(Id.Client.to_int x.client_id)
(Strictly_positive_int.to_int x.n_state)
(Strictly_positive_int.to_int x.n_det)
(Strictly_positive_int.to_int x.psi_det_size)
(Strictly_positive_int.to_int g)
(Strictly_positive_int.to_int s)
| _, _, _ ->
Printf.sprintf "put_psi %d %d %d %d %d %d"
(Id.Client.to_int x.client_id)
(Strictly_positive_int.to_int x.n_state)
(Strictly_positive_int.to_int x.n_det)
(Strictly_positive_int.to_int x.psi_det_size)
(-1) (-1)
end
(** PutPsiReply_msg : Reply to the PutPsi message *)
module PutPsiReply_msg : sig
type t
val create : client_id:Id.Client.t -> t
val to_string : t -> string
end = struct
type t =
{ client_id : Id.Client.t ;
}
let create ~client_id =
{ client_id; }
let to_string x =
Printf.sprintf "put_psi_reply %d"
(Id.Client.to_int x.client_id)
end
(** TaskDone : Inform the server that a task is finished *)
module TaskDone_msg : sig
type t =
{ client_id: Id.Client.t ;
state: State.t ;
task_id: Id.Task.t;
}
{ client_id: Id.Client.t ;
state: State.t ;
task_id: Id.Task.t ;
}
val create : state:string -> client_id:string -> task_id:string -> t
val to_string : t -> string
end = struct
@ -215,7 +505,9 @@ end = struct
let create ~state ~client_id ~task_id =
{ client_id = Id.Client.of_string client_id ;
state = State.of_string state ;
task_id = Id.Task.of_string task_id }
task_id = Id.Task.of_string task_id;
}
let to_string x =
Printf.sprintf "task_done %s %d %d"
(State.to_string x.state)
@ -262,19 +554,26 @@ end
(** Message *)
type t =
| Newjob of Newjob_msg.t
| Connect of Connect_msg.t
| ConnectReply of ConnectReply_msg.t
| Disconnect of Disconnect_msg.t
| DisconnectReply of DisconnectReply_msg.t
| GetTask of GetTask_msg.t
| GetTaskReply of GetTaskReply_msg.t
| AddTask of AddTask_msg.t
| AddTaskReply of AddTaskReply_msg.t
| TaskDone of TaskDone_msg.t
| Terminate of Terminate_msg.t
| Ok of Ok_msg.t
| Error of Error_msg.t
| GetPsi of GetPsi_msg.t
| PutPsi of PutPsi_msg.t
| GetPsiReply of GetPsiReply_msg.t
| PutPsiReply of PutPsiReply_msg.t
| Newjob of Newjob_msg.t
| Endjob of Endjob_msg.t
| Connect of Connect_msg.t
| ConnectReply of ConnectReply_msg.t
| Disconnect of Disconnect_msg.t
| DisconnectReply of DisconnectReply_msg.t
| GetTask of GetTask_msg.t
| GetTaskReply of GetTaskReply_msg.t
| DelTask of DelTask_msg.t
| DelTaskReply of DelTaskReply_msg.t
| AddTask of AddTask_msg.t
| AddTaskReply of AddTaskReply_msg.t
| TaskDone of TaskDone_msg.t
| Terminate of Terminate_msg.t
| Ok of Ok_msg.t
| Error of Error_msg.t
let of_string s =
@ -286,6 +585,8 @@ let of_string s =
match l with
| "add_task" :: state :: task ->
AddTask (AddTask_msg.create ~state ~task:(String.concat ~sep:" " task) )
| "del_task" :: state :: task_id :: [] ->
DelTask (DelTask_msg.create ~state ~task_id)
| "get_task" :: state :: client_id :: [] ->
GetTask (GetTask_msg.create ~state ~client_id)
| "task_done" :: state :: client_id :: task_id :: [] ->
@ -296,8 +597,19 @@ let of_string s =
Connect (Connect_msg.create t)
| "new_job" :: state :: push_address_tcp :: push_address_inproc :: [] ->
Newjob (Newjob_msg.create push_address_tcp push_address_inproc state)
| "end_job" :: state :: [] ->
Endjob (Endjob_msg.create state)
| "terminate" :: [] ->
Terminate (Terminate_msg.create () )
| "get_psi" :: client_id :: [] ->
GetPsi (GetPsi_msg.create ~client_id)
| "put_psi" :: client_id :: n_state :: n_det :: psi_det_size :: n_det_generators :: n_det_selectors :: [] ->
PutPsi (PutPsi_msg.create ~client_id ~n_state ~n_det ~psi_det_size
~n_det_generators:(Some n_det_generators) ~n_det_selectors:(Some n_det_selectors)
~psi_det:None ~psi_coef:None )
| "put_psi" :: client_id :: n_state :: n_det :: psi_det_size :: [] ->
PutPsi (PutPsi_msg.create ~client_id ~n_state ~n_det ~psi_det_size ~n_det_generators:None
~n_det_selectors:None ~psi_det:None ~psi_coef:None )
| "ok" :: [] ->
Ok (Ok_msg.create ())
| "error" :: rest ->
@ -306,18 +618,29 @@ let of_string s =
let to_string = function
| Newjob x -> Newjob_msg.to_string x
| Connect x -> Connect_msg.to_string x
| ConnectReply x -> ConnectReply_msg.to_string x
| Disconnect x -> Disconnect_msg.to_string x
| DisconnectReply x -> DisconnectReply_msg.to_string x
| GetTask x -> GetTask_msg.to_string x
| GetTaskReply x -> GetTaskReply_msg.to_string x
| AddTask x -> AddTask_msg.to_string x
| AddTaskReply x -> AddTaskReply_msg.to_string x
| TaskDone x -> TaskDone_msg.to_string x
| Terminate x -> Terminate_msg.to_string x
| Ok x -> Ok_msg.to_string x
| Error x -> Error_msg.to_string x
| GetPsi x -> GetPsi_msg.to_string x
| PutPsiReply x -> PutPsiReply_msg.to_string x
| Newjob x -> Newjob_msg.to_string x
| Endjob x -> Endjob_msg.to_string x
| Connect x -> Connect_msg.to_string x
| ConnectReply x -> ConnectReply_msg.to_string x
| Disconnect x -> Disconnect_msg.to_string x
| DisconnectReply x -> DisconnectReply_msg.to_string x
| GetTask x -> GetTask_msg.to_string x
| GetTaskReply x -> GetTaskReply_msg.to_string x
| DelTask x -> DelTask_msg.to_string x
| DelTaskReply x -> DelTaskReply_msg.to_string x
| AddTask x -> AddTask_msg.to_string x
| AddTaskReply x -> AddTaskReply_msg.to_string x
| TaskDone x -> TaskDone_msg.to_string x
| Terminate x -> Terminate_msg.to_string x
| Ok x -> Ok_msg.to_string x
| Error x -> Error_msg.to_string x
| PutPsi x -> PutPsi_msg.to_string x
| GetPsiReply x -> GetPsiReply_msg.to_string x
let to_string_list = function
| PutPsi x -> PutPsi_msg.to_string_list x
| GetPsiReply x -> GetPsiReply_msg.to_string_list x
| _ -> assert false

108
ocaml/Progress_bar.ml Normal file
View File

@ -0,0 +1,108 @@
open Core.Std
type t =
{
title: string;
start_value: float;
cur_value : float;
end_value : float;
bar_length : int;
init_time : Time.t;
dirty : bool;
next : Time.t;
}
let init ?(bar_length=20) ?(start_value=0.) ?(end_value=1.) ~title =
{ title ; start_value ; end_value ; bar_length ; cur_value=start_value ;
init_time= Time.now () ; dirty = true ; next = Time.now () }
let update ~cur_value bar =
{ bar with cur_value ; dirty=true }
let increment_end bar =
{ bar with end_value=(bar.end_value +. 1.) ; dirty=true }
let increment_cur bar =
{ bar with cur_value=(bar.cur_value +. 1.) ; dirty=true }
let display_tty bar =
let percent =
100. *. (bar.cur_value -. bar.start_value) /.
(bar.end_value -. bar.start_value)
in
let n_hashes =
(Float.of_int bar.bar_length) *. percent /. 100.
|> Float.to_int
in
let hashes =
String.init bar.bar_length ~f:(fun i ->
if (i < n_hashes) then '#'
else ' '
)
in
let now =
Time.now ()
in
let running_time =
Time.abs_diff now bar.init_time
in
let stop_time =
let x =
Time.Span.to_float running_time
in
if (percent > 0.) then
x *. 100. /. percent -. x
|> Time.Span.of_float
else
Time.Span.of_float 0.
in
Printf.printf "%s : [%s] %4.1f%% | %10s, ~%10s left\r%!"
bar.title
hashes
percent
(Time.Span.to_string running_time)
(stop_time |> Time.Span.to_string );
{ bar with dirty = false ; next = Time.add now (Time.Span.of_float 0.1) }
let display_file bar =
let percent =
100. *. (bar.cur_value -. bar.start_value) /.
(bar.end_value -. bar.start_value)
in
let running_time =
Time.abs_diff (Time.now ()) bar.init_time
in
let stop_time =
let x =
Time.Span.to_float running_time
in
if (percent > 0.) then
x *. 100. /. percent -. x
|> Time.Span.of_float
else
Time.Span.of_float 0.
in
Printf.printf "%5.2f %% in %20s, ~%20s left\n%!"
percent
(Time.Span.to_string running_time)
(Time.Span.to_string stop_time);
{ bar with dirty = false ; next = Time.add (Time.now ()) (Time.Span.of_float 2.) }
let display bar =
if (not bar.dirty) then
bar
else if (Time.now () < bar.next) then
bar
else
begin
if (Unix.isatty Unix.stdout) then
display_tty bar
else
display_file bar
end

19
ocaml/Queuing_system.ml
View File

@ -1,4 +1,5 @@
open Core.Std
open Qptypes
type t =
@ -32,7 +33,7 @@ let add_task ~task q =
queued = task_id :: q.queued ;
tasks = Map.add q.tasks ~key:task_id ~data:task ;
next_task_id = Id.Task.increment task_id ;
}, task_id
}
@ -81,13 +82,25 @@ let end_task ~task_id ~client_id q =
in
{ q with
running = Map.remove running task_id ;
tasks = Map.remove tasks task_id ;
}
let del_task ~task_id q =
let { tasks ; _ } =
q
in
if (Map.mem tasks task_id) then
{ q with
tasks = Map.remove tasks task_id ;
}
else
Printf.sprintf "Task %d is already deleted" (Id.Task.to_int task_id)
|> failwith
let number_of_queued q =
List.length q.queued
Map.length q.tasks
let number_of_running q =
Map.length q.running

816
ocaml/TaskServer.ml
View File

@ -1,47 +1,60 @@
open Core.Std
open Qptypes
(**
The tasks server listens on a REQ socket and accepts the following commands:
* "new_job %s %s %s" state push_address_tcp push_address_inproc -> "OK"
-> "OK"
type t =
{
queue : Queuing_system.t ;
state : Message.State.t option ;
address_tcp : Address.Tcp.t option ;
address_inproc : Address.Inproc.t option ;
psi : Message.Psi.t option;
progress_bar : Progress_bar.t option ;
running : bool;
}
* "connect %s" ["tcp"|"inproc"]
-> "%d %s %s" id state push_address
* "disconnect %d" id
-> "OK"
* "get_task %d %s" id state
-> "%d %s" task_id task
let debug_env =
match Sys.getenv "QP_TASK_DEBUG" with
| Some x -> x <> ""
| None -> false
* "task_done %d task_id %s" id state
-> "%d %s" task_id task
*)
let debug str =
if debug_env then
Printf.printf "TASK : %s%!" str
let zmq_context =
ZMQ.Context.create ()
let bind_socket ~socket_type ~socket ~address =
try
ZMQ.Socket.bind socket address
with
| Unix.Unix_error (_, message, f) ->
failwith @@ Printf.sprintf
"\n%s\nUnable to bind the %s socket :\n %s\n%s"
f socket_type address message
| other_exception -> raise other_exception
let rec loop = function
| 0 -> failwith @@ Printf.sprintf
"Unable to bind the %s socket : %s "
socket_type address
| -1 -> ();
| i ->
try
ZMQ.Socket.bind socket address;
loop (-1)
with
| Unix.Unix_error _ -> (Time.pause @@ Time.Span.of_float 1. ; loop (i-1) )
| other_exception -> raise other_exception
in loop 10
(** Name of the host on which the server runs *)
let hostname = lazy (
try
Unix.gethostname ()
with
| _ -> "localhost"
)
)
(** IP address *)
let ip_address = lazy (
match Sys.getenv "QP_NIC" with
| None ->
@ -67,271 +80,540 @@ let ip_address = lazy (
)
let reply_ok rep_socket =
Message.Ok_msg.create ()
|> Message.Ok_msg.to_string
|> ZMQ.Socket.send rep_socket
let reply_wrong_state rep_socket =
Printf.printf "WRONG STATE\n%!";
Message.Error_msg.create "Wrong state"
|> Message.Error_msg.to_string
|> ZMQ.Socket.send rep_socket
let stop ~port =
let zmq_context =
ZMQ.Context.create ()
in
let req_socket =
ZMQ.Socket.create zmq_context ZMQ.Socket.req
and address =
Printf.sprintf "tcp://%s:%d" (Lazy.force ip_address) port
in
ZMQ.Socket.connect req_socket address;
debug "STOP";
let req_socket =
ZMQ.Socket.create zmq_context ZMQ.Socket.req
and address =
Printf.sprintf "tcp://%s:%d" (Lazy.force ip_address) port
in
ZMQ.Socket.set_linger_period req_socket 1_000_000;
ZMQ.Socket.connect req_socket address;
Message.Terminate (Message.Terminate_msg.create ())
|> Message.to_string
|> ZMQ.Socket.send ~block:false req_socket ;
Message.Terminate (Message.Terminate_msg.create ())
|> Message.to_string
|> ZMQ.Socket.send req_socket ;
let msg =
ZMQ.Socket.recv req_socket
|> Message.of_string
in
let () =
match msg with
| Message.Ok _ -> ()
| _ -> failwith "Problem in termination"
in
ZMQ.Socket.set_linger_period req_socket 1000;
ZMQ.Socket.close req_socket
let msg =
ZMQ.Socket.recv req_socket
|> Message.of_string
in
let () =
match msg with
| Message.Ok _ -> ()
| _ -> failwith "Problem in termination"
in
ZMQ.Socket.set_linger_period req_socket 1_000;
ZMQ.Socket.close req_socket
(** Run the task server *)
let run ~port =
let zmq_context =
ZMQ.Context.create ()
in
let new_job msg program_state rep_socket =
let rep_socket =
ZMQ.Socket.create zmq_context ZMQ.Socket.rep
and address =
Printf.sprintf "tcp://%s:%d" (Lazy.force ip_address) port
in
bind_socket "REP" rep_socket address;
let pollitem =
ZMQ.Poll.mask_of
[| (rep_socket, ZMQ.Poll.In) |]
in
Printf.printf "Task server running : %s\n%!" address;
(** State variables *)
let q = ref
(Queuing_system.create ())
and running =
ref true
and job =
ref None
in
let get_state () =
match !job with
| None -> None
| Some j -> Some j.Message.Newjob_msg.state
in
let get_tcp_address () =
match !job with
| Some j -> Address.Tcp j.Message.Newjob_msg.address_tcp
| None -> assert false
in
let get_inproc_address () =
match !job with
| Some j -> Address.Inproc j.Message.Newjob_msg.address_inproc
| None -> assert false
in
let ok =
Message.Ok (Message.Ok_msg.create ())
in
while ( !running )
do
let state =
get_state ()
and polling =
ZMQ.Poll.poll ~timeout:1000 pollitem
let state =
msg.Message.Newjob_msg.state
in
let terminate () =
running := false;
Message.to_string ok
|> ZMQ.Socket.send ~block:false rep_socket
let progress_bar =
Progress_bar.init
~start_value:0.
~end_value:1.
~bar_length:20
~title:(Message.State.to_string state)
in
and newjob x =
q := Queuing_system.create ();
job := Some x;
Message.to_string ok
|> ZMQ.Socket.send ~block:false rep_socket
let result =
{ program_state with
state = Some state ;
progress_bar = Some progress_bar ;
address_tcp = Some msg.Message.Newjob_msg.address_tcp;
address_inproc = Some msg.Message.Newjob_msg.address_inproc;
}
in
reply_ok rep_socket;
result
and connect state msg =
let push_address =
match msg with
| Message.Connect_msg.Tcp -> get_tcp_address ()
| Message.Connect_msg.Inproc -> get_inproc_address ()
| Message.Connect_msg.Ipc -> assert false
in
let new_q, client_id =
Queuing_system.add_client !q
in
q := new_q;
Message.ConnectReply (Message.ConnectReply_msg.create
~state ~client_id ~push_address)
|> Message.to_string
|> ZMQ.Socket.send ~block:false rep_socket
and disconnect state msg =
let s, c =
msg.Message.Disconnect_msg.state ,
msg.Message.Disconnect_msg.client_id
in
assert (s = state);
let new_q =
Queuing_system.del_client ~client_id:c !q
in
q := new_q;
let finished =
Queuing_system.number_of_queued !q +
Queuing_system.number_of_running !q = 0
in
Message.DisconnectReply (Message.DisconnectReply_msg.create
~state ~finished)
|> Message.to_string
|> ZMQ.Socket.send ~block:false rep_socket
let end_job msg program_state rep_socket =
and add_task state msg =
let s, task =
msg.Message.AddTask_msg.state,
msg.Message.AddTask_msg.task
in
assert (s = state);
Message.to_string ok
|> ZMQ.Socket.send ~block:false rep_socket
;
let failure () =
reply_wrong_state rep_socket;
program_state
and success state =
reply_ok rep_socket;
{ program_state with
state = None ;
progress_bar = None ;
}
in
match program_state.state with
| None -> failure ()
| Some state ->
begin
match
String.split ~on:' ' msg.Message.AddTask_msg.task
|> List.filter ~f:(fun x -> x <> "")
with
| "triangle" :: str_l :: [] ->
begin
let l =
Int.of_string str_l
in
for j=1 to l
do
let task =
Printf.sprintf "%d %s" j str_l
in
let new_q, _ =
Queuing_system.add_task ~task !q
in
q := new_q
done
end
| "range" :: str_i :: str_j :: [] ->
begin
let i, j =
Int.of_string str_i,
Int.of_string str_j
in
for k=i to (j+1)
do
let task =
Int.to_string k
in
let new_q, task_id =
Queuing_system.add_task ~task !q
in
q := new_q
done
end
| _ ->
let new_q, task_id =
Queuing_system.add_task ~task !q
in
q := new_q
if (msg.Message.Endjob_msg.state = state) then
success state
else
failure ()
end
and get_task state msg =
let s, client_id =
msg.Message.GetTask_msg.state,
msg.Message.GetTask_msg.client_id
in
assert (s = state);
let new_q, task_id, task =
Queuing_system.pop_task ~client_id !q
in
q := new_q;
let reply =
let connect msg program_state rep_socket =
let state =
match program_state.state with
| Some state -> state
| None -> assert false
in
let push_address =
match msg with
| Message.Connect_msg.Tcp ->
begin
match program_state.address_tcp with
| Some address -> Address.Tcp address
| None -> failwith "Error: No TCP address"
end
| Message.Connect_msg.Inproc ->
begin
match program_state.address_inproc with
| Some address -> Address.Inproc address
| None -> failwith "Error: No inproc address"
end
| Message.Connect_msg.Ipc -> assert false
in
let new_queue, client_id =
Queuing_system.add_client program_state.queue
in
Message.ConnectReply (Message.ConnectReply_msg.create
~state:state ~client_id ~push_address)
|> Message.to_string
|> ZMQ.Socket.send rep_socket ;
{ program_state with
queue = new_queue
}
let disconnect msg program_state rep_socket =
let state, client_id =
msg.Message.Disconnect_msg.state,
msg.Message.Disconnect_msg.client_id
in
let failure () =
reply_wrong_state rep_socket;
program_state
and success () =
let new_program_state =
{ program_state with
queue = Queuing_system.del_client ~client_id program_state.queue
}
in
Message.DisconnectReply (Message.DisconnectReply_msg.create ~state)
|> Message.to_string
|> ZMQ.Socket.send rep_socket ;
new_program_state
in
match program_state.state with
| None -> assert false
| Some state' ->
begin
if (state = state') then
success ()
else
failure ()
end
let del_task msg program_state rep_socket =
let state, task_id =
msg.Message.DelTask_msg.state,
msg.Message.DelTask_msg.task_id
in
let failure () =
reply_wrong_state rep_socket;
program_state
and success () =
let new_program_state =
{ program_state with
queue = Queuing_system.del_task ~task_id program_state.queue
}
in
let more =
(Queuing_system.number_of_queued new_program_state.queue +
Queuing_system.number_of_running new_program_state.queue) > 0
in
Message.DelTaskReply (Message.DelTaskReply_msg.create ~task_id ~more)
|> Message.to_string
|> ZMQ.Socket.send ~block:true rep_socket ; (** /!\ Has to be blocking *)
new_program_state
in
match program_state.state with
| None -> assert false
| Some state' ->
begin
if (state = state') then
success ()
else
failure ()
end
let add_task msg program_state rep_socket =
let state, task =
msg.Message.AddTask_msg.state,
msg.Message.AddTask_msg.task
in
let increment_progress_bar = function
| Some bar -> Some (Progress_bar.increment_end bar)
| None -> None
in
let rec add_task_triangle program_state imax = function
| 0 -> program_state
| i ->
let task =
Printf.sprintf "%d %d" i imax
in
let new_program_state =
{ program_state with
queue = Queuing_system.add_task ~task program_state.queue ;
progress_bar = increment_progress_bar program_state.progress_bar ;
}
in
add_task_triangle new_program_state imax (i-1)
in
let rec add_task_range program_state i = function
| j when (j < i) -> program_state
| j ->
let task =
Printf.sprintf "%d" j
in
let new_program_state =
{ program_state with
queue = Queuing_system.add_task ~task program_state.queue ;
progress_bar = increment_progress_bar program_state.progress_bar ;
}
in
add_task_range new_program_state i (j-1)
in
let new_program_state = function
| "triangle" :: i_str :: [] ->
let imax =
Int.of_string i_str
in
add_task_triangle program_state imax imax
| "range" :: i_str :: j_str :: [] ->
let i, j =
Int.of_string i_str,
Int.of_string j_str
in
add_task_range program_state i j
| _ ->
{ program_state with
queue = Queuing_system.add_task ~task program_state.queue ;
progress_bar = increment_progress_bar program_state.progress_bar ;
}
in
let result =
String.split ~on:' ' task
|> List.filter ~f:(fun x -> x <> "")
|> new_program_state
in
reply_ok rep_socket;
result
let get_task msg program_state rep_socket =
let state, client_id =
msg.Message.GetTask_msg.state,
msg.Message.GetTask_msg.client_id
in
let failure () =
reply_wrong_state rep_socket;
program_state
and success () =
let new_queue, task_id, task =
Queuing_system.pop_task ~client_id program_state.queue
in
let new_program_state =
{ program_state with
queue = new_queue
}
in
match (task, task_id) with
| Some task, Some task_id ->
Message.GetTaskReply (Message.GetTaskReply_msg.create ~task ~task_id)
| _ -> Message.Terminate (Message.Terminate_msg.create ())
in
Message.to_string reply
|> ZMQ.Socket.send ~block:false rep_socket
and task_done state msg =
let s, client_id, task_id =
| Some task, Some task_id ->
begin
Message.GetTaskReply (Message.GetTaskReply_msg.create ~task ~task_id)
|> Message.to_string
|> ZMQ.Socket.send rep_socket ;
new_program_state
end
| _ ->
begin
Message.Terminate (Message.Terminate_msg.create ())
|> Message.to_string
|> ZMQ.Socket.send rep_socket ;
program_state
end
in
match program_state.state with
| None -> assert false
| Some state' ->
begin
if (state = state') then
success ()
else
failure ()
end
let task_done msg program_state rep_socket =
let state, client_id, task_id =
msg.Message.TaskDone_msg.state,
msg.Message.TaskDone_msg.client_id,
msg.Message.TaskDone_msg.task_id
in
assert (s = state);
let new_q =
Queuing_system.end_task ~task_id ~client_id !q
in
q := new_q;
Message.to_string ok
|> ZMQ.Socket.send ~block:false rep_socket
and error msg =
Message.Error (Message.Error_msg.create msg)
|> Message.to_string
|> ZMQ.Socket.send ~block:false rep_socket
in
if (polling.(0) = Some ZMQ.Poll.In) then
let raw_message =
ZMQ.Socket.recv rep_socket
in
try
let message =
Message.of_string raw_message
let increment_progress_bar = function
| Some bar -> Some (Progress_bar.increment_cur bar)
| None -> None
in
let failure () =
reply_wrong_state rep_socket;
program_state
and success () =
let result =
{ program_state with
queue = Queuing_system.end_task ~task_id ~client_id program_state.queue ;
progress_bar = increment_progress_bar program_state.progress_bar ;
}
in
(*
Printf.printf "%d %d : %s\n%!"
(Queuing_system.number_of_queued !q)
(Queuing_system.number_of_running !q)
(Message.to_string message);
Printf.printf "%s\n%!" (Queuing_system.to_string !q); *)
match (state, message) with
| _ , Message.Terminate _ -> terminate ()
| None , Message.Newjob x -> newjob x
| None , _ -> error "No job is running"
| _ , Message.Newjob _ -> error "A job is already running"
| Some s, Message.Connect x -> connect s x
| Some s, Message.Disconnect x -> disconnect s x
| Some s, Message.AddTask x -> add_task s x
| Some s, Message.GetTask x -> get_task s x
| Some s, Message.TaskDone x -> task_done s x
| _ , _ ->
error ("Invalid message : "^(Message.to_string message))
with
| Failure f -> error (f^" : "^raw_message)
| Assert_failure (f,i,j) -> error (Printf.sprintf "%s:%d:%d : %s" f i j raw_message)
done;
ZMQ.Socket.set_linger_period rep_socket 1000;
ZMQ.Socket.close rep_socket
reply_ok rep_socket;
result
in
match program_state.state with
| None -> assert false
| Some state' ->
begin
if (state = state') then
success ()
else
failure ()
end
(*
let () =
Printf.printf "export QP_RUN_ADDRESS=tcp://%s:%d\n%!" (Lazy.force ip_address) (Lazy.force port)
*)
let put_psi msg rest_of_msg program_state rep_socket =
let psi_local =
match msg.Message.PutPsi_msg.psi with
| Some x -> x
| None ->
begin
let psi_det, psi_coef =
match rest_of_msg with
| [ x ; y ] -> x, y
| _ -> failwith "Badly formed put_psi message"
in
Message.Psi.create
~n_state:msg.Message.PutPsi_msg.n_state
~n_det:msg.Message.PutPsi_msg.n_det
~psi_det_size:msg.Message.PutPsi_msg.psi_det_size
~n_det_generators:msg.Message.PutPsi_msg.n_det_generators
~n_det_selectors:msg.Message.PutPsi_msg.n_det_selectors
~psi_det
~psi_coef
end
in
let new_program_state =
{ program_state with
psi = Some psi_local
}
and client_id =
msg.Message.PutPsi_msg.client_id
in
Message.PutPsiReply (Message.PutPsiReply_msg.create ~client_id)
|> Message.to_string
|> ZMQ.Socket.send rep_socket;
new_program_state
let get_psi msg program_state rep_socket =
let client_id =
msg.Message.GetPsi_msg.client_id
in
match program_state.psi with
| None -> failwith "No wave function saved in TaskServer"
| Some psi ->
Message.GetPsiReply (Message.GetPsiReply_msg.create ~client_id ~psi)
|> Message.to_string_list
|> ZMQ.Socket.send_all rep_socket;
program_state
let terminate program_state rep_socket =
reply_ok rep_socket;
{ program_state with
running = false
}
let error msg program_state rep_socket =
Printf.printf "%s\n%!" msg;
Message.Error (Message.Error_msg.create msg)
|> Message.to_string
|> ZMQ.Socket.send rep_socket ;
program_state
let run ~port =
(** Bind REP socket *)
let rep_socket =
ZMQ.Socket.create zmq_context ZMQ.Socket.rep
and address =
Printf.sprintf "tcp://%s:%d" (Lazy.force ip_address) port
in
bind_socket "REP" rep_socket address;
ZMQ.Socket.set_linger_period rep_socket 1_000_000;
let initial_program_state =
{ queue = Queuing_system.create () ;
running = true ;
psi = None;
state = None;
address_tcp = None;
address_inproc = None;
progress_bar = None ;
}
in
(** ZMR polling item *)
let pollitem =
ZMQ.Poll.mask_of
[| (rep_socket, ZMQ.Poll.In) |]
in
Printf.printf "Task server running : %s\n%!" address;
(** Main loop *)
let rec main_loop program_state = function
| false -> ()
| true ->
let polling =
ZMQ.Poll.poll ~timeout:1000 pollitem
in
if (polling.(0) <> Some ZMQ.Poll.In) then
main_loop program_state true
else
begin
let program_state =
match program_state.progress_bar with
| None -> program_state
| Some bar ->
if bar.Progress_bar.dirty then
{ program_state with
progress_bar = Some (Progress_bar.display bar)
}
else
program_state
in
(** Extract message *)
let raw_message, rest =
match ZMQ.Socket.recv_all rep_socket with
| x :: rest -> x, rest
| [] -> failwith "Badly formed message"
in
let message =
Message.of_string raw_message
in
(** Debug input *)
Printf.sprintf "%d %d : %s\n%!"
(Queuing_system.number_of_queued program_state.queue)
(Queuing_system.number_of_running program_state.queue)
(Message.to_string message)
|> debug;
let new_program_state =
try
match program_state.state, message with
| _ , Message.Terminate _ -> terminate program_state rep_socket
| _ , Message.PutPsi x -> put_psi x rest program_state rep_socket
| _ , Message.GetPsi x -> get_psi x program_state rep_socket
| None , Message.Newjob x -> new_job x program_state rep_socket
| _ , Message.Newjob _ -> error "A job is already running" program_state rep_socket
| Some _, Message.Endjob x -> end_job x program_state rep_socket
| None , _ -> error "No job is running" program_state rep_socket
| Some _, Message.Connect x -> connect x program_state rep_socket
| Some _, Message.Disconnect x -> disconnect x program_state rep_socket
| Some _, Message.AddTask x -> add_task x program_state rep_socket
| Some _, Message.DelTask x -> del_task x program_state rep_socket
| Some _, Message.GetTask x -> get_task x program_state rep_socket
| Some _, Message.TaskDone x -> task_done x program_state rep_socket
| _ , _ ->
error ("Invalid message : "^(Message.to_string message)) program_state rep_socket
with
| Failure f ->
error (f^" : "^raw_message) program_state rep_socket
| Assert_failure (f,i,j) ->
error (Printf.sprintf "%s:%d:%d : %s" f i j raw_message) program_state rep_socket
in
main_loop new_program_state new_program_state.running
end
in main_loop initial_program_state true;

1
ocaml/_tags
View File

@ -1,2 +1,3 @@
true: package(core,sexplib.syntax,cryptokit,ZMQ)
true: thread
false: profile

308
ocaml/qp_edit.ml
View File

@ -1,308 +0,0 @@
open Qputils;;
open Qptypes;;
open Core.Std;;
(** Interactive editing of the input.
WARNING
This file is autogenerad by
`${QP_ROOT}/script/ezfio_interface/ei_handler.py`
*)
(** Keywords used to define input sections *)
type keyword =
| Ao_basis
| Determinants_by_hand
| Electrons
| Mo_basis
| Nuclei
| Determinants
| Perturbation
| Pseudo
| Integrals_bielec
| Properties
| Hartree_fock
;;
let keyword_to_string = function
| Ao_basis -> "AO basis"
| Determinants_by_hand -> "Determinants_by_hand"
| Electrons -> "Electrons"
| Mo_basis -> "MO basis"
| Nuclei -> "Molecule"
| Determinants -> "Determinants"
| Perturbation -> "Perturbation"
| Pseudo -> "Pseudo"
| Integrals_bielec -> "Integrals_bielec"
| Properties -> "Properties"
| Hartree_fock -> "Hartree_fock"
;;
(** Create the header of the temporary file *)
let file_header filename =
Printf.sprintf "
==================================================================
Quantum Package
==================================================================
Editing file `%s`
" filename
;;
(** Creates the header of a section *)
let make_header kw =
let s = keyword_to_string kw in
let l = String.length s in
"\n\n"^s^"\n"^(String.init l ~f:(fun _ -> '='))^"\n\n"
;;
(** Returns the rst string of section [s] *)
let get s =
let header = (make_header s) in
let f (read,to_rst) =
match read () with
| Some text -> header ^ (Rst_string.to_string (to_rst text))
| None -> ""
in
let rst =
try
begin
let open Input in
match s with
| Mo_basis ->
f Mo_basis.(read, to_rst)
| Electrons ->
f Electrons.(read, to_rst)
| Nuclei ->
f Nuclei.(read, to_rst)
| Ao_basis ->
f Ao_basis.(read, to_rst)
| Determinants_by_hand ->
f Determinants_by_hand.(read, to_rst)
| Determinants ->
f Determinants.(read, to_rst)
| Perturbation ->
f Perturbation.(read, to_rst)
| Pseudo ->
f Pseudo.(read, to_rst)
| Integrals_bielec ->
f Integrals_bielec.(read, to_rst)
| Properties ->
f Properties.(read, to_rst)
| Hartree_fock ->
f Hartree_fock.(read, to_rst)
end
with
| Sys_error msg -> (Printf.eprintf "Info: %s\n%!" msg ; "")
in
rst
;;
(** Applies the changes from the string [str] corresponding to section [s] *)
let set str s =
let header = (make_header s) in
match String.substr_index ~pos:0 ~pattern:header str with
| None -> ()
| Some idx ->
begin
let index_begin = idx + (String.length header) in
let index_end =
match ( String.substr_index ~pos:(index_begin+(String.length header)+1)
~pattern:"==" str) with
| Some i -> i
| None -> String.length str
in
let l = index_end - index_begin in
let str = String.sub ~pos:index_begin ~len:l str
|> Rst_string.of_string
in
let write (of_rst,w) s =
try
match of_rst str with
| Some data -> w data
| None -> ()
with
| _ -> (Printf.eprintf "Info: Read error in %s\n%!"
(keyword_to_string s); ignore (of_rst str) )
in
let open Input in
match s with
| Determinants -> write Determinants.(of_rst, write) s
| Perturbation -> write Perturbation.(of_rst, write) s
| Pseudo -> write Pseudo.(of_rst, write) s
| Integrals_bielec -> write Integrals_bielec.(of_rst, write) s
| Properties -> write Properties.(of_rst, write) s
| Hartree_fock -> write Hartree_fock.(of_rst, write) s
| Electrons -> write Electrons.(of_rst, write) s
| Determinants_by_hand -> write Determinants_by_hand.(of_rst, write) s
| Nuclei -> write Nuclei.(of_rst, write) s
| Ao_basis -> () (* TODO *)
| Mo_basis -> () (* TODO *)
end
;;
(** Creates the temporary file for interactive editing *)
let create_temp_file ezfio_filename fields =
let temp_filename = Filename.temp_file "qp_edit_" ".rst" in
begin
Out_channel.with_file temp_filename ~f:(fun out_channel ->
(file_header ezfio_filename) :: (List.map ~f:get fields)
|> String.concat ~sep:"\n"
|> Out_channel.output_string out_channel
)
end
; temp_filename
;;
let run check_only ezfio_filename =
(* Open EZFIO *)
if (not (Sys.file_exists_exn ezfio_filename)) then
failwith (ezfio_filename^" does not exists");
Ezfio.set_file ezfio_filename;
(*
let output = (file_header ezfio_filename) :: (
List.map ~f:get [
Ao_basis ;
Mo_basis ;
])
in
String.concat output
|> print_string
*)
let tasks = [
Nuclei ;
Ao_basis;
Electrons ;
Determinants ;
Perturbation ;
Pseudo ;
Integrals_bielec ;
Properties ;
Hartree_fock ;
Mo_basis;
Determinants_by_hand ;
]
in
(* Create the temp file *)
let temp_filename = create_temp_file ezfio_filename tasks in
(* Open the temp file with external editor *)
let editor =
match Sys.getenv "EDITOR" with
| Some editor -> editor
| None -> "vi"
in
match check_only with
| true -> ()
| false ->
Printf.sprintf "%s %s" editor temp_filename
|> Sys.command_exn
;
(* Re-read the temp file *)
let temp_string =
In_channel.with_file temp_filename ~f:(fun in_channel ->
In_channel.input_all in_channel)
in
List.iter ~f:(fun x -> set temp_string x) tasks;
(* Remove temp_file *)
Sys.remove temp_filename;
;;
(** Create a backup file in case of an exception *)
let create_backup ezfio_filename =
Printf.sprintf "
rm -f %s/backup.tgz ;
tar -zcf .backup.tgz %s && mv .backup.tgz %s/backup.tgz
"
ezfio_filename ezfio_filename ezfio_filename
|> Sys.command_exn
;;
(** Restore the backup file when an exception occuprs *)
let restore_backup ezfio_filename =
Printf.sprintf "tar -zxf %s/backup.tgz"
ezfio_filename
|> Sys.command_exn
;;
let spec =
let open Command.Spec in
empty
+> flag "-c" no_arg
~doc:"Checks the input data"
(*
+> flag "o" (optional string)
~doc:"Prints output data"
*)
+> anon ("ezfio_file" %: string)
;;
let command =
Command.basic
~summary: "Quantum Package command"
~readme:(fun () ->
"
Edit input data
")
spec
(* (fun i o ezfio_file () -> *)
(*fun ezfio_file () ->
try
run ezfio_file
with
| _ msg -> print_string ("\n\nError\n\n"^msg^"\n\n")
*)
(fun c ezfio_file () ->
try
run c ezfio_file ;
(* create_backup ezfio_file; *)
with
| Failure exc
| Invalid_argument exc as e ->
begin
Printf.eprintf "=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n\n";
Printf.eprintf "%s\n\n" exc;
Printf.eprintf "=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n\n";
(* restore_backup ezfio_file; *)
raise e
end
| Assert_failure (file, line, ch) as e ->
begin
Printf.eprintf "=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n\n";
Printf.eprintf "Assert error in file $QP_ROOT/ocaml/%s, line %d, character %d\n\n" file line ch;
Printf.eprintf "=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n\n";
(* restore_backup ezfio_file; *)
raise e
end
)
;;
let () =
Command.run command;
exit 0
;;

95
ocaml/qp_run.ml
View File

@ -1,21 +1,64 @@
open Core.Std;;
open Qputils;;
open Core.Std
open Qputils
(* Environment variables :
QP_PREFIX=gdb : to run gdb (or valgrind, or whatever)
QP_TASK_DEBUG=1 : debug task server
*)
let print_list () =
Lazy.force Qpackage.executables
|> List.iter ~f:(fun (x,_) -> Printf.printf " * %s\n" x)
;;
let run exe ezfio_file =
let () =
Random.self_init ()
let time_start = Time.now() in
let run ~master exe ezfio_file =
(** Check availability of the ports *)
let port_number =
let zmq_context =
ZMQ.Context.create ()
in
let dummy_socket =
ZMQ.Socket.create zmq_context ZMQ.Socket.rep
in
let rec try_new_port port_number =
try
List.iter [ 0;1;2;3;4 ] ~f:(fun i ->
let address =
Printf.sprintf "tcp://%s:%d" (Lazy.force TaskServer.ip_address) (port_number+i)
in
ZMQ.Socket.bind dummy_socket address;
ZMQ.Socket.unbind dummy_socket address;
);
port_number
with
| Unix.Unix_error _ -> try_new_port (port_number+100)
in
let result =
try_new_port 41279
in
ZMQ.Socket.close dummy_socket;
result
in
let time_start =
Time.now ()
in
if (not (Sys.file_exists_exn ezfio_file)) then
failwith ("EZFIO directory "^ezfio_file^" not found");
let executables = Lazy.force Qpackage.executables in
if (not (List.exists ~f:(fun (x,_) -> x = exe) executables)) then
failwith ("Executable "^exe^" not found");
begin
Printf.printf "\nPossible choices:\n";
List.iter executables ~f:(fun (x,_) -> Printf.printf "* %s\n%!" x);
failwith ("Executable "^exe^" not found")
end;
Printf.printf "%s\n" (Time.to_string time_start);
Printf.printf "===============\nQuantum Package\n===============\n\n";
@ -26,16 +69,18 @@ let run exe ezfio_file =
(** Check input *)
match (Sys.command ("qp_edit -c "^ezfio_file)) with
| 0 -> ()
| i -> failwith "Error: Input inconsistent\n";
;
begin
match (Sys.command ("qp_edit -c "^ezfio_file)) with
| 0 -> ()
| i -> failwith "Error: Input inconsistent\n"
end;
begin
match master with
| Some address -> Unix.putenv ~key:"QP_RUN_ADDRESS_MASTER" ~data:address
| None -> ()
end;
(** Start task server *)
let port_number =
12345
in
let address =
Printf.sprintf "tcp://%s:%d" (Lazy.force TaskServer.ip_address) port_number
in
@ -49,12 +94,16 @@ let run exe ezfio_file =
Unix.putenv ~key:"QP_RUN_ADDRESS" ~data:address;
(** Run executable *)
let exe =
let prefix =
match Sys.getenv "QP_PREFIX" with
| Some x -> x^" "
| None -> ""
and exe =
match (List.find ~f:(fun (x,_) -> x = exe) executables) with
| Some (_,x) -> x^" "
| None -> assert false
| Some (_,x) -> x
in
match (Sys.command (exe^" "^ezfio_file)) with
match (Sys.command (prefix^exe^ezfio_file)) with
| 0 -> ()
| i -> Printf.printf "Program exited with code %d.\n%!" i;
;
@ -64,16 +113,19 @@ let run exe ezfio_file =
let duration = Time.diff (Time.now()) time_start
|> Core.Span.to_string in
Printf.printf "Wall time : %s\n\n" duration;
;;
Printf.printf "Wall time : %s\n\n" duration
let spec =
let open Command.Spec in
empty
+> flag "master" (optional string)
~doc:("address Address of the master process")
+> anon ("executable" %: string)
+> anon ("ezfio_file" %: string)
;;
let () =
Command.basic
~summary: "Quantum Package command"
@ -85,10 +137,9 @@ Executes a Quantum Package binary file among these:\n\n"
)
)
spec
(fun exe ezfio_file () ->
run exe ezfio_file
(fun master exe ezfio_file () ->
run ~master exe ezfio_file
)
|> Command.run ~version: Git.sha1 ~build_info: Git.message
;;

3
ocaml/qptypes_generator.ml
View File

@ -13,6 +13,9 @@ let input_data = "
* Strictly_negative_float : float
assert (x < 0.) ;
* Positive_int64 : int64
assert (x >= 0L) ;
* Positive_int : int
assert (x >= 0) ;

59
ocaml/test_task_server.py
View File

@ -3,7 +3,6 @@
import zmq
import sys, os
def main():
context = zmq.Context()
socket = context.socket(zmq.REQ)
@ -11,9 +10,11 @@ def main():
def send(msg,expected):
print "Send : ", msg
print " -> ", socket.send(msg)
socket.send(msg)
reply = socket.recv()
print "Reply : ", reply
print "Reply : ", ':'+reply+':'
if (reply != expected):
print "Expected: ", ':'+expected+':'
print ""
assert (reply == expected)
@ -23,23 +24,59 @@ def main():
send("new_job ao_integrals tcp://130.120.229.139:12345 inproc://ao_integrals",
"error A job is already running")
send("connect","error Message not understood : connect")
# send("connect","error Message not understood : connect")
send("connect tcp","connect_reply ao_integrals 1 tcp://130.120.229.139:12345")
send("connect inproc","connect_reply ao_integrals 2 inproc://ao_integrals")
send("disconnect ao_integrals 3","error Queuing_system.ml:65:2 : disconnect ao_integrals 3")
send("disconnect ao_integrals 2","disconnect_reply ao_integrals 1")
send("disconnect ao_integrals 3","error Queuing_system.ml:68:2 : disconnect ao_integrals 3")
send("disconnect ao_integrals 2","disconnect_reply ao_integrals")
send("connect inproc","connect_reply ao_integrals 3 inproc://ao_integrals")
for i in range(10):
send("add_task ao_integrals triangle 3", "ok")
send("add_task ao_integrals range 4 7", "ok")
for i in range(8,11):
send("add_task ao_integrals %d %d"%(i,i+10), "ok")
for i in range(10):
send("get_task ao_integrals 3", "get_task_reply %d %d %d"%(i+1,i,i+10))
send("task_done ao_integrals 3 %d"%(i+1), "ok")
send("get_task ao_integrals 3", "get_task_reply 10 10 20")
send("get_task ao_integrals 3", "get_task_reply 9 9 19")
send("get_task ao_integrals 3", "get_task_reply 8 8 18")
send("get_task ao_integrals 3", "terminate")
send("task_done ao_integrals 3 10", "ok")
send("task_done ao_integrals 3 9", "ok")
send("task_done ao_integrals 3 8", "ok")
send("del_task ao_integrals 10", "del_task_reply more 10")
send("del_task ao_integrals 9", "del_task_reply more 9")
send("del_task ao_integrals 8", "del_task_reply more 8")
send("del_task ao_integrals 10", "error Task 10 is already deleted : del_task ao_integrals 10")
send("get_task ao_integrals 1", "get_task_reply 7 4")
send("get_task ao_integrals 3", "get_task_reply 6 5")
send("get_task ao_integrals 1", "get_task_reply 5 6")
send("get_task ao_integrals 3", "get_task_reply 4 7")
send("get_task ao_integrals 3", "get_task_reply 3 1 3")
send("get_task ao_integrals 1", "get_task_reply 2 2 3")
send("get_task ao_integrals 1", "get_task_reply 1 3 3")
send("task_done ao_integrals 1 1", "ok")
send("task_done ao_integrals 1 2", "ok")
send("task_done ao_integrals 3 3", "ok")
send("task_done ao_integrals 3 4", "ok")
send("task_done ao_integrals 1 5", "ok")
send("task_done ao_integrals 1 6", "error Queuing_system.ml:81:30 : task_done ao_integrals 1 6")
send("task_done ao_integrals 3 6", "ok")
send("task_done ao_integrals 1 7", "ok")
send("del_task ao_integrals 1", "del_task_reply more 1")
send("del_task ao_integrals 2", "del_task_reply more 2")
send("del_task ao_integrals 3", "del_task_reply more 3")
send("del_task ao_integrals 4", "del_task_reply more 4")
send("del_task ao_integrals 5", "del_task_reply more 5")
send("del_task ao_integrals 6", "del_task_reply more 6")
send("del_task ao_integrals 7", "del_task_reply done 7")
send("end_job ao_integrals","ok")
send("end_job ao_integrals","error No job is running")
send("terminate","ok")
if __name__ == '__main__':

5
plugins/All_singles/EZFIO.cfg Normal file
View File

@ -0,0 +1,5 @@
[energy]
type: double precision
doc: Calculated Selected all_singles or all_1h_1p energy
interface: ezfio

18
plugins/All_singles/H_apply.irp.f Normal file
View File

@ -0,0 +1,18 @@
use bitmasks
BEGIN_SHELL [ /usr/bin/env python ]
from generate_h_apply import *
s = H_apply("just_1h_1p")
s.set_selection_pt2("epstein_nesbet_2x2")
s.unset_skip()
s.filter_only_1h1p()
print s
s = H_apply("just_mono")
s.set_selection_pt2("epstein_nesbet_2x2")
s.unset_skip()
s.unset_double_excitations()
print s
END_SHELL

1
plugins/All_singles/NEEDED_CHILDREN_MODULES Normal file
View File

@ -0,0 +1 @@
Generators_restart Perturbation Properties Selectors_no_sorted Utils

12
plugins/All_singles/README.rst Normal file
View File

@ -0,0 +1,12 @@
===========
All_singles
===========
Needed Modules
==============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.
Documentation
=============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.

76
plugins/All_singles/all_1h_1p.irp.f Normal file
View File

@ -0,0 +1,76 @@
program restart_more_singles
BEGIN_DOC
! Generates and select single and double excitations of type 1h-1p
! on the top of a given restart wave function of type CAS
END_DOC
read_wf = .true.
touch read_wf
print*,'ref_bitmask_energy = ',ref_bitmask_energy
call routine
end
subroutine routine
implicit none
integer :: i,k
double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:),E_before(:)
integer :: N_st, degree
integer :: n_det_before
N_st = N_states
allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st))
i = 0
print*,'N_det = ',N_det
print*,'n_det_max = ',n_det_max
print*,'pt2_max = ',pt2_max
pt2=-1.d0
E_before = ref_bitmask_energy
do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max)
n_det_before = N_det
i += 1
print*,'-----------------------'
print*,'i = ',i
call H_apply_just_1h_1p(pt2, norm_pert, H_pert_diag, N_st)
call diagonalize_CI
print*,'N_det = ',N_det
print*,'E = ',CI_energy(1)
print*,'pt2 = ',pt2(1)
print*,'E+PT2 = ',E_before + pt2(1)
E_before = CI_energy
if(N_states_diag.gt.1)then
print*,'Variational Energy difference'
do i = 2, N_st
print*,'Delta E = ',CI_energy(i) - CI_energy(1)
enddo
endif
if(N_states.gt.1)then
print*,'Variational + perturbative Energy difference'
do i = 2, N_st
print*,'Delta E = ',E_before(i)+ pt2(i) - (E_before(1) + pt2(1))
enddo
endif
call save_wavefunction
if(n_det_before == N_det)then
selection_criterion = selection_criterion * 0.5d0
endif
enddo
threshold_davidson = 1.d-10
soft_touch threshold_davidson davidson_criterion
call diagonalize_CI
if(N_states_diag.gt.1)then
print*,'Variational Energy difference'
do i = 2, N_st
print*,'Delta E = ',CI_energy(i) - CI_energy(1)
enddo
endif
if(N_states.gt.1)then
print*,'Variational + perturbative Energy difference'
do i = 2, N_st
print*,'Delta E = ',CI_energy(i)+ pt2(i) - (CI_energy(1) + pt2(1))
enddo
endif
call ezfio_set_all_singles_energy(CI_energy)
call save_wavefunction
deallocate(pt2,norm_pert)
end

76
plugins/All_singles/all_singles.irp.f Normal file
View File

@ -0,0 +1,76 @@
program restart_more_singles
BEGIN_DOC
! Generates and select single excitations
! on the top of a given restart wave function
END_DOC
read_wf = .true.
touch read_wf
call routine
end
subroutine routine
implicit none
integer :: i,k
double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:)
integer :: N_st, degree
double precision,allocatable :: E_before(:)
integer :: n_det_before
N_st = N_states
allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st))
i = 0
print*,'N_det = ',N_det
print*,'n_det_max = ',n_det_max
print*,'pt2_max = ',pt2_max
pt2=-1.d0
E_before = ref_bitmask_energy
pt2_max = 1.d-10
n_det_max = 200000
do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max)
n_det_before = N_det
i += 1
print*,'-----------------------'
print*,'i = ',i
call H_apply_just_mono(pt2, norm_pert, H_pert_diag, N_st)
call diagonalize_CI
print*,'N_det = ',N_det
print*,'E = ',CI_energy
print*,'pt2 = ',pt2
print*,'E+PT2 = ',E_before + pt2
if(N_states_diag.gt.1)then
print*,'Variational Energy difference'
do i = 2, N_st
print*,'Delta E = ',CI_energy(i) - CI_energy(1)
enddo
endif
if(N_states.gt.1)then
print*,'Variational + perturbative Energy difference'
do i = 2, N_st
print*,'Delta E = ',E_before(i)+ pt2(i) - (E_before(1) + pt2(1))
enddo
endif
E_before = CI_energy
call save_wavefunction
if(n_det_before == N_det)then
selection_criterion = selection_criterion * 0.5d0
endif
enddo
threshold_davidson = 1.d-10
soft_touch threshold_davidson davidson_criterion
call diagonalize_CI
if(N_states_diag.gt.1)then
print*,'Variational Energy difference'
do i = 2, N_st
print*,'Delta E = ',CI_energy(i) - CI_energy(1)
enddo
endif
if(N_states.gt.1)then
print*,'Variational + perturbative Energy difference'
do i = 2, N_st
print*,'Delta E = ',CI_energy(i)+ pt2(i) - (CI_energy(1) + pt2(1))
enddo
endif
call save_wavefunction
deallocate(pt2,norm_pert,E_before)
end

3
plugins/CASSCF/casscf.irp.f
View File

@ -119,9 +119,6 @@ program casscf
E_CI = sum(CI_energy(1:N_states)+pt2(1:N_states))/dble(N_states)
call ezfio_set_casscf_energy(CI_energy(1))
if (abort_all) then
exit
endif
if (N_det == N_det_old) then
exit
endif

4
plugins/CAS_SD/H_apply.irp.f
View File

@ -20,18 +20,22 @@ print s
s = H_apply("CAS_S",do_double_exc=False)
s.unset_double_excitations()
print s
s = H_apply("CAS_S_selected_no_skip",do_double_exc=False)
s.unset_double_excitations()
s.set_selection_pt2("epstein_nesbet_2x2")
s.unset_skip()
print s
s = H_apply("CAS_S_selected",do_double_exc=False)
s.unset_double_excitations()
s.set_selection_pt2("epstein_nesbet_2x2")
print s
s = H_apply("CAS_S_PT2",do_double_exc=False)
s.unset_double_excitations()
s.set_perturbation("epstein_nesbet_2x2")
print s

3
plugins/CAS_SD/cas_s.irp.f
View File

@ -54,9 +54,6 @@ program full_ci
print *, 'E+PT2 = ', CI_energy+pt2
print *, '-----'
call ezfio_set_cas_sd_energy(CI_energy(1))
if (abort_all) then
exit
endif
if (N_det == N_det_old) then
exit
endif

3
plugins/CAS_SD/cas_s_selected.irp.f
View File

@ -51,9 +51,6 @@ program full_ci
print *, 'E+PT2 = ', CI_energy+pt2
print *, '-----'
call ezfio_set_cas_sd_energy(CI_energy(1))
if (abort_all) then
exit
endif
enddo
call diagonalize_CI

3
plugins/CAS_SD/cas_sd.irp.f
View File

@ -54,9 +54,6 @@ program full_ci
print *, 'E+PT2 = ', CI_energy+pt2
print *, '-----'
call ezfio_set_cas_sd_energy(CI_energy(1))
if (abort_all) then
exit
endif
if (N_det == N_det_old) then
exit
endif

3
plugins/CAS_SD/cas_sd_selected.irp.f
View File

@ -51,9 +51,6 @@ program full_ci
print *, 'E+PT2 = ', CI_energy+pt2
print *, '-----'
call ezfio_set_cas_sd_energy(CI_energy(1))
if (abort_all) then
exit
endif
enddo
call diagonalize_CI

9
plugins/CID_SC2_selected/cid_sc2_selection.irp.f
View File

@ -13,7 +13,7 @@ program cisd_sc2_selected
pt2 = 1.d0
perturbation = "epstein_nesbet_sc2_projected"
E_old(1) = HF_energy
davidson_threshold = 1.d-6
threshold_davidson = 1.d-6
do while (maxval(abs(pt2(1:N_st))) > 1.d-4)
print*,'----'
@ -33,14 +33,11 @@ program cisd_sc2_selected
E_old(i) = CI_SC2_energy(i)
enddo
! print *, 'E corr = ', (E_old(1)) - HF_energy
if (abort_all) then
exit
endif
enddo
pt2 = 0.d0
call H_apply_PT2(pt2, norm_pert, H_pert_diag, N_st)
davidson_threshold = 1.d-10
touch davidson_threshold davidson_criterion
threshold_davidson = 1.d-10
touch threshold_davidson davidson_criterion
do i = 1, N_st
max = 0.d0

3
plugins/CID_selected/cid_selection.irp.f → plugins/CID_selected/cid_selected.irp.f
View File

@ -26,9 +26,6 @@ program cisd
! print *, 'E+PT2_new= ', (E_old(1)+1.d0*pt2(1)+H_pert_diag(1))/(1.d0 +norm_pert(1))
enddo
E_old = CI_energy
if (abort_all) then
exit
endif
enddo
deallocate(pt2,norm_pert,H_pert_diag)
end

10
plugins/CIS/super_ci.irp.f
View File

@ -13,11 +13,11 @@ subroutine super_CI
character :: save_char
call write_time(output_hartree_fock)
write(output_hartree_fock,'(A4,X,A16, X, A16, X, A16 )'), &
write(output_hartree_fock,'(A4,X,A16, X, A16, X, A16 )') &
'====','================','================','================'
write(output_hartree_fock,'(A4,X,A16, X, A16, X, A16 )'), &
write(output_hartree_fock,'(A4,X,A16, X, A16, X, A16 )') &
' N ', 'Energy ', 'Energy diff ', 'Save '
write(output_hartree_fock,'(A4,X,A16, X, A16, X, A16 )'), &
write(output_hartree_fock,'(A4,X,A16, X, A16, X, A16 )') &
'====','================','================','================'
E = HF_energy + 1.d0
@ -39,7 +39,7 @@ subroutine super_CI
save_char = ' '
endif
E_min = min(E,E_min)
write(output_hartree_fock,'(I4,X,F16.10, X, F16.10, X, A8 )'),&
write(output_hartree_fock,'(I4,X,F16.10, X, F16.10, X, A8 )') &
k, E, delta_E, save_char
if ( (delta_E < 0.d0).and.(dabs(delta_E) < thresh_scf) ) then
exit
@ -55,7 +55,7 @@ subroutine super_CI
TOUCH mo_coef
enddo
write(output_hartree_fock,'(A4,X,A16, X, A16, X, A16 )'), &
write(output_hartree_fock,'(A4,X,A16, X, A16, X, A16 )') &
'====','================','================','================'
call write_time(output_hartree_fock)
end

9
plugins/CISD_SC2_selected/cisd_sc2_selection.irp.f
View File

@ -14,7 +14,7 @@ program cisd_sc2_selected
perturbation = "epstein_nesbet_sc2_projected"
E_old(1) = HF_energy
davidson_threshold = 1.d-10
threshold_davidson = 1.d-10
if (N_det > N_det_max) then
call diagonalize_CI_SC2
call save_wavefunction
@ -59,9 +59,6 @@ program cisd_sc2_selected
else
i_count = 0
endif
if (abort_all) then
exit
endif
! =~=~=~=~=~=~=~=~=~=~=~=~=~!
! W r i t e _ o n _ d i s k !
@ -71,8 +68,8 @@ program cisd_sc2_selected
enddo
N_det = min(N_det_max,N_det)
davidson_threshold = 1.d-10
touch N_det psi_det psi_coef davidson_threshold davidson_criterion
threshold_davidson = 1.d-10
touch N_det psi_det psi_coef threshold_davidson davidson_criterion
call diagonalize_CI_SC2
pt2 = 0.d0

3
plugins/CISD_selected/cisd_selected.irp.f
View File

@ -34,9 +34,6 @@ program cisd
enddo
E_old = CI_energy
call save_wavefunction
if (abort_all) then
exit
endif
enddo
N_det = min(N_det,N_det_max)
touch N_det psi_det psi_coef

3
plugins/DDCI_selected/ddci.irp.f
View File

@ -50,9 +50,6 @@ program ddci
print *, 'E+PT2 = ', CI_energy+pt2
print *, '-----'
call ezfio_set_ddci_selected_energy(CI_energy)
if (abort_all) then
exit
endif
enddo
if(do_pt2_end)then
call H_apply_DDCI_pt2(pt2, norm_pert, H_pert_diag, N_st)

37
plugins/Dressed_Ref_Hamiltonian/Dressed_Ref_Hamiltonian.main.irp.f Normal file
View File

@ -0,0 +1,37 @@
program Dressed_Ref_Hamiltonian implicit none
BEGIN_DOC
! TODO
END_DOC
print *, ' _/ '
print *, ' -:\_?, _Jm####La '
print *, 'J"(:" > _]#AZ#Z#UUZ##, '
print *, '_,::./ %(|i%12XmX1*1XL _?, '
print *, ' \..\ _\(vmWQwodY+ia%lnL _",/ ( '
print *, ' .:< ]J=mQD?WXn<uQWmmvd, -.-:=!'
print *, ' "{Z jC]QW|=3Zv)Bi3BmXv3 = _7'
print *, ' ]h[Z6)WQ;)jZs]C;|$BZv+, : ./ '
print *, ' -#sJX%$Wmm#ev]hinW#Xi:` c ; '
print *, ' #X#X23###1}vI$WWmX1>|,)nr" '
print *, ' 4XZ#Xov1v}=)vnXAX1nnv;1n" '
print *, ' ]XX#ZXoovvvivnnnlvvo2*i7 '
print *, ' "23Z#1S2oo2XXSnnnoSo2>v" '
print *, ' miX#L -~`""!!1}oSoe|i7 '
print *, ' 4cn#m, v221=|v[ '
print *, ' ]hI3Zma,;..__wXSe=+vo '
print *, ' ]Zov*XSUXXZXZXSe||vo2 '
print *, ' ]Z#><iiii|i||||==vn2( '
print *, ' ]Z#i<ii||+|=||=:{no2[ '
print *, ' ]ZUsiiiiivi|=||=vo22[ '
print *, ' ]XZvlliiIi|i=|+|vooo '
print *, ' =v1llli||||=|||||lii( '
print *, ' ]iillii||||||||=>=|< '
print *, ' -ziiiii||||||+||==+> '
print *, ' -%|+++||=|=+|=|==/ '
print *, ' -a>====+|====-:- '
print *, ' "~,- -- /- '
print *, ' -. )> '
print *, ' .~ +- '
print *, ' . .... : . '
print *, ' -------~ '
print *, ''
end

1
plugins/Dressed_Ref_Hamiltonian/NEEDED_CHILDREN_MODULES Normal file
View File

@ -0,0 +1 @@
MRCC_Utils

16
plugins/Dressed_Ref_Hamiltonian/README.rst Normal file
View File

@ -0,0 +1,16 @@
=======================
Dressed_Ref_Hamiltonian
=======================
The following modules proposes to build an effective Hamiltonian
spanned on the reference determinants supposed to be the CAS ones.
The effective matrix Hamiltonian are built using the multi parentage
proposal used in the MR-CCSD formalism of Giner et. al. (JCP, 144, 064101 (2016); doi: 10.1063/1.4940781)
Needed Modules
==============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.
Documentation
=============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.

41
plugins/Dressed_Ref_Hamiltonian/dressed_eigenvectors.irp.f Normal file
View File

@ -0,0 +1,41 @@
BEGIN_PROVIDER [double precision, psi_ref_coef_dressed, (n_det_ref,N_states) ]
&BEGIN_PROVIDER [double precision, energies_ref_dressed, (N_states) ]
implicit none
integer :: i,j,k,l,istate,igoodstate
double precision, allocatable :: H_matrix_tmp(:,:)
double precision, allocatable :: eigvalues(:),eigvectors(:,:),psi_coef_ref_tmp(:)
double precision :: accu, accu1
allocate(H_matrix_tmp(n_det_ref,n_det_ref))
allocate(eigvalues(n_det_ref))
allocate(eigvectors(n_det_ref,n_det_ref))
allocate(psi_coef_ref_tmp(n_det_ref))
do istate = 1, N_states
accu1 = 0.d0
do j = 1, n_det_ref
accu1 += psi_ref_coef(j,istate)**2 ! norm of the "istate" eigenvector in the projected in the reference space
do k = 1, n_det_ref
H_matrix_tmp(j,k) = hamiltonian_total_dressed(j,k,istate)
enddo
enddo
accu1 = 1.d0/dsqrt(accu1)
do j = 1, n_det_ref
psi_coef_ref_tmp(j) = psi_ref_coef(j,istate) * accu1
enddo
call lapack_diagd(eigvalues,eigvectors,H_matrix_tmp,n_det_ref,n_det_ref)
do j = 1, n_det_ref
accu = 0.d0
do k = 1, n_det_ref
accu += eigvectors(k,j) * psi_coef_ref_tmp(k)
enddo
if(dabs(accu).gt.0.9d0)then
igoodstate = j
exit
endif
enddo
energies_ref_dressed(istate) = eigvalues(igoodstate)
do j = 1,n_det_ref
psi_ref_coef_dressed(j,istate) = eigvectors(j,igoodstate)
enddo
enddo
END_PROVIDER

46
plugins/Dressed_Ref_Hamiltonian/dressed_hamiltonian.irp.f Normal file
View File

@ -0,0 +1,46 @@
BEGIN_PROVIDER [double precision, dressing_ref_hamiltonian, (n_det_ref,n_det_ref,N_states)]
implicit none
integer :: i,j,k,l
integer :: ii,jj,istate
double precision :: hij,sec_order,H_ref(N_det_ref),hik,hkl
integer :: idx(0:N_det_ref)
double precision :: accu_negative,accu_positive,phase
integer :: degree_exc_ionic,degree_exc_neutral,exc(0:2,2,2)
dressing_ref_hamiltonian = 0.d0
accu_negative = 0.d0
accu_positive = 0.d0
integer :: h1,p1,h2,p2,s1,s2
do istate = 1, N_states
do i = 1, N_det_non_ref
call filter_connected_i_H_psi0(psi_ref,psi_non_ref(1,1,i),N_int,N_det_ref,idx)
H_ref = 0.d0
do ii=1,idx(0)
k = idx(ii)
!DEC$ FORCEINLINE
call i_H_j(psi_ref(1,1,k),psi_non_ref(1,1,i),N_int,hij)
H_ref(k) = hij
enddo
do ii= 1, idx(0)
k = idx(ii)
hik = H_ref(k) * lambda_mrcc(istate,i)
do jj = 1, idx(0)
l = idx(jj)
dressing_ref_hamiltonian(k,l,istate) += hik * H_ref(l)
enddo
enddo
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, hamiltonian_total_dressed, (n_det_ref,n_det_ref,N_states)]
implicit none
integer :: i,j,k
do k = 1, N_states
do i = 1, N_det_ref
do j = 1, N_det_ref
hamiltonian_total_dressed(j,i,k) = dressing_ref_hamiltonian(j,i,k) + ref_hamiltonian_matrix(j,i)
enddo
enddo
enddo
END_PROVIDER

108
plugins/Dressed_Ref_Hamiltonian/print_CAS_effective_Hamiltonian.irp.f Normal file
View File

@ -0,0 +1,108 @@
program print
read_wf = .True.
touch read_wf
call provide_all_stuffs
end
subroutine provide_all_stuffs
implicit none
provide ref_hamiltonian_matrix dressing_ref_hamiltonian
integer :: i,j,istate
double precision, allocatable :: psi_restart_ref_normalized(:),psi_ref_zeroth_order(:),psi_ref_dressed(:)
double precision, allocatable :: eigvalues(:),eigvectors(:,:)
double precision, allocatable :: H_dressed(:,:)
double precision, allocatable :: H_print(:,:)
double precision :: accu_norm
allocate (H_dressed(N_det_ref,N_det_ref))
allocate (H_print(N_det_ref,N_det_ref))
allocate (psi_restart_ref_normalized(N_det_ref))
allocate (psi_ref_zeroth_order(N_det_ref))
print*,'# nuclear_repulsion = ',nuclear_repulsion
allocate (psi_ref_dressed(N_det_ref))
allocate (eigvalues(N_det_ref))
allocate (eigvectors(N_det_ref,N_det_ref))
do istate= 1, N_states
do i = 1, N_det_ref
do j = 1, N_det_ref
H_print(i,j) = ref_hamiltonian_matrix(j,i)
enddo
enddo
do i = 1, N_det_ref
H_print(i,i) -= ref_hamiltonian_matrix(1,1)
enddo
print*,'Ref Hamiltonian matrix emelent = ',ref_hamiltonian_matrix(1,1)
print*,'ISTATE = ',istate
accu_norm = 0.d0
do i = 1, N_det_ref
accu_norm += psi_ref_coef(i,1) * psi_ref_coef(i,1)
enddo
print*,'accu_norm = ',accu_norm
accu_norm = 1.d0/dsqrt(accu_norm)
do i = 1, N_det_ref
psi_restart_ref_normalized(i) = psi_ref_coef(i,istate)* accu_norm
enddo
print*,'-------------------'
print*,'-------------------'
print*,'CAS MATRIX '
print*,''
do i = 1, N_det_ref
write(*,'(10(F8.5 ,4X))') H_print(i,:)
enddo
print*,''
print*,'-------------------'
print*,'-------------------'
print*,'CAS MATRIX DRESSING'
print*,''
do i = 1, N_det_ref
write(*,'(10(F8.5 ,4X))') dressing_ref_hamiltonian(i,:,istate)
enddo
print*,''
print*,'-------------------'
print*,'-------------------'
do i = 1, N_det_ref
do j = 1, N_det_ref
H_dressed(j,i) = ref_hamiltonian_matrix(j,i) + dressing_ref_hamiltonian(j,i,istate)
H_print(i,j) += dressing_ref_hamiltonian(j,i,istate)
enddo
enddo
print*,''
print*,'-------------------'
print*,'-------------------'
print*,'TOTAL DRESSED H MATRIX '
print*,''
do i = 1, N_det_ref
write(*,'(10(F8.5 ,4X))') H_print(i,:)
enddo
print*,''
print*,''
print*,''
call lapack_diagd(eigvalues,eigvectors,ref_hamiltonian_matrix,n_det_ref,n_det_ref)
do i = 1, N_det_ref
psi_ref_zeroth_order(i) = eigvectors(i,istate)
enddo
call lapack_diagd(eigvalues,eigvectors,H_dressed,n_det_ref,n_det_ref)
do i = 1, N_det_ref
psi_ref_dressed(i) = eigvectors(i,istate)
enddo
print*,'E+PT2 = ',eigvalues(istate) + nuclear_repulsion
do i = 1, N_det_ref
write(*,'(10(F10.7 ,4X))') psi_ref_coef(i,istate)/psi_ref_coef(1,istate), psi_ref_dressed(i)/psi_ref_dressed(1),psi_ref_zeroth_order(i)/psi_ref_zeroth_order(1)
enddo
enddo
deallocate (H_dressed)
deallocate (H_print)
deallocate (psi_restart_ref_normalized)
deallocate (psi_ref_zeroth_order)
deallocate (psi_ref_dressed)
deallocate (eigvalues)
deallocate (eigvectors)
end

30
plugins/FOBOCI/EZFIO.cfg Normal file
View File

@ -0,0 +1,30 @@
[threshold_singles]
type: double precision
doc: threshold to select the pertinent single excitations at second order
interface: ezfio,provider,ocaml
default: 0.01
[threshold_fobo_dm]
type: double precision
doc: threshold to eliminate small density matrix elements in the fobo procedure
interface: ezfio,provider,ocaml
default: 0.00001
[do_it_perturbative]
type: logical
doc: if true, you do the FOBOCI calculation perturbatively
interface: ezfio,provider,ocaml
default: .False.
[second_order_h]
type: logical
doc: if true, you do the FOBOCI calculation using second order intermediate Hamiltonian
interface: ezfio,provider,ocaml
default: .False.
[do_all_2p]
type: logical
doc: if true, you do all 2p type excitation on the LMCT
interface: ezfio,provider,ocaml
default: .True.

50
plugins/FOBOCI/H_apply.irp.f Normal file
View File

@ -0,0 +1,50 @@
use bitmasks
BEGIN_SHELL [ /usr/bin/env python ]
from generate_h_apply import *
s = H_apply("just_1h_1p")
s.set_selection_pt2("epstein_nesbet_2x2")
s.unset_skip()
s.filter_only_1h1p()
print s
s = H_apply("all_but_1h_and_1p")
s.set_selection_pt2("epstein_nesbet_2x2")
s.unset_skip()
s.filter_1h()
s.filter_1p()
print s
s = H_apply("standard")
s.set_selection_pt2("epstein_nesbet")
s.unset_skip()
print s
s = H_apply("just_mono",do_double_exc=False)
s.set_selection_pt2("epstein_nesbet_2x2")
s.unset_skip()
print s
s = H_apply("just_mono_no_1h_no_1p",do_double_exc=False)
s.set_selection_pt2("epstein_nesbet_2x2")
s.unset_skip()
s.filter_1h()
s.filter_1p()
print s
s = H_apply("just_mono_no_1h_no_1p_no_2p",do_double_exc=False)
s.set_selection_pt2("epstein_nesbet_2x2")
s.unset_skip()
s.filter_1h()
s.filter_1p()
s.filter_2p()
print s
END_SHELL

570
plugins/FOBOCI/H_apply_dressed_autonom.irp.f Normal file
View File

@ -0,0 +1,570 @@
subroutine H_apply_dressed_pert_diexc(key_in, hole_1,particl_1, hole_2, particl_2, i_generator, iproc_in , delta_ij_generators_, Ndet_generators,psi_det_generators_input,E_ref )
use omp_lib
use bitmasks
implicit none
BEGIN_DOC
! Generate all double excitations of key_in using the bit masks of holes and
! particles.
! Assume N_int is already provided.
END_DOC
integer,parameter :: size_max = 3072
integer, intent(in) :: Ndet_generators
double precision, intent(inout) :: delta_ij_generators_(Ndet_generators,Ndet_generators),E_ref
integer(bit_kind), intent(in) :: psi_det_generators_input(N_int,2,Ndet_generators)
integer ,intent(in) :: i_generator
integer(bit_kind),intent(in) :: key_in(N_int,2)
integer(bit_kind),allocatable :: keys_out(:,:,:)
integer(bit_kind), intent(in) :: hole_1(N_int,2), particl_1(N_int,2)
integer(bit_kind), intent(in) :: hole_2(N_int,2), particl_2(N_int,2)
integer, intent(in) :: iproc_in
integer(bit_kind), allocatable :: hole_save(:,:)
integer(bit_kind), allocatable :: key(:,:),hole(:,:), particle(:,:)
integer(bit_kind), allocatable :: hole_tmp(:,:), particle_tmp(:,:)
integer(bit_kind), allocatable :: key_union_hole_part(:)
integer :: ii,i,jj,j,k,ispin,l
integer, allocatable :: occ_particle(:,:), occ_hole(:,:)
integer, allocatable :: occ_particle_tmp(:,:), occ_hole_tmp(:,:)
integer :: kk,pp,other_spin,key_idx
integer :: N_elec_in_key_hole_1(2),N_elec_in_key_part_1(2)
integer :: N_elec_in_key_hole_2(2),N_elec_in_key_part_2(2)
double precision :: mo_bielec_integral
logical :: is_a_two_holes_two_particles
integer, allocatable :: ia_ja_pairs(:,:,:)
integer, allocatable :: ib_jb_pairs(:,:)
double precision :: diag_H_mat_elem
integer :: iproc
integer :: jtest_vvvv
integer(omp_lock_kind), save :: lck, ifirst=0
if (ifirst == 0) then
!$ call omp_init_lock(lck)
ifirst=1
endif
logical :: check_double_excitation
logical :: is_a_1h1p
logical :: b_cycle
check_double_excitation = .True.
iproc = iproc_in
PROVIDE elec_num_tab
! !$OMP PARALLEL DEFAULT(SHARED) &
! !$OMP PRIVATE(i,j,k,l,keys_out,hole,particle, &
! !$OMP occ_particle,occ_hole,j_a,k_a,other_spin, &
! !$OMP hole_save,ispin,jj,l_a,ib_jb_pairs,array_pairs, &
! !$OMP accu,i_a,hole_tmp,particle_tmp,occ_particle_tmp, &
! !$OMP occ_hole_tmp,key_idx,i_b,j_b,key,N_elec_in_key_part_1,&
! !$OMP N_elec_in_key_hole_1,N_elec_in_key_part_2, &
! !$OMP N_elec_in_key_hole_2,ia_ja_pairs,key_union_hole_part) &
! !$OMP SHARED(key_in,N_int,elec_num_tab,mo_tot_num, &
! !$OMP hole_1, particl_1, hole_2, particl_2, &
! !$OMP elec_alpha_num,i_generator) FIRSTPRIVATE(iproc)
!$ iproc = omp_get_thread_num()
allocate (keys_out(N_int,2,size_max), hole_save(N_int,2), &
key(N_int,2),hole(N_int,2), particle(N_int,2), hole_tmp(N_int,2),&
particle_tmp(N_int,2), occ_particle(N_int*bit_kind_size,2), &
occ_hole(N_int*bit_kind_size,2), occ_particle_tmp(N_int*bit_kind_size,2),&
occ_hole_tmp(N_int*bit_kind_size,2),key_union_hole_part(N_int))
!!!! First couple hole particle
do j = 1, N_int
hole(j,1) = iand(hole_1(j,1),key_in(j,1))
hole(j,2) = iand(hole_1(j,2),key_in(j,2))
particle(j,1) = iand(xor(particl_1(j,1),key_in(j,1)),particl_1(j,1))
particle(j,2) = iand(xor(particl_1(j,2),key_in(j,2)),particl_1(j,2))
enddo
call bitstring_to_list(particle(1,1),occ_particle(1,1),N_elec_in_key_part_1(1),N_int)
call bitstring_to_list(particle(1,2),occ_particle(1,2),N_elec_in_key_part_1(2),N_int)
call bitstring_to_list(hole(1,1),occ_hole(1,1),N_elec_in_key_hole_1(1),N_int)
call bitstring_to_list(hole(1,2),occ_hole(1,2),N_elec_in_key_hole_1(2),N_int)
allocate (ia_ja_pairs(2,0:(elec_alpha_num)*mo_tot_num,2), &
ib_jb_pairs(2,0:(elec_alpha_num)*mo_tot_num))
do ispin=1,2
i=0
do ii=N_elec_in_key_hole_1(ispin),1,-1 ! hole
i_a = occ_hole(ii,ispin)
ASSERT (i_a > 0)
ASSERT (i_a <= mo_tot_num)
do jj=1,N_elec_in_key_part_1(ispin) !particle
j_a = occ_particle(jj,ispin)
ASSERT (j_a > 0)
ASSERT (j_a <= mo_tot_num)
i += 1
ia_ja_pairs(1,i,ispin) = i_a
ia_ja_pairs(2,i,ispin) = j_a
enddo
enddo
ia_ja_pairs(1,0,ispin) = i
enddo
key_idx = 0
integer :: i_a,j_a,i_b,j_b,k_a,l_a,k_b,l_b
integer(bit_kind) :: test(N_int,2)
double precision :: accu
logical, allocatable :: array_pairs(:,:)
allocate(array_pairs(mo_tot_num,mo_tot_num))
accu = 0.d0
do ispin=1,2
other_spin = iand(ispin,1)+1
! !$OMP DO SCHEDULE (static)
do ii=1,ia_ja_pairs(1,0,ispin)
i_a = ia_ja_pairs(1,ii,ispin)
ASSERT (i_a > 0)
ASSERT (i_a <= mo_tot_num)
j_a = ia_ja_pairs(2,ii,ispin)
ASSERT (j_a > 0)
ASSERT (j_a <= mo_tot_num)
hole = key_in
k = ishft(i_a-1,-bit_kind_shift)+1
j = i_a-ishft(k-1,bit_kind_shift)-1
hole(k,ispin) = ibclr(hole(k,ispin),j)
k_a = ishft(j_a-1,-bit_kind_shift)+1
l_a = j_a-ishft(k_a-1,bit_kind_shift)-1
hole(k_a,ispin) = ibset(hole(k_a,ispin),l_a)
!!!! Second couple hole particle
do j = 1, N_int
hole_tmp(j,1) = iand(hole_2(j,1),hole(j,1))
hole_tmp(j,2) = iand(hole_2(j,2),hole(j,2))
particle_tmp(j,1) = iand(xor(particl_2(j,1),hole(j,1)),particl_2(j,1))
particle_tmp(j,2) = iand(xor(particl_2(j,2),hole(j,2)),particl_2(j,2))
enddo
call bitstring_to_list(particle_tmp(1,1),occ_particle_tmp(1,1),N_elec_in_key_part_2(1),N_int)
call bitstring_to_list(particle_tmp(1,2),occ_particle_tmp(1,2),N_elec_in_key_part_2(2),N_int)
call bitstring_to_list(hole_tmp (1,1),occ_hole_tmp (1,1),N_elec_in_key_hole_2(1),N_int)
call bitstring_to_list(hole_tmp (1,2),occ_hole_tmp (1,2),N_elec_in_key_hole_2(2),N_int)
! hole = a^(+)_j_a(ispin) a_i_a(ispin)|key_in> : mono exc :: orb(i_a,ispin) --> orb(j_a,ispin)
hole_save = hole
! Build array of the non-zero integrals of second excitation
array_pairs = .True.
if (ispin == 1) then
integer :: jjj
i=0
do kk = 1,N_elec_in_key_hole_2(other_spin)
i_b = occ_hole_tmp(kk,other_spin)
ASSERT (i_b > 0)
ASSERT (i_b <= mo_tot_num)
do jjj=1,N_elec_in_key_part_2(other_spin) ! particule
j_b = occ_particle_tmp(jjj,other_spin)
ASSERT (j_b > 0)
ASSERT (j_b <= mo_tot_num)
if (array_pairs(i_b,j_b)) then
i+= 1
ib_jb_pairs(1,i) = i_b
ib_jb_pairs(2,i) = j_b
endif
enddo
enddo
ib_jb_pairs(1,0) = i
do kk = 1,ib_jb_pairs(1,0)
hole = hole_save
i_b = ib_jb_pairs(1,kk)
j_b = ib_jb_pairs(2,kk)
k = ishft(i_b-1,-bit_kind_shift)+1
j = i_b-ishft(k-1,bit_kind_shift)-1
hole(k,other_spin) = ibclr(hole(k,other_spin),j)
key = hole
k = ishft(j_b-1,-bit_kind_shift)+1
l = j_b-ishft(k-1,bit_kind_shift)-1
key(k,other_spin) = ibset(key(k,other_spin),l)
key_idx += 1
do k=1,N_int
keys_out(k,1,key_idx) = key(k,1)
keys_out(k,2,key_idx) = key(k,2)
enddo
ASSERT (key_idx <= size_max)
if (key_idx == size_max) then
call standard_dress(delta_ij_generators_,size_max,Ndet_generators,i_generator,key_idx,keys_out,N_int,iproc,psi_det_generators_input,E_ref)
key_idx = 0
endif
enddo
endif
! does all the mono excitations of the same spin
i=0
do kk = 1,N_elec_in_key_hole_2(ispin)
i_b = occ_hole_tmp(kk,ispin)
if (i_b <= i_a.or.i_b == j_a) cycle
ASSERT (i_b > 0)
ASSERT (i_b <= mo_tot_num)
do jjj=1,N_elec_in_key_part_2(ispin) ! particule
j_b = occ_particle_tmp(jjj,ispin)
ASSERT (j_b > 0)
ASSERT (j_b <= mo_tot_num)
if (j_b <= j_a) cycle
if (array_pairs(i_b,j_b)) then
i+= 1
ib_jb_pairs(1,i) = i_b
ib_jb_pairs(2,i) = j_b
endif
enddo
enddo
ib_jb_pairs(1,0) = i
do kk = 1,ib_jb_pairs(1,0)
hole = hole_save
i_b = ib_jb_pairs(1,kk)
j_b = ib_jb_pairs(2,kk)
k = ishft(i_b-1,-bit_kind_shift)+1
j = i_b-ishft(k-1,bit_kind_shift)-1
hole(k,ispin) = ibclr(hole(k,ispin),j)
key = hole
k = ishft(j_b-1,-bit_kind_shift)+1
l = j_b-ishft(k-1,bit_kind_shift)-1
key(k,ispin) = ibset(key(k,ispin),l)
key_idx += 1
do k=1,N_int
keys_out(k,1,key_idx) = key(k,1)
keys_out(k,2,key_idx) = key(k,2)
enddo
ASSERT (key_idx <= size_max)
if (key_idx == size_max) then
call standard_dress(delta_ij_generators_,size_max,Ndet_generators,i_generator,key_idx,keys_out,N_int,iproc,psi_det_generators_input,E_ref)
key_idx = 0
endif
enddo ! kk
enddo ! ii
! !$OMP ENDDO NOWAIT
enddo ! ispin
call standard_dress(delta_ij_generators_,size_max,Ndet_generators,i_generator,key_idx,keys_out,N_int,iproc,psi_det_generators_input,E_ref)
deallocate (ia_ja_pairs, ib_jb_pairs, &
keys_out, hole_save, &
key,hole, particle, hole_tmp,&
particle_tmp, occ_particle, &
occ_hole, occ_particle_tmp,&
occ_hole_tmp,array_pairs,key_union_hole_part)
! !$OMP END PARALLEL
end
subroutine H_apply_dressed_pert_monoexc(key_in, hole_1,particl_1,i_generator,iproc_in , delta_ij_generators_, Ndet_generators,psi_det_generators_input,E_ref )
use omp_lib
use bitmasks
implicit none
BEGIN_DOC
! Generate all single excitations of key_in using the bit masks of holes and
! particles.
! Assume N_int is already provided.
END_DOC
integer,parameter :: size_max = 3072
integer, intent(in) :: Ndet_generators
double precision, intent(in) :: delta_ij_generators_(Ndet_generators,Ndet_generators),E_ref
integer(bit_kind), intent(in) :: psi_det_generators_input(N_int,2,Ndet_generators)
integer ,intent(in) :: i_generator
integer(bit_kind),intent(in) :: key_in(N_int,2)
integer(bit_kind),intent(in) :: hole_1(N_int,2), particl_1(N_int,2)
integer, intent(in) :: iproc_in
integer(bit_kind),allocatable :: keys_out(:,:,:)
integer(bit_kind),allocatable :: hole_save(:,:)
integer(bit_kind),allocatable :: key(:,:),hole(:,:), particle(:,:)
integer(bit_kind),allocatable :: hole_tmp(:,:), particle_tmp(:,:)
integer(bit_kind),allocatable :: hole_2(:,:), particl_2(:,:)
integer :: ii,i,jj,j,k,ispin,l
integer,allocatable :: occ_particle(:,:), occ_hole(:,:)
integer,allocatable :: occ_particle_tmp(:,:), occ_hole_tmp(:,:)
integer,allocatable :: ib_jb_pairs(:,:)
integer :: kk,pp,other_spin,key_idx
integer :: N_elec_in_key_hole_1(2),N_elec_in_key_part_1(2)
integer :: N_elec_in_key_hole_2(2),N_elec_in_key_part_2(2)
logical :: is_a_two_holes_two_particles
integer(bit_kind), allocatable :: key_union_hole_part(:)
integer, allocatable :: ia_ja_pairs(:,:,:)
logical, allocatable :: array_pairs(:,:)
double precision :: diag_H_mat_elem
integer(omp_lock_kind), save :: lck, ifirst=0
integer :: iproc
logical :: check_double_excitation
logical :: is_a_1h1p
logical :: is_a_1h
logical :: is_a_1p
iproc = iproc_in
check_double_excitation = .True.
check_double_excitation = .False.
if (ifirst == 0) then
ifirst=1
!!$ call omp_init_lock(lck)
endif
PROVIDE elec_num_tab
! !$OMP PARALLEL DEFAULT(SHARED) &
! !$OMP PRIVATE(i,j,k,l,keys_out,hole,particle, &
! !$OMP occ_particle,occ_hole,j_a,k_a,other_spin, &
! !$OMP hole_save,ispin,jj,l_a,ib_jb_pairs,array_pairs, &
! !$OMP accu,i_a,hole_tmp,particle_tmp,occ_particle_tmp, &
! !$OMP occ_hole_tmp,key_idx,i_b,j_b,key,N_elec_in_key_part_1,&
! !$OMP N_elec_in_key_hole_1,N_elec_in_key_part_2, &
! !$OMP N_elec_in_key_hole_2,ia_ja_pairs,key_union_hole_part) &
! !$OMP SHARED(key_in,N_int,elec_num_tab,mo_tot_num, &
! !$OMP hole_1, particl_1, hole_2, particl_2, &
! !$OMP elec_alpha_num,i_generator) FIRSTPRIVATE(iproc)
!!$ iproc = omp_get_thread_num()
allocate (keys_out(N_int,2,size_max), hole_save(N_int,2), &
key(N_int,2),hole(N_int,2), particle(N_int,2), hole_tmp(N_int,2),&
particle_tmp(N_int,2), occ_particle(N_int*bit_kind_size,2), &
occ_hole(N_int*bit_kind_size,2), occ_particle_tmp(N_int*bit_kind_size,2),&
occ_hole_tmp(N_int*bit_kind_size,2),key_union_hole_part(N_int))
!!!! First couple hole particle
do j = 1, N_int
hole(j,1) = iand(hole_1(j,1),key_in(j,1))
hole(j,2) = iand(hole_1(j,2),key_in(j,2))
particle(j,1) = iand(xor(particl_1(j,1),key_in(j,1)),particl_1(j,1))
particle(j,2) = iand(xor(particl_1(j,2),key_in(j,2)),particl_1(j,2))
enddo
call bitstring_to_list(particle(1,1),occ_particle(1,1),N_elec_in_key_part_1(1),N_int)
call bitstring_to_list(particle(1,2),occ_particle(1,2),N_elec_in_key_part_1(2),N_int)
call bitstring_to_list(hole (1,1),occ_hole (1,1),N_elec_in_key_hole_1(1),N_int)
call bitstring_to_list(hole (1,2),occ_hole (1,2),N_elec_in_key_hole_1(2),N_int)
allocate (ia_ja_pairs(2,0:(elec_alpha_num)*mo_tot_num,2))
do ispin=1,2
i=0
do ii=N_elec_in_key_hole_1(ispin),1,-1 ! hole
i_a = occ_hole(ii,ispin)
do jj=1,N_elec_in_key_part_1(ispin) !particule
j_a = occ_particle(jj,ispin)
i += 1
ia_ja_pairs(1,i,ispin) = i_a
ia_ja_pairs(2,i,ispin) = j_a
enddo
enddo
ia_ja_pairs(1,0,ispin) = i
enddo
key_idx = 0
integer :: i_a,j_a,i_b,j_b,k_a,l_a,k_b,l_b
integer(bit_kind) :: test(N_int,2)
double precision :: accu
accu = 0.d0
integer :: jjtest,na,nb
do ispin=1,2
other_spin = iand(ispin,1)+1
! !$OMP DO SCHEDULE (static)
do ii=1,ia_ja_pairs(1,0,ispin)
i_a = ia_ja_pairs(1,ii,ispin)
j_a = ia_ja_pairs(2,ii,ispin)
hole = key_in
k = ishft(i_a-1,-bit_kind_shift)+1
j = i_a-ishft(k-1,bit_kind_shift)-1
hole(k,ispin) = ibclr(hole(k,ispin),j)
k_a = ishft(j_a-1,-bit_kind_shift)+1
l_a = j_a-ishft(k_a-1,bit_kind_shift)-1
hole(k_a,ispin) = ibset(hole(k_a,ispin),l_a)
na = 0
nb = 0
! if (is_a_1h(hole)) then
! cycle
! endif
! if (is_a_1p(hole)) then
! cycle
! endif
key_idx += 1
do k=1,N_int
keys_out(k,1,key_idx) = hole(k,1)
keys_out(k,2,key_idx) = hole(k,2)
enddo
if (key_idx == size_max) then
call standard_dress(delta_ij_generators_,size_max,Ndet_generators,i_generator,key_idx,keys_out,N_int,iproc,psi_det_generators_input,E_ref)
key_idx = 0
endif
enddo ! ii
! !$OMP ENDDO NOWAIT
enddo ! ispin
call standard_dress(delta_ij_generators_,size_max,Ndet_generators,i_generator,key_idx,keys_out,N_int,iproc,psi_det_generators_input,E_ref)
deallocate (ia_ja_pairs, &
keys_out, hole_save, &
key,hole, particle, hole_tmp,&
particle_tmp, occ_particle, &
occ_hole, occ_particle_tmp,&
occ_hole_tmp,key_union_hole_part)
! !$OMP END PARALLEL
end
subroutine H_apply_dressed_pert(delta_ij_generators_, Ndet_generators,psi_det_generators_input,E_ref)
implicit none
use omp_lib
use bitmasks
BEGIN_DOC
! Calls H_apply on the HF determinant and selects all connected single and double
! excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script.
END_DOC
integer, intent(in) :: Ndet_generators
integer(bit_kind), intent(in) :: psi_det_generators_input(N_int,2,Ndet_generators),E_ref
double precision, intent(in) :: delta_ij_generators_(Ndet_generators,Ndet_generators)
integer :: i_generator, nmax
double precision :: wall_0, wall_1
integer(omp_lock_kind) :: lck
integer(bit_kind), allocatable :: mask(:,:,:)
integer :: ispin, k
integer :: iproc
PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map
nmax = mod( Ndet_generators,nproc )
! !$ call omp_init_lock(lck)
call wall_time(wall_0)
iproc = 0
allocate( mask(N_int,2,6) )
do i_generator=1,nmax
! ! Create bit masks for holes and particles
do ispin=1,2
do k=1,N_int
mask(k,ispin,s_hole) = &
iand(generators_bitmask(k,ispin,s_hole,i_bitmask_gen), &
psi_det_generators_input(k,ispin,i_generator) )
mask(k,ispin,s_part) = &
iand(generators_bitmask(k,ispin,s_part,i_bitmask_gen), &
not(psi_det_generators_input(k,ispin,i_generator)) )
mask(k,ispin,d_hole1) = &
iand(generators_bitmask(k,ispin,d_hole1,i_bitmask_gen), &
psi_det_generators_input(k,ispin,i_generator) )
mask(k,ispin,d_part1) = &
iand(generators_bitmask(k,ispin,d_part1,i_bitmask_gen), &
not(psi_det_generators_input(k,ispin,i_generator)) )
mask(k,ispin,d_hole2) = &
iand(generators_bitmask(k,ispin,d_hole2,i_bitmask_gen), &
psi_det_generators_input(k,ispin,i_generator) )
mask(k,ispin,d_part2) = &
iand(generators_bitmask(k,ispin,d_part2,i_bitmask_gen), &
not(psi_det_generators_input(k,ispin,i_generator)) )
enddo
enddo
if(.False.)then
call H_apply_dressed_pert_diexc(psi_det_generators_input(1,1,i_generator), &
mask(1,1,d_hole1), mask(1,1,d_part1), &
mask(1,1,d_hole2), mask(1,1,d_part2), &
i_generator, iproc , delta_ij_generators_, Ndet_generators,psi_det_generators_input,E_ref)
endif
if(.True.)then
call H_apply_dressed_pert_monoexc(psi_det_generators_input(1,1,i_generator), &
mask(1,1,s_hole ), mask(1,1,s_part ), &
i_generator, iproc , delta_ij_generators_, Ndet_generators,psi_det_generators_input,E_ref)
endif
call wall_time(wall_1)
if (wall_1 - wall_0 > 2.d0) then
write(output_determinants,*) &
100.*float(i_generator)/float(Ndet_generators), '% in ', wall_1-wall_0, 's'
wall_0 = wall_1
endif
enddo
deallocate( mask )
! !$OMP PARALLEL DEFAULT(SHARED) &
! !$OMP PRIVATE(i_generator,wall_1,wall_0,ispin,k,mask,iproc)
call wall_time(wall_0)
! !$ iproc = omp_get_thread_num()
allocate( mask(N_int,2,6) )
! !$OMP DO SCHEDULE(dynamic,1)
do i_generator=nmax+1,Ndet_generators
! Create bit masks for holes and particles
do ispin=1,2
do k=1,N_int
mask(k,ispin,s_hole) = &
iand(generators_bitmask(k,ispin,s_hole,i_bitmask_gen), &
psi_det_generators_input(k,ispin,i_generator) )
mask(k,ispin,s_part) = &
iand(generators_bitmask(k,ispin,s_part,i_bitmask_gen), &
not(psi_det_generators_input(k,ispin,i_generator)) )
mask(k,ispin,d_hole1) = &
iand(generators_bitmask(k,ispin,d_hole1,i_bitmask_gen), &
psi_det_generators_input(k,ispin,i_generator) )
mask(k,ispin,d_part1) = &
iand(generators_bitmask(k,ispin,d_part1,i_bitmask_gen), &
not(psi_det_generators_input(k,ispin,i_generator)) )
mask(k,ispin,d_hole2) = &
iand(generators_bitmask(k,ispin,d_hole2,i_bitmask_gen), &
psi_det_generators_input(k,ispin,i_generator) )
mask(k,ispin,d_part2) = &
iand(generators_bitmask(k,ispin,d_part2,i_bitmask_gen), &
not (psi_det_generators_input(k,ispin,i_generator)) )
enddo
enddo
if(.False.)then
call H_apply_dressed_pert_diexc(psi_det_generators_input(1,1,i_generator), &
mask(1,1,d_hole1), mask(1,1,d_part1), &
mask(1,1,d_hole2), mask(1,1,d_part2), &
i_generator, iproc , delta_ij_generators_, Ndet_generators,psi_det_generators_input,E_ref)
endif
if(.True.)then
call H_apply_dressed_pert_monoexc(psi_det_generators_input(1,1,i_generator), &
mask(1,1,s_hole ), mask(1,1,s_part ), &
i_generator, iproc , delta_ij_generators_, Ndet_generators,psi_det_generators_input,E_ref)
endif
! !$ call omp_set_lock(lck)
call wall_time(wall_1)
if (wall_1 - wall_0 > 2.d0) then
write(output_determinants,*) &
100.*float(i_generator)/float(Ndet_generators), '% in ', wall_1-wall_0, 's'
wall_0 = wall_1
endif
! !$ call omp_unset_lock(lck)
enddo
! !$OMP END DO
deallocate( mask )
! !$OMP END PARALLEL
! !$ call omp_destroy_lock(lck)
end

1
plugins/FOBOCI/NEEDED_CHILDREN_MODULES Normal file
View File

@ -0,0 +1 @@
Perturbation Generators_restart Selectors_no_sorted

12
plugins/FOBOCI/README.rst Normal file
View File

@ -0,0 +1,12 @@
======
FOBOCI
======
Needed Modules
==============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.
Documentation
=============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.

362
plugins/FOBOCI/all_singles.irp.f Normal file
View File

@ -0,0 +1,362 @@
subroutine all_single
implicit none
integer :: i,k
double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:)
integer :: N_st, degree
double precision,allocatable :: E_before(:)
N_st = N_states
allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st))
selection_criterion = 1.d-8
soft_touch selection_criterion
threshold_davidson = 1.d-5
soft_touch threshold_davidson davidson_criterion
i = 0
print*,'Doing all the mono excitations !'
print*,'N_det = ',N_det
print*,'n_det_max = ',n_det_max
print*,'pt2_max = ',pt2_max
print*,'N_det_generators = ',N_det_generators
pt2=-1.d0
E_before = ref_bitmask_energy
print*,'Initial Step '
print*,'Inital determinants '
print*,'N_det = ',N_det
do i = 1, N_states_diag
print*,''
print*,'i = ',i
print*,'E = ',CI_energy(i)
print*,'S^2 = ',CI_eigenvectors_s2(i)
enddo
n_det_max = 100000
do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max)
i += 1
print*,'-----------------------'
print*,'i = ',i
call H_apply_just_mono(pt2, norm_pert, H_pert_diag, N_st)
call diagonalize_CI
print*,'N_det = ',N_det
print*,'E = ',CI_energy(1)
print*,'pt2 = ',pt2(1)
print*,'E+PT2 = ',E_before + pt2(1)
if(N_states_diag.gt.1)then
print*,'Variational Energy difference'
do i = 2, N_st
print*,'Delta E = ',CI_energy(i) - CI_energy(1)
enddo
endif
if(N_states.gt.1)then
print*,'Variational + perturbative Energy difference'
do i = 2, N_st
print*,'Delta E = ',E_before(i)+ pt2(i) - (E_before(1) + pt2(1))
enddo
endif
E_before = CI_energy
enddo
threshold_davidson = 1.d-10
soft_touch threshold_davidson davidson_criterion
call diagonalize_CI
print*,'Final Step '
print*,'N_det = ',N_det
do i = 1, N_states_diag
print*,''
print*,'i = ',i
print*,'E = ',CI_energy(i)
print*,'S^2 = ',CI_eigenvectors_s2(i)
enddo
do i = 1, 2
print*,'psi_coef = ',psi_coef(i,1)
enddo
! call save_wavefunction
deallocate(pt2,norm_pert,E_before)
end
subroutine all_single_no_1h_or_1p
implicit none
integer :: i,k
double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:)
integer :: N_st, degree
double precision,allocatable :: E_before(:)
N_st = N_states
allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st))
threshold_davidson = 1.d-5
soft_touch threshold_davidson davidson_criterion
i = 0
print*,'Doing all the mono excitations !'
print*,'N_det = ',N_det
print*,'n_det_max = ',n_det_max
print*,'pt2_max = ',pt2_max
print*,'N_det_generators = ',N_det_generators
pt2=-1.d0
E_before = ref_bitmask_energy
print*,'Initial Step '
print*,'Inital determinants '
print*,'N_det = ',N_det
do i = 1, N_states_diag
print*,''
print*,'i = ',i
print*,'E = ',CI_energy(i)
print*,'S^2 = ',CI_eigenvectors_s2(i)
enddo
n_det_max = 100000
do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max)
i += 1
print*,'-----------------------'
print*,'i = ',i
call H_apply_just_mono_no_1h_no_1p(pt2, norm_pert, H_pert_diag, N_st)
call diagonalize_CI
print*,'N_det = ',N_det
print*,'E = ',CI_energy(1)
print*,'pt2 = ',pt2(1)
print*,'E+PT2 = ',E_before + pt2(1)
if(N_states_diag.gt.1)then
print*,'Variational Energy difference'
do i = 2, N_st
print*,'Delta E = ',CI_energy(i) - CI_energy(1)
enddo
endif
if(N_states.gt.1)then
print*,'Variational + perturbative Energy difference'
do i = 2, N_st
print*,'Delta E = ',E_before(i)+ pt2(i) - (E_before(1) + pt2(1))
enddo
endif
E_before = CI_energy
enddo
threshold_davidson = 1.d-10
soft_touch threshold_davidson davidson_criterion
call diagonalize_CI
print*,'Final Step '
print*,'N_det = ',N_det
do i = 1, N_states_diag
print*,''
print*,'i = ',i
print*,'E = ',CI_energy(i)
print*,'S^2 = ',CI_eigenvectors_s2(i)
enddo
do i = 1, 2
print*,'psi_coef = ',psi_coef(i,1)
enddo
! call save_wavefunction
deallocate(pt2,norm_pert,E_before)
end
subroutine all_single_no_1h_or_1p_or_2p
implicit none
integer :: i,k
double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:)
integer :: N_st, degree
double precision,allocatable :: E_before(:)
N_st = N_states
allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st))
selection_criterion = 0.d0
soft_touch selection_criterion
threshold_davidson = 1.d-5
soft_touch threshold_davidson davidson_criterion
i = 0
print*,'Doing all the mono excitations !'
print*,'N_det = ',N_det
print*,'n_det_max = ',n_det_max
print*,'pt2_max = ',pt2_max
print*,'N_det_generators = ',N_det_generators
pt2=-1.d0
E_before = ref_bitmask_energy
print*,'Initial Step '
print*,'Inital determinants '
print*,'N_det = ',N_det
do i = 1, N_states_diag
print*,''
print*,'i = ',i
print*,'E = ',CI_energy(i)
print*,'S^2 = ',CI_eigenvectors_s2(i)
enddo
n_det_max = 100000
do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max)
i += 1
print*,'-----------------------'
print*,'i = ',i
call H_apply_just_mono_no_1h_no_1p_no_2p(pt2, norm_pert, H_pert_diag, N_st)
call diagonalize_CI
print*,'N_det = ',N_det
print*,'E = ',CI_energy(1)
print*,'pt2 = ',pt2(1)
print*,'E+PT2 = ',E_before + pt2(1)
if(N_states_diag.gt.1)then
print*,'Variational Energy difference'
do i = 2, N_st
print*,'Delta E = ',CI_energy(i) - CI_energy(1)
enddo
endif
if(N_states.gt.1)then
print*,'Variational + perturbative Energy difference'
do i = 2, N_st
print*,'Delta E = ',E_before(i)+ pt2(i) - (E_before(1) + pt2(1))
enddo
endif
E_before = CI_energy
enddo
threshold_davidson = 1.d-10
soft_touch threshold_davidson davidson_criterion
call diagonalize_CI
print*,'Final Step '
print*,'N_det = ',N_det
do i = 1, N_states_diag
print*,''
print*,'i = ',i
print*,'E = ',CI_energy(i)
print*,'S^2 = ',CI_eigenvectors_s2(i)
enddo
do i = 1, 2
print*,'psi_coef = ',psi_coef(i,1)
enddo
! call save_wavefunction
deallocate(pt2,norm_pert,E_before)
end
subroutine all_2p
implicit none
integer :: i,k
double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:)
integer :: N_st, degree
double precision,allocatable :: E_before(:)
N_st = N_states
allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st))
selection_criterion = 0.d0
soft_touch selection_criterion
threshold_davidson = 1.d-5
soft_touch threshold_davidson davidson_criterion
i = 0
print*,''
print*,''
print*,''
print*,''
print*,''
print*,'*****************************'
print*,'Doing all the 2P excitations'
print*,'*****************************'
print*,''
print*,''
print*,'N_det = ',N_det
print*,'n_det_max = ',n_det_max
print*,'pt2_max = ',pt2_max
print*,'N_det_generators = ',N_det_generators
pt2=-1.d0
E_before = ref_bitmask_energy
print*,'Initial Step '
print*,'Inital determinants '
print*,'N_det = ',N_det
do i = 1, N_states_diag
print*,''
print*,'i = ',i
print*,'E = ',CI_energy(i)
print*,'S^2 = ',CI_eigenvectors_s2(i)
enddo
n_det_max = 100000
i = 0
do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max)
i += 1
print*,'-----------------------'
print*,'i = ',i
call H_apply_standard(pt2, norm_pert, H_pert_diag, N_st)
call diagonalize_CI
print*,'N_det = ',N_det
print*,'E = ',CI_energy(1)
print*,'pt2 = ',pt2(1)
print*,'E+PT2 = ',E_before + pt2(1)
if(N_states_diag.gt.1)then
print*,'Variational Energy difference'
do i = 2, N_st
print*,'Delta E = ',CI_energy(i) - CI_energy(1)
enddo
endif
if(N_states.gt.1)then
print*,'Variational + perturbative Energy difference'
do i = 2, N_st
print*,'Delta E = ',E_before(i)+ pt2(i) - (E_before(1) + pt2(1))
enddo
endif
E_before = CI_energy
enddo
print*,'Final Step '
print*,'N_det = ',N_det
do i = 1, N_states_diag
print*,''
print*,'i = ',i
print*,'E = ',CI_energy(i)
print*,'S^2 = ',CI_eigenvectors_s2(i)
enddo
! call save_wavefunction
deallocate(pt2,norm_pert,E_before)
end
subroutine all_1h_1p_routine
implicit none
integer :: i,k
double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:)
integer :: N_st, degree
double precision :: E_before
integer :: n_det_before
N_st = N_states
allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st))
i = 0
print*,'N_det = ',N_det
print*,'n_det_max = ',n_det_max
print*,'pt2_max = ',pt2_max
pt2=-1.d0
E_before = ref_bitmask_energy
do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max)
n_det_before = N_det
i += 1
print*,'-----------------------'
print*,'i = ',i
call H_apply_just_1h_1p(pt2, norm_pert, H_pert_diag, N_st)
call diagonalize_CI
print*,'N_det = ',N_det
print*,'E = ',CI_energy(1)
print*,'pt2 = ',pt2(1)
print*,'E+PT2 = ',E_before + pt2(1)
E_before = CI_energy(1)
if(n_det_before == N_det)then
selection_criterion = selection_criterion * 0.5d0
endif
enddo
deallocate(pt2,norm_pert)
end
subroutine all_but_1h_1p_routine
implicit none
integer :: i,k
double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:)
integer :: N_st, degree
double precision :: E_before
integer :: n_det_before
N_st = N_states
allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st))
i = 0
print*,'N_det = ',N_det
print*,'n_det_max = ',n_det_max
print*,'pt2_max = ',pt2_max
pt2=-1.d0
E_before = ref_bitmask_energy
do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max)
n_det_before = N_det
i += 1
print*,'-----------------------'
print*,'i = ',i
call H_apply_all_but_1h_and_1p(pt2, norm_pert, H_pert_diag, N_st)
call diagonalize_CI
print*,'N_det = ',N_det
print*,'E = ',CI_energy(1)
print*,'pt2 = ',pt2(1)
print*,'E+PT2 = ',E_before + pt2(1)
E_before = CI_energy(1)
if(n_det_before == N_det)then
selection_criterion = selection_criterion * 0.5d0
endif
enddo
deallocate(pt2,norm_pert)
end

243
plugins/FOBOCI/all_singles_split.irp.f Normal file
View File

@ -0,0 +1,243 @@
subroutine all_single_split(psi_det_generators_input,psi_coef_generators_input,Ndet_generators_input,dressing_matrix)
implicit none
use bitmasks
integer, intent(in) :: Ndet_generators_input
integer(bit_kind), intent(in) :: psi_det_generators_input(N_int,2,Ndet_generators_input)
double precision, intent(inout) :: dressing_matrix(Ndet_generators_input,Ndet_generators_input)
double precision, intent(in) :: psi_coef_generators_input(ndet_generators_input,n_states)
integer :: i,i_hole
n_det_max_jacobi = 50
soft_touch n_det_max_jacobi
do i = 1, n_inact_orb
i_hole = list_inact(i)
print*,''
print*,'Doing all the single excitations from the orbital '
print*,i_hole
print*,''
print*,''
threshold_davidson = 1.d-4
soft_touch threshold_davidson davidson_criterion
call modify_bitmasks_for_hole(i_hole)
call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_generators_as_input_psi(ndet_generators_input,psi_det_generators_input,psi_coef_generators_input)
call set_psi_det_as_input_psi(ndet_generators_input,psi_det_generators_input,psi_coef_generators_input)
call all_single
threshold_davidson = 1.d-10
soft_touch threshold_davidson davidson_criterion
call diagonalize_CI
call provide_matrix_dressing(dressing_matrix,ndet_generators_input,psi_det_generators_input)
enddo
n_det_max_jacobi = 1000
soft_touch n_det_max_jacobi
end
subroutine all_single_for_1h(dressing_matrix_1h1p,dressing_matrix_2h1p)
implicit none
use bitmasks
double precision, intent(inout) :: dressing_matrix_1h1p(N_det_generators,N_det_generators)
double precision, intent(inout) :: dressing_matrix_2h1p(N_det_generators,N_det_generators)
integer :: i,i_hole
n_det_max_jacobi = 50
soft_touch n_det_max_jacobi
integer :: n_det_1h1p,n_det_2h1p
integer(bit_kind), allocatable :: psi_ref_out(:,:,:)
integer(bit_kind), allocatable :: psi_1h1p(:,:,:)
integer(bit_kind), allocatable :: psi_2h1p(:,:,:)
double precision, allocatable :: psi_ref_coef_out(:,:)
double precision, allocatable :: psi_coef_1h1p(:,:)
double precision, allocatable :: psi_coef_2h1p(:,:)
call all_single_no_1h_or_1p
threshold_davidson = 1.d-12
soft_touch threshold_davidson davidson_criterion
call diagonalize_CI
call give_n_1h1p_and_n_2h1p_in_psi_det(n_det_1h1p,n_det_2h1p)
allocate(psi_ref_out(N_int,2,N_det_generators))
allocate(psi_1h1p(N_int,2,n_det_1h1p))
allocate(psi_2h1p(N_int,2,n_det_2h1p))
allocate(psi_ref_coef_out(N_det_generators,N_states))
allocate(psi_coef_1h1p(n_det_1h1p,N_states))
allocate(psi_coef_2h1p(n_det_2h1p,N_states))
call split_wf_generators_and_1h1p_and_2h1p(n_det_1h1p,n_det_2h1p,psi_ref_out,psi_ref_coef_out,psi_1h1p,psi_coef_1h1p,psi_2h1p,psi_coef_2h1p)
call provide_matrix_dressing_general(dressing_matrix_1h1p,psi_ref_out,psi_ref_coef_out,N_det_generators, &
psi_1h1p,psi_coef_1h1p,n_det_1h1p)
call provide_matrix_dressing_general(dressing_matrix_2h1p,psi_ref_out,psi_ref_coef_out,N_det_generators, &
psi_2h1p,psi_coef_2h1p,n_det_2h1p)
deallocate(psi_ref_out)
deallocate(psi_1h1p)
deallocate(psi_2h1p)
deallocate(psi_ref_coef_out)
deallocate(psi_coef_1h1p)
deallocate(psi_coef_2h1p)
end
subroutine all_single_split_for_1h(dressing_matrix_1h1p,dressing_matrix_2h1p)
implicit none
use bitmasks
double precision, intent(inout) :: dressing_matrix_1h1p(N_det_generators,N_det_generators)
double precision, intent(inout) :: dressing_matrix_2h1p(N_det_generators,N_det_generators)
integer :: i,i_hole
n_det_max_jacobi = 50
soft_touch n_det_max_jacobi
integer :: n_det_1h1p,n_det_2h1p
integer(bit_kind), allocatable :: psi_ref_out(:,:,:)
integer(bit_kind), allocatable :: psi_1h1p(:,:,:)
integer(bit_kind), allocatable :: psi_2h1p(:,:,:)
double precision, allocatable :: psi_ref_coef_out(:,:)
double precision, allocatable :: psi_coef_1h1p(:,:)
double precision, allocatable :: psi_coef_2h1p(:,:)
do i = 1, n_inact_orb
i_hole = list_inact(i)
print*,''
print*,'Doing all the single excitations from the orbital '
print*,i_hole
print*,''
print*,''
threshold_davidson = 1.d-4
soft_touch threshold_davidson davidson_criterion
selection_criterion_factor = 1.d-4
soft_touch selection_criterion_factor selection_criterion selection_criterion_min
call modify_bitmasks_for_hole(i_hole)
call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_generators_as_input_psi(n_det_generators,psi_det_generators,psi_coef_generators)
call set_psi_det_as_input_psi(n_det_generators,psi_det_generators,psi_coef_generators)
call all_single_no_1h_or_1p
threshold_davidson = 1.d-10
soft_touch threshold_davidson davidson_criterion
call diagonalize_CI
call give_n_1h1p_and_n_2h1p_in_psi_det(n_det_1h1p,n_det_2h1p)
allocate(psi_ref_out(N_int,2,N_det_generators))
allocate(psi_1h1p(N_int,2,n_det_1h1p))
allocate(psi_2h1p(N_int,2,n_det_2h1p))
allocate(psi_ref_coef_out(N_det_generators,N_states))
allocate(psi_coef_1h1p(n_det_1h1p,N_states))
allocate(psi_coef_2h1p(n_det_2h1p,N_states))
call split_wf_generators_and_1h1p_and_2h1p(n_det_1h1p,n_det_2h1p,psi_ref_out,psi_ref_coef_out,psi_1h1p,psi_coef_1h1p,psi_2h1p,psi_coef_2h1p)
call provide_matrix_dressing_general(dressing_matrix_1h1p,psi_ref_out,psi_ref_coef_out,N_det_generators, &
psi_1h1p,psi_coef_1h1p,n_det_1h1p)
call provide_matrix_dressing_general(dressing_matrix_2h1p,psi_ref_out,psi_ref_coef_out,N_det_generators, &
psi_2h1p,psi_coef_2h1p,n_det_2h1p)
deallocate(psi_ref_out)
deallocate(psi_1h1p)
deallocate(psi_2h1p)
deallocate(psi_ref_coef_out)
deallocate(psi_coef_1h1p)
deallocate(psi_coef_2h1p)
enddo
n_det_max_jacobi = 1000
soft_touch n_det_max_jacobi
end
subroutine all_single_split_for_1p(dressing_matrix_1h1p,dressing_matrix_1h2p)
implicit none
use bitmasks
double precision, intent(inout) :: dressing_matrix_1h1p(N_det_generators,N_det_generators)
double precision, intent(inout) :: dressing_matrix_1h2p(N_det_generators,N_det_generators)
integer :: i,i_hole
n_det_max_jacobi = 50
soft_touch n_det_max_jacobi
integer :: n_det_1h1p,n_det_1h2p
integer(bit_kind), allocatable :: psi_ref_out(:,:,:)
integer(bit_kind), allocatable :: psi_1h1p(:,:,:)
integer(bit_kind), allocatable :: psi_1h2p(:,:,:)
double precision, allocatable :: psi_ref_coef_out(:,:)
double precision, allocatable :: psi_coef_1h1p(:,:)
double precision, allocatable :: psi_coef_1h2p(:,:)
do i = 1, n_inact_orb
i_hole = list_inact(i)
print*,''
print*,'Doing all the single excitations from the orbital '
print*,i_hole
print*,''
print*,''
threshold_davidson = 1.d-4
soft_touch threshold_davidson davidson_criterion
selection_criterion_factor = 1.d-4
soft_touch selection_criterion_factor selection_criterion selection_criterion_min
call modify_bitmasks_for_hole(i_hole)
call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_generators_as_input_psi(n_det_generators,psi_det_generators,psi_coef_generators)
call set_psi_det_as_input_psi(n_det_generators,psi_det_generators,psi_coef_generators)
call all_single_no_1h_or_1p
threshold_davidson = 1.d-10
soft_touch threshold_davidson davidson_criterion
call diagonalize_CI
call give_n_1h1p_and_n_1h2p_in_psi_det(n_det_1h1p,n_det_1h2p)
allocate(psi_ref_out(N_int,2,N_det_generators))
allocate(psi_1h1p(N_int,2,n_det_1h1p))
allocate(psi_1h2p(N_int,2,n_det_1h2p))
allocate(psi_ref_coef_out(N_det_generators,N_states))
allocate(psi_coef_1h1p(n_det_1h1p,N_states))
allocate(psi_coef_1h2p(n_det_1h2p,N_states))
call split_wf_generators_and_1h1p_and_1h2p(n_det_1h1p,n_det_1h2p,psi_ref_out,psi_ref_coef_out,psi_1h1p,psi_coef_1h1p,psi_1h2p,psi_coef_1h2p)
call provide_matrix_dressing_general(dressing_matrix_1h1p,psi_ref_out,psi_ref_coef_out,N_det_generators, &
psi_1h1p,psi_coef_1h1p,n_det_1h1p)
call provide_matrix_dressing_general(dressing_matrix_1h2p,psi_ref_out,psi_ref_coef_out,N_det_generators, &
psi_1h2p,psi_coef_1h2p,n_det_1h2p)
deallocate(psi_ref_out)
deallocate(psi_1h1p)
deallocate(psi_1h2p)
deallocate(psi_ref_coef_out)
deallocate(psi_coef_1h1p)
deallocate(psi_coef_1h2p)
enddo
n_det_max_jacobi = 1000
soft_touch n_det_max_jacobi
end
subroutine all_single_for_1p(dressing_matrix_1h1p,dressing_matrix_1h2p)
implicit none
use bitmasks
double precision, intent(inout) :: dressing_matrix_1h1p(N_det_generators,N_det_generators)
double precision, intent(inout) :: dressing_matrix_1h2p(N_det_generators,N_det_generators)
integer :: i,i_hole
n_det_max_jacobi = 50
soft_touch n_det_max_jacobi
integer :: n_det_1h1p,n_det_1h2p
integer(bit_kind), allocatable :: psi_ref_out(:,:,:)
integer(bit_kind), allocatable :: psi_1h1p(:,:,:)
integer(bit_kind), allocatable :: psi_1h2p(:,:,:)
double precision, allocatable :: psi_ref_coef_out(:,:)
double precision, allocatable :: psi_coef_1h1p(:,:)
double precision, allocatable :: psi_coef_1h2p(:,:)
call all_single_no_1h_or_1p_or_2p
threshold_davidson = 1.d-12
soft_touch threshold_davidson davidson_criterion
call diagonalize_CI
call give_n_1h1p_and_n_1h2p_in_psi_det(n_det_1h1p,n_det_1h2p)
allocate(psi_ref_out(N_int,2,N_det_generators))
allocate(psi_1h1p(N_int,2,n_det_1h1p))
allocate(psi_1h2p(N_int,2,n_det_1h2p))
allocate(psi_ref_coef_out(N_det_generators,N_states))
allocate(psi_coef_1h1p(n_det_1h1p,N_states))
allocate(psi_coef_1h2p(n_det_1h2p,N_states))
call split_wf_generators_and_1h1p_and_1h2p(n_det_1h1p,n_det_1h2p,psi_ref_out,psi_ref_coef_out,psi_1h1p,psi_coef_1h1p,psi_1h2p,psi_coef_1h2p)
call provide_matrix_dressing_general(dressing_matrix_1h1p,psi_ref_out,psi_ref_coef_out,N_det_generators, &
psi_1h1p,psi_coef_1h1p,n_det_1h1p)
call provide_matrix_dressing_general(dressing_matrix_1h2p,psi_ref_out,psi_ref_coef_out,N_det_generators, &
psi_1h2p,psi_coef_1h2p,n_det_1h2p)
deallocate(psi_ref_out)
deallocate(psi_1h1p)
deallocate(psi_1h2p)
deallocate(psi_ref_coef_out)
deallocate(psi_coef_1h1p)
deallocate(psi_coef_1h2p)
end

218
plugins/FOBOCI/create_1h_or_1p.irp.f Normal file
View File

@ -0,0 +1,218 @@
subroutine create_restart_and_1h(i_hole)
implicit none
use bitmasks
integer, intent(in) :: i_hole
integer(bit_kind) :: key_tmp(N_int,2)
integer :: i,j,i_part_act,ispin,k,l,i_ok
integer :: n_new_det
integer(bit_kind), allocatable :: new_det(:,:,:)
integer(bit_kind), allocatable :: old_psi_det(:,:,:)
allocate (old_psi_det(N_int,2,n_det))
do i = 1, N_det
do j = 1, N_int
old_psi_det(j,1,i) = psi_det(j,1,i)
old_psi_det(j,2,i) = psi_det(j,2,i)
enddo
enddo
n_new_det = 0
do j = 1, n_act_orb
i_part_act = list_act(j) ! index of the particle in the active space
do i = 1, N_det
do ispin = 1,2
do k = 1, N_int
key_tmp(k,1) = psi_det(k,1,i)
key_tmp(k,2) = psi_det(k,2,i)
enddo
call do_mono_excitation(key_tmp,i_hole,i_part_act,ispin,i_ok)
if(i_ok .ne. 1)cycle
n_new_det +=1
enddo
enddo
enddo
integer :: N_det_old
N_det_old = N_det
N_det += n_new_det
allocate (new_det(N_int,2,n_new_det))
if (psi_det_size < N_det) then
psi_det_size = N_det
TOUCH psi_det_size
endif
do i = 1, N_det_old
do k = 1, N_int
psi_det(k,1,i) = old_psi_det(k,1,i)
psi_det(k,2,i) = old_psi_det(k,2,i)
enddo
enddo
n_new_det = 0
do j = 1, n_act_orb
i_part_act = list_act(j) ! index of the particle in the active space
do i = 1, N_det_old
do ispin = 1,2
do k = 1, N_int
key_tmp(k,1) = psi_det(k,1,i)
key_tmp(k,2) = psi_det(k,2,i)
enddo
call do_mono_excitation(key_tmp,i_hole,i_part_act,ispin,i_ok)
if(i_ok .ne. 1)cycle
n_new_det +=1
do k = 1, N_int
psi_det(k,1,n_det_old+n_new_det) = key_tmp(k,1)
psi_det(k,2,n_det_old+n_new_det) = key_tmp(k,2)
enddo
psi_coef(n_det_old+n_new_det,:) = 0.d0
enddo
enddo
enddo
SOFT_TOUCH N_det psi_det psi_coef
logical :: found_duplicates
call remove_duplicates_in_psi_det(found_duplicates)
end
subroutine create_restart_and_1p(i_particle)
implicit none
integer, intent(in) :: i_particle
use bitmasks
integer(bit_kind) :: key_tmp(N_int,2)
integer :: i,j,i_hole_act,ispin,k,l,i_ok
integer :: n_new_det
integer(bit_kind), allocatable :: new_det(:,:,:)
integer(bit_kind), allocatable :: old_psi_det(:,:,:)
allocate (old_psi_det(N_int,2,n_det))
do i = 1, N_det
do j = 1, N_int
old_psi_det(j,1,i) = psi_det(j,1,i)
old_psi_det(j,2,i) = psi_det(j,2,i)
enddo
enddo
n_new_det = 0
do j = 1, n_act_orb
i_hole_act = list_act(j) ! index of the particle in the active space
do i = 1, N_det
do ispin = 1,2
do k = 1, N_int
key_tmp(k,1) = psi_det(k,1,i)
key_tmp(k,2) = psi_det(k,2,i)
enddo
call do_mono_excitation(key_tmp,i_hole_act,i_particle,ispin,i_ok)
if(i_ok .ne. 1)cycle
n_new_det +=1
enddo
enddo
enddo
integer :: N_det_old
N_det_old = N_det
N_det += n_new_det
allocate (new_det(N_int,2,n_new_det))
if (psi_det_size < N_det) then
psi_det_size = N_det
TOUCH psi_det_size
endif
do i = 1, N_det_old
do k = 1, N_int
psi_det(k,1,i) = old_psi_det(k,1,i)
psi_det(k,2,i) = old_psi_det(k,2,i)
enddo
enddo
n_new_det = 0
do j = 1, n_act_orb
i_hole_act = list_act(j) ! index of the particle in the active space
do i = 1, N_det_old
do ispin = 1,2
do k = 1, N_int
key_tmp(k,1) = psi_det(k,1,i)
key_tmp(k,2) = psi_det(k,2,i)
enddo
call do_mono_excitation(key_tmp,i_hole_act,i_particle,ispin,i_ok)
if(i_ok .ne. 1)cycle
n_new_det +=1
do k = 1, N_int
psi_det(k,1,n_det_old+n_new_det) = key_tmp(k,1)
psi_det(k,2,n_det_old+n_new_det) = key_tmp(k,2)
enddo
psi_coef(n_det_old+n_new_det,:) = 0.d0
enddo
enddo
enddo
SOFT_TOUCH N_det psi_det psi_coef
logical :: found_duplicates
call remove_duplicates_in_psi_det(found_duplicates)
end
subroutine create_restart_1h_1p(i_hole,i_part)
implicit none
use bitmasks
integer, intent(in) :: i_hole
integer, intent(in) :: i_part
integer :: i,j,i_part_act,ispin,k,l,i_ok
integer(bit_kind) :: key_tmp(N_int,2)
integer :: n_new_det
integer(bit_kind), allocatable :: new_det(:,:,:)
integer(bit_kind), allocatable :: old_psi_det(:,:,:)
allocate (old_psi_det(N_int,2,n_det))
do i = 1, N_det
do j = 1, N_int
old_psi_det(j,1,i) = psi_det(j,1,i)
old_psi_det(j,2,i) = psi_det(j,2,i)
enddo
enddo
n_new_det = 0
i_part_act = i_part ! index of the particle in the active space
do i = 1, N_det
do ispin = 1,2
do k = 1, N_int
key_tmp(k,1) = psi_det(k,1,i)
key_tmp(k,2) = psi_det(k,2,i)
enddo
call do_mono_excitation(key_tmp,i_hole,i_part_act,ispin,i_ok)
if(i_ok .ne. 1)cycle
n_new_det +=1
enddo
enddo
integer :: N_det_old
N_det_old = N_det
N_det += n_new_det
allocate (new_det(N_int,2,n_new_det))
if (psi_det_size < N_det) then
psi_det_size = N_det
TOUCH psi_det_size
endif
do i = 1, N_det_old
do k = 1, N_int
psi_det(k,1,i) = old_psi_det(k,1,i)
psi_det(k,2,i) = old_psi_det(k,2,i)
enddo
enddo
n_new_det = 0
i_part_act = i_part ! index of the particle in the active space
do i = 1, N_det_old
do ispin = 1,2
do k = 1, N_int
key_tmp(k,1) = psi_det(k,1,i)
key_tmp(k,2) = psi_det(k,2,i)
enddo
call do_mono_excitation(key_tmp,i_hole,i_part_act,ispin,i_ok)
if(i_ok .ne. 1)cycle
n_new_det +=1
do k = 1, N_int
psi_det(k,1,n_det_old+n_new_det) = key_tmp(k,1)
psi_det(k,2,n_det_old+n_new_det) = key_tmp(k,2)
enddo
psi_coef(n_det_old+n_new_det,:) = 0.d0
enddo
enddo
SOFT_TOUCH N_det psi_det psi_coef
logical :: found_duplicates
call remove_duplicates_in_psi_det(found_duplicates)
end

133
plugins/FOBOCI/density_matrix.irp.f Normal file
View File

@ -0,0 +1,133 @@
BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha_generators_restart, (mo_tot_num_align,mo_tot_num) ]
&BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta_generators_restart, (mo_tot_num_align,mo_tot_num) ]
&BEGIN_PROVIDER [ double precision, norm_generators_restart]
implicit none
BEGIN_DOC
! Alpha and beta one-body density matrix for the generators restart
END_DOC
integer :: j,k,l,m
integer :: occ(N_int*bit_kind_size,2)
double precision :: ck, cl, ckl
double precision :: phase
integer :: h1,h2,p1,p2,s1,s2, degree
integer :: exc(0:2,2,2),n_occ_alpha
double precision, allocatable :: tmp_a(:,:), tmp_b(:,:)
integer :: degree_respect_to_HF_k
integer :: degree_respect_to_HF_l,index_ref_generators_restart
double precision :: inv_coef_ref_generators_restart
integer :: i
do i = 1, N_det_generators_restart
! Find the reference determinant for intermediate normalization
call get_excitation_degree(ref_generators_restart,psi_det_generators_restart(1,1,i),degree,N_int)
if(degree == 0)then
index_ref_generators_restart = i
inv_coef_ref_generators_restart = 1.d0/psi_coef_generators_restart(i,1)
exit
endif
enddo
norm_generators_restart = 0.d0
do i = 1, N_det_generators_restart
psi_coef_generators_restart(i,1) = psi_coef_generators_restart(i,1) * inv_coef_ref_generators_restart
norm_generators_restart += psi_coef_generators_restart(i,1)**2
enddo
one_body_dm_mo_alpha_generators_restart = 0.d0
one_body_dm_mo_beta_generators_restart = 0.d0
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP PRIVATE(j,k,l,m,occ,ck, cl, ckl,phase,h1,h2,p1,p2,s1,s2, degree,exc, &
!$OMP tmp_a, tmp_b, n_occ_alpha)&
!$OMP SHARED(psi_det_generators_restart,psi_coef_generators_restart,N_int,elec_alpha_num,&
!$OMP elec_beta_num,one_body_dm_mo_alpha_generators_restart,one_body_dm_mo_beta_generators_restart,N_det_generators_restart,mo_tot_num_align,&
!$OMP mo_tot_num,N_states, state_average_weight)
allocate(tmp_a(mo_tot_num_align,mo_tot_num), tmp_b(mo_tot_num_align,mo_tot_num) )
tmp_a = 0.d0
tmp_b = 0.d0
!$OMP DO SCHEDULE(dynamic)
do k=1,N_det_generators_restart
call bitstring_to_list(psi_det_generators_restart(1,1,k), occ(1,1), n_occ_alpha, N_int)
call bitstring_to_list(psi_det_generators_restart(1,2,k), occ(1,2), n_occ_alpha, N_int)
do m=1,N_states
ck = psi_coef_generators_restart(k,m)*psi_coef_generators_restart(k,m) * state_average_weight(m)
do l=1,elec_alpha_num
j = occ(l,1)
tmp_a(j,j) += ck
enddo
do l=1,elec_beta_num
j = occ(l,2)
tmp_b(j,j) += ck
enddo
enddo
do l=1,k-1
call get_excitation_degree(psi_det_generators_restart(1,1,k),psi_det_generators_restart(1,1,l),degree,N_int)
if (degree /= 1) then
cycle
endif
call get_mono_excitation(psi_det_generators_restart(1,1,k),psi_det_generators_restart(1,1,l),exc,phase,N_int)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
do m=1,N_states
ckl = psi_coef_generators_restart(k,m) * psi_coef_generators_restart(l,m) * phase * state_average_weight(m)
if (s1==1) then
tmp_a(h1,p1) += ckl
tmp_a(p1,h1) += ckl
else
tmp_b(h1,p1) += ckl
tmp_b(p1,h1) += ckl
endif
enddo
enddo
enddo
!$OMP END DO NOWAIT
!$OMP CRITICAL
one_body_dm_mo_alpha_generators_restart = one_body_dm_mo_alpha_generators_restart + tmp_a
!$OMP END CRITICAL
!$OMP CRITICAL
one_body_dm_mo_beta_generators_restart = one_body_dm_mo_beta_generators_restart + tmp_b
!$OMP END CRITICAL
deallocate(tmp_a,tmp_b)
!$OMP BARRIER
!$OMP END PARALLEL
do i = 1, mo_tot_num
print*,'DM restat',i,one_body_dm_mo_beta_generators_restart(i,i) + one_body_dm_mo_alpha_generators_restart(i,i)
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, one_body_dm_mo_generators_restart, (mo_tot_num_align,mo_tot_num) ]
implicit none
BEGIN_DOC
! One-body density matrix for the generators_restart
END_DOC
one_body_dm_mo_generators_restart = one_body_dm_mo_alpha_generators_restart + one_body_dm_mo_beta_generators_restart
END_PROVIDER
BEGIN_PROVIDER [ double precision, one_body_spin_density_mo_generators_restart, (mo_tot_num_align,mo_tot_num) ]
implicit none
BEGIN_DOC
! rho(alpha) - rho(beta)
END_DOC
one_body_spin_density_mo_generators_restart = one_body_dm_mo_alpha_generators_restart - one_body_dm_mo_beta_generators_restart
END_PROVIDER
BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha_osoci, (mo_tot_num_align,mo_tot_num) ]
&BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta_osoci, (mo_tot_num_align,mo_tot_num) ]
implicit none
BEGIN_DOC
! Alpha and beta one-body density matrix that will be used for the OSOCI approach
END_DOC
END_PROVIDER
BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha_1h1p, (mo_tot_num_align,mo_tot_num) ]
&BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta_1h1p, (mo_tot_num_align,mo_tot_num) ]
implicit none
BEGIN_DOC
! Alpha and beta one-body density matrix that will be used for the 1h1p approach
END_DOC
END_PROVIDER

35
plugins/FOBOCI/diag_fock_inactiv_virt.irp.f Normal file
View File

@ -0,0 +1,35 @@
subroutine diag_inactive_virt_and_update_mos
implicit none
integer :: i,j,i_inact,j_inact,i_virt,j_virt
double precision :: tmp(mo_tot_num_align,mo_tot_num)
character*(64) :: label
tmp = 0.d0
do i = 1, mo_tot_num
tmp(i,i) = Fock_matrix_mo(i,i)
enddo
do i = 1, n_inact_orb
i_inact = list_inact(i)
do j = i+1, n_inact_orb
j_inact = list_inact(j)
tmp(i_inact,j_inact) = Fock_matrix_mo(i_inact,j_inact)
tmp(j_inact,i_inact) = Fock_matrix_mo(j_inact,i_inact)
enddo
enddo
do i = 1, n_virt_orb
i_virt = list_virt(i)
do j = i+1, n_virt_orb
j_virt = list_virt(j)
tmp(i_virt,j_virt) = Fock_matrix_mo(i_virt,j_virt)
tmp(j_virt,i_virt) = Fock_matrix_mo(j_virt,i_virt)
enddo
enddo
label = "Canonical"
call mo_as_eigvectors_of_mo_matrix(tmp,size(tmp,1),size(tmp,2),label,1)
soft_touch mo_coef
end

358
plugins/FOBOCI/dress_simple.irp.f Normal file
View File

@ -0,0 +1,358 @@
subroutine standard_dress(delta_ij_generators_,size_buffer,Ndet_generators,i_generator,n_selected,det_buffer,Nint,iproc,psi_det_generators_input,E_ref)
use bitmasks
implicit none
integer, intent(in) :: i_generator,n_selected, Nint, iproc
integer, intent(in) :: Ndet_generators,size_buffer
double precision, intent(inout) :: delta_ij_generators_(Ndet_generators,Ndet_generators),E_ref
integer(bit_kind), intent(in) :: det_buffer(Nint,2,size_buffer)
integer(bit_kind), intent(in) :: psi_det_generators_input(N_int,2,Ndet_generators)
integer :: i,j,k,m
integer :: new_size
integer :: degree(Ndet_generators)
integer :: idx(0:Ndet_generators)
logical :: good
integer :: c_ref
integer :: connected_to_ref
double precision :: hka, haa
double precision :: haj
double precision :: f
integer :: connected_to_ref_by_mono
logical :: is_in_wavefunction
double precision :: H_array(Ndet_generators)
double precision :: H_matrix_tmp(Ndet_generators+1,Ndet_generators+1)
double precision :: eigenvectors(Ndet_generators+1,Ndet_generators+1), eigenvalues(Ndet_generators+1)
double precision :: contrib,lambda_i,accu
do k = 1, Ndet_generators
call i_h_j(psi_det_generators_input(1,1,k),psi_det_generators_input(1,1,k),Nint,hka)
H_matrix_tmp(k,k) = hka
do j = k+1, Ndet_generators
call i_h_j(psi_det_generators_input(1,1,k),psi_det_generators_input(1,1,j),Nint,hka)
H_matrix_tmp(k,j) = hka
H_matrix_tmp(j,k) = hka
enddo
H_matrix_tmp(k,Ndet_generators+1) = 0.d0
enddo
do i=1,n_selected
c_ref = connected_to_ref_by_mono(det_buffer(1,1,i),psi_det_generators_input,N_int,i_generator,Ndet_generators)
if (c_ref /= 0) then
cycle
endif
if (is_in_wavefunction(det_buffer(1,1,i),Nint)) then
cycle
endif
call get_excitation_degree_vector(psi_det_generators_input,det_buffer(1,1,i),degree,N_int,Ndet_generators,idx)
H_array = 0.d0
do k=1,idx(0)
call i_h_j(det_buffer(1,1,i),psi_det_generators_input(1,1,idx(k)),Nint,hka)
H_array(idx(k)) = hka
enddo
call i_h_j(det_buffer(1,1,i),det_buffer(1,1,i),Nint,haa)
f = 1.d0/(E_ref-haa)
if(second_order_h)then
lambda_i = f
else
! You write the new Hamiltonian matrix
do k = 1, Ndet_generators
H_matrix_tmp(k,Ndet_generators+1) = H_array(k)
H_matrix_tmp(Ndet_generators+1,k) = H_array(k)
enddo
H_matrix_tmp(Ndet_generators+1,Ndet_generators+1) = haa
! Then diagonalize it
call lapack_diag(eigenvalues,eigenvectors,H_matrix_tmp,Ndet_generators+1,Ndet_generators+1)
! Then you extract the effective denominator
accu = 0.d0
do k = 1, Ndet_generators
accu += eigenvectors(k,1) * H_array(k)
enddo
lambda_i = eigenvectors(Ndet_generators+1,1)/accu
endif
do k=1,idx(0)
contrib = H_array(idx(k)) * H_array(idx(k)) * lambda_i
delta_ij_generators_(idx(k), idx(k)) += contrib
do j=k+1,idx(0)
contrib = H_array(idx(k)) * H_array(idx(j)) * lambda_i
delta_ij_generators_(idx(k), idx(j)) += contrib
delta_ij_generators_(idx(j), idx(k)) += contrib
enddo
enddo
! H_matrix_tmp_bis(idx(k),idx(k)) += contrib
! H_matrix_tmp_bis(idx(k),idx(j)) += contrib
! H_matrix_tmp_bis(idx(j),idx(k)) += contrib
! do k = 1, Ndet_generators
! do j = 1, Ndet_generators
! H_matrix_tmp_bis(k,j) = H_matrix_tmp(k,j)
! enddo
! enddo
! double precision :: H_matrix_tmp_bis(Ndet_generators,Ndet_generators)
! double precision :: eigenvectors_bis(Ndet_generators,Ndet_generators), eigenvalues_bis(Ndet_generators)
! call lapack_diag(eigenvalues_bis,eigenvectors_bis,H_matrix_tmp_bis,Ndet_generators,Ndet_generators)
! print*,'f,lambda_i = ',f,lambda_i
! print*,'eigenvalues_bi(1)',eigenvalues_bis(1)
! print*,'eigenvalues ',eigenvalues(1)
! do k = 1, Ndet_generators
! print*,'coef,coef_dres = ', eigenvectors(k,1), eigenvectors_bis(k,1)
! enddo
! pause
! accu = 0.d0
! do k = 1, Ndet_generators
! do j = 1, Ndet_generators
! accu += eigenvectors(k,1) * eigenvectors(j,1) * (H_matrix_tmp(k,j) + delta_ij_generators_(k,j))
! enddo
! enddo
! print*,'accu,eigv = ',accu,eigenvalues(1)
! pause
enddo
end
subroutine is_a_good_candidate(threshold,is_ok,verbose)
use bitmasks
implicit none
double precision, intent(in) :: threshold
logical, intent(out) :: is_ok
logical, intent(in) :: verbose
integer :: l,k,m
double precision,allocatable :: dressed_H_matrix(:,:)
double precision,allocatable :: psi_coef_diagonalized_tmp(:,:)
integer(bit_kind), allocatable :: psi_det_generators_input(:,:,:)
allocate(psi_det_generators_input(N_int,2,N_det_generators),dressed_H_matrix(N_det_generators,N_det_generators))
allocate(psi_coef_diagonalized_tmp(N_det_generators,N_states))
dressed_H_matrix = 0.d0
do k = 1, N_det_generators
do l = 1, N_int
psi_det_generators_input(l,1,k) = psi_det_generators(l,1,k)
psi_det_generators_input(l,2,k) = psi_det_generators(l,2,k)
enddo
enddo
!call H_apply_dressed_pert(dressed_H_matrix,N_det_generators,psi_det_generators_input)
call dress_H_matrix_from_psi_det_input(psi_det_generators_input,N_det_generators,is_ok,psi_coef_diagonalized_tmp, dressed_H_matrix,threshold,verbose)
if(do_it_perturbative)then
if(is_ok)then
N_det = N_det_generators
do m = 1, N_states
do k = 1, N_det_generators
do l = 1, N_int
psi_det(l,1,k) = psi_det_generators_input(l,1,k)
psi_det(l,2,k) = psi_det_generators_input(l,2,k)
enddo
psi_coef(k,m) = psi_coef_diagonalized_tmp(k,m)
enddo
enddo
touch psi_coef psi_det N_det
endif
endif
deallocate(psi_det_generators_input,dressed_H_matrix,psi_coef_diagonalized_tmp)
end
subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_generators,is_ok,psi_coef_diagonalized_tmp, dressed_H_matrix,threshold,verbose)
use bitmasks
implicit none
integer(bit_kind), intent(in) :: psi_det_generators_input(N_int,2,Ndet_generators)
integer, intent(in) :: Ndet_generators
double precision, intent(in) :: threshold
logical, intent(in) :: verbose
logical, intent(out) :: is_ok
double precision, intent(out) :: psi_coef_diagonalized_tmp(Ndet_generators,N_states)
double precision, intent(inout) :: dressed_H_matrix(Ndet_generators, Ndet_generators)
integer :: i,j,degree,index_ref_generators_restart,i_count,k,i_det_no_ref
double precision :: eigvalues(Ndet_generators), eigvectors(Ndet_generators,Ndet_generators),hij
double precision :: psi_coef_ref(Ndet_generators,N_states),diag_h_mat_average,diag_h_mat_no_ref_average
logical :: is_a_ref_det(Ndet_generators)
is_a_ref_det = .False.
do i = 1, N_det_generators
do j = 1, N_det_generators_restart
call get_excitation_degree(psi_det_generators_input(1,1,i),psi_det_generators_restart(1,1,j),degree,N_int)
if(degree == 0)then
is_a_ref_det(i) = .True.
exit
endif
enddo
enddo
do i = 1, Ndet_generators
call get_excitation_degree(ref_generators_restart,psi_det_generators_input(1,1,i),degree,N_int)
if(degree == 0)then
index_ref_generators_restart = i
endif
do j = 1, Ndet_generators
call i_h_j(psi_det_generators_input(1,1,j),psi_det_generators_input(1,1,i),N_int,hij) ! Fill the zeroth order H matrix
dressed_H_matrix(i,j) = hij
enddo
enddo
i_det_no_ref = 0
diag_h_mat_average = 0.d0
do i = 1, Ndet_generators
if(is_a_ref_det(i))cycle
i_det_no_ref +=1
diag_h_mat_average+=dressed_H_matrix(i,i)
enddo
diag_h_mat_average = diag_h_mat_average/dble(i_det_no_ref)
print*,'diag_h_mat_average = ',diag_h_mat_average
print*,'ref h_mat = ',dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart)
integer :: number_of_particles, number_of_holes
! Filter the the MLCT that are higher than 27.2 eV in energy with respect to the reference determinant
do i = 1, Ndet_generators
if(is_a_ref_det(i))cycle
if(number_of_holes(psi_det_generators_input(1,1,i)).eq.0 .and. number_of_particles(psi_det_generators_input(1,1,i)).eq.1)then
if(diag_h_mat_average - dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart) .gt.2.d0)then
is_ok = .False.
return
endif
endif
! Filter the the LMCT that are higher than 54.4 eV in energy with respect to the reference determinant
if(number_of_holes(psi_det_generators_input(1,1,i)).eq.1 .and. number_of_particles(psi_det_generators_input(1,1,i)).eq.0)then
if(diag_h_mat_average - dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart) .gt.2.d0)then
is_ok = .False.
return
endif
endif
exit
enddo
call lapack_diagd(eigvalues,eigvectors,dressed_H_matrix,Ndet_generators,Ndet_generators) ! Diagonalize the Dressed_H_matrix
double precision :: s2,E_ref(N_states)
integer :: i_state(N_states)
integer :: n_state_good
n_state_good = 0
if(s2_eig)then
do i = 1, Ndet_generators
call get_s2_u0(psi_det_generators_input,eigvectors(1,i),Ndet_generators,Ndet_generators,s2)
print*,'s2 = ',s2
print*,dabs(s2-expected_s2)
if(dabs(s2-expected_s2).le.0.3d0)then
n_state_good +=1
i_state(n_state_good) = i
E_ref(n_state_good) = eigvalues(i)
endif
if(n_state_good==N_states)then
exit
endif
enddo
else
do i = 1, N_states
i_state(i) = i
E_ref(i) = eigvalues(i)
enddo
endif
do i = 1,N_states
print*,'i_state = ',i_state(i)
enddo
do k = 1, N_states
print*,'state ',k
do i = 1, Ndet_generators
psi_coef_diagonalized_tmp(i,k) = eigvectors(i,i_state(k)) / eigvectors(index_ref_generators_restart,i_state(k))
psi_coef_ref(i,k) = eigvectors(i,i_state(k))
print*,'psi_coef_ref(i) = ',psi_coef_ref(i,k)
enddo
enddo
if(verbose)then
print*,'Zeroth order space :'
do i = 1, Ndet_generators
write(*,'(10(F16.8),X)')dressed_H_matrix(i,:)
enddo
print*,''
print*,'Zeroth order space Diagonalized :'
do k = 1, N_states
print*,'state ',k
do i = 1, Ndet_generators
print*,'coef, <I|H|I> = ',psi_coef_diagonalized_tmp(i,k),dressed_H_matrix(i,i)-dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart),is_a_ref_det(i)
enddo
enddo
endif
double precision :: E_ref_average
E_ref_average = 0.d0
do i = 1, N_states
E_ref_average += E_ref(i)
enddo
E_ref_average = E_ref_average / dble(N_states)
call H_apply_dressed_pert(dressed_H_matrix,Ndet_generators,psi_det_generators_input,E_ref_average) ! Calculate the dressing of the H matrix
if(verbose)then
print*,'Zeroth order space Dressed by outer space:'
do i = 1, Ndet_generators
write(*,'(10(F16.8),X)')dressed_H_matrix(i,:)
enddo
endif
call lapack_diagd(eigvalues,eigvectors,dressed_H_matrix,Ndet_generators,Ndet_generators) ! Diagonalize the Dressed_H_matrix
integer :: i_good_state(0:N_states)
i_good_state(0) = 0
do i = 1, Ndet_generators
call get_s2_u0(psi_det_generators_input,eigvectors(1,i),Ndet_generators,Ndet_generators,s2)
! State following
do k = 1, N_states
accu = 0.d0
do j =1, Ndet_generators
accu += eigvectors(j,i) * psi_coef_ref(j,k)
enddo
if(dabs(accu).ge.0.8d0)then
i_good_state(0) +=1
i_good_state(i_good_state(0)) = i
endif
enddo
if(i_good_state(0)==N_states)then
exit
endif
enddo
do i = 1, N_states
i_state(i) = i_good_state(i)
E_ref(i) = eigvalues(i_good_state(i))
enddo
double precision :: accu
accu = 0.d0
do k = 1, N_states
do i = 1, Ndet_generators
psi_coef_diagonalized_tmp(i,k) = eigvectors(i,i_state(k)) / eigvectors(index_ref_generators_restart,i_state(k))
enddo
enddo
if(verbose)then
do k = 1, N_states
print*,'state ',k
do i = 1, Ndet_generators
print*,'coef, <I|H+Delta H|I> = ',psi_coef_diagonalized_tmp(i,k),dressed_H_matrix(i,i)-dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart),is_a_ref_det(i)
enddo
enddo
endif
is_ok = .False.
do i = 1, Ndet_generators
if(is_a_ref_det(i))cycle
do k = 1, N_states
if(dabs(psi_coef_diagonalized_tmp(i,k)) .gt.threshold)then
is_ok = .True.
exit
endif
enddo
if(is_ok)then
exit
endif
enddo
if(verbose)then
print*,'is_ok = ',is_ok
endif
end

5
plugins/FOBOCI/fobo_coupled_ci.irp.f Normal file
View File

@ -0,0 +1,5 @@
program osoci_program
implicit none
call new_approach
! call save_natural_mos
end

18
plugins/FOBOCI/fobo_diff_dm.irp.f Normal file
View File

@ -0,0 +1,18 @@
program osoci_program
call debug_det(ref_bitmask,N_int)
implicit none
call FOBOCI_lmct_mlct_old_thr
call provide_all_the_rest
end
subroutine provide_all_the_rest
implicit none
integer :: i
call update_one_body_dm_mo
call provide_properties
call save_osoci_natural_mos
call save_mos
end

315
plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f Normal file
View File

@ -0,0 +1,315 @@
subroutine FOBOCI_lmct_mlct_old_thr
use bitmasks
implicit none
integer :: i,j,k,l
integer(bit_kind),allocatable :: unpaired_bitmask(:,:)
integer, allocatable :: occ(:,:)
integer :: n_occ_alpha, n_occ_beta
double precision :: norm_tmp(N_states),norm_total(N_states)
logical :: test_sym
double precision :: thr,hij
double precision :: threshold
double precision, allocatable :: dressing_matrix(:,:)
logical :: verbose,is_ok
verbose = .True.
threshold = threshold_singles
print*,'threshold = ',threshold
thr = 1.d-12
allocate(unpaired_bitmask(N_int,2))
allocate (occ(N_int*bit_kind_size,2))
do i = 1, N_int
unpaired_bitmask(i,1) = unpaired_alpha_electrons(i)
unpaired_bitmask(i,2) = unpaired_alpha_electrons(i)
enddo
norm_total = 0.d0
call initialize_density_matrix_osoci
call bitstring_to_list(inact_bitmask(1,1), occ(1,1), n_occ_beta, N_int)
print*,''
print*,''
print*,'mulliken spin population analysis'
accu =0.d0
do i = 1, nucl_num
accu += mulliken_spin_densities(i)
print*,i,nucl_charge(i),mulliken_spin_densities(i)
enddo
print*,''
print*,''
print*,'DOING FIRST LMCT !!'
do i = 1, n_inact_orb
integer :: i_hole_osoci
i_hole_osoci = list_inact(i)
print*,'--------------------------'
! First set the current generators to the one of restart
call set_generators_to_generators_restart
call set_psi_det_to_generators
call check_symetry(i_hole_osoci,thr,test_sym)
if(.not.test_sym)cycle
print*,'i_hole_osoci = ',i_hole_osoci
call create_restart_and_1h(i_hole_osoci)
call set_generators_to_psi_det
print*,'Passed set generators'
call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_bitmask_hole_as_input(reunion_of_bitmask)
call is_a_good_candidate(threshold,is_ok,verbose)
print*,'is_ok = ',is_ok
if(.not.is_ok)cycle
! so all the mono excitation on the new generators
allocate(dressing_matrix(N_det_generators,N_det_generators))
if(.not.do_it_perturbative)then
! call all_single
dressing_matrix = 0.d0
do k = 1, N_det_generators
do l = 1, N_det_generators
call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl)
dressing_matrix(k,l) = hkl
enddo
enddo
double precision :: hkl
! call all_single_split(psi_det_generators,psi_coef_generators,N_det_generators,dressing_matrix)
! call diag_dressed_matrix_and_set_to_psi_det(psi_det_generators,N_det_generators,dressing_matrix)
call debug_det(reunion_of_bitmask,N_int)
call all_single
endif
call set_intermediate_normalization_lmct_old(norm_tmp,i_hole_osoci)
do k = 1, N_states
print*,'norm_tmp = ',norm_tmp(k)
norm_total(k) += norm_tmp(k)
enddo
call update_density_matrix_osoci
deallocate(dressing_matrix)
enddo
if(.True.)then
print*,''
print*,'DOING THEN THE MLCT !!'
do i = 1, n_virt_orb
integer :: i_particl_osoci
i_particl_osoci = list_virt(i)
print*,'--------------------------'
! First set the current generators to the one of restart
call set_generators_to_generators_restart
call set_psi_det_to_generators
call check_symetry(i_particl_osoci,thr,test_sym)
if(.not.test_sym)cycle
print*,'i_particl_osoci= ',i_particl_osoci
! Initialize the bitmask to the restart ones
call initialize_bitmask_to_restart_ones
! Impose that only the hole i_hole_osoci can be done
call modify_bitmasks_for_particl(i_particl_osoci)
call print_generators_bitmasks_holes
! Impose that only the active part can be reached
call set_bitmask_hole_as_input(unpaired_bitmask)
!! call all_single_h_core
call create_restart_and_1p(i_particl_osoci)
!! ! Update the generators
call set_generators_to_psi_det
call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_bitmask_hole_as_input(reunion_of_bitmask)
!! ! so all the mono excitation on the new generators
call is_a_good_candidate(threshold,is_ok,verbose)
print*,'is_ok = ',is_ok
if(.not.is_ok)cycle
allocate(dressing_matrix(N_det_generators,N_det_generators))
if(.not.do_it_perturbative)then
dressing_matrix = 0.d0
do k = 1, N_det_generators
do l = 1, N_det_generators
call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl)
dressing_matrix(k,l) = hkl
enddo
enddo
! call all_single_split(psi_det_generators,psi_coef_generators,N_det_generators,dressing_matrix)
! call diag_dressed_matrix_and_set_to_psi_det(psi_det_generators,N_det_generators,dressing_matrix)
call all_single
endif
call set_intermediate_normalization_mlct_old(norm_tmp,i_particl_osoci)
do k = 1, N_states
print*,'norm_tmp = ',norm_tmp(k)
norm_total(k) += norm_tmp(k)
enddo
call update_density_matrix_osoci
deallocate(dressing_matrix)
enddo
endif
if(.False.)then
print*,'LAST loop for all the 1h-1p'
print*,'--------------------------'
! First set the current generators to the one of restart
call set_generators_to_generators_restart
call set_psi_det_to_generators
call initialize_bitmask_to_restart_ones
! Impose that only the hole i_hole_osoci can be done
call set_bitmask_particl_as_input(inact_virt_bitmask)
call set_bitmask_hole_as_input(inact_virt_bitmask)
! call set_bitmask_particl_as_input(reunion_of_bitmask)
! call set_bitmask_hole_as_input(reunion_of_bitmask)
call all_single
call set_intermediate_normalization_1h1p(norm_tmp)
norm_total += norm_tmp
call update_density_matrix_osoci
endif
print*,'norm_total = ',norm_total
norm_total = norm_generators_restart
norm_total = 1.d0/norm_total
! call rescale_density_matrix_osoci(norm_total)
double precision :: accu
accu = 0.d0
do i = 1, mo_tot_num
accu += one_body_dm_mo_alpha_osoci(i,i) + one_body_dm_mo_beta_osoci(i,i)
enddo
print*,'accu = ',accu
end
subroutine FOBOCI_mlct_old
use bitmasks
implicit none
integer :: i,j,k,l
integer(bit_kind),allocatable :: unpaired_bitmask(:,:)
integer, allocatable :: occ(:,:)
integer :: n_occ_alpha, n_occ_beta
double precision :: norm_tmp,norm_total
logical :: test_sym
double precision :: thr
double precision :: threshold
logical :: verbose,is_ok
verbose = .False.
threshold = 1.d-2
thr = 1.d-12
allocate(unpaired_bitmask(N_int,2))
allocate (occ(N_int*bit_kind_size,2))
do i = 1, N_int
unpaired_bitmask(i,1) = unpaired_alpha_electrons(i)
unpaired_bitmask(i,2) = unpaired_alpha_electrons(i)
enddo
norm_total = 0.d0
call initialize_density_matrix_osoci
call bitstring_to_list(inact_bitmask(1,1), occ(1,1), n_occ_beta, N_int)
print*,''
print*,''
print*,''
print*,'DOING FIRST MLCT !!'
do i = 1, n_virt_orb
integer :: i_particl_osoci
i_particl_osoci = list_virt(i)
print*,'--------------------------'
! First set the current generators to the one of restart
call set_generators_to_generators_restart
call set_psi_det_to_generators
call check_symetry(i_particl_osoci,thr,test_sym)
if(.not.test_sym)cycle
print*,'i_particl_osoci= ',i_particl_osoci
! Initialize the bitmask to the restart ones
call initialize_bitmask_to_restart_ones
! Impose that only the hole i_hole_osoci can be done
call modify_bitmasks_for_particl(i_particl_osoci)
call print_generators_bitmasks_holes
! Impose that only the active part can be reached
call set_bitmask_hole_as_input(unpaired_bitmask)
! call all_single_h_core
call create_restart_and_1p(i_particl_osoci)
! ! Update the generators
call set_generators_to_psi_det
call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_bitmask_hole_as_input(reunion_of_bitmask)
! ! so all the mono excitation on the new generators
call is_a_good_candidate(threshold,is_ok,verbose)
print*,'is_ok = ',is_ok
is_ok =.True.
if(.not.is_ok)cycle
call all_single
call set_intermediate_normalization_mlct_old(norm_tmp,i_particl_osoci)
print*,'norm_tmp = ',norm_tmp
norm_total += norm_tmp
call update_density_matrix_osoci
enddo
print*,'norm_total = ',norm_total
norm_total += 1.d0
norm_total = 1.d0/norm_total
call rescale_density_matrix_osoci(norm_total)
double precision :: accu
accu = 0.d0
do i = 1, mo_tot_num
accu += one_body_dm_mo_alpha_osoci(i,i) + one_body_dm_mo_beta_osoci(i,i)
enddo
print*,'accu = ',accu
end
subroutine FOBOCI_lmct_old
use bitmasks
implicit none
integer :: i,j,k,l
integer(bit_kind),allocatable :: unpaired_bitmask(:,:)
integer, allocatable :: occ(:,:)
integer :: n_occ_alpha, n_occ_beta
double precision :: norm_tmp,norm_total
logical :: test_sym
double precision :: thr
double precision :: threshold
logical :: verbose,is_ok
verbose = .False.
threshold = 1.d-2
thr = 1.d-12
allocate(unpaired_bitmask(N_int,2))
allocate (occ(N_int*bit_kind_size,2))
do i = 1, N_int
unpaired_bitmask(i,1) = unpaired_alpha_electrons(i)
unpaired_bitmask(i,2) = unpaired_alpha_electrons(i)
enddo
norm_total = 0.d0
call initialize_density_matrix_osoci
call bitstring_to_list(inact_bitmask(1,1), occ(1,1), n_occ_beta, N_int)
print*,''
print*,''
print*,'DOING FIRST LMCT !!'
do i = 1, n_inact_orb
integer :: i_hole_osoci
i_hole_osoci = list_inact(i)
print*,'--------------------------'
! First set the current generators to the one of restart
call set_generators_to_generators_restart
call set_psi_det_to_generators
call check_symetry(i_hole_osoci,thr,test_sym)
if(.not.test_sym)cycle
print*,'i_hole_osoci = ',i_hole_osoci
! Initialize the bitmask to the restart ones
call initialize_bitmask_to_restart_ones
! Impose that only the hole i_hole_osoci can be done
call modify_bitmasks_for_hole(i_hole_osoci)
call print_generators_bitmasks_holes
! Impose that only the active part can be reached
call set_bitmask_particl_as_input(unpaired_bitmask)
! call all_single_h_core
call create_restart_and_1h(i_hole_osoci)
! ! Update the generators
call set_generators_to_psi_det
call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_bitmask_hole_as_input(reunion_of_bitmask)
call is_a_good_candidate(threshold,is_ok,verbose)
print*,'is_ok = ',is_ok
if(.not.is_ok)cycle
! ! so all the mono excitation on the new generators
call all_single
! call set_intermediate_normalization_lmct_bis(norm_tmp,i_hole_osoci)
call set_intermediate_normalization_lmct_old(norm_tmp,i_hole_osoci)
print*,'norm_tmp = ',norm_tmp
norm_total += norm_tmp
call update_density_matrix_osoci
enddo
print*,'norm_total = ',norm_total
norm_total += 1.d0
norm_total = 1.d0/norm_total
call rescale_density_matrix_osoci(norm_total)
double precision :: accu
accu = 0.d0
do i = 1, mo_tot_num
accu += one_body_dm_mo_alpha_osoci(i,i) + one_body_dm_mo_beta_osoci(i,i)
enddo
print*,'accu = ',accu
end

126
plugins/FOBOCI/generators_restart_save.irp.f Normal file
View File

@ -0,0 +1,126 @@
use bitmasks
BEGIN_PROVIDER [ integer, N_det_generators_restart ]
implicit none
BEGIN_DOC
! Number of determinants in the wave function
END_DOC
logical :: exists
character*64 :: label
integer, save :: ifirst = 0
!if(ifirst == 0)then
PROVIDE ezfio_filename
call ezfio_has_determinants_n_det(exists)
print*,'exists = ',exists
if(.not.exists)then
print*,'The OSOCI needs a restart WF'
print*,'There are none in the EZFIO file ...'
print*,'Stopping ...'
stop
endif
print*,'passed N_det_generators_restart'
call ezfio_get_determinants_n_det(N_det_generators_restart)
ASSERT (N_det_generators_restart > 0)
ifirst = 1
!endif
END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators_restart, (N_int,2,psi_det_size) ]
&BEGIN_PROVIDER [ integer(bit_kind), ref_generators_restart, (N_int,2) ]
implicit none
BEGIN_DOC
! The wave function determinants. Initialized with Hartree-Fock if the EZFIO file
! is empty
END_DOC
integer :: i
logical :: exists
character*64 :: label
integer, save :: ifirst = 0
!if(ifirst == 0)then
provide N_det_generators_restart
if(.True.)then
call ezfio_has_determinants_N_int(exists)
if (exists) then
call ezfio_has_determinants_bit_kind(exists)
if (exists) then
call ezfio_has_determinants_N_det(exists)
if (exists) then
call ezfio_has_determinants_N_states(exists)
if (exists) then
call ezfio_has_determinants_psi_det(exists)
endif
endif
endif
endif
if(.not.exists)then
print*,'The OSOCI needs a restart WF'
print*,'There are none in the EZFIO file ...'
print*,'Stopping ...'
stop
endif
print*,'passed psi_det_generators_restart'
call read_dets(psi_det_generators_restart,N_int,N_det_generators_restart)
do i = 1, N_int
ref_generators_restart(i,1) = psi_det_generators_restart(i,1,1)
ref_generators_restart(i,2) = psi_det_generators_restart(i,2,1)
enddo
endif
ifirst = 1
!endif
END_PROVIDER
BEGIN_PROVIDER [ double precision, psi_coef_generators_restart, (psi_det_size,N_states_diag) ]
implicit none
BEGIN_DOC
! The wave function coefficients. Initialized with Hartree-Fock if the EZFIO file
! is empty
END_DOC
integer :: i,k, N_int2
logical :: exists
double precision, allocatable :: psi_coef_read(:,:)
character*(64) :: label
integer, save :: ifirst = 0
!if(ifirst == 0)then
psi_coef_generators_restart = 0.d0
do i=1,N_states_diag
psi_coef_generators_restart(i,i) = 1.d0
enddo
call ezfio_has_determinants_psi_coef(exists)
if(.not.exists)then
print*,'The OSOCI needs a restart WF'
print*,'There are none in the EZFIO file ...'
print*,'Stopping ...'
stop
endif
print*,'passed psi_coef_generators_restart'
if (exists) then
allocate (psi_coef_read(N_det_generators_restart,N_states))
call ezfio_get_determinants_psi_coef(psi_coef_read)
do k=1,N_states
do i=1,N_det_generators_restart
psi_coef_generators_restart(i,k) = psi_coef_read(i,k)
enddo
enddo
deallocate(psi_coef_read)
endif
ifirst = 1
!endif
END_PROVIDER

157
plugins/FOBOCI/modify_generators.irp.f Normal file
View File

@ -0,0 +1,157 @@
subroutine set_generators_to_psi_det
implicit none
BEGIN_DOC
! subroutines that sets psi_det_generators to
! the current psi_det
END_DOC
N_det_generators = N_det
integer :: i,k
do i=1,N_det_generators
do k=1,N_int
psi_det_generators(k,1,i) = psi_det(k,1,i)
psi_det_generators(k,2,i) = psi_det(k,2,i)
enddo
do k = 1, N_states
psi_coef_generators(i,k) = psi_coef(i,k)
enddo
enddo
touch N_det_generators psi_coef_generators psi_det_generators
end
subroutine set_generators_as_input_psi(ndet_input,psi_det_input,psi_coef_input)
implicit none
integer, intent(in) :: ndet_input
integer(bit_kind), intent(in) :: psi_det_input(N_int,2,ndet_input)
double precision, intent(in) :: psi_coef_input(ndet_input,N_states)
BEGIN_DOC
! subroutines that sets psi_det_generators to
! the current psi_det
END_DOC
N_det_generators = ndet_input
integer :: i,k
do i=1,N_det_generators
do k=1,N_int
psi_det_generators(k,1,i) = psi_det_input(k,1,i)
psi_det_generators(k,2,i) = psi_det_input(k,2,i)
enddo
do k = 1, N_states
psi_coef_generators(i,k) = psi_coef_input(i,k)
enddo
enddo
touch N_det_generators psi_coef_generators psi_det_generators
end
subroutine set_psi_det_as_input_psi(ndet_input,psi_det_input,psi_coef_input)
implicit none
integer, intent(in) :: ndet_input
integer(bit_kind), intent(in) :: psi_det_input(N_int,2,ndet_input)
double precision, intent(in) :: psi_coef_input(ndet_input,N_states)
BEGIN_DOC
! subroutines that sets psi_det_generators to
! the current psi_det
END_DOC
N_det= ndet_input
if (psi_det_size < N_det) then
psi_det_size = N_det
TOUCH psi_det_size
endif
integer :: i,k
do i=1,N_det
do k=1,N_int
psi_det(k,1,i) = psi_det_input(k,1,i)
psi_det(k,2,i) = psi_det_input(k,2,i)
enddo
do k = 1, N_states
psi_coef(i,k) = psi_coef_input(i,k)
enddo
enddo
soft_touch N_det psi_coef psi_det
end
subroutine set_psi_det_to_generators
implicit none
BEGIN_DOC
! subroutines that sets psi_det_generators to
! the current psi_det
END_DOC
N_det= N_det_generators
integer :: i,k
do i = 1, psi_det_size
do k=1,N_int
psi_det(k,1,i) = 0_bit_kind
psi_det(k,2,i) = 0_bit_kind
enddo
do k = 1, N_states
psi_coef(i,k) = 0.d0
enddo
enddo
do i=1,N_det_generators
do k=1,N_int
psi_det(k,1,i) = psi_det_generators(k,1,i)
psi_det(k,2,i) = psi_det_generators(k,2,i)
enddo
do k = 1, N_states
psi_coef(i,k) = psi_coef_generators(i,k)
enddo
enddo
touch N_det psi_coef psi_det
end
subroutine set_generators_to_generators_restart
implicit none
BEGIN_DOC
! subroutines that sets psi_det_generators to
! the current psi_det
END_DOC
N_det_generators = N_det_generators_restart
integer :: i,k
do i=1,N_det_generators
do k=1,N_int
psi_det_generators(k,1,i) = psi_det_generators_restart(k,1,i)
psi_det_generators(k,2,i) = psi_det_generators_restart(k,2,i)
enddo
do k = 1, N_states
psi_coef_generators(i,k) = psi_coef_generators_restart(i,k)
enddo
enddo
touch N_det_generators psi_coef_generators psi_det_generators
end
subroutine set_psi_det_to_generators_restart
implicit none
BEGIN_DOC
! subroutines that sets psi_det_generators to
! the current psi_det
END_DOC
N_det = N_det_generators_restart
integer :: i,k
do i=1,N_det_generators
do k=1,N_int
psi_det(k,1,i) = psi_det_generators_restart(k,1,i)
psi_det(k,2,i) = psi_det_generators_restart(k,2,i)
enddo
do k = 1, N_states
psi_coef(i,k) = psi_coef_generators_restart(i,k)
enddo
enddo
touch N_det psi_coef psi_det
end

413
plugins/FOBOCI/new_approach.irp.f Normal file
View File

@ -0,0 +1,413 @@
subroutine new_approach
use bitmasks
implicit none
integer :: n_max_good_det
n_max_good_det = n_inact_orb * n_act_orb *n_det_generators_restart + n_virt_orb * n_act_orb * n_det_generators_restart
integer :: n_good_det,n_good_hole, n_good_particl
n_good_det = 0
n_good_hole = 0
n_good_particl = 0
integer(bit_kind), allocatable :: psi_good_det(:,:,:)
double precision, allocatable :: dressing_restart_good_det(:,:)
double precision, allocatable :: dressing_matrix_restart_1h1p(:,:)
double precision, allocatable :: dressing_matrix_restart_2h1p(:,:)
double precision, allocatable :: dressing_matrix_restart_1h2p(:,:)
double precision, allocatable :: dressing_diag_good_det(:)
double precision :: hjk
integer :: i,j,k,l,i_hole_foboci
logical :: test_sym
double precision :: thr,hij
double precision :: threshold,accu
double precision, allocatable :: dressing_matrix_1h1p(:,:)
double precision, allocatable :: dressing_matrix_2h1p(:,:)
double precision, allocatable :: dressing_matrix_1h2p(:,:)
double precision, allocatable :: H_matrix_tmp(:,:)
logical :: verbose,is_ok
double precision,allocatable :: eigenvectors(:,:), eigenvalues(:)
allocate(psi_good_det(N_int,2,n_max_good_det))
allocate(dressing_restart_good_det(n_max_good_det,n_det_generators_restart))
allocate(dressing_matrix_restart_1h1p(N_det_generators_restart, N_det_generators_restart))
allocate(dressing_matrix_restart_2h1p(N_det_generators_restart, N_det_generators_restart))
allocate(dressing_matrix_restart_1h2p(N_det_generators_restart, N_det_generators_restart))
allocate(dressing_diag_good_det(n_max_good_det))
dressing_restart_good_det = 0.d0
dressing_matrix_restart_1h1p = 0.d0
dressing_matrix_restart_2h1p = 0.d0
dressing_matrix_restart_1h2p = 0.d0
dressing_diag_good_det = 0.d0
verbose = .True.
threshold = threshold_singles
print*,'threshold = ',threshold
thr = 1.d-12
print*,''
print*,''
print*,'mulliken spin population analysis'
accu =0.d0
do i = 1, nucl_num
accu += mulliken_spin_densities(i)
print*,i,nucl_charge(i),mulliken_spin_densities(i)
enddo
print*,''
print*,''
print*,'DOING FIRST LMCT !!'
integer :: i_particl_osoci
do i = 1, n_inact_orb
i_hole_foboci = list_inact(i)
print*,'--------------------------'
! First set the current generators to the one of restart
call set_generators_to_generators_restart
call set_psi_det_to_generators
call check_symetry(i_hole_foboci,thr,test_sym)
if(.not.test_sym)cycle
print*,'i_hole_foboci = ',i_hole_foboci
call create_restart_and_1h(i_hole_foboci)
! ! Update the generators
call set_generators_to_psi_det
call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_bitmask_hole_as_input(reunion_of_bitmask)
call is_a_good_candidate(threshold,is_ok,verbose)
print*,'is_ok = ',is_ok
if(.not.is_ok)cycle
! so all the mono excitation on the new generators
allocate(dressing_matrix_1h1p(N_det_generators,N_det_generators))
allocate(dressing_matrix_2h1p(N_det_generators,N_det_generators))
dressing_matrix_1h1p = 0.d0
dressing_matrix_2h1p = 0.d0
if(.not.do_it_perturbative)then
n_good_hole +=1
! call all_single_split_for_1h(dressing_matrix_1h1p,dressing_matrix_2h1p)
call all_single_for_1h(dressing_matrix_1h1p,dressing_matrix_2h1p)
allocate(H_matrix_tmp(N_det_generators,N_det_generators))
do j = 1,N_det_generators
do k = 1, N_det_generators
call i_h_j(psi_det_generators(1,1,j),psi_det_generators(1,1,k),N_int,hjk)
H_matrix_tmp(j,k) = hjk
enddo
enddo
do j = 1, N_det_generators
do k = 1, N_det_generators
H_matrix_tmp(j,k) += dressing_matrix_1h1p(j,k) + dressing_matrix_2h1p(j,k)
enddo
enddo
hjk = H_matrix_tmp(1,1)
do j = 1, N_det_generators
H_matrix_tmp(j,j) -= hjk
enddo
print*,'-----------------------'
print*,'-----------------------'
print*,'-----------------------'
print*,'-----------------------'
print*,'-----------------------'
print*,'Dressed matrix :'
do j = 1, N_det_generators
write(*,'(100(X,F8.5))') H_matrix_tmp(j,:)
enddo
allocate(eigenvectors(N_det_generators,N_det_generators), eigenvalues(N_det_generators))
call lapack_diag(eigenvalues,eigenvectors,H_matrix_tmp,N_det_generators,N_det_generators)
print*,'Eigenvector of the dressed matrix :'
do j = 1, N_det_generators
print*,'coef = ',eigenvectors(j,1)
enddo
print*,'-----------------------'
print*,'-----------------------'
print*,'-----------------------'
print*,'-----------------------'
print*,'-----------------------'
deallocate(eigenvectors, eigenvalues)
deallocate(H_matrix_tmp)
call update_dressing_matrix(dressing_matrix_1h1p,dressing_matrix_2h1p,dressing_restart_good_det,dressing_matrix_restart_1h1p, &
dressing_matrix_restart_2h1p,dressing_diag_good_det,psi_good_det,n_good_det,n_max_good_det)
endif
deallocate(dressing_matrix_1h1p)
deallocate(dressing_matrix_2h1p)
enddo
print*,''
print*,''
print*,'DOING THEN THE MLCT !!'
do i = 1, n_virt_orb
i_particl_osoci = list_virt(i)
print*,'--------------------------'
! First set the current generators to the one of restart
call set_generators_to_generators_restart
call set_psi_det_to_generators
call check_symetry(i_particl_osoci,thr,test_sym)
if(.not.test_sym)cycle
print*,'i_part_foboci = ',i_particl_osoci
call create_restart_and_1p(i_particl_osoci)
! Update the generators
call set_generators_to_psi_det
call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_bitmask_hole_as_input(reunion_of_bitmask)
call is_a_good_candidate(threshold,is_ok,verbose)
print*,'is_ok = ',is_ok
if(.not.is_ok)cycle
! so all the mono excitation on the new generators
allocate(dressing_matrix_1h1p(N_det_generators,N_det_generators))
allocate(dressing_matrix_1h2p(N_det_generators,N_det_generators))
dressing_matrix_1h1p = 0.d0
dressing_matrix_1h2p = 0.d0
if(.not.do_it_perturbative)then
n_good_hole +=1
! call all_single_split_for_1p(dressing_matrix_1h1p,dressing_matrix_1h2p)
call all_single_for_1p(dressing_matrix_1h1p,dressing_matrix_1h2p)
allocate(H_matrix_tmp(N_det_generators,N_det_generators))
do j = 1,N_det_generators
do k = 1, N_det_generators
call i_h_j(psi_det_generators(1,1,j),psi_det_generators(1,1,k),N_int,hjk)
H_matrix_tmp(j,k) = hjk
enddo
enddo
do j = 1, N_det_generators
do k = 1, N_det_generators
H_matrix_tmp(j,k) += dressing_matrix_1h1p(j,k) + dressing_matrix_1h2p(j,k)
enddo
enddo
hjk = H_matrix_tmp(1,1)
do j = 1, N_det_generators
H_matrix_tmp(j,j) -= hjk
enddo
print*,'-----------------------'
print*,'-----------------------'
print*,'-----------------------'
print*,'-----------------------'
print*,'-----------------------'
print*,'Dressed matrix :'
do j = 1, N_det_generators
write(*,'(100(F8.5))') H_matrix_tmp(j,:)
enddo
allocate(eigenvectors(N_det_generators,N_det_generators), eigenvalues(N_det_generators))
call lapack_diag(eigenvalues,eigenvectors,H_matrix_tmp,N_det_generators,N_det_generators)
print*,'Eigenvector of the dressed matrix :'
do j = 1, N_det_generators
print*,'coef = ',eigenvectors(j,1)
enddo
print*,'-----------------------'
print*,'-----------------------'
print*,'-----------------------'
print*,'-----------------------'
print*,'-----------------------'
deallocate(eigenvectors, eigenvalues)
deallocate(H_matrix_tmp)
call update_dressing_matrix(dressing_matrix_1h1p,dressing_matrix_1h2p,dressing_restart_good_det,dressing_matrix_restart_1h1p, &
dressing_matrix_restart_1h2p,dressing_diag_good_det,psi_good_det,n_good_det,n_max_good_det)
endif
deallocate(dressing_matrix_1h1p)
deallocate(dressing_matrix_1h2p)
enddo
double precision, allocatable :: H_matrix_total(:,:)
integer :: n_det_total
n_det_total = N_det_generators_restart + n_good_det
allocate(H_matrix_total(n_det_total, n_det_total))
! Building of the effective Hamiltonian
! We assume that the first determinants are the n_det_generators_restart ones
! and then come the n_good_det determinants in psi_good_det
H_matrix_total = 0.d0
do i = 1, N_det_generators_restart
do j = 1, N_det_generators_restart
call i_H_j(psi_det_generators_restart(1,1,i),psi_det_generators_restart(1,1,j),N_int,hij)
H_matrix_total(i,j) = hij
!!! Adding the averaged dressing coming from the 1h1p that are redundant for each of the "n_good_hole" 1h
H_matrix_total(i,j) += dressing_matrix_restart_1h1p(i,j)/dble(n_good_hole+n_good_particl)
!!! Adding the dressing coming from the 2h1p that are not redundant for the any of CI calculations
H_matrix_total(i,j) += dressing_matrix_restart_2h1p(i,j)
enddo
enddo
do i = 1, n_good_det
call i_H_j(psi_good_det(1,1,i),psi_good_det(1,1,i),N_int,hij)
!!! Adding the diagonal dressing coming from the singles
H_matrix_total(n_det_generators_restart+i,n_det_generators_restart+i) = hij + dressing_diag_good_det(i)
do j = 1, N_det_generators_restart
!!! Adding the extra diagonal dressing between the references and the singles
print*,' dressing_restart_good_det = ',dressing_restart_good_det(i,j)
call i_H_j(psi_good_det(1,1,i),psi_det_generators_restart(1,1,j),N_int,hij)
H_matrix_total(n_det_generators_restart+i,j) += hij
H_matrix_total(j,n_det_generators_restart+i) += hij
H_matrix_total(j,n_det_generators_restart+i) += dressing_restart_good_det(i,j)
H_matrix_total(n_det_generators_restart+i,j) += dressing_restart_good_det(i,j)
enddo
do j = i+1, n_good_det
!!! Building the naked Hamiltonian matrix between the singles
call i_H_j(psi_good_det(1,1,i),psi_good_det(1,1,j),N_int,hij)
H_matrix_total(n_det_generators_restart+i,n_det_generators_restart+j) = hij
H_matrix_total(n_det_generators_restart+j,n_det_generators_restart+i) = hij
enddo
enddo
print*,'H matrix to diagonalize'
double precision :: href
href = H_matrix_total(1,1)
do i = 1, n_det_total
H_matrix_total(i,i) -= href
enddo
do i = 1, n_det_total
write(*,'(100(X,F16.8))')H_matrix_total(i,:)
enddo
double precision, allocatable :: eigvalues(:),eigvectors(:,:)
allocate(eigvalues(n_det_total),eigvectors(n_det_total,n_det_total))
call lapack_diag(eigvalues,eigvectors,H_matrix_total,n_det_total,n_det_total)
print*,'e_dressed = ',eigvalues(1) + nuclear_repulsion + href
do i = 1, n_det_total
print*,'coef = ',eigvectors(i,1)
enddo
integer(bit_kind), allocatable :: psi_det_final(:,:,:)
double precision, allocatable :: psi_coef_final(:,:)
double precision :: norm
allocate(psi_coef_final(n_det_total, N_states))
allocate(psi_det_final(N_int,2,n_det_total))
do i = 1, N_det_generators_restart
do j = 1,N_int
psi_det_final(j,1,i) = psi_det_generators_restart(j,1,i)
psi_det_final(j,2,i) = psi_det_generators_restart(j,2,i)
enddo
enddo
do i = 1, n_good_det
do j = 1,N_int
psi_det_final(j,1,n_det_generators_restart+i) = psi_good_det(j,1,i)
psi_det_final(j,2,n_det_generators_restart+i) = psi_good_det(j,2,i)
enddo
enddo
norm = 0.d0
do i = 1, n_det_total
do j = 1, N_states
psi_coef_final(i,j) = eigvectors(i,j)
enddo
norm += psi_coef_final(i,1)**2
! call debug_det(psi_det_final(1, 1, i), N_int)
enddo
print*,'norm = ',norm
call set_psi_det_as_input_psi(n_det_total,psi_det_final,psi_coef_final)
print*,''
!do i = 1, N_det
! call debug_det(psi_det(1,1,i),N_int)
! print*,'coef = ',psi_coef(i,1)
!enddo
provide one_body_dm_mo
integer :: i_core,iorb,jorb,i_inact,j_inact,i_virt,j_virt,j_core
do i = 1, n_core_orb
i_core = list_core(i)
one_body_dm_mo(i_core,i_core) = 10.d0
do j = i+1, n_core_orb
j_core = list_core(j)
one_body_dm_mo(i_core,j_core) = 0.d0
one_body_dm_mo(j_core,i_core) = 0.d0
enddo
do j = 1, n_inact_orb
iorb = list_inact(j)
one_body_dm_mo(i_core,iorb) = 0.d0
one_body_dm_mo(iorb,i_core) = 0.d0
enddo
do j = 1, n_act_orb
iorb = list_act(j)
one_body_dm_mo(i_core,iorb) = 0.d0
one_body_dm_mo(iorb,i_core) = 0.d0
enddo
do j = 1, n_virt_orb
iorb = list_virt(j)
one_body_dm_mo(i_core,iorb) = 0.d0
one_body_dm_mo(iorb,i_core) = 0.d0
enddo
enddo
! Set to Zero the inact-inact part to avoid arbitrary rotations
do i = 1, n_inact_orb
i_inact = list_inact(i)
do j = i+1, n_inact_orb
j_inact = list_inact(j)
one_body_dm_mo(i_inact,j_inact) = 0.d0
one_body_dm_mo(j_inact,i_inact) = 0.d0
enddo
enddo
! Set to Zero the inact-virt part to avoid arbitrary rotations
do i = 1, n_inact_orb
i_inact = list_inact(i)
do j = 1, n_virt_orb
j_virt = list_virt(j)
one_body_dm_mo(i_inact,j_virt) = 0.d0
one_body_dm_mo(j_virt,i_inact) = 0.d0
enddo
enddo
! Set to Zero the virt-virt part to avoid arbitrary rotations
do i = 1, n_virt_orb
i_virt = list_virt(i)
do j = i+1, n_virt_orb
j_virt = list_virt(j)
one_body_dm_mo(i_virt,j_virt) = 0.d0
one_body_dm_mo(j_virt,i_virt) = 0.d0
enddo
enddo
print*,''
print*,'Inactive-active Part of the One body DM'
print*,''
do i = 1,n_act_orb
iorb = list_act(i)
print*,''
print*,'ACTIVE ORBITAL ',iorb
do j = 1, n_inact_orb
jorb = list_inact(j)
if(dabs(one_body_dm_mo(iorb,jorb)).gt.threshold_singles)then
print*,'INACTIVE '
print*,'DM ',iorb,jorb,dabs(one_body_dm_mo(iorb,jorb))
endif
enddo
do j = 1, n_virt_orb
jorb = list_virt(j)
if(dabs(one_body_dm_mo(iorb,jorb)).gt.threshold_singles)then
print*,'VIRT '
print*,'DM ',iorb,jorb,dabs(one_body_dm_mo(iorb,jorb))
endif
enddo
enddo
do i = 1, mo_tot_num
do j = i+1, mo_tot_num
if(dabs(one_body_dm_mo(i,j)).le.threshold_fobo_dm)then
one_body_dm_mo(i,j) = 0.d0
one_body_dm_mo(j,i) = 0.d0
endif
enddo
enddo
label = "Natural"
character*(64) :: label
integer :: sign
sign = -1
call mo_as_eigvectors_of_mo_matrix(one_body_dm_mo,size(one_body_dm_mo,1),size(one_body_dm_mo,2),label,sign)
soft_touch mo_coef
call save_mos
deallocate(eigvalues,eigvectors,psi_det_final,psi_coef_final)
deallocate(H_matrix_total)
deallocate(psi_good_det)
deallocate(dressing_restart_good_det)
deallocate(dressing_matrix_restart_1h1p)
deallocate(dressing_matrix_restart_2h1p)
deallocate(dressing_diag_good_det)
end

56
plugins/FOBOCI/routine_new_approach.irp.f Normal file
View File

@ -0,0 +1,56 @@
subroutine update_dressing_matrix(dressing_matrix_1h1p,dressing_matrix_2h1p,dressing_restart_good_det,dressing_matrix_restart_1h1p, &
dressing_matrix_restart_2h1p,dressing_diag_good_det,psi_good_det,n_good_det,n_max_good_det)
implicit none
integer, intent(in) :: n_max_good_det
integer, intent(inout) :: n_good_det
integer(bit_kind), intent(inout) :: psi_good_det(N_int,2,n_max_good_det)
double precision, intent(in) :: dressing_matrix_1h1p(N_det_generators,N_det_generators)
double precision, intent(in) :: dressing_matrix_2h1p(N_det_generators,N_det_generators)
double precision, intent(inout) :: dressing_matrix_restart_1h1p(N_det_generators_restart, N_det_generators_restart)
double precision, intent(inout) :: dressing_matrix_restart_2h1p(N_det_generators_restart, N_det_generators_restart)
double precision, intent(inout) :: dressing_restart_good_det(n_max_good_det,N_det_generators_restart)
double precision, intent(inout) :: dressing_diag_good_det(n_max_good_det)
use bitmasks
integer :: k,l,degree
logical, allocatable :: is_a_ref_det(:)
integer, allocatable :: index_restart_generators(:)
allocate(is_a_ref_det(N_det_generators),index_restart_generators(N_det_generators))
is_a_ref_det = .False.
do k = 1, N_det_generators
do l = 1, N_det_generators_restart
call get_excitation_degree(psi_det_generators(1,1,k),psi_det_generators_restart(1,1,l), degree, N_int)
if(degree==0)then
is_a_ref_det(k) = .True.
index_restart_generators(k) = l
endif
enddo
enddo
do k = 1, N_det_generators
if(is_a_ref_det(k))then
do l = 1, N_det_generators
if(.not.is_a_ref_det(l))cycle
!!!! Dressing of the reference space in the order of the restart determinants
dressing_matrix_restart_1h1p(index_restart_generators(l),index_restart_generators(k)) += dressing_matrix_1h1p(k,l)
print*,' dressing_matrix_1h1p(k,l) = ',dressing_matrix_1h1p(k,l)
dressing_matrix_restart_2h1p(index_restart_generators(l),index_restart_generators(k)) += dressing_matrix_2h1p(k,l)
enddo
else
!!!! Incrementing the counting of the good determinants
n_good_det +=1
!!!! Adding the good determinant to the global_list (psi_good_det)
do l = 1, N_int
psi_good_det(l,1,n_good_det) = psi_det_generators(l,1,k)
psi_good_det(l,2,n_good_det) = psi_det_generators(l,2,k)
enddo
!!! Storing the diagonal dressing of the good det
dressing_diag_good_det(n_good_det) = dressing_matrix_1h1p(k,k) + dressing_matrix_2h1p(k,k)
do l = 1, N_det_generators
if(.not.is_a_ref_det(l))cycle
!!! Storing the extra diagonal dressing of the good det with the restart determinants
dressing_restart_good_det(n_good_det,index_restart_generators(l)) = dressing_matrix_1h1p(k,l) + dressing_matrix_2h1p(k,l)
enddo
endif
enddo
deallocate(is_a_ref_det,index_restart_generators)
end

457
plugins/FOBOCI/routines_dressing.irp.f Normal file
View File

@ -0,0 +1,457 @@
subroutine provide_matrix_dressing(dressing_matrix,ndet_generators_input,psi_det_generators_input)
use bitmasks
implicit none
integer, intent(in) :: ndet_generators_input
integer(bit_kind), intent(in) :: psi_det_generators_input(N_int,2,ndet_generators_input)
double precision, intent(inout) :: dressing_matrix(ndet_generators_input,ndet_generators_input)
double precision :: H_array(N_det),hka
logical :: is_a_ref_det(N_det)
integer :: i,j,n_det_ref_tmp
integer :: connected_to_ref_by_mono,degree
double precision :: coef_ref(Ndet_generators_input)
double precision :: accu,lambda_i
integer :: k
integer :: index_ref_tmp(N_det)
is_a_ref_det = .False.
n_det_ref_tmp = 0
do i = 1, N_det
do j = 1, Ndet_generators_input
call get_excitation_degree(psi_det(1,1,i),psi_det_generators_input(1,1,j),degree,N_int)
if(degree == 0)then
is_a_ref_det(i) = .True.
n_det_ref_tmp +=1
index_ref_tmp(n_det_ref_tmp) = i
coef_ref(n_det_ref_tmp) = psi_coef(i,1)
exit
endif
enddo
enddo
if( ndet_generators_input .ne. n_det_ref_tmp)then
print*,'Problem !!!! '
print*,' ndet_generators .ne. n_det_ref_tmp !!!'
print*,'ndet_generators,n_det_ref_tmp'
print*,ndet_generators_input,n_det_ref_tmp
stop
endif
call i_h_j(psi_det_generators_input(1,1,1),psi_det_generators_input(1,1,1),N_int,href)
integer :: i_pert, i_pert_count
i_pert_count = 0
do i = 1, N_det
if(is_a_ref_det(i))cycle
call i_h_j(psi_det(1,1,i),psi_det(1,1,i),N_int,hka)
double precision :: f,href
f = 1.d0/(href - hka)
H_array = 0.d0
accu = 0.d0
do j=1,ndet_generators_input
call i_h_j(psi_det(1,1,i),psi_det_generators_input(1,1,j),N_int,hka)
H_array(j) = hka
accu += coef_ref(j) * hka
enddo
lambda_i = psi_coef(i,1)/accu
i_pert = 1
if(accu * f / psi_coef(i,1) .gt. 0.5d0 .and. accu * f/psi_coef(i,1).gt.0.d0)then
i_pert = 0
endif
do j = 1, ndet_generators_input
if(dabs(H_array(j)*lambda_i).gt.0.5d0)then
i_pert = 1
exit
endif
enddo
! print*,''
! print*,'lambda_i,f = ',lambda_i,f
! print*,'i_pert = ',i_pert
! print*,''
if(i_pert==1)then
lambda_i = f
i_pert_count +=1
endif
do k=1,ndet_generators_input
double precision :: contrib
contrib = H_array(k) * H_array(k) * lambda_i
dressing_matrix(k, k) += contrib
do j=k+1,ndet_generators_input
contrib = H_array(k) * H_array(j) * lambda_i
dressing_matrix(k, j) += contrib
dressing_matrix(j, k) += contrib
enddo
enddo
enddo
!print*,'i_pert_count = ',i_pert_count
end
subroutine provide_matrix_dressing_general(dressing_matrix,psi_det_ref_input,psi_coef_ref_input,n_det_ref_input, &
psi_det_outer_input,psi_coef_outer_input,n_det_outer_input)
use bitmasks
implicit none
integer, intent(in) :: n_det_ref_input
integer(bit_kind), intent(in) :: psi_det_ref_input(N_int,2,n_det_ref_input)
double precision, intent(in) :: psi_coef_ref_input(n_det_ref_input,N_states)
integer, intent(in) :: n_det_outer_input
integer(bit_kind), intent(in) :: psi_det_outer_input(N_int,2,n_det_outer_input)
double precision, intent(in) :: psi_coef_outer_input(n_det_outer_input,N_states)
double precision, intent(inout) :: dressing_matrix(n_det_ref_input,n_det_ref_input)
integer :: i_pert, i_pert_count,i,j,k
double precision :: f,href,hka,lambda_i
double precision :: H_array(n_det_ref_input),accu
call i_h_j(psi_det_ref_input(1,1,1),psi_det_ref_input(1,1,1),N_int,href)
i_pert_count = 0
do i = 1, n_det_outer_input
call i_h_j(psi_det_outer_input(1,1,i),psi_det_outer_input(1,1,i),N_int,hka)
f = 1.d0/(href - hka)
H_array = 0.d0
accu = 0.d0
do j=1,n_det_ref_input
call i_h_j(psi_det_outer_input(1,1,i),psi_det_ref_input(1,1,j),N_int,hka)
H_array(j) = hka
accu += psi_coef_ref_input(j,1) * hka
enddo
lambda_i = psi_coef_outer_input(i,1)/accu
i_pert = 1
if(accu * f / psi_coef_outer_input(i,1) .gt. 0.5d0 .and. accu * f/psi_coef_outer_input(i,1).gt.0.d0)then
i_pert = 0
endif
do j = 1, n_det_ref_input
if(dabs(H_array(j)*lambda_i).gt.0.3d0)then
i_pert = 1
exit
endif
enddo
if(i_pert==1)then
lambda_i = f
i_pert_count +=1
endif
do k=1,n_det_ref_input
double precision :: contrib
contrib = H_array(k) * H_array(k) * lambda_i
dressing_matrix(k, k) += contrib
do j=k+1,n_det_ref_input
contrib = H_array(k) * H_array(j) * lambda_i
dressing_matrix(k, j) += contrib
dressing_matrix(j, k) += contrib
enddo
enddo
enddo
end
subroutine diag_dressed_matrix_and_set_to_psi_det(psi_det_generators_input,Ndet_generators_input,dressing_matrix)
use bitmasks
implicit none
integer, intent(in) :: ndet_generators_input
integer(bit_kind), intent(in) :: psi_det_generators_input(N_int,2,ndet_generators_input)
double precision, intent(inout) :: dressing_matrix(ndet_generators_input,ndet_generators_input)
integer :: i,j
double precision :: eigenvectors(Ndet_generators_input,Ndet_generators_input), eigenvalues(Ndet_generators_input)
call lapack_diag(eigenvalues,eigenvectors,dressing_matrix,Ndet_generators_input,Ndet_generators_input)
print*,'Dressed eigenvalue, to be compared with the CI one'
print*,'E = ',eigenvalues(1)+nuclear_repulsion
print*,'Dressed matrix, to be compared to the intermediate Hamiltonian one'
do i = 1, Ndet_generators_input
write(*,'(100(F12.5,X))')dressing_matrix(i,:)
enddo
n_det = Ndet_generators_input
do i = 1, Ndet_generators_input
psi_coef(i,1) = eigenvectors(i,1)
do j = 1, N_int
psi_det(j,1,i) = psi_det_generators_input(j,1,i)
psi_det(j,2,i) = psi_det_generators_input(j,2,i)
enddo
enddo
touch N_det psi_coef psi_det
end
subroutine give_n_1h1p_and_n_2h1p_in_psi_det(n_det_1h1p,n_det_2h1p)
use bitmasks
implicit none
integer, intent(out) :: n_det_1h1p, n_det_2h1p
integer :: i
integer :: n_det_ref_restart_tmp,n_det_1h
integer :: number_of_holes,n_h, number_of_particles,n_p
n_det_ref_restart_tmp = 0
n_det_1h = 0
n_det_1h1p = 0
n_det_2h1p = 0
do i = 1, N_det
n_h = number_of_holes(psi_det(1,1,i))
n_p = number_of_particles(psi_det(1,1,i))
if(n_h == 0 .and. n_p == 0)then
n_det_ref_restart_tmp +=1
else if (n_h ==1 .and. n_p==0)then
n_det_1h +=1
else if (n_h ==1 .and. n_p==1)then
n_det_1h1p +=1
else if (n_h ==2 .and. n_p==1)then
n_det_2h1p +=1
else
print*,'PB !!!!'
print*,'You have something else than a 1h, 1h1p or 2h1p'
call debug_det(psi_det(1,1,i),N_int)
stop
endif
enddo
! if(n_det_1h.ne.1)then
! print*,'PB !! You have more than one 1h'
! stop
! endif
if(n_det_ref_restart_tmp + n_det_1h .ne. n_det_generators)then
print*,'PB !!!!'
print*,'You have forgotten something in your generators ... '
stop
endif
end
subroutine give_n_1h1p_and_n_1h2p_in_psi_det(n_det_1h1p,n_det_1h2p)
use bitmasks
implicit none
integer, intent(out) :: n_det_1h1p, n_det_1h2p
integer :: i
integer :: n_det_ref_restart_tmp,n_det_1h
integer :: number_of_holes,n_h, number_of_particles,n_p
n_det_ref_restart_tmp = 0
n_det_1h = 0
n_det_1h1p = 0
n_det_1h2p = 0
do i = 1, N_det
n_h = number_of_holes(psi_det(1,1,i))
n_p = number_of_particles(psi_det(1,1,i))
if(n_h == 0 .and. n_p == 0)then
n_det_ref_restart_tmp +=1
else if (n_h ==0 .and. n_p==1)then
n_det_1h +=1
else if (n_h ==1 .and. n_p==1)then
n_det_1h1p +=1
else if (n_h ==1 .and. n_p==2)then
n_det_1h2p +=1
else
print*,'PB !!!!'
print*,'You have something else than a 1p, 1h1p or 1h2p'
call debug_det(psi_det(1,1,i),N_int)
stop
endif
enddo
if(n_det_ref_restart_tmp + n_det_1h .ne. n_det_generators)then
print*,'PB !!!!'
print*,'You have forgotten something in your generators ... '
stop
endif
end
subroutine split_wf_generators_and_1h1p_and_2h1p(n_det_1h1p,n_det_2h1p,psi_ref_out,psi_ref_coef_out,psi_1h1p,psi_coef_1h1p,psi_2h1p,psi_coef_2h1p)
use bitmasks
implicit none
integer, intent(in) :: n_det_1h1p,n_det_2h1p
integer(bit_kind), intent(out) :: psi_ref_out(N_int,2,N_det_generators)
integer(bit_kind), intent(out) :: psi_1h1p(N_int,2,n_det_1h1p)
integer(bit_kind), intent(out) :: psi_2h1p(N_int,2,n_det_2h1p)
double precision, intent(out) :: psi_ref_coef_out(N_det_generators,N_states)
double precision, intent(out) :: psi_coef_1h1p(n_det_1h1p, N_states)
double precision, intent(out) :: psi_coef_2h1p(n_det_2h1p, N_states)
integer :: i,j
integer :: degree
integer :: number_of_holes,n_h, number_of_particles,n_p
integer :: n_det_generators_tmp,n_det_1h1p_tmp,n_det_2h1p_tmp
integer, allocatable :: index_generator(:)
integer, allocatable :: index_1h1p(:)
integer, allocatable :: index_2h1p(:)
allocate(index_1h1p(n_det))
allocate(index_2h1p(n_det))
allocate(index_generator(N_det))
n_det_generators_tmp = 0
n_det_1h1p_tmp = 0
n_det_2h1p_tmp = 0
do i = 1, n_det
n_h = number_of_holes(psi_det(1,1,i))
n_p = number_of_particles(psi_det(1,1,i))
if (n_h ==1 .and. n_p==1)then
n_det_1h1p_tmp +=1
index_1h1p(n_det_1h1p_tmp) = i
else if (n_h ==2 .and. n_p==1)then
n_det_2h1p_tmp +=1
index_2h1p(n_det_2h1p_tmp) = i
endif
do j = 1, N_det_generators
call get_excitation_degree(psi_det_generators(1,1,j),psi_det(1,1,i), degree, N_int)
if(degree == 0)then
n_det_generators_tmp +=1
index_generator(n_det_generators_tmp) = i
endif
enddo
enddo
if(n_det_1h1p_tmp.ne.n_det_1h1p)then
print*,'PB !!!'
print*,'n_det_1h1p_tmp.ne.n_det_1h1p)'
stop
endif
if(n_det_2h1p_tmp.ne.n_det_2h1p)then
print*,'PB !!!'
print*,'n_det_2h1p_tmp.ne.n_det_2h1p)'
stop
endif
if(N_det_generators_tmp.ne.n_det_generators)then
print*,'PB !!!'
print*,'N_det_generators_tmp.ne.n_det_generators'
stop
endif
do i = 1,N_det_generators
do j = 1, N_int
psi_ref_out(j,1,i) = psi_det(j,1,index_generator(i))
psi_ref_out(j,2,i) = psi_det(j,2,index_generator(i))
enddo
do j = 1, N_states
psi_ref_coef_out(i,j) = psi_coef(index_generator(i),j)
enddo
enddo
do i = 1, n_det_1h1p
do j = 1, N_int
psi_1h1p(j,1,i) = psi_det(j,1,index_1h1p(i))
psi_1h1p(j,2,i) = psi_det(j,2,index_1h1p(i))
enddo
do j = 1, N_states
psi_coef_1h1p(i,j) = psi_coef(index_1h1p(i),j)
enddo
enddo
do i = 1, n_det_2h1p
do j = 1, N_int
psi_2h1p(j,1,i) = psi_det(j,1,index_2h1p(i))
psi_2h1p(j,2,i) = psi_det(j,2,index_2h1p(i))
enddo
do j = 1, N_states
psi_coef_2h1p(i,j) = psi_coef(index_2h1p(i),j)
enddo
enddo
deallocate(index_generator)
deallocate(index_1h1p)
deallocate(index_2h1p)
end
subroutine split_wf_generators_and_1h1p_and_1h2p(n_det_1h1p,n_det_1h2p,psi_ref_out,psi_ref_coef_out,psi_1h1p,psi_coef_1h1p,psi_1h2p,psi_coef_1h2p)
use bitmasks
implicit none
integer, intent(in) :: n_det_1h1p,n_det_1h2p
integer(bit_kind), intent(out) :: psi_ref_out(N_int,2,N_det_generators)
integer(bit_kind), intent(out) :: psi_1h1p(N_int,2,n_det_1h1p)
integer(bit_kind), intent(out) :: psi_1h2p(N_int,2,n_det_1h2p)
double precision, intent(out) :: psi_ref_coef_out(N_det_generators,N_states)
double precision, intent(out) :: psi_coef_1h1p(n_det_1h1p, N_states)
double precision, intent(out) :: psi_coef_1h2p(n_det_1h2p, N_states)
integer :: i,j
integer :: degree
integer :: number_of_holes,n_h, number_of_particles,n_p
integer :: n_det_generators_tmp,n_det_1h1p_tmp,n_det_1h2p_tmp
integer, allocatable :: index_generator(:)
integer, allocatable :: index_1h1p(:)
integer, allocatable :: index_1h2p(:)
allocate(index_1h1p(n_det))
allocate(index_1h2p(n_det))
allocate(index_generator(N_det))
n_det_generators_tmp = 0
n_det_1h1p_tmp = 0
n_det_1h2p_tmp = 0
do i = 1, n_det
n_h = number_of_holes(psi_det(1,1,i))
n_p = number_of_particles(psi_det(1,1,i))
if (n_h ==1 .and. n_p==1)then
n_det_1h1p_tmp +=1
index_1h1p(n_det_1h1p_tmp) = i
else if (n_h ==1 .and. n_p==2)then
n_det_1h2p_tmp +=1
index_1h2p(n_det_1h2p_tmp) = i
endif
do j = 1, N_det_generators
call get_excitation_degree(psi_det_generators(1,1,j),psi_det(1,1,i), degree, N_int)
if(degree == 0)then
n_det_generators_tmp +=1
index_generator(n_det_generators_tmp) = i
endif
enddo
enddo
if(n_det_1h1p_tmp.ne.n_det_1h1p)then
print*,'PB !!!'
print*,'n_det_1h1p_tmp.ne.n_det_1h1p)'
stop
endif
if(n_det_1h2p_tmp.ne.n_det_1h2p)then
print*,'PB !!!'
print*,'n_det_1h2p_tmp.ne.n_det_1h2p)'
stop
endif
if(N_det_generators_tmp.ne.n_det_generators)then
print*,'PB !!!'
print*,'N_det_generators_tmp.ne.n_det_generators'
stop
endif
do i = 1,N_det_generators
do j = 1, N_int
psi_ref_out(j,1,i) = psi_det(j,1,index_generator(i))
psi_ref_out(j,2,i) = psi_det(j,2,index_generator(i))
enddo
do j = 1, N_states
psi_ref_coef_out(i,j) = psi_coef(index_generator(i),j)
enddo
enddo
do i = 1, n_det_1h1p
do j = 1, N_int
psi_1h1p(j,1,i) = psi_det(j,1,index_1h1p(i))
psi_1h1p(j,2,i) = psi_det(j,2,index_1h1p(i))
enddo
do j = 1, N_states
psi_coef_1h1p(i,j) = psi_coef(index_1h1p(i),j)
enddo
enddo
do i = 1, n_det_1h2p
do j = 1, N_int
psi_1h2p(j,1,i) = psi_det(j,1,index_1h2p(i))
psi_1h2p(j,2,i) = psi_det(j,2,index_1h2p(i))
enddo
do j = 1, N_states
psi_coef_1h2p(i,j) = psi_coef(index_1h2p(i),j)
enddo
enddo
deallocate(index_generator)
deallocate(index_1h1p)
deallocate(index_1h2p)
end

616
plugins/FOBOCI/routines_foboci.irp.f Normal file
View File

@ -0,0 +1,616 @@
subroutine set_intermediate_normalization_lmct_old(norm,i_hole)
implicit none
integer, intent(in) :: i_hole
double precision, intent(out) :: norm(N_states)
integer :: i,j,degree,index_ref_generators_restart,k
integer:: number_of_holes,n_h, number_of_particles,n_p
integer, allocatable :: index_one_hole(:),index_one_hole_one_p(:),index_two_hole_one_p(:),index_two_hole(:)
integer, allocatable :: index_one_p(:)
integer :: n_one_hole,n_one_hole_one_p,n_two_hole_one_p,n_two_hole,n_one_p
logical :: is_the_hole_in_det
double precision :: inv_coef_ref_generators_restart(N_states),hij,hii,accu
integer :: index_good_hole(1000)
integer :: n_good_hole
logical,allocatable :: is_a_ref_det(:)
allocate(index_one_hole(n_det),index_one_hole_one_p(n_det),index_two_hole_one_p(N_det),index_two_hole(N_det),index_one_p(N_det),is_a_ref_det(N_det))
n_one_hole = 0
n_one_hole_one_p = 0
n_two_hole_one_p = 0
n_two_hole = 0
n_one_p = 0
n_good_hole = 0
! Find the one holes and one hole one particle
is_a_ref_det = .False.
do i = 1, N_det
! Find the reference determinant for intermediate normalization
call get_excitation_degree(ref_generators_restart,psi_det(1,1,i),degree,N_int)
if(degree == 0)then
index_ref_generators_restart = i
do k = 1, N_states
inv_coef_ref_generators_restart(k) = 1.d0/psi_coef(i,k)
enddo
! cycle
endif
! Find all the determinants present in the reference wave function
do j = 1, N_det_generators_restart
call get_excitation_degree(psi_det(1,1,i),psi_det_generators_restart(1,1,j),degree,N_int)
if(degree == 0)then
is_a_ref_det(i) = .True.
exit
endif
enddo
if(is_a_ref_det(i))cycle
n_h = number_of_holes(psi_det(1,1,i))
n_p = number_of_particles(psi_det(1,1,i))
if(n_h == 1 .and. n_p == 0)then
if(is_the_hole_in_det(psi_det(1,1,i),1,i_hole).or.is_the_hole_in_det(psi_det(1,1,i),2,i_hole))then
n_good_hole +=1
index_good_hole(n_good_hole) = i
else
do k = 1, N_states
psi_coef(i,k) = 0.d0
enddo
endif
else
do k = 1, N_states
psi_coef(i,k) = 0.d0
enddo
endif
enddo
!do k = 1, N_det
! call debug_det(psi_det(1,1,k),N_int)
! print*,'k,coef = ',k,psi_coef(k,1)/psi_coef(index_ref_generators_restart,1)
!enddo
print*,''
print*,'n_good_hole = ',n_good_hole
do k = 1,N_states
print*,'state ',k
do i = 1, n_good_hole
print*,'psi_coef(index_good_hole) = ',psi_coef(index_good_hole(i),k)/psi_coef(index_ref_generators_restart,k)
enddo
print*,''
enddo
norm = 0.d0
! Set the wave function to the intermediate normalization
do k = 1, N_states
do i = 1, N_det
psi_coef(i,k) = psi_coef(i,k) * inv_coef_ref_generators_restart(k)
enddo
enddo
do k = 1,N_states
print*,'state ',k
do i = 1, N_det
!! print*,'psi_coef(i_ref) = ',psi_coef(i,1)
if (is_a_ref_det(i))then
print*,'i,psi_coef_ref = ',psi_coef(i,k)
cycle
endif
norm(k) += psi_coef(i,k) * psi_coef(i,k)
enddo
print*,'norm = ',norm(k)
enddo
deallocate(index_one_hole,index_one_hole_one_p,index_two_hole_one_p,index_two_hole,index_one_p,is_a_ref_det)
soft_touch psi_coef
end
subroutine set_intermediate_normalization_mlct_old(norm,i_particl)
implicit none
integer, intent(in) :: i_particl
double precision, intent(out) :: norm(N_states)
integer :: i,j,degree,index_ref_generators_restart,k
integer:: number_of_holes,n_h, number_of_particles,n_p
integer, allocatable :: index_one_hole(:),index_one_hole_one_p(:),index_two_hole_one_p(:),index_two_hole(:)
integer, allocatable :: index_one_p(:),index_one_hole_two_p(:)
integer :: n_one_hole,n_one_hole_one_p,n_two_hole_one_p,n_two_hole,n_one_p,n_one_hole_two_p
logical :: is_the_particl_in_det
double precision :: inv_coef_ref_generators_restart(N_states)
integer :: exc(0:2,2,2)
double precision :: phase,hij,hii,accu
integer :: h1,p1,h2,p2,s1,s2
integer :: index_good_particl(1000)
integer :: n_good_particl
logical,allocatable :: is_a_ref_det(:)
integer :: i_count
allocate(index_one_hole(n_det),index_one_hole_one_p(n_det),index_two_hole_one_p(N_det),index_two_hole(N_det),index_one_p(N_det),is_a_ref_det(N_det))
allocate(index_one_hole_two_p(n_det))
n_one_hole = 0
n_one_hole_one_p = 0
n_two_hole_one_p = 0
n_two_hole = 0
n_one_p = 0
n_one_hole_two_p = 0
n_good_particl = 0
! Find the one holes and one hole one particle
i_count = 0
is_a_ref_det = .False.
do i = 1, N_det
call get_excitation_degree(ref_generators_restart,psi_det(1,1,i),degree,N_int)
if(degree == 0)then
index_ref_generators_restart = i
do k = 1, N_states
inv_coef_ref_generators_restart(k) = 1.d0/psi_coef(i,k)
enddo
! cycle
endif
! Find all the determinants present in the reference wave function
do j = 1, N_det_generators_restart
call get_excitation_degree(psi_det(1,1,i),psi_det_generators_restart(1,1,j),degree,N_int)
if(degree == 0)then
is_a_ref_det(i) = .True.
exit
endif
enddo
if(is_a_ref_det(i))cycle
n_h = number_of_holes(psi_det(1,1,i))
n_p = number_of_particles(psi_det(1,1,i))
if(n_h == 0 .and. n_p == 1)then ! 1p
if(is_the_particl_in_det(psi_det(1,1,i),1,i_particl).or.is_the_particl_in_det(psi_det(1,1,i),2,i_particl))then
n_good_particl += 1
index_good_particl(n_good_particl) = i
else
do k = 1, N_states
psi_coef(i,k) = 0.d0
enddo
endif
else
do k = 1, N_states
psi_coef(i,k) = 0.d0
enddo
endif
enddo
norm = 0.d0
print*,''
print*,'n_good_particl = ',n_good_particl
do k = 1, N_states
print*,'state ',k
do i = 1, n_good_particl
print*,'psi_coef(index_good_particl,1) = ',psi_coef(index_good_particl(i),k)/psi_coef(index_ref_generators_restart,k)
enddo
print*,''
enddo
! Set the wave function to the intermediate normalization
do k = 1, N_states
do i = 1, N_det
psi_coef(i,k) = psi_coef(i,k) * inv_coef_ref_generators_restart(k)
enddo
enddo
do k = 1, N_states
print*,'state ',k
do i = 1, N_det
!! print*,'i = ',i, psi_coef(i,1)
if (is_a_ref_det(i))then
print*,'i,psi_coef_ref = ',psi_coef(i,k)
cycle
endif
norm(k) += psi_coef(i,k) * psi_coef(i,k)
enddo
print*,'norm = ',norm
enddo
soft_touch psi_coef
deallocate(index_one_hole,index_one_hole_one_p,index_two_hole_one_p,index_two_hole,index_one_p,is_a_ref_det)
end
subroutine update_density_matrix_osoci
implicit none
BEGIN_DOC
! one_body_dm_mo_alpha_osoci += Delta rho alpha
! one_body_dm_mo_beta_osoci += Delta rho beta
END_DOC
integer :: i,j
integer :: iorb,jorb
do i = 1, mo_tot_num
do j = 1, mo_tot_num
one_body_dm_mo_alpha_osoci(i,j) = one_body_dm_mo_alpha_osoci(i,j) + (one_body_dm_mo_alpha(i,j) - one_body_dm_mo_alpha_generators_restart(i,j))
one_body_dm_mo_beta_osoci(i,j) = one_body_dm_mo_beta_osoci(i,j) + (one_body_dm_mo_beta(i,j) - one_body_dm_mo_beta_generators_restart(i,j))
enddo
enddo
end
subroutine initialize_density_matrix_osoci
implicit none
one_body_dm_mo_alpha_osoci = one_body_dm_mo_alpha_generators_restart
one_body_dm_mo_beta_osoci = one_body_dm_mo_beta_generators_restart
end
subroutine rescale_density_matrix_osoci(norm)
implicit none
double precision, intent(in) :: norm(N_states)
integer :: i,j
double precision :: norm_tmp
norm_tmp = 0.d0
do i = 1, N_states
norm_tmp += norm(i)
enddo
print*,'norm = ',norm_tmp
do i = 1, mo_tot_num
do j = 1,mo_tot_num
one_body_dm_mo_alpha_osoci(i,j) = one_body_dm_mo_alpha_osoci(i,j) * norm_tmp
one_body_dm_mo_beta_osoci(j,i) = one_body_dm_mo_beta_osoci(j,i) * norm_tmp
enddo
enddo
end
subroutine save_osoci_natural_mos
implicit none
BEGIN_DOC
! Set natural orbitals, obtained by diagonalization of the one-body density matrix in the MO basis
END_DOC
character*(64) :: label
double precision, allocatable :: tmp(:,:),tmp_bis(:,:)
integer, allocatable :: occ(:,:)
integer :: n_occ_alpha,i,i_core,j_core,iorb,jorb,j,i_inact,j_inact,i_virt,j_virt
allocate(tmp(size(one_body_dm_mo_alpha_osoci,1),size(one_body_dm_mo_alpha_osoci,2)))
allocate(tmp_bis(size(one_body_dm_mo_alpha_osoci,1),size(one_body_dm_mo_alpha_osoci,2)))
allocate (occ(N_int*bit_kind_size,2))
! Negation to have the occupied MOs first after the diagonalization
tmp_bis = -one_body_dm_mo_alpha_osoci - one_body_dm_mo_beta_osoci
! Set to Zero the core-inact-act-virt part
do i = 1, n_core_orb
i_core = list_core(i)
tmp_bis(i_core,i_core) = -10.d0
do j = i+1, n_core_orb
j_core = list_core(j)
tmp_bis(i_core,j_core) = 0.d0
tmp_bis(j_core,i_core) = 0.d0
enddo
do j = 1, n_inact_orb
iorb = list_inact(j)
tmp_bis(i_core,iorb) = 0.d0
tmp_bis(iorb,i_core) = 0.d0
enddo
do j = 1, n_act_orb
iorb = list_act(j)
tmp_bis(i_core,iorb) = 0.d0
tmp_bis(iorb,i_core) = 0.d0
enddo
do j = 1, n_virt_orb
iorb = list_virt(j)
tmp_bis(i_core,iorb) = 0.d0
tmp_bis(iorb,i_core) = 0.d0
enddo
enddo
do i = 1, n_core_orb
print*,'dm core = ',list_core(i),tmp_bis(list_core(i),list_core(i))
enddo
! Set to Zero the inact-inact part to avoid arbitrary rotations
do i = 1, n_inact_orb
i_inact = list_inact(i)
do j = i+1, n_inact_orb
j_inact = list_inact(j)
tmp_bis(i_inact,j_inact) = 0.d0
tmp_bis(j_inact,i_inact) = 0.d0
enddo
enddo
! Set to Zero the inact-virt part to avoid arbitrary rotations
do i = 1, n_inact_orb
i_inact = list_inact(i)
do j = 1, n_virt_orb
j_virt = list_virt(j)
tmp_bis(i_inact,j_virt) = 0.d0
tmp_bis(j_virt,i_inact) = 0.d0
enddo
enddo
! Set to Zero the virt-virt part to avoid arbitrary rotations
do i = 1, n_virt_orb
i_virt = list_virt(i)
do j = i+1, n_virt_orb
j_virt = list_virt(j)
tmp_bis(i_virt,j_virt) = 0.d0
tmp_bis(j_virt,i_virt) = 0.d0
enddo
enddo
double precision :: accu
! Set to Zero the act-act part to avoid arbitrary rotations
do i = 1,n_act_orb
iorb = list_act(i)
do j = i+1,n_act_orb
jorb = list_act(j)
tmp_bis(iorb,jorb) = 0.d0
tmp_bis(jorb,iorb) = 0.d0
enddo
enddo
tmp = tmp_bis
!! Symetrization act-virt
do j = 1, n_virt_orb
j_virt= list_virt(j)
accu = 0.d0
do i = 1, n_act_orb
jorb = list_act(i)
accu += dabs(tmp_bis(j_virt,jorb))
enddo
do i = 1, n_act_orb
iorb = list_act(i)
tmp(j_virt,iorb) = dsign(accu/dble(n_act_orb),tmp_bis(j_virt,iorb))
tmp(iorb,j_virt) = dsign(accu/dble(n_act_orb),tmp_bis(j_virt,iorb))
enddo
enddo
!! Symetrization act-inact
!do j = 1, n_inact_orb
! j_inact = list_inact(j)
! accu = 0.d0
! do i = 1, n_act_orb
! jorb = list_act(i)
! accu += dabs(tmp_bis(j_inact,jorb))
! enddo
! do i = 1, n_act_orb
! iorb = list_act(i)
! tmp(j_inact,iorb) = dsign(accu/dble(n_act_orb),tmp_bis(j_inact,iorb))
! tmp(iorb,j_inact) = dsign(accu/dble(n_act_orb),tmp_bis(j_inact,iorb))
! enddo
!enddo
!!! Symetrization act-act
!!accu = 0.d0
!!do i = 1, n_act_orb
!! iorb = list_act(i)
!! accu += tmp_bis(iorb,iorb)
!!enddo
!!do i = 1, n_act_orb
!! iorb = list_act(i)
!! tmp(iorb,iorb) = accu/dble(n_act_orb)
!!enddo
call bitstring_to_list(reunion_of_bitmask(1,1), occ(1,1), n_occ_alpha, N_int)
double precision :: maxvaldm,imax,jmax
maxvaldm = 0.d0
imax = 1
jmax = 1
print*,''
print*,'Inactive-active Part of the One body DM'
print*,''
do i = 1,n_act_orb
iorb = list_act(i)
print*,''
print*,'ACTIVE ORBITAL ',iorb
do j = 1, n_inact_orb
jorb = list_inact(j)
if(dabs(tmp(iorb,jorb)).gt.threshold_singles)then
print*,'INACTIVE '
print*,'DM ',iorb,jorb,dabs(tmp(iorb,jorb))
endif
enddo
do j = 1, n_virt_orb
jorb = list_virt(j)
if(dabs(tmp(iorb,jorb)).gt.threshold_singles)then
print*,'VIRT '
print*,'DM ',iorb,jorb,dabs(tmp(iorb,jorb))
endif
enddo
enddo
do i = 1, mo_tot_num
do j = i+1, mo_tot_num
if(dabs(tmp(i,j)).le.threshold_fobo_dm)then
tmp(i,j) = 0.d0
tmp(j,i) = 0.d0
endif
enddo
enddo
label = "Natural"
call mo_as_eigvectors_of_mo_matrix(tmp,size(tmp,1),size(tmp,2),label,1)
soft_touch mo_coef
deallocate(tmp,occ)
end
subroutine set_osoci_natural_mos
implicit none
BEGIN_DOC
! Set natural orbitals, obtained by diagonalization of the one-body density matrix in the MO basis
END_DOC
character*(64) :: label
double precision, allocatable :: tmp(:,:),tmp_bis(:,:)
integer, allocatable :: occ(:,:)
integer :: n_occ_alpha,i,i_core,j_core,iorb,jorb,j,i_inact,j_inact,i_virt,j_virt
allocate(tmp(size(one_body_dm_mo_alpha_osoci,1),size(one_body_dm_mo_alpha_osoci,2)))
allocate(tmp_bis(size(one_body_dm_mo_alpha_osoci,1),size(one_body_dm_mo_alpha_osoci,2)))
allocate (occ(N_int*bit_kind_size,2))
! Negation to have the occupied MOs first after the diagonalization
tmp_bis = -one_body_dm_mo_alpha_osoci - one_body_dm_mo_beta_osoci
! Set to Zero the core-inact-act-virt part
do i = 1, n_core_orb
i_core = list_core(i)
tmp_bis(i_core,i_core) = -10.d0
do j = i+1, n_core_orb
j_core = list_core(j)
tmp_bis(i_core,j_core) = 0.d0
tmp_bis(j_core,i_core) = 0.d0
enddo
do j = 1, n_inact_orb
iorb = list_inact(j)
tmp_bis(i_core,iorb) = 0.d0
tmp_bis(iorb,i_core) = 0.d0
enddo
do j = 1, n_act_orb
iorb = list_act(j)
tmp_bis(i_core,iorb) = 0.d0
tmp_bis(iorb,i_core) = 0.d0
enddo
do j = 1, n_virt_orb
iorb = list_virt(j)
tmp_bis(i_core,iorb) = 0.d0
tmp_bis(iorb,i_core) = 0.d0
enddo
enddo
do i = 1, n_core_orb
print*,'dm core = ',list_core(i),tmp_bis(list_core(i),list_core(i))
enddo
! Set to Zero the inact-inact part to avoid arbitrary rotations
do i = 1, n_inact_orb
i_inact = list_inact(i)
do j = i+1, n_inact_orb
j_inact = list_inact(j)
tmp_bis(i_inact,j_inact) = 0.d0
tmp_bis(j_inact,i_inact) = 0.d0
enddo
enddo
! Set to Zero the inact-virt part to avoid arbitrary rotations
do i = 1, n_inact_orb
i_inact = list_inact(i)
do j = 1, n_virt_orb
j_virt = list_virt(j)
tmp_bis(i_inact,j_virt) = 0.d0
tmp_bis(j_virt,i_inact) = 0.d0
enddo
enddo
! Set to Zero the virt-virt part to avoid arbitrary rotations
do i = 1, n_virt_orb
i_virt = list_virt(i)
do j = i+1, n_virt_orb
j_virt = list_virt(j)
tmp_bis(i_virt,j_virt) = 0.d0
tmp_bis(j_virt,i_virt) = 0.d0
enddo
enddo
double precision :: accu
! Set to Zero the act-act part to avoid arbitrary rotations
do i = 1,n_act_orb
iorb = list_act(i)
do j = i+1,n_act_orb
jorb = list_act(j)
tmp_bis(iorb,jorb) = 0.d0
tmp_bis(jorb,iorb) = 0.d0
enddo
enddo
tmp = tmp_bis
call bitstring_to_list(reunion_of_bitmask(1,1), occ(1,1), n_occ_alpha, N_int)
double precision :: maxvaldm,imax,jmax
maxvaldm = 0.d0
imax = 1
jmax = 1
print*,''
print*,'Inactive-active Part of the One body DM'
print*,''
do i = 1,n_act_orb
iorb = list_act(i)
print*,''
print*,'ACTIVE ORBITAL ',iorb
do j = 1, n_inact_orb
jorb = list_inact(j)
if(dabs(tmp(iorb,jorb)).gt.threshold_singles)then
print*,'INACTIVE '
print*,'DM ',iorb,jorb,dabs(tmp(iorb,jorb))
endif
enddo
do j = 1, n_virt_orb
jorb = list_virt(j)
if(dabs(tmp(iorb,jorb)).gt.threshold_singles)then
print*,'VIRT '
print*,'DM ',iorb,jorb,dabs(tmp(iorb,jorb))
endif
enddo
enddo
do i = 1, mo_tot_num
do j = i+1, mo_tot_num
if(dabs(tmp(i,j)).le.threshold_fobo_dm)then
tmp(i,j) = 0.d0
tmp(j,i) = 0.d0
endif
enddo
enddo
label = "Natural"
call mo_as_eigvectors_of_mo_matrix(tmp,size(tmp,1),size(tmp,2),label,1)
soft_touch mo_coef
deallocate(tmp,occ)
end
subroutine check_symetry(i_hole,thr,test)
implicit none
integer, intent(in) :: i_hole
double precision, intent(in) :: thr
logical, intent(out) :: test
integer :: i,j,k,l
double precision :: accu
accu = 0.d0
do i = 1, n_act_orb
accu += dabs(mo_mono_elec_integral(i_hole,list_act(i)))
enddo
if(accu.gt.thr)then
test = .True.
else
test = .false.
endif
end
subroutine check_symetry_1h1p(i_hole,i_part,thr,test)
implicit none
integer, intent(in) :: i_hole,i_part
double precision, intent(in) :: thr
logical, intent(out) :: test
integer :: i,j,k,l
double precision :: accu
accu = dabs(mo_mono_elec_integral(i_hole,i_part))
if(accu.gt.thr)then
test = .True.
else
test = .false.
endif
end
subroutine update_one_body_dm_mo
implicit none
integer :: i
double precision :: accu_tot,accu_sd
print*,'touched the one_body_dm_mo_beta'
one_body_dm_mo_alpha = one_body_dm_mo_alpha_osoci
one_body_dm_mo_beta = one_body_dm_mo_beta_osoci
touch one_body_dm_mo_alpha one_body_dm_mo_beta
accu_tot = 0.d0
accu_sd = 0.d0
do i = 1, mo_tot_num
accu_tot += one_body_dm_mo_alpha(i,i) + one_body_dm_mo_beta(i,i)
accu_sd += one_body_dm_mo_alpha(i,i) - one_body_dm_mo_beta(i,i)
enddo
print*,'accu_tot = ',accu_tot
print*,'accu_sdt = ',accu_sd
end
subroutine provide_properties
implicit none
integer :: i
double precision :: accu
if(.True.)then
accu= 0.d0
do i = 1, nucl_num
accu += mulliken_spin_densities(i)
print*,i,nucl_charge(i),mulliken_spin_densities(i)
enddo
print*,'Sum of Mulliken SD = ',accu
endif
end

7
plugins/FOBOCI/save_fock_diag_inactiv_virt.irp.f Normal file
View File

@ -0,0 +1,7 @@
program save_fock_inactiv_virt_mos
implicit none
call diag_inactive_virt_and_update_mos
call save_mos
end

14
plugins/Full_CI/H_apply.irp.f
View File

@ -2,41 +2,49 @@ use bitmasks
BEGIN_SHELL [ /usr/bin/env python ]
from generate_h_apply import *
s = H_apply("FCI")
s = H_apply_zmq("FCI")
s.set_selection_pt2("epstein_nesbet_2x2")
s.unset_openmp()
print s
s = H_apply("FCI_PT2")
s = H_apply_zmq("FCI_PT2")
s.set_perturbation("epstein_nesbet_2x2")
s.unset_openmp()
print s
s = H_apply("FCI_no_skip")
s = H_apply_zmq("FCI_no_skip")
s.set_selection_pt2("epstein_nesbet_2x2")
s.unset_skip()
s.unset_openmp()
print s
s = H_apply("FCI_mono")
s.set_selection_pt2("epstein_nesbet_2x2")
s.unset_double_excitations()
s.unset_openmp()
print s
s = H_apply("select_mono_delta_rho")
s.unset_double_excitations()
s.set_selection_pt2("delta_rho_one_point")
s.unset_openmp()
print s
s = H_apply("pt2_mono_delta_rho")
s.unset_double_excitations()
s.set_perturbation("delta_rho_one_point")
s.unset_openmp()
print s
s = H_apply("select_mono_di_delta_rho")
s.set_selection_pt2("delta_rho_one_point")
s.unset_openmp()
print s
s = H_apply("pt2_mono_di_delta_rho")
s.set_perturbation("delta_rho_one_point")
s.unset_openmp()
print s

25
plugins/Full_CI/full_ci.irp.f
View File

@ -62,15 +62,28 @@ program full_ci
endif
print *, 'N_det = ', N_det
print *, 'N_states = ', N_states
print *, 'PT2 = ', pt2
print *, 'E = ', CI_energy
print *, 'E(before)+PT2 = ', E_CI_before+pt2
do k = 1, N_states
print*,'State ',k
print *, 'PT2 = ', pt2(k)
print *, 'E = ', CI_energy(k)
print *, 'E(before)+PT2 = ', E_CI_before(k)+pt2(k)
enddo
print *, '-----'
E_CI_before = CI_energy
call ezfio_set_full_ci_energy(CI_energy)
if (abort_all) then
exit
if(N_states.gt.1)then
print*,'Variational Energy difference'
do i = 2, N_states
print*,'Delta E = ',CI_energy(i) - CI_energy(1)
enddo
endif
if(N_states.gt.1)then
print*,'Variational + perturbative Energy difference'
do i = 2, N_states
print*,'Delta E = ',E_CI_before(i)+ pt2(i) - (E_CI_before(1) + pt2(1))
enddo
endif
E_CI_before = CI_energy
call ezfio_set_full_ci_energy(CI_energy)
enddo
N_det = min(N_det_max,N_det)
touch N_det psi_det psi_coef

3
plugins/Full_CI/full_ci_no_skip.irp.f
View File

@ -67,9 +67,6 @@ program full_ci
print *, '-----'
E_CI_before = CI_energy
call ezfio_set_full_ci_energy(CI_energy)
if (abort_all) then
exit
endif
enddo
N_det = min(N_det_max,N_det)
touch N_det psi_det psi_coef

42
plugins/Full_CI/micro_pt2.irp.f Normal file
View File

@ -0,0 +1,42 @@
program micro_pt2
implicit none
BEGIN_DOC
! Helper program to compute the PT2 in distributed mode.
END_DOC
read_wf = .False.
SOFT_TOUCH read_wf
call provide_everything
call switch_qp_run_to_master
call run_wf
end
subroutine provide_everything
PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context
end
subroutine run_wf
use f77_zmq
implicit none
integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
print *, 'Getting wave function'
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
call zmq_get_psi(zmq_to_qp_run_socket, 1)
call write_double(6,ci_energy,'Energy')
zmq_state = 'h_apply_fci_pt2'
call provide_everything
integer :: rc, i
!$OMP PARALLEL PRIVATE(i)
i = omp_get_thread_num()
call H_apply_FCI_PT2_slave_tcp(i)
!$OMP END PARALLEL
end

3
plugins/Full_CI/target_pt2.irp.f
View File

@ -73,9 +73,6 @@ program var_pt2_ratio_run
print *, 'N_det = ', N_det
print *, 'E = ', CI_energy(1)
call ezfio_set_full_ci_energy(CI_energy)
if (abort_all) then
exit
endif
enddo
deallocate(pt2,norm_pert)
end

3
plugins/Full_CI/var_pt2_ratio.irp.f
View File

@ -63,9 +63,6 @@ program var_pt2_ratio_run
print *, 'N_det = ', N_det
print *, 'E = ', CI_energy(1)
call ezfio_set_full_ci_energy(CI_energy)
if (abort_all) then
exit
endif
enddo
deallocate(pt2,norm_pert)
end

2
plugins/Hartree_Fock/.gitignore vendored
View File

@ -5,7 +5,6 @@ AO_Basis
Bitmask
Electrons
Ezfio_files
Huckel_guess
IRPF90_man
IRPF90_temp
Integrals_Bielec
@ -16,7 +15,6 @@ Makefile
Makefile.depend
Nuclei
Pseudo
SCF
Utils
ZMQ
ezfio_interface.irp.f

7
plugins/Hartree_Fock/EZFIO.cfg
View File

@ -26,3 +26,10 @@ default: Huckel
type: double precision
doc: Calculated HF energy
interface: ezfio
[no_oa_or_av_opt]
type: logical
doc: If true, skip the (inactive+core) --> (active) and the (active) --> (virtual) orbital rotations within the SCF procedure
interface: ezfio,provider,ocaml
default: False

2
plugins/Hartree_Fock/NEEDED_CHILDREN_MODULES
View File

@ -1 +1 @@
Integrals_Bielec MOGuess
Integrals_Bielec MOGuess Bitmask

10
plugins/Hartree_Fock/damping_SCF.irp.f
View File

@ -30,11 +30,11 @@ subroutine damping_SCF
call write_time(output_hartree_fock)
write(output_hartree_fock,'(A4,X,A16, X, A16, X, A16, X, A4 )'), &
write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') &
'====','================','================','================', '===='
write(output_hartree_fock,'(A4,X,A16, X, A16, X, A16, X, A4 )'), &
write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') &
' N ', 'Energy ', 'Energy diff ', 'Density diff ', 'Save'
write(output_hartree_fock,'(A4,X,A16, X, A16, X, A16, X, A4 )'), &
write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') &
'====','================','================','================', '===='
E = HF_energy + 1.d0
@ -58,7 +58,7 @@ subroutine damping_SCF
save_char = ' '
endif
write(output_hartree_fock,'(I4,X,F16.10, X, F16.10, X, F16.10, 3X, A )'), &
write(output_hartree_fock,'(I4,1X,F16.10, 1X, F16.10, 1X, F16.10, 3X, A )') &
k, E, delta_E, delta_D, save_char
D_alpha = HF_density_matrix_ao_alpha
@ -116,7 +116,7 @@ subroutine damping_SCF
enddo
write(output_hartree_fock,'(A4,X,A16, X, A16, X, A16, X, A4 )'), '====','================','================','================', '===='
write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') '====','================','================','================', '===='
write(output_hartree_fock,*)
call mo_as_eigvectors_of_mo_matrix(Fock_matrix_mo,size(Fock_matrix_mo,1),size(Fock_matrix_mo,2),mo_label,1)

74
plugins/Hartree_Fock/diagonalize_fock.irp.f
View File

@ -11,63 +11,35 @@
double precision, allocatable :: work(:), F(:,:), S(:,:)
! if (mo_tot_num == ao_num) then
! ! Solve H.C = E.S.C in AO basis set
!
! allocate(F(ao_num_align,ao_num), S(ao_num_align,ao_num) )
! do j=1,ao_num
! do i=1,ao_num
! S(i,j) = ao_overlap(i,j)
! F(i,j) = Fock_matrix_ao(i,j)
! enddo
! enddo
!
! n = ao_num
! lwork = 1+6*n + 2*n*n
! liwork = 3 + 5*n
!
! allocate(work(lwork), iwork(liwork) )
!
! lwork = -1
! liwork = -1
!
! call dsygvd(1,'v','u',ao_num,F,size(F,1),S,size(S,1),&
! diagonal_Fock_matrix_mo, work, lwork, iwork, liwork, info)
!
! if (info /= 0) then
! print *, irp_here//' failed : ', info
! stop 1
! endif
! lwork = int(work(1))
! liwork = iwork(1)
! deallocate(work,iwork)
! allocate(work(lwork), iwork(liwork) )
!
! call dsygvd(1,'v','u',ao_num,F,size(F,1),S,size(S,1),&
! diagonal_Fock_matrix_mo, work, lwork, iwork, liwork, info)
!
! if (info /= 0) then
! print *, irp_here//' failed : ', info
! stop 1
! endif
! do j=1,mo_tot_num
! do i=1,ao_num
! eigenvectors_Fock_matrix_mo(i,j) = F(i,j)
! enddo
! enddo
!
! deallocate(work, iwork, F, S)
!
! else
!
! Solve H.C = E.C in MO basis set
allocate( F(mo_tot_num_align,mo_tot_num) )
do j=1,mo_tot_num
do i=1,mo_tot_num
F(i,j) = Fock_matrix_mo(i,j)
enddo
enddo
if(no_oa_or_av_opt)then
integer :: iorb,jorb
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_inact_orb
jorb = list_inact(j)
F(iorb,jorb) = 0.d0
F(jorb,iorb) = 0.d0
enddo
do j = 1, n_virt_orb
jorb = list_virt(j)
F(iorb,jorb) = 0.d0
F(jorb,iorb) = 0.d0
enddo
do j = 1, n_core_orb
jorb = list_core(j)
F(iorb,jorb) = 0.d0
F(jorb,iorb) = 0.d0
enddo
enddo
endif
! Insert level shift here

2
plugins/MRCC_Utils/NEEDED_CHILDREN_MODULES
View File

@ -1 +1 @@
Perturbation Selectors_full Generators_full Psiref_Utils
Perturbation Selectors_full Generators_full Psiref_Utils Psiref_CAS

1
plugins/MRCC_Utils/davidson.irp.f
View File

@ -359,7 +359,6 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nin
y, &
lambda &
)
abort_here = abort_all
end

4
plugins/MRCC_Utils/mrcc_dummy.irp.f Normal file
View File

@ -0,0 +1,4 @@
program pouet
end

1
plugins/OVB/NEEDED_CHILDREN_MODULES Normal file
View File

@ -0,0 +1 @@
Determinants Psiref_CAS

20
plugins/OVB/README.rst Normal file
View File

@ -0,0 +1,20 @@
=======================
OVB
=======================
The present module proposes an orthogonal Valence Bond analysis
of the wave function, that are the printing of the various Hamiltonian
matrix elements on the basis of the level of ionicity of the components
of the wave function.
Assumptions : it supposes that you have some orthogonal local orbitals within
the active space and that you performed a CI within the active orbitals.
Such CI might be complete or not, no matter.
Needed Modules
==============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.
Documentation
=============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.

510
plugins/OVB/ovb_components.irp.f Normal file
View File

@ -0,0 +1,510 @@
use bitmasks
BEGIN_PROVIDER [integer, max_number_ionic]
&BEGIN_PROVIDER [integer, min_number_ionic]
BEGIN_DOC
! Maximum and minimum number of ionization in psi_ref
END_DOC
implicit none
integer :: i,j
integer :: n_closed_shell_cas
max_number_ionic = 0
min_number_ionic = 100000
do i = 1, N_det_ref
j = n_closed_shell_cas(psi_ref(1,1,i),n_int)
if(j> max_number_ionic)then
max_number_ionic = j
endif
if(j< min_number_ionic)then
min_number_ionic = j
endif
enddo
print*,'max_number_ionic = ',max_number_ionic
print*,'min_number_ionic = ',min_number_ionic
END_PROVIDER
BEGIN_PROVIDER [integer, ionic_index, (min_number_ionic:max_number_ionic,0:N_det_ref)]
&BEGIN_PROVIDER [double precision, normalization_factor_ionic, (min_number_ionic:max_number_ionic, N_states)]
BEGIN_DOC
! Index of the various determinants in psi_ref according to their level of ionicity
! ionic_index(i,0) = number of determinants in psi_ref having the degree of ionicity "i"
! ionic_index(i,j) = index of the determinants having the degree of ionicity "i"
END_DOC
implicit none
integer :: i,j,k
integer :: n_closed_shell_cas
double precision :: accu
ionic_index = 0
do i = 1, N_det_ref
j = n_closed_shell_cas(psi_ref(1,1,i),n_int)
ionic_index(j,0) +=1
ionic_index(j,ionic_index(j,0)) = i
enddo
do i = min_number_ionic,max_number_ionic
accu = 0.d0
do j = 1, N_states
do k = 1, ionic_index(i,0)
accu += psi_ref_coef_diagonalized(ionic_index(i,k),j) * psi_ref_coef_diagonalized(ionic_index(i,k),j)
enddo
normalization_factor_ionic(i,j) = 1.d0/dsqrt(accu)
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, H_OVB_naked, (min_number_ionic:max_number_ionic, min_number_ionic:max_number_ionic, n_states)]
BEGIN_DOC
! Hamiltonian matrix expressed in the basis of contracted forms in terms of ionic structures
END_DOC
implicit none
integer :: i,j,istate,k,l
double precision :: accu,hij
do i = min_number_ionic,max_number_ionic
do j = min_number_ionic,max_number_ionic
do istate = 1, N_states
accu = 0.d0
do k = 1, ionic_index(i,0)
do l = 1, ionic_index(j,0)
hij = ref_hamiltonian_matrix(ionic_index(i,k),ionic_index(j,l))
accu += psi_ref_coef_diagonalized(ionic_index(i,k),istate) * normalization_factor_ionic(i,istate) * &
psi_ref_coef_diagonalized(ionic_index(j,l),istate) * normalization_factor_ionic(j,istate) * hij
enddo
enddo
H_OVB_naked(i,j,istate) = accu
enddo
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [integer, n_couples_act_orb]
implicit none
n_couples_act_orb = 3
END_PROVIDER
BEGIN_PROVIDER [integer, couples_act_orb, (n_couples_act_orb,2) ]
implicit none
couples_act_orb(1,1) = 20
couples_act_orb(1,2) = 21
couples_act_orb(2,1) = 22
couples_act_orb(2,2) = 23
couples_act_orb(3,1) = 24
couples_act_orb(3,2) = 25
END_PROVIDER
BEGIN_PROVIDER [double precision, H_matrix_between_ionic_on_given_atom , (n_act_orb,n_act_orb)]
implicit none
BEGIN_DOC
! Hamiltonian matrix elements between the various contracted functions
! that have a negative charge on a given active orbital
END_DOC
integer :: i,j,k,l,jj,ii
integer(bit_kind), allocatable :: key_1(:,:),key_2(:,:)
double precision :: accu,hij
double precision :: norm
allocate (key_1(N_int,2),key_2(N_int,2))
do i = 1, n_act_orb
j = i ! Diagonal part
norm = 0.d0
accu = 0.d0
do k = 1, n_det_ionic_on_given_atom(i)
norm += psi_coef_mono_ionic_on_given_atom(k,i) **2
do ii = 1, N_int
key_1(ii,1) = psi_det_mono_ionic_on_given_atom(ii,1,k,i)
key_1(ii,2) = psi_det_mono_ionic_on_given_atom(ii,2,k,i)
enddo
do l = 1, n_det_ionic_on_given_atom(j)
do jj = 1, N_int
key_2(jj,1) = psi_det_mono_ionic_on_given_atom(jj,1,l,j)
key_2(jj,2) = psi_det_mono_ionic_on_given_atom(jj,2,l,j)
enddo
call i_H_j(key_1,key_2,N_int,hij)
accu += psi_coef_mono_ionic_on_given_atom(l,j) * psi_coef_mono_ionic_on_given_atom(k,i) * hij
enddo
enddo
H_matrix_between_ionic_on_given_atom(i,j) = accu
do j = i+1, n_act_orb ! Extra diagonal part
accu = 0.d0
do k = 1, n_det_ionic_on_given_atom(i)
do jj = 1, N_int
key_1(jj,1) = psi_det_mono_ionic_on_given_atom(jj,1,k,i)
key_1(jj,2) = psi_det_mono_ionic_on_given_atom(jj,2,k,i)
enddo
do l = 1, n_det_ionic_on_given_atom(j)
do jj = 1, N_int
key_2(jj,1) = psi_det_mono_ionic_on_given_atom(jj,1,l,j)
key_2(jj,2) = psi_det_mono_ionic_on_given_atom(jj,2,l,j)
enddo
call i_H_j(key_1,key_2,N_int,hij)
accu += psi_coef_mono_ionic_on_given_atom(l,j) * psi_coef_mono_ionic_on_given_atom(k,i) * hij
enddo
enddo
H_matrix_between_ionic_on_given_atom(i,j) = accu
H_matrix_between_ionic_on_given_atom(j,i) = accu
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, H_matrix_between_ionic_on_given_atom_and_others , (n_act_orb,min_number_ionic:max_number_ionic)]
implicit none
use bitmasks
BEGIN_DOC
! Hamiltonian matrix elements between the various contracted functions
! that have a negative charge on a given active orbital
! and all the other fully contracted OVB structures
END_DOC
integer :: i,j,k,l,jj,ii
integer(bit_kind), allocatable :: key_1(:,:),key_2(:,:)
double precision :: accu,hij
double precision :: norm
allocate (key_1(N_int,2),key_2(N_int,2))
do i = 1, n_act_orb
do j = min_number_ionic,max_number_ionic
if(j==1)then
H_matrix_between_ionic_on_given_atom_and_others(i,j) = 0.d0
endif
accu = 0.d0
do k = 1, n_det_ionic_on_given_atom(i)
do jj = 1, N_int
key_1(jj,1) = psi_det_mono_ionic_on_given_atom(jj,1,k,i)
key_1(jj,2) = psi_det_mono_ionic_on_given_atom(jj,2,k,i)
enddo
do l = 1, ionic_index(j,0)
do ii = 1, N_int
key_2(ii,1) = psi_det_ovb(ii,1,l,j)
key_2(ii,2) = psi_det_ovb(ii,2,l,j)
enddo
call i_H_j(key_1,key_2,N_int,hij)
accu += psi_coef_ovb(l,j) * psi_coef_mono_ionic_on_given_atom(k,i) * hij
enddo
enddo
H_matrix_between_ionic_on_given_atom_and_others(i,j) = accu
enddo
enddo
print*,'H_matrix_between_ionic_on_given_atom_and_others'
print*,''
do i = 1, n_act_orb
write(*,'(I3,X,100(F16.7))'),H_matrix_between_ionic_on_given_atom_and_others(i,:)
enddo
END_PROVIDER
BEGIN_PROVIDER [integer, n_det_ionic_on_given_atom, (n_act_orb)]
&BEGIN_PROVIDER [double precision, normalization_factor_ionic_on_given_atom, (n_act_orb) ]
&BEGIN_PROVIDER [double precision, psi_coef_mono_ionic_on_given_atom, (N_det_ref,n_act_orb) ]
&BEGIN_PROVIDER [integer(bit_kind), psi_det_mono_ionic_on_given_atom, (N_int,2,N_det_ref,n_act_orb)]
implicit none
use bitmasks
BEGIN_DOC
! number of determinants that are mono ionic with the negative charge
! on a given atom, normalization_factor, array of determinants,and coefficients
END_DOC
integer :: i,j,k,l
ionicity_level = 1
integer :: ionicity_level
logical :: doubly_occupied_array(n_act_orb)
n_det_ionic_on_given_atom = 0
normalization_factor_ionic_on_given_atom = 0.d0
do i = 1, ionic_index(ionicity_level,0)
call give_index_of_doubly_occ_in_active_space(psi_det(1,1,ionic_index(ionicity_level,i)),doubly_occupied_array)
do j = 1, n_act_orb
if(doubly_occupied_array(j))then
n_det_ionic_on_given_atom(j) += 1
normalization_factor_ionic_on_given_atom(j) += psi_ref_coef_diagonalized(ionic_index(1,i),1) **2
do k = 1, N_int
psi_det_mono_ionic_on_given_atom(k,1,n_det_ionic_on_given_atom(j),j) = psi_det(k,1,ionic_index(ionicity_level,i))
psi_det_mono_ionic_on_given_atom(k,2,n_det_ionic_on_given_atom(j),j) = psi_det(k,2,ionic_index(ionicity_level,i))
enddo
psi_coef_mono_ionic_on_given_atom(n_det_ionic_on_given_atom(j),j) = psi_ref_coef_diagonalized(ionic_index(1,i),1)
endif
enddo
enddo
integer :: i_count
i_count = 0
do j = 1, n_act_orb
i_count += n_det_ionic_on_given_atom(j)
normalization_factor_ionic_on_given_atom(j) = 1.d0/dsqrt(normalization_factor_ionic_on_given_atom(j))
enddo
if(i_count.ne.ionic_index(ionicity_level,0))then
print*,'PB with n_det_ionic_on_given_atom'
print*,'i_count = ',i_count
print*,'ionic_index(ionicity_level,0)',ionic_index(ionicity_level,0)
stop
endif
do j = 1, n_act_orb
do i = 1, n_det_ionic_on_given_atom(j)
psi_coef_mono_ionic_on_given_atom(i,j) = psi_coef_mono_ionic_on_given_atom(i,j) * normalization_factor_ionic_on_given_atom(j)
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [integer(bit_kind), psi_det_ovb, (N_int,2,N_det_ref,min_number_ionic:max_number_ionic)]
&BEGIN_PROVIDER [double precision, psi_coef_ovb, (N_det_ref,min_number_ionic:max_number_ionic) ]
implicit none
BEGIN_DOC
! Array of the determinants belonging to each ovb structures (neutral, mono ionic, bi ionic etc ...)
! together with the arrays of coefficients
END_DOC
integer :: i,j,k,l
use bitmasks
integer :: ionicity_level,i_count
double precision :: accu
do ionicity_level = min_number_ionic,max_number_ionic
accu = 0.d0
do i = 1, ionic_index(ionicity_level,0)
do j = 1, N_int
psi_det_ovb(j,1,i,ionicity_level) = psi_det(j,1,ionic_index(ionicity_level,i))
psi_det_ovb(j,2,i,ionicity_level) = psi_det(j,2,ionic_index(ionicity_level,i))
enddo
psi_coef_ovb(i,ionicity_level) = psi_ref_coef_diagonalized(ionic_index(ionicity_level,i),1) * normalization_factor_ionic(ionicity_level,1)
accu += psi_coef_ovb(i,ionicity_level)**2
enddo
accu = 1.d0/dsqrt(accu)
do i = 1, ionic_index(ionicity_level,0)
psi_coef_ovb(i,ionicity_level) = psi_coef_ovb(i,ionicity_level) * accu
enddo
accu = 0.d0
do i = 1, ionic_index(ionicity_level,0)
accu += psi_coef_ovb(i,ionicity_level) **2
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, H_matrix_psi_det_ovb, (min_number_ionic:max_number_ionic,min_number_ionic:max_number_ionic)]
implicit none
BEGIN_DOC
! H matrix between the fully contracted OVB forms
END_DOC
integer :: i,j,k,l,jj,ii
integer(bit_kind), allocatable :: key_1(:,:),key_2(:,:)
use bitmasks
double precision :: accu,hij
double precision :: norm
allocate (key_1(N_int,2),key_2(N_int,2))
do i = min_number_ionic,max_number_ionic
do j = min_number_ionic,max_number_ionic
accu = 0.d0
do k = 1, ionic_index(i,0)
do ii = 1, N_int
key_1(ii,1) = psi_det_ovb(ii,1,k,i)
key_1(ii,2) = psi_det_ovb(ii,2,k,i)
enddo
do l = 1, ionic_index(j,0)
do ii = 1, N_int
key_2(ii,1) = psi_det_ovb(ii,1,l,j)
key_2(ii,2) = psi_det_ovb(ii,2,l,j)
enddo
call i_H_j(key_1,key_2,N_int,hij)
accu += psi_coef_ovb(l,j) * psi_coef_ovb(k,i) * hij
enddo
enddo
H_matrix_psi_det_ovb(i,j) = accu
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [integer, number_first_ionic_couples]
&BEGIN_PROVIDER [logical , is_a_first_ionic_couple, (N_det_ref)]
&BEGIN_PROVIDER [double precision, normalization_factor_special_first_ionic, (2)]
implicit none
BEGIN_DOC
! Number of determinants belonging to the class of first ionic
! AND that have a couple of positive/negative charge belonging
! to a couple of orbital couples_act_orb
! If is_a_first_ionic_couple(i) = .True. then this determinant is a first ionic
! and have a couple of positive/negative charge belonging
! to a couple of orbital couples_act_orb
! normalization factor (1) = 1/(sum c_i^2 .with. is_a_first_ionic_couple(i) = .True.)
! normalization factor (2) = 1/(sum c_i^2 .with. is_a_first_ionic_couple(i) = .False.)
END_DOC
integer :: i,j
use bitmasks
number_first_ionic_couples = 0
integer :: ionicity_level
logical :: couples_out(0:n_couples_act_orb)
integer(bit_kind) :: key_tmp(N_int,2)
ionicity_level = 1
normalization_factor_special_first_ionic = 0.d0
do i = 1, ionic_index(ionicity_level,0)
do j = 1, N_int
key_tmp(j,1) = psi_det(j,1,ionic_index(ionicity_level,i))
key_tmp(j,2) = psi_det(j,2,ionic_index(ionicity_level,i))
enddo
call doubly_occ_empty_in_couple(key_tmp,n_couples_act_orb,couples_act_orb,couples_out)
if(couples_out(0))then
number_first_ionic_couples +=1
is_a_first_ionic_couple(i) = .True.
normalization_factor_special_first_ionic(1) += psi_ref_coef_diagonalized(ionic_index(1,i),1) **2
else
is_a_first_ionic_couple(i) = .False.
normalization_factor_special_first_ionic(2) += psi_ref_coef_diagonalized(ionic_index(1,i),1) **2
endif
enddo
normalization_factor_special_first_ionic(1) = 1.d0/dsqrt(normalization_factor_special_first_ionic(1))
normalization_factor_special_first_ionic(2) = 1.d0/dsqrt(normalization_factor_special_first_ionic(2))
print*,'number_first_ionic_couples = ',number_first_ionic_couples
END_PROVIDER
BEGIN_PROVIDER [integer, number_neutral_no_hund_couples]
&BEGIN_PROVIDER [logical , is_a_neutral_no_hund_couple, (N_det_ref)]
&BEGIN_PROVIDER [double precision, normalization_factor_neutra_no_hund_couple, (2)]
&BEGIN_PROVIDER [double precision, ratio_hund_no_hund ]
implicit none
BEGIN_DOC
! Number of determinants belonging to the class of neutral determinants
! AND that have a couple of alpha beta electrons in couple of orbital couples_act_orb
! If is_a_neutral_no_hund_couple(i) = .True. then this determinant is a neutral determinants
! and have a a couple of alpha beta electrons in couple of orbital couples_act_orb
! normalization factor (1) = 1/sqrt(sum c_i^2 .with. is_a_neutral_no_hund_couple(i) = .True.)
! normalization factor (2) = 1/sqrt(sum c_i^2 .with. is_a_neutral_no_hund_couple(i) = .False.)
END_DOC
integer :: i,j
use bitmasks
number_neutral_no_hund_couples = 0
integer :: ionicity_level
logical :: couples_out(0:n_couples_act_orb)
integer(bit_kind) :: key_tmp(N_int,2)
integer :: ifirst_hund,ifirst_no_hund
double precision :: coef_ref_hund,coef_ref_no_hund
ifirst_hund = 0
ifirst_no_hund = 0
ionicity_level = 0
normalization_factor_neutra_no_hund_couple = 0.d0
do i = 1, ionic_index(ionicity_level,0)
do j = 1, N_int
key_tmp(j,1) = psi_det(j,1,ionic_index(ionicity_level,i))
key_tmp(j,2) = psi_det(j,2,ionic_index(ionicity_level,i))
enddo
call neutral_no_hund_in_couple(key_tmp,n_couples_act_orb,couples_act_orb,couples_out)
if(couples_out(0))then
if(ifirst_no_hund == 0)then
coef_ref_no_hund = psi_ref_coef_diagonalized(ionic_index(ionicity_level,i),1)
ifirst_no_hund = 1
endif
number_neutral_no_hund_couples +=1
is_a_neutral_no_hund_couple(i) = .True.
normalization_factor_neutra_no_hund_couple(1) += psi_ref_coef_diagonalized(ionic_index(ionicity_level,i),1) **2
else
if(ifirst_hund == 0)then
coef_ref_hund = psi_ref_coef_diagonalized(ionic_index(ionicity_level,i),1)
ifirst_hund = 1
endif
is_a_neutral_no_hund_couple(i) = .False.
normalization_factor_neutra_no_hund_couple(2) += psi_ref_coef_diagonalized(ionic_index(ionicity_level,i),1) **2
endif
enddo
ratio_hund_no_hund = coef_ref_no_hund/coef_ref_hund
normalization_factor_neutra_no_hund_couple(1) = 1.d0/dsqrt(normalization_factor_neutra_no_hund_couple(1))
normalization_factor_neutra_no_hund_couple(2) = 1.d0/dsqrt(normalization_factor_neutra_no_hund_couple(2))
print*,'number_neutral_no_hund_couples = ',number_neutral_no_hund_couples
END_PROVIDER
BEGIN_PROVIDER [double precision, H_OVB_naked_first_ionic, (2,min_number_ionic:max_number_ionic,n_states)]
&BEGIN_PROVIDER [double precision, H_OVB_naked_first_ionic_between_ionic, (2,2,n_states)]
BEGIN_DOC
! H_OVB_naked_first_ionic(1,i) = H_matrix element between the first ionic determinants belonging to is_a_first_ionic_couple = True
! and the contracted ith ionic form
! if i == 1 not defined
! H_OVB_naked_first_ionic(2,i) = H_matrix element between the first ionic determinants belonging to is_a_first_ionic_couple = False
! and the contracted ith ionic form
! if i == 1 not defined
! H_OVB_naked_first_ionic_between_ionic(1,1) = H_matrix element between the first ionic determinants belonging to is_a_first_ionic_couple = True
! and the first ionic determinants belonging to is_a_first_ionic_couple = True
! H_OVB_naked_first_ionic_between_ionic(1,2) = H_matrix element between the first ionic determinants belonging to is_a_first_ionic_couple = True
! and the first ionic determinants belonging to is_a_first_ionic_couple = False
! H_OVB_naked_first_ionic_between_ionic(2,2) = H_matrix element between the first ionic determinants belonging to is_a_first_ionic_couple = False
! and the first ionic determinants belonging to is_a_first_ionic_couple = False
END_DOC
implicit none
integer :: i,j,istate,k,l
double precision :: accu_1,accu_2,hij
H_OVB_naked_first_ionic = 0.d0
H_OVB_naked_first_ionic_between_ionic = 0.d0
i = 1
do j = min_number_ionic,max_number_ionic
if(j==1)cycle
do istate = 1, N_states
accu_1 = 0.d0
accu_2 = 0.d0
do k = 1, ionic_index(i,0)
if(is_a_first_ionic_couple(k))then
do l = 1, ionic_index(j,0)
hij = ref_hamiltonian_matrix(ionic_index(i,k),ionic_index(j,l))
accu_1 += psi_ref_coef_diagonalized(ionic_index(i,k),istate) * normalization_factor_special_first_ionic(1) * &
psi_ref_coef_diagonalized(ionic_index(j,l),istate) * normalization_factor_ionic(j,istate) * hij
enddo
else
do l = 1, ionic_index(j,0)
hij = ref_hamiltonian_matrix(ionic_index(i,k),ionic_index(j,l))
accu_2 += psi_ref_coef_diagonalized(ionic_index(i,k),istate) * normalization_factor_special_first_ionic(2) * &
psi_ref_coef_diagonalized(ionic_index(j,l),istate) * normalization_factor_ionic(j,istate) * hij
enddo
endif
enddo
H_OVB_naked_first_ionic(1,j,istate) = accu_1
H_OVB_naked_first_ionic(2,j,istate) = accu_2
enddo
enddo
do istate = 1, N_states
accu_1 = 0.d0
accu_2 = 0.d0
integer :: i_count
i_count = 0
do k = 1, ionic_index(1,0)
do l = 1, ionic_index(1,0)
hij = ref_hamiltonian_matrix(ionic_index(1,k),ionic_index(1,l))
accu_1 = hij * psi_ref_coef_diagonalized(ionic_index(1,k),istate) * psi_ref_coef_diagonalized(ionic_index(1,l),istate)
if(is_a_first_ionic_couple(k).and. is_a_first_ionic_couple(l))then
H_OVB_naked_first_ionic_between_ionic(1,1,istate) += accu_1 * normalization_factor_special_first_ionic(1) **2
elseif(is_a_first_ionic_couple(k).and. .not.is_a_first_ionic_couple(l))then
i_count += 1
H_OVB_naked_first_ionic_between_ionic(1,2,istate) += accu_1 * &
normalization_factor_special_first_ionic(1) *normalization_factor_special_first_ionic(2)
! elseif(is_a_first_ionic_couple(l).and. .not.is_a_first_ionic_couple(k))then
! i_count += 1
! H_OVB_naked_first_ionic_between_ionic(1,2,istate) += accu_1 * &
! normalization_factor_special_first_ionic(1) *normalization_factor_special_first_ionic(2)
elseif(.not.is_a_first_ionic_couple(k).and. .not.is_a_first_ionic_couple(l))then
H_OVB_naked_first_ionic_between_ionic(2,2,istate) += accu_1 * normalization_factor_special_first_ionic(2) **2
endif
enddo
enddo
enddo
print*,'i_count = ',i_count
print*,'number_first_ionic_couples**2 = ',ionic_index(1,0) * number_first_ionic_couples
double precision :: convert_hartree_ev
convert_hartree_ev = 27.211399d0
print*,'Special H matrix'
do i = 1,2
write(*,'(I4,X,10(F16.8 ,4X))')i, H_OVB_naked_first_ionic(i,:,1)
enddo
print*,'Special H matrix bis'
do i = 1,2
write(*,'(I4,X,10(F16.8 ,4X))')i, H_OVB_naked_first_ionic_between_ionic(i,:,1)
enddo
END_PROVIDER

27
plugins/OVB/print_ovb.irp.f Normal file
View File

@ -0,0 +1,27 @@
program print_OVB
implicit none
read_wf = .True.
call provide_all
end
subroutine provide_all
implicit none
integer :: i,j,k,l,istate
do istate= 1, N_states
print*,'-------------------'
print*,'ISTATE = ',istate
print*,'-------------------'
print*,'CAS MATRIX '
print*,''
do i = min_number_ionic,max_number_ionic
write(*,'(I4,X,10(F8.5 ,4X))')i, H_OVB_naked(i,:,istate)
enddo
print*,''
print*,'-------------------'
print*,'-------------------'
enddo
end

1
plugins/OVB_effective_Hamiltonian/NEEDED_CHILDREN_MODULES Normal file
View File

@ -0,0 +1 @@
Dressed_Ref_Hamiltonian OVB

59
plugins/OVB_effective_Hamiltonian/OVB_effective_H.irp.f Normal file
View File

@ -0,0 +1,59 @@
BEGIN_PROVIDER [double precision, H_OVB_dressing, (min_number_ionic:max_number_ionic, min_number_ionic:max_number_ionic, n_states)]
BEGIN_DOC
! Hamiltonian matrix expressed in the basis of all the
END_DOC
implicit none
integer :: i,j,istate,k,l
double precision :: accu,hij
do i = min_number_ionic,max_number_ionic
do j = min_number_ionic,max_number_ionic
accu = 0.d0
do istate = 1, N_states
do k = 1, ionic_index(i,0)
do l = 1, ionic_index(j,0)
hij = dressing_ref_hamiltonian(ionic_index(i,k),ionic_index(j,l),istate)
! accu += psi_ref_coef(ionic_index(i,k),istate) * normalization_factor_ionic(i,istate) * &
! psi_ref_coef(ionic_index(j,l),istate) * normalization_factor_ionic(j,istate) * hij
accu += psi_ref_coef_dressed(ionic_index(i,k),istate) * normalization_factor_ionic_dressed(i,istate) * &
psi_ref_coef_dressed(ionic_index(j,l),istate) * normalization_factor_ionic_dressed(j,istate) * hij
enddo
enddo
H_OVB_dressing(i,j,istate) = accu
enddo
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, H_OVB_total_dressed, (min_number_ionic:max_number_ionic, min_number_ionic:max_number_ionic, n_states)]
BEGIN_DOC
! Hamiltonian matrix expressed in the basis of all the
END_DOC
implicit none
integer :: i,j,istate
double precision :: accu,hij
do i = min_number_ionic,max_number_ionic
do j = min_number_ionic,max_number_ionic
do istate = 1, N_states
H_OVB_total_dressed(i,j,istate) = H_OVB_dressing(i,j,istate) + H_OVB_naked(i,j,istate)
enddo
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, normalization_factor_ionic_dressed, (min_number_ionic:max_number_ionic, N_states) ]
implicit none
integer :: i,j,istate,k
double precision :: accu
do j = min_number_ionic, max_number_ionic
do istate = 1, N_states
accu = 0.d0
do k = 1, ionic_index(j,0)
accu += psi_ref_coef_dressed(ionic_index(j,k),istate) **2
enddo
normalization_factor_ionic_dressed(j,istate) = 1.d0/dsqrt(accu)
enddo
enddo
END_PROVIDER

13
plugins/OVB_effective_Hamiltonian/README.rst Normal file
View File

@ -0,0 +1,13 @@
=========================
OVB_effective_Hamiltonian
=========================
Dressing of the OVB matrix by use of the Dressed_Ref_Hamiltonian dressing
Needed Modules
==============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.
Documentation
=============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.

101
plugins/OVB_effective_Hamiltonian/print_OVB_effective_H_diagonalized.irp.f Normal file
View File

@ -0,0 +1,101 @@
program print
read_wf = .True.
touch read_wf
call provide_all_stuffs
end
subroutine provide_all_stuffs
implicit none
provide ref_hamiltonian_matrix dressing_ref_hamiltonian
integer :: i,j,istate
double precision, allocatable :: psi_restart_ref_normalized(:),psi_ref_zeroth_order(:),psi_ref_dressed(:)
double precision, allocatable :: eigvalues(:),eigvectors(:,:)
double precision, allocatable :: H_naked(:,:)
double precision, allocatable :: H_dressed(:,:)
double precision, allocatable :: H_print(:,:)
double precision :: accu_norm
allocate (H_dressed(max_number_ionic+1,max_number_ionic+1))
allocate (H_print(min_number_ionic:max_number_ionic,min_number_ionic:max_number_ionic))
allocate (H_naked(max_number_ionic+1,max_number_ionic+1))
allocate (psi_restart_ref_normalized(min_number_ionic:max_number_ionic))
allocate (psi_ref_zeroth_order(min_number_ionic:max_number_ionic))
print*,'# nuclear_repulsion = ',nuclear_repulsion
allocate (psi_ref_dressed(min_number_ionic:max_number_ionic))
allocate (eigvalues(max_number_ionic+1))
allocate (eigvectors(max_number_ionic+1,max_number_ionic+1))
do istate= 1, N_states
print*,'ISTATE = ',istate
do i = min_number_ionic,max_number_ionic
do j = min_number_ionic,max_number_ionic
H_print(i,j) = H_OVB_naked(j,i,istate)
enddo
enddo
do i = min_number_ionic,max_number_ionic
H_print(i,i) -= H_OVB_naked(min_number_ionic,min_number_ionic,istate)
enddo
print*,'Ref Hamiltonian matrix emelent = ',H_OVB_naked(min_number_ionic,min_number_ionic,istate)
print*,'-------------------'
print*,'-------------------'
print*,'CAS MATRIX '
print*,''
do i = min_number_ionic,max_number_ionic
write(*,'(I4,X,10(F8.5 ,4X))')i, H_print(i,:)
enddo
print*,'CAS MATRIX DRESSING'
print*,''
do i = min_number_ionic,max_number_ionic
write(*,'(I4,X,10(F8.5 ,4X))')i, H_OVB_dressing(i,:,istate)
enddo
print*,''
print*,'-------------------'
print*,'-------------------'
print*,'CAS MATRIX DRESSED '
print*,''
do i = min_number_ionic,max_number_ionic
do j = min_number_ionic,max_number_ionic
H_print(i,j) = H_OVB_total_dressed(j,i,istate)
enddo
enddo
do i = min_number_ionic,max_number_ionic
H_print(i,i) -= H_OVB_total_dressed(min_number_ionic,min_number_ionic,istate)
enddo
do i = min_number_ionic,max_number_ionic
write(*,'(I4,X,10(F8.5 ,4X))')i, H_print(i,:)
enddo
print*,''
do i = min_number_ionic,max_number_ionic
do j = min_number_ionic,max_number_ionic
H_dressed(j+1,i+1) = H_OVB_total_dressed(i,j,istate)
H_naked(j+1,i+1) = H_OVB_naked(i,j,istate)
enddo
enddo
call lapack_diagd(eigvalues,eigvectors,H_naked,max_number_ionic+1,max_number_ionic+1)
print*,'E+PT2 = ',eigvalues(istate) + nuclear_repulsion
do i = min_number_ionic,max_number_ionic
psi_ref_zeroth_order(i) = eigvectors(i+1,istate)
enddo
call lapack_diagd(eigvalues,eigvectors,H_dressed,max_number_ionic+1,max_number_ionic+1)
do i = min_number_ionic,max_number_ionic
psi_ref_dressed(i) = eigvectors(i+1,istate)
enddo
print*,'E+PT2 = ',eigvalues(istate) + nuclear_repulsion
do i = min_number_ionic,max_number_ionic
write(*,'(10(F10.7 ,4X))') psi_ref_dressed(i)/psi_ref_dressed(min_number_ionic) ,psi_ref_zeroth_order(i)/psi_ref_zeroth_order(min_number_ionic)
enddo
enddo
deallocate (H_dressed)
deallocate (H_naked)
deallocate (psi_restart_ref_normalized)
deallocate (psi_ref_zeroth_order)
deallocate (psi_ref_dressed)
deallocate (eigvalues)
deallocate (eigvectors)
end

90
plugins/OVB_effective_Hamiltonian/save_wf_only_ionic_and_1p_amplitudes.irp.f Normal file
View File

@ -0,0 +1,90 @@
program save_wf
implicit none
read_wf = .True.
touch read_wf
call routine
end
subroutine routine
implicit none
use bitmasks
integer :: i,j,k,l
integer(bit_kind), allocatable :: psi_save_final(:,:,:)
double precision, allocatable :: psi_coef_save_final(:,:)
integer :: index_ref_determinants_save(psi_det_size)
integer :: n_det_ref_determinants_save
integer :: index_non_ref_determinants_save(psi_det_size)
integer :: n_det_non_ref_determinants_save
integer :: n_det_save_final
integer :: number_of_particles
n_det_ref_determinants_save = 0
integer :: ionic_level
ionic_level = 1
do i = 1, ionic_index(ionic_level,0) ! number of determinants in the ref wf that are neutrals
n_det_ref_determinants_save +=1
index_ref_determinants_save(n_det_ref_determinants_save) = ionic_index(ionic_level,i)
enddo
! save all the 1p determinants in order to have the single excitations
! on the top of the neutral structures
n_det_non_ref_determinants_save = 0
do i = 1, N_det_non_ref
if(number_of_particles(psi_non_ref(1,1,i))==1)then
n_det_non_ref_determinants_save +=1
index_non_ref_determinants_save(n_det_non_ref_determinants_save) = i
endif
enddo
print*,'n_det_ref_determinants_save = ',n_det_ref_determinants_save
print*,'n_det_non_ref_determinants_save = ',n_det_non_ref_determinants_save
n_det_save_final = n_det_ref_determinants_save + n_det_non_ref_determinants_save
allocate (psi_save_final(N_int,2,n_det_save_final))
allocate (psi_coef_save_final(n_det_save_final,1))
integer :: n_det_tmp
n_det_tmp = 0
do i = 1, n_det_ref_determinants_save ! set the CAS determinants to psi_save_final
n_det_tmp +=1
do j = 1, N_int
psi_save_final(j,1,n_det_tmp) = psi_ref(j,1,index_ref_determinants_save(i))
psi_save_final(j,2,n_det_tmp) = psi_ref(j,2,index_ref_determinants_save(i))
enddo
psi_coef_save_final(n_det_tmp,1) = psi_ref_coef(index_ref_determinants_save(i),1)
enddo
pause
do i = 1, n_det_non_ref_determinants_save ! set the non ref determinants to psi_save_final
n_det_tmp +=1
do j = 1, N_int
psi_save_final(j,1,n_det_tmp) = psi_non_ref(j,1,index_non_ref_determinants_save(i))
psi_save_final(j,2,n_det_tmp) = psi_non_ref(j,2,index_non_ref_determinants_save(i))
enddo
accu = 0.d0
double precision :: t_ik,hij
do j = 1, n_det_ref_determinants_save
call i_H_j(psi_non_ref(1,1,index_non_ref_determinants_save(i)),psi_ref(1,1,index_ref_determinants_save(j)),N_int,hij)
t_ik = hij * lambda_mrcc(1,index_non_ref_determinants_save(i))
accu += psi_ref_coef(index_ref_determinants_save(j),1) * t_ik
enddo
psi_coef_save_final(n_det_tmp,1) = accu
enddo
double precision :: accu
accu = 0.d0
do i = 1, n_det_save_final
accu += psi_coef_save_final(i,1) * psi_coef_save_final(i,1)
enddo
accu = 1.d0/dsqrt(accu)
do i = 1, n_det_save_final
psi_coef_save_final(i,1) = accu * psi_coef_save_final(i,1)
enddo
do i = 1, n_det_save_final
print*,''
print*,'Det'
call debug_det(psi_save_final(1,1,i),N_int)
print*,'coef = ',psi_coef_save_final(i,1)
enddo
call save_wavefunction_general(n_det_save_final,1,psi_save_final,n_det_save_final,psi_coef_save_final)
deallocate (psi_save_final)
deallocate (psi_coef_save_final)
end

88
plugins/OVB_effective_Hamiltonian/save_wf_only_neutral_and_1p_amplitudes.irp.f Normal file
View File

@ -0,0 +1,88 @@
program save_wf
implicit none
read_wf = .True.
touch read_wf
call routine
end
subroutine routine
implicit none
use bitmasks
integer :: i,j,k,l
integer(bit_kind), allocatable :: psi_save_final(:,:,:)
double precision, allocatable :: psi_coef_save_final(:,:)
integer :: index_ref_determinants_save(psi_det_size)
integer :: n_det_ref_determinants_save
integer :: index_non_ref_determinants_save(psi_det_size)
integer :: n_det_non_ref_determinants_save
integer :: n_det_save_final
integer :: number_of_particles
n_det_ref_determinants_save = 0
do i = 1, ionic_index(0,0) ! number of determinants in the ref wf that are neutrals
n_det_ref_determinants_save +=1
index_ref_determinants_save(n_det_ref_determinants_save) = ionic_index(0,i)
enddo
! save all the 1p determinants in order to have the single excitations
! on the top of the neutral structures
n_det_non_ref_determinants_save = 0
do i = 1, N_det_non_ref
if(number_of_particles(psi_non_ref(1,1,i))==1)then
n_det_non_ref_determinants_save +=1
index_non_ref_determinants_save(n_det_non_ref_determinants_save) = i
endif
enddo
print*,'n_det_ref_determinants_save = ',n_det_ref_determinants_save
print*,'n_det_non_ref_determinants_save = ',n_det_non_ref_determinants_save
n_det_save_final = n_det_ref_determinants_save + n_det_non_ref_determinants_save
allocate (psi_save_final(N_int,2,n_det_save_final))
allocate (psi_coef_save_final(n_det_save_final,1))
integer :: n_det_tmp
n_det_tmp = 0
do i = 1, n_det_ref_determinants_save ! set the CAS determinants to psi_save_final
n_det_tmp +=1
do j = 1, N_int
psi_save_final(j,1,n_det_tmp) = psi_ref(j,1,index_ref_determinants_save(i))
psi_save_final(j,2,n_det_tmp) = psi_ref(j,2,index_ref_determinants_save(i))
enddo
psi_coef_save_final(n_det_tmp,1) = psi_ref_coef(index_ref_determinants_save(i),1)
enddo
pause
do i = 1, n_det_non_ref_determinants_save ! set the non ref determinants to psi_save_final
n_det_tmp +=1
do j = 1, N_int
psi_save_final(j,1,n_det_tmp) = psi_non_ref(j,1,index_non_ref_determinants_save(i))
psi_save_final(j,2,n_det_tmp) = psi_non_ref(j,2,index_non_ref_determinants_save(i))
enddo
accu = 0.d0
double precision :: t_ik,hij
do j = 1, n_det_ref_determinants_save
call i_H_j(psi_non_ref(1,1,index_non_ref_determinants_save(i)),psi_ref(1,1,index_ref_determinants_save(j)),N_int,hij)
t_ik = hij * lambda_mrcc(1,index_non_ref_determinants_save(i))
accu += psi_ref_coef(index_ref_determinants_save(j),1) * t_ik
enddo
psi_coef_save_final(n_det_tmp,1) = accu
enddo
double precision :: accu
accu = 0.d0
do i = 1, n_det_save_final
accu += psi_coef_save_final(i,1) * psi_coef_save_final(i,1)
enddo
accu = 1.d0/dsqrt(accu)
do i = 1, n_det_save_final
psi_coef_save_final(i,1) = accu * psi_coef_save_final(i,1)
enddo
do i = 1, n_det_save_final
print*,''
print*,'Det'
call debug_det(psi_save_final(1,1,i),N_int)
print*,'coef = ',psi_coef_save_final(i,1)
enddo
call save_wavefunction_general(n_det_save_final,1,psi_save_final,n_det_save_final,psi_coef_save_final)
deallocate (psi_save_final)
deallocate (psi_coef_save_final)
end

1
plugins/Orbital_Entanglement/NEEDED_CHILDREN_MODULES Normal file
View File

@ -0,0 +1 @@
Determinants

345
plugins/Orbital_Entanglement/Orbital_Entanglement.irp.f Normal file
View File

@ -0,0 +1,345 @@
use bitmasks
BEGIN_PROVIDER [integer, mo_inp_num]
implicit none
BEGIN_DOC
! This is the number of orbitals involved in the entanglement calculation.
! It is taken equal to the number of active orbitals n_act_orb.
END_DOC
mo_inp_num = n_act_orb
END_PROVIDER
BEGIN_PROVIDER [integer, mo_inp_list, (N_int*bit_kind_size)]
&BEGIN_PROVIDER [integer, mo_inp_list_rev, (mo_tot_num)]
&BEGIN_PROVIDER [integer(bit_kind), mo_inp_bit_list, (N_int)]
implicit none
BEGIN_DOC
! mo_inp_list is the list of the orbitals involved in the entanglement calculation.
! It is taken equal to the list of active orbitals list_act.
! mo_inp_list_rev is a list such that mo_inp_list_rev(mo_inp_list(i))=i.
END_DOC
integer :: i
do i = 1, mo_inp_num
mo_inp_list(i)=list_act(i)
enddo
do i = 1, mo_inp_num
mo_inp_list_rev(mo_inp_list(i))=i
enddo
call list_to_bitstring( mo_inp_bit_list, mo_inp_list, mo_inp_num, N_int)
END_PROVIDER
BEGIN_PROVIDER [double precision, entropy_one_orb, (mo_inp_num)]
&BEGIN_PROVIDER [double precision, entropy_two_orb, (mo_inp_num,mo_inp_num)]
implicit none
BEGIN_DOC
! entropy_one_orb is the one-orbital von Neumann entropy S(1)_i
! entropy_two_orb is the two-orbital von Neumann entropy S(2)_ij.
END_DOC
double precision, allocatable :: ro1(:,:),ro2(:,:,:)
integer :: i,j,k,l,ii,jj,iii,istate,kl,info
integer, allocatable :: occ(:,:)
integer :: n_occ_alpha, n_occ_beta
logical, allocatable :: zocc(:,:)
logical :: zalpha, zbeta, zalpha2, zbeta2
integer :: exc(0:2,2,2),degree,h1,p1,h2,p2,spin1,spin2
double precision :: phase
integer(bit_kind) :: key_tmp(N_int), key_tmp2(N_int)
integer :: ip
double precision, parameter :: eps=10.d0**(-14)
double precision :: w(16), work(3*16)
allocate(ro1(4,mo_inp_num),ro2(16,16,(mo_inp_num*(mo_inp_num-1)/2)))
entropy_one_orb = 0.d0
entropy_two_orb = 0.d0
ro1 = 0.d0
ro2 = 0.d0
allocate (occ(N_int*bit_kind_size,2))
allocate (zocc(mo_tot_num,2))
istate = 1 !Only GS, to be generalized...
do ii=1,N_det
! We get the occupation of the alpha electrons in occ(:,1)
call bitstring_to_list(psi_det(1,1,ii), occ(1,1), n_occ_alpha, N_int)
! We get the occupation of the beta electrons in occ(:,2)
call bitstring_to_list(psi_det(1,2,ii), occ(1,2), n_occ_beta, N_int)
zocc = .false.
do i=1,n_occ_alpha
zocc(occ(i,1),1)=.true.
enddo
do i=1,n_occ_beta
zocc(occ(i,2),2)=.true.
enddo
do k=1,mo_inp_num
zalpha = zocc(mo_inp_list(k),1)
zbeta = zocc(mo_inp_list(k),2)
! mono start
if (zbeta.and.zalpha) then
ro1(4,k) = ro1(4,k) + psi_coef(ii,istate)**2 ! double occupied
elseif (zalpha) then
ro1(2,k) = ro1(2,k) + psi_coef(ii,istate)**2 ! single alpha
elseif (zbeta) then
ro1(3,k) = ro1(3,k) + psi_coef(ii,istate)**2 ! single beta
else
ro1(1,k) = ro1(1,k) + psi_coef(ii,istate)**2 ! empty
endif
! mono stop
! double start
if (k.eq.mo_inp_num) cycle
do l=k+1,mo_inp_num
kl=(l-1)*(l-2)/2+k
zalpha2 = zocc(mo_inp_list(l),1)
zbeta2 = zocc(mo_inp_list(l),2)
if (zbeta.and.zalpha.and.zbeta2.and.zalpha2) then
ro2(16,16,kl) = ro2(16,16,kl) + psi_coef(ii,istate)**2 ! both double occupied
else if (zbeta.and.zalpha.and.zbeta2) then
ro2(15,15,kl) = ro2(15,15,kl) + psi_coef(ii,istate)**2 ! one double, one beta
else if (zbeta.and.zalpha.and.zalpha2) then
ro2(13,13,kl) = ro2(13,13,kl) + psi_coef(ii,istate)**2 ! one double, one alpha
else if (zbeta.and.zbeta2.and.zalpha2) then
ro2(14,14,kl) = ro2(14,14,kl) + psi_coef(ii,istate)**2 ! one beta, one double
else if (zalpha.and.zbeta2.and.zalpha2) then
ro2(12,12,kl) = ro2(12,12,kl) + psi_coef(ii,istate)**2 ! one alpha, one double
else if (zalpha.and.zbeta) then
ro2(11,11,kl) = ro2(11,11,kl) + psi_coef(ii,istate)**2 ! one double, one empty
else if (zbeta2.and.zalpha2) then
ro2(8,8,kl) = ro2(8,8,kl) + psi_coef(ii,istate)**2 ! one empty, one double
else if (zbeta.and.zalpha2) then
ro2(10,10,kl) = ro2(10,10,kl) + psi_coef(ii,istate)**2 ! one beta, one alpha
else if (zalpha.and.zbeta2) then
ro2(9,9,kl) = ro2(9,9,kl) + psi_coef(ii,istate)**2 ! one alpha, one beta
else if (zbeta.and.zbeta2) then
ro2(7,7,kl) = ro2(7,7,kl) + psi_coef(ii,istate)**2 ! one beta, one beta
else if (zalpha.and.zalpha2) then
ro2(6,6,kl) = ro2(6,6,kl) + psi_coef(ii,istate)**2 ! one alpha, one alpha
else if (zbeta) then
ro2(5,5,kl) = ro2(5,5,kl) + psi_coef(ii,istate)**2 ! one beta, one empty
else if (zbeta2) then
ro2(4,4,kl) = ro2(4,4,kl) + psi_coef(ii,istate)**2 ! one empty, one beta
else if (zalpha) then
ro2(3,3,kl) = ro2(3,3,kl) + psi_coef(ii,istate)**2 ! one alpha, one empty
else if (zalpha2) then
ro2(2,2,kl) = ro2(2,2,kl) + psi_coef(ii,istate)**2 ! one empty, one alpha
else
ro2(1,1,kl) = ro2(1,1,kl) + psi_coef(ii,istate)**2 ! both empty
end if
enddo
enddo
! stop double
if (ii.eq.N_det) cycle
!Off Diagonal Elements
do jj=ii+1,N_det
call get_excitation_degree(psi_det(1,1,ii),psi_det(1,1,jj),degree,N_int)
if (degree.gt.2) cycle
ip=0
do iii =1,N_int
key_tmp(iii) = ior(xor(psi_det(iii,1,ii),psi_det(iii,1,jj)),xor(psi_det(iii,2,ii),psi_det(iii,2,jj)))
ip += popcnt(key_tmp(iii))
enddo
if (ip.ne.2) cycle !They involve more than 2 orbitals.
ip=0
do iii=1,N_int
ip += popcnt(iand(key_tmp(iii),mo_inp_bit_list(iii)))
enddo
if (ip.ne.2) cycle !They do not involve orbitals of the list.
if (degree.eq.2) then
call get_double_excitation(psi_det(1,1,ii),psi_det(1,1,jj),exc,phase,N_int)
call decode_exc(exc,degree,h1,p1,h2,p2,spin1,spin2)
k=mo_inp_list_rev(h1)
l=mo_inp_list_rev(p1)
if (k.gt.l) then
kl=(k-1)*(k-2)/2+l
else
kl=(l-1)*(l-2)/2+k
endif
if ((.not.zocc(mo_inp_list(l),1)).and.(.not.zocc(mo_inp_list(l),2))&
.and.(zocc(mo_inp_list(k),1)).and.(zocc(mo_inp_list(k),2))) then
ro2(8,11,kl) += phase*psi_coef(ii,istate)*psi_coef(jj,istate)
ro2(11,8,kl) = ro2(8,11,kl)
endif
if ((zocc(mo_inp_list(l),1)).and.(.not.zocc(mo_inp_list(l),2))&
.and.(.not.zocc(mo_inp_list(k),1)).and.(zocc(mo_inp_list(k),2))) then
ro2(9,10,kl) -= phase*psi_coef(ii,istate)*psi_coef(jj,istate) !negative
ro2(10,9,kl) = ro2(9,10,kl)
endif
if ((zocc(mo_inp_list(k),1)).and.(.not.zocc(mo_inp_list(k),2))&
.and.(.not.zocc(mo_inp_list(l),1)).and.(zocc(mo_inp_list(l),2))) then
ro2(9,10,kl) -= phase*psi_coef(ii,istate)*psi_coef(jj,istate) !negative
ro2(10,9,kl) = ro2(9,10,kl)
endif
endif
if (degree.eq.1) then
call get_mono_excitation(psi_det(1,1,ii),psi_det(1,1,jj),exc,phase,N_int)
call decode_exc(exc,degree,h1,p1,h2,p2,spin1,spin2)
k=mo_inp_list_rev(h1)
l=mo_inp_list_rev(p1)
if (k.gt.l) then
kl=(k-1)*(k-2)/2+l
else
kl=(l-1)*(l-2)/2+k
endif
if ((.not.(zocc(mo_inp_list(l),2))).and.&
(.not.(zocc(mo_inp_list(l),1))).and.(zocc(mo_inp_list(k),1))&
.and.(.not.(zocc(mo_inp_list(k),2)))) then
ro2(2,3,kl) += phase*psi_coef(ii,istate)*psi_coef(jj,istate)
ro2(3,2,kl)=ro2(2,3,kl)
endif
if ((.not.(zocc(mo_inp_list(l),2))).and.&
(.not.(zocc(mo_inp_list(l),1))).and.(zocc(mo_inp_list(k),2))&
.and.(.not.(zocc(mo_inp_list(k),1)))) then
ro2(4,5,kl) += phase*psi_coef(ii,istate)*psi_coef(jj,istate)
ro2(5,4,kl)=ro2(4,5,kl)
endif
if ((.not.(zocc(mo_inp_list(l),1))).and.& !k doubly occupied, l empty
(.not.(zocc(mo_inp_list(l),2))).and.&
(zocc(mo_inp_list(k),1)).and.&
(zocc(mo_inp_list(k),2))) then
if (k.gt.l) then
if (spin1.eq.1) then !spin alpha
ro2(8,9,kl) += phase*psi_coef(ii,istate)*psi_coef(jj,istate)
ro2(9,8,kl)=ro2(8,9,kl)
else !spin beta
ro2(8,10,kl) -= phase*psi_coef(ii,istate)*psi_coef(jj,istate) !negative
ro2(10,8,kl)=ro2(8,10,kl)
endif
else ! k.lt.l
if (spin1.eq.1) then !spin alpha
ro2(10,11,kl) -= phase*psi_coef(ii,istate)*psi_coef(jj,istate) !negative
ro2(11,10,kl)=ro2(10,11,kl)
else !spin beta
ro2(9,11,kl) += phase*psi_coef(ii,istate)*psi_coef(jj,istate)
ro2(11,9,kl)=ro2(9,11,kl)
endif
endif
endif
if ((.not.(zocc(mo_inp_list(l),1))).and.& !k alpha, l beta
(.not.(zocc(mo_inp_list(k),2))).and.&
(zocc(mo_inp_list(k),1)).and.&
(zocc(mo_inp_list(l),2))) then
if (k.gt.l) then
if (spin1.eq.1) then !spin alpha
ro2(10,11,kl) -= phase*psi_coef(ii,istate)*psi_coef(jj,istate) !negative
ro2(11,10,kl)=ro2(10,11,kl)
else !spin beta
print*, "problem in k alpha l beta k.gt.l spin beta"
endif
else ! k.lt.l
if (spin1.eq.1) then !spin alpha
ro2(8,9,kl) += phase*psi_coef(ii,istate)*psi_coef(jj,istate)
ro2(9,8,kl)=ro2(8,9,kl)
else !spin beta
print*, "problem in k alpha l beta k.lt.l spin beta"
endif
endif
endif
if ((.not.(zocc(mo_inp_list(k),1))).and.& !k beta, l alpha
(.not.(zocc(mo_inp_list(l),2))).and.&
(zocc(mo_inp_list(l),1)).and.&
(zocc(mo_inp_list(k),2))) then
if (k.gt.l) then
if (spin1.eq.2) then !spin beta
ro2(9,11,kl) += phase*psi_coef(ii,istate)*psi_coef(jj,istate)
ro2(11,9,kl)=ro2(9,11,kl)
else !spin alpha
print*, "problem in k beta l alpha k.gt.l spin alpha"
endif
else ! k.lt.l
if (spin1.eq.2) then !spin beta
ro2(8,10,kl) -= phase*psi_coef(ii,istate)*psi_coef(jj,istate) !negative
ro2(10,8,kl)=ro2(8,10,kl)
else !spin alpha
print*, "problem in k beta l alpha k.lt.l spin alpha"
endif
endif
endif
if (zocc(mo_inp_list(l),1).and.(.not.zocc(mo_inp_list(l),2))&
.and.(zocc(mo_inp_list(k),1)).and.(zocc(mo_inp_list(k),2))) then
ro2(12,13,kl) -= phase*psi_coef(ii,istate)*psi_coef(jj,istate)
ro2(13,12,kl) = ro2(12,13,kl)
endif
if (zocc(mo_inp_list(l),2).and.(.not.zocc(mo_inp_list(l),1))&
.and.(zocc(mo_inp_list(k),1)).and.(zocc(mo_inp_list(k),2))) then
ro2(14,15,kl) -= phase*psi_coef(ii,istate)*psi_coef(jj,istate)
ro2(15,14,kl) = ro2(14,15,kl)
endif
endif
enddo
enddo
entropy_one_orb=0.d0
do k=1,mo_inp_num
do i=1,4
if (ro1(i,k).ge.eps) then
entropy_one_orb(k) = entropy_one_orb(k)-ro1(i,k)*log(ro1(i,k))
endif
enddo
enddo
entropy_two_orb=0.d0
do k=1,mo_inp_num
do l=1,k
if (k.eq.l) cycle
kl=(k-1)*(k-2)/2+l
call dsyev('N','U',16,ro2(1,1,kl),16,w,work,3*16,info)
if (info.ne.0) then
write(*,*) "Errore in dsyev"
endif
do j=1,16
if (w(j).ge.eps) then
entropy_two_orb(k,l) = entropy_two_orb(k,l)-w(j)*log(w(j))
entropy_two_orb(l,k) = entropy_two_orb(k,l)
elseif ((w(j)).lt.(-eps)) then
write(6,*) "Negative Eigenvalue. You have a big problem..."
write(6,*) w(j)
stop
endif
enddo
enddo
enddo
deallocate (occ,zocc,ro1,ro2)
END_PROVIDER
BEGIN_PROVIDER [double precision, mutinf, (mo_inp_num,mo_inp_num)]
implicit none
BEGIN_DOC
!mutinf is the mutual information (entanglement), calculated as I_ij=0.5*[S(1)_i+S(1)_j-S(2)_ij]
!see the refence: 10.1016/j.chemphys.2005.10.018
END_DOC
integer :: i,j
! mutal information:
mutinf = 0.d0
do i=1,mo_inp_num
do j=1,mo_inp_num
if (j.eq.i) cycle
mutinf(i,j)=-0.5d0*(entropy_two_orb(i,j)-entropy_one_orb(i)-entropy_one_orb(j))
enddo
enddo
END_PROVIDER

65
plugins/Orbital_Entanglement/README.rst Normal file
View File

@ -0,0 +1,65 @@
====================
Orbital_Entanglement
====================
Needed Modules
==============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.
.. image:: tree_dependency.png
* `Determinants <http://github.com/LCPQ/quantum_package/tree/master/src/Determinants>`_
Documentation
=============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.
`entropy_one_orb <http://github.com/LCPQ/quantum_package/tree/master/plugins/Orbital_Entanglement/Orbital_Entanglement.irp.f#L35>`_
entropy_one_orb is the one-orbital von Neumann entropy S(1)_i
entropy_two_orb is the two-orbital von Neumann entropy S(2)_ij.
`entropy_two_orb <http://github.com/LCPQ/quantum_package/tree/master/plugins/Orbital_Entanglement/Orbital_Entanglement.irp.f#L36>`_
entropy_one_orb is the one-orbital von Neumann entropy S(1)_i
entropy_two_orb is the two-orbital von Neumann entropy S(2)_ij.
`mo_inp_bit_list <http://github.com/LCPQ/quantum_package/tree/master/plugins/Orbital_Entanglement/Orbital_Entanglement.irp.f#L15>`_
mo_inp_list is the list of the orbitals involved in the entanglement calculation.
It is taken equal to the list of active orbitals list_act.
mo_inp_list_rev is a list such that mo_inp_list_rev(mo_inp_list(i))=i.
`mo_inp_list <http://github.com/LCPQ/quantum_package/tree/master/plugins/Orbital_Entanglement/Orbital_Entanglement.irp.f#L13>`_
mo_inp_list is the list of the orbitals involved in the entanglement calculation.
It is taken equal to the list of active orbitals list_act.
mo_inp_list_rev is a list such that mo_inp_list_rev(mo_inp_list(i))=i.
`mo_inp_list_rev <http://github.com/LCPQ/quantum_package/tree/master/plugins/Orbital_Entanglement/Orbital_Entanglement.irp.f#L14>`_
mo_inp_list is the list of the orbitals involved in the entanglement calculation.
It is taken equal to the list of active orbitals list_act.
mo_inp_list_rev is a list such that mo_inp_list_rev(mo_inp_list(i))=i.
`mo_inp_num <http://github.com/LCPQ/quantum_package/tree/master/plugins/Orbital_Entanglement/Orbital_Entanglement.irp.f#L3>`_
This is the number of orbitals involved in the entanglement calculation.
It is taken equal to the number of active orbitals n_act_orb.
`mutinf <http://github.com/LCPQ/quantum_package/tree/master/plugins/Orbital_Entanglement/Orbital_Entanglement.irp.f#L330>`_
mutinf is the mutual information (entanglement), calculated as I_ij=0.5*[S(1)_i+S(1)_j-S(2)_ij]
see the refence: 10.1016/j.chemphys.2005.10.018
`pouet <http://github.com/LCPQ/quantum_package/tree/master/plugins/Orbital_Entanglement/print_entanglement.irp.f#L1>`_
Undocumented
`routine <http://github.com/LCPQ/quantum_package/tree/master/plugins/Orbital_Entanglement/print_entanglement.irp.f#L9>`_
Undocumented

46
plugins/Orbital_Entanglement/print_entanglement.irp.f Normal file
View File

@ -0,0 +1,46 @@
program pouet
implicit none
read_wf = .true.
touch read_wf
call routine
end
subroutine routine
implicit none
integer:: i,j
write(6,*) 'Total orbitals: ', mo_tot_num
write(6,*) 'Orbitals for entanglement calculation: ', mo_inp_num
write(6,*) 'Index: ',(mo_inp_list(i),i=1,mo_inp_num)
write(6,*)
write(6,*) "s1: One-Orbital von Neumann entropy"
write(6,'(1000f8.5)') entropy_one_orb
write(6,*)
write(6,*) "s2: Two-Orbital von Neumann entropy"
do i=1,mo_inp_num
write(6,'(1000f8.5)') (entropy_two_orb(i,j),j=1,mo_inp_num)
enddo
write(6,*)
! mutal information:
write(6,*) "Mutual Information (Entanglement)"
do i=1,mo_inp_num
write(6,'(1000f8.5)') (mutinf(i,j),j=1,mo_inp_num)
enddo
open(17,file=(trim(ezfio_filename)//".entanglement"),status='unknown',form='formatted')
write(17,'(1000f8.5)') entropy_one_orb
do i=1,mo_inp_num
write(17,'(1000f8.5)') (mutinf(i,j),j=1,mo_inp_num)
enddo
close(17)
write(6,*)
write(6,*) "The .entanglement file is the input for the entanglement.py script."
write(6,*) "You can find the script in the directory Scripts of QP."
write(6,*)
end

21
plugins/Orbital_Entanglement/tree_dependency Normal file
View File

@ -0,0 +1,21 @@
// ['Orbital_Entanglement']
digraph {
Orbital_Entanglement [fontcolor=red]
Orbital_Entanglement -> Determinants
Determinants -> Integrals_Monoelec
Integrals_Monoelec -> MO_Basis
MO_Basis -> AO_Basis
AO_Basis -> Nuclei
Nuclei -> Ezfio_files
Nuclei -> Utils
MO_Basis -> Electrons
Electrons -> Ezfio_files
Integrals_Monoelec -> Pseudo
Pseudo -> Nuclei
Determinants -> Integrals_Bielec
Integrals_Bielec -> Pseudo
Integrals_Bielec -> Bitmask
Bitmask -> MO_Basis
Integrals_Bielec -> ZMQ
ZMQ -> Utils
}

0
plugins/Orbital_Entanglement/tree_dependency.png Normal file
View File

66
plugins/Perturbation/perturbation.template.f
View File

@ -3,7 +3,6 @@ import perturbation
END_SHELL
subroutine perturb_buffer_$PERT(i_generator,buffer,buffer_size,e_2_pert_buffer,coef_pert_buffer,sum_e_2_pert,sum_norm_pert,sum_H_pert_diag,N_st,Nint,key_mask,fock_diag_tmp)
implicit none
BEGIN_DOC
@ -18,7 +17,7 @@ subroutine perturb_buffer_$PERT(i_generator,buffer,buffer_size,e_2_pert_buffer,c
double precision, intent(inout) :: sum_norm_pert(N_st),sum_e_2_pert(N_st)
double precision, intent(inout) :: coef_pert_buffer(N_st,buffer_size),e_2_pert_buffer(N_st,buffer_size),sum_H_pert_diag(N_st)
double precision :: c_pert(N_st), e_2_pert(N_st), H_pert_diag(N_st)
integer :: i,k, c_ref, ni, ex
integer :: i,k,l, c_ref, ni, ex
integer, external :: connected_to_ref
logical, external :: is_in_wavefunction
@ -59,6 +58,7 @@ subroutine perturb_buffer_$PERT(i_generator,buffer,buffer_size,e_2_pert_buffer,c
deallocate( minilist, minilist_gen, idx_minilist )
return
end if
call create_minilist(key_mask, psi_selectors, minilist, idx_miniList, N_det_selectors, N_minilist, Nint)
allocate( microlist(Nint,2,N_minilist*4), &
idx_microlist(N_minilist*4), &
@ -80,15 +80,25 @@ subroutine perturb_buffer_$PERT(i_generator,buffer,buffer_size,e_2_pert_buffer,c
do i=0,mo_tot_num*2
do k=ptr_microlist(i),ptr_microlist(i+1)-1
idx_microlist(k) = idx_minilist(idx_microlist(k))
end do
do k=ptr_microlist(i),ptr_microlist(i+1)-1
idx_microlist(k) = idx_minilist(idx_microlist(k))
end do
end do
if(N_microlist(0) > 0) then
microlist_zero(:,:,1:N_microlist(0)) = microlist(:,:,1:N_microlist(0))
idx_microlist_zero(1:N_microlist(0)) = idx_microlist(1:N_microlist(0))
! TODO OLD
! microlist_zero(:,:,1:N_microlist(0)) = microlist(:,:,1:N_microlist(0))
! idx_microlist_zero(1:N_microlist(0)) = idx_microlist(1:N_microlist(0))
! TODO OLD
ASSERT (N_microlist(0) <= N_minilist)
do l=1,N_microlist(0)
do k=1,Nint
microlist_zero(k,1,l) = microlist(k,1,l)
microlist_zero(k,2,l) = microlist(k,2,l)
enddo
idx_microlist_zero(l) = idx_microlist(l)
enddo
end if
end if
@ -100,7 +110,7 @@ subroutine perturb_buffer_$PERT(i_generator,buffer,buffer_size,e_2_pert_buffer,c
endif
if(key_mask(1,1) /= 0) then
call getMobiles(buffer(:,:,i), key_mask, mobiles, Nint)
call getMobiles(buffer(1,1,i), key_mask, mobiles, Nint)
if(N_microlist(mobiles(1)) < N_microlist(mobiles(2))) then
smallerlist = mobiles(1)
else
@ -108,24 +118,44 @@ subroutine perturb_buffer_$PERT(i_generator,buffer,buffer_size,e_2_pert_buffer,c
end if
if(N_microlist_gen(smallerlist) > 0) then
if(is_connected_to(buffer(1,1,i), microlist_gen(:,:,ptr_microlist_gen(smallerlist):ptr_microlist_gen(smallerlist+1)-1), Nint, N_microlist_gen(smallerlist))) then
! TODO OLD
! if(is_connected_to(buffer(1,1,i), microlist_gen(:,:,ptr_microlist_gen(smallerlist):ptr_microlist_gen(smallerlist+1)-1), Nint, N_microlist_gen(smallerlist))) then
! TODO OLD
ASSERT (ptr_microlist_gen(smallerlist) <= N_minilist_gen*4)
if(is_connected_to(buffer(1,1,i), microlist_gen(1,1,ptr_microlist_gen(smallerlist)), Nint, N_microlist_gen(smallerlist))) then
cycle
end if
end if
if(N_microlist_gen(0) > 0) then
if(is_connected_to(buffer(1,1,i), microlist_gen(:,:,1:ptr_microlist_gen(1)-1), Nint, N_microlist_gen(0))) then
! TODO OLD
! if(is_connected_to(buffer(1,1,i), microlist_gen(:,:,1:ptr_microlist_gen(1)-1), Nint, N_microlist_gen(0))) then
! TODO OLD
ASSERT ( N_microlist_gen(0) <= buffer_size)
if(is_connected_to(buffer(1,1,i), microlist_gen(1,1,1), Nint, N_microlist_gen(0))) then
cycle
end if
end if
if(N_microlist(smallerlist) > 0) then
microlist_zero(:,:,ptr_microlist(1):ptr_microlist(1)+N_microlist(smallerlist)-1) = microlist(:,:,ptr_microlist(smallerlist):ptr_microlist(smallerlist+1)-1)
idx_microlist_zero(ptr_microlist(1):ptr_microlist(1)+N_microlist(smallerlist)-1) = idx_microlist(ptr_microlist(smallerlist):ptr_microlist(smallerlist+1)-1)
! call merdge(microlist(:,:,:,smallerlist), idx_microlist(:,smallerlist), N_microlist(smallerlist), microlist(:,:,:,0), idx_microlist(:,0), N_microlist(0))
! TODO OLD
! microlist_zero(:,:,ptr_microlist(1):ptr_microlist(1)+N_microlist(smallerlist)-1) = microlist(:,:,ptr_microlist(smallerlist):ptr_microlist(smallerlist+1)-1)
! idx_microlist_zero(ptr_microlist(1):ptr_microlist(1)+N_microlist(smallerlist)-1) = idx_microlist(ptr_microlist(smallerlist):ptr_microlist(smallerlist+1)-1)
! TODO OLD
ASSERT ( ptr_microlist(1)+N_microlist(smallerlist)-1 <= N_minilist )
ASSERT ( ptr_microlist(smallerlist)+N_microlist(smallerlist)-1 <= N_minilist*4 )
do l=0, N_microlist(smallerlist)-1
do k=1,Nint
microlist_zero(k,1,ptr_microlist(1)+l) = microlist(k,1,ptr_microlist(smallerlist)+l)
microlist_zero(k,2,ptr_microlist(1)+l) = microlist(k,2,ptr_microlist(smallerlist)+l)
enddo
idx_microlist_zero(ptr_microlist(1)+l) = idx_microlist(ptr_microlist(smallerlist)+l)
enddo
end if
call pt2_$PERT(psi_det_generators(1,1,i_generator),buffer(1,1,i), fock_diag_tmp, &
c_pert,e_2_pert,H_pert_diag,Nint,N_microlist(smallerlist)+N_microlist(0),n_st,microlist_zero(:,:,:),idx_microlist_zero(:),N_microlist(smallerlist)+N_microlist(0))
call pt2_$PERT(psi_det_generators(1,1,i_generator),buffer(1,1,i), fock_diag_tmp, &
c_pert,e_2_pert,H_pert_diag,Nint,N_microlist(smallerlist)+N_microlist(0), &
n_st,microlist_zero,idx_microlist_zero,N_microlist(smallerlist)+N_microlist(0))
else
ASSERT (N_minilist_gen <= N_det_generators)
if(is_connected_to(buffer(1,1,i), miniList_gen, Nint, N_minilist_gen)) then
cycle
end if
@ -146,9 +176,9 @@ subroutine perturb_buffer_$PERT(i_generator,buffer,buffer_size,e_2_pert_buffer,c
enddo
enddo
deallocate( minilist, minilist_gen, idx_minilist )
deallocate( microlist, idx_microlist, N_microlist,ptr_microlist )
deallocate( microlist_gen, idx_microlist_gen,N_microlist_gen,ptr_microlist_gen )
deallocate( minilist, minilist_gen, idx_minilist, &
microlist, idx_microlist, N_microlist,ptr_microlist, &
microlist_gen, idx_microlist_gen,N_microlist_gen,ptr_microlist_gen )
end

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