LCPQ/quantum_package
10
0
Fork 0
mirror of https://github.com/LCPQ/quantum_package synced 2024-06-17 02:35:26 +02:00
Code Issues Releases Wiki Activity

Merge branch 'master' into mrcepa0

Browse Source 
Conflicts:
	ocaml/.gitignore
	ocaml/qp_edit.ml
	plugins/MRCC_Utils/mrcc_utils.irp.f
This commit is contained in:
Yann Garniron 2016-03-31 11:57:19 +02:00
commit 306a86d33b
95 changed files with 5056 additions and 2934 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.travis.yml
View File

@ -27,4 +27,4 @@ script:
- 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

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

2
config/ifort.cfg
View File

@ -31,7 +31,7 @@ OPENMP : 1 ; Append OpenMP flags
# -ftz : Flushes denormal results to zero
#
[OPT]
FCFLAGS : -xHost -O2 -ip -ftz -g
FCFLAGS : -xSSE4.2 -O2 -ip -ftz -g
# Profiling flags
#################

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

118
data/list_element.txt Normal file
View File

@ -0,0 +1,118 @@
1 H Hydrogen
2 He Helium
3 Li Lithium
4 Be Beryllium
5 B Boron
6 C Carbon
7 N Nitrogen
8 O Oxygen
9 F Fluorine
10 Ne Neon
11 Na Sodium
12 Mg Magnesium
13 Al Aluminum
14 Si Silicon
15 P Phosphorus
16 S Sulfur
17 Cl Chlorine
18 Ar Argon
19 K Potassium
20 Ca Calcium
21 Sc Scandium
22 Ti Titanium
23 V Vanadium
24 Cr Chromium
25 Mn Manganese
26 Fe Iron
27 Co Cobalt
28 Ni Nickel
29 Cu Copper
30 Zn Zinc
31 Ga Gallium
32 Ge Germanium
33 As Arsenic
34 Se Selenium
35 Br Bromine
36 Kr Krypton
37 Rb Rubidium
38 Sr Strontium
39 Y Yttrium
40 Zr Zirconium
41 Nb Niobium
42 Mo Molybdenum
43 Tc Technetium
44 Ru Ruthenium
45 Rh Rhodium
46 Pd Palladium
47 Ag Silver
48 Cd Cadmium
49 In Indium
50 Sn Tin
51 Sb Antimony
52 Te Tellurium
53 I Iodine
54 Xe Xenon
55 Cs Cesium
56 Ba Barium
57 La Lanthanum
58 Ce Cerium
59 Pr Praseodymium
60 Nd Neodymium
61 Pm Promethium
62 Sm Samarium
63 Eu Europium
64 Gd Gadolinium
65 Tb Terbium
66 Dy Dysprosium
67 Ho Holmium
68 Er Erbium
69 Tm Thulium
70 Yb Ytterbium
71 Lu Lutetium
72 Hf Hafnium
73 Ta Tantalum
74 W Tungsten
75 Re Rhenium
76 Os Osmium
77 Ir Iridium
78 Pt Platinum
79 Au Gold
80 Hg Mercury
81 Tl Thallium
82 Pb Lead
83 Bi Bismuth
84 Po Polonium
85 At Astatine
86 Rn Radon
87 Fr Francium
88 Ra Radium
89 Ac Actinium
90 Th Thorium
91 Pa Protactinium
92 U Uranium
93 Np Neptunium
94 Pu Plutonium
95 Am Americium
96 Cm Curium
97 Bk Berkelium
98 Cf Californium
99 Es Einsteinium
100 Fm Fermium
101 Md Mendelevium
102 No Nobelium
103 Lr Lawrencium
104 Rf Rutherfordium
105 Db Dubnium
106 Sg Seaborgium
107 Bh Bohrium
108 Hs Hassium
109 Mt Meitnerium
110 Ds Darmstadtium
111 Rg Roentgenium
112 Cn Copernicium
113 Uut Ununtrium
114 Fl Flerovium
115 Uup Ununpentium
116 Lv Livermorium
117 Uus Ununseptium
118 Uuo Ununoctium

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

85
ocaml/Input_determinants_by_hand.ml
View File

@ -11,11 +11,13 @@ module Determinants_by_hand : sig
psi_coef : Det_coef.t array;
psi_det : Determinant.t array;
} with sexp
val read : unit -> t option
val read : unit -> t
val read_maybe : unit -> t option
val write : t -> unit
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 +31,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 +211,24 @@ 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 () ;
}
{ 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
failwith "No molecular orbitals, so no determinants"
;;
let read_maybe () =
let n_det =
read_n_det ()
in
if ( (Det_number.to_int n_det) < n_det_read_max ) then
try Some (read ()) with
| Failure _ -> None
else
None
;;
@ -236,11 +250,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 +412,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
| Integrals_bielec
| Pseudo
| Perturbation
| Hartree_fock
| Properties
;;
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"
| Integrals_bielec -> "Integrals_bielec"
| Pseudo -> "Pseudo"
| Perturbation -> "Perturbation"
| Hartree_fock -> "Hartree_fock"
| Properties -> "Properties"
;;
(** 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)
| Integrals_bielec ->
f Integrals_bielec.(read, to_rst)
| Pseudo ->
f Pseudo.(read, to_rst)
| Perturbation ->
f Perturbation.(read, to_rst)
| Hartree_fock ->
f Hartree_fock.(read, to_rst)
| Properties ->
f Properties.(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
| Integrals_bielec -> write Integrals_bielec.(of_rst, write) s
| Pseudo -> write Pseudo.(of_rst, write) s
| Perturbation -> write Perturbation.(of_rst, write) s
| Hartree_fock -> write Hartree_fock.(of_rst, write) s
| Properties -> write Properties.(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 ;
Integrals_bielec ;
Pseudo ;
Perturbation ;
Hartree_fock ;
Properties ;
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
;;

19
ocaml/qp_print_basis.ml
View File

@ -35,7 +35,24 @@ let mo () =
|> print_endline
let psi_det () =
let ezfio_filename =
Sys.argv.(1)
in
if (not (Sys.file_exists_exn ezfio_filename)) then
failwith "Error reading EZFIO file";
Ezfio.set_file ezfio_filename;
let psi_det =
Input.Determinants_by_hand.read ()
in
Input.Determinants_by_hand.to_rst psi_det
|> Rst_string.to_string
|> print_endline
let () =
basis ();
mo ()
mo ();
psi_det ()

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

4
ocaml/test_message.ml
View File

@ -1,7 +1,7 @@
open Core.Std
let () =
Message.of_string "new_job tcp://127.0.0.1 inproc://ao_ints:12345 ao_integrals"
Message.of_string "new_job ao_integrals tcp://127.0.0.1 inproc://ao_ints:12345"
|> Message.to_string
|> print_endline
;
@ -37,7 +37,7 @@ let () =
;
try
Message.of_string "new_job inproc://ao_ints tcp://127.0.0.1:12345 ao_integrals"
Message.of_string "new_job ao_integrals inproc://ao_ints tcp://127.0.0.1:12345"
|> Message.to_string
|> print_endline
;

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__':

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

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)

35
plugins/FOBOCI/H_apply_dressed_autonom.irp.f
View File

@ -117,14 +117,8 @@ subroutine H_apply_dressed_pert_diexc(key_in, hole_1,particl_1, hole_2, particl_
accu = 0.d0
do ispin=1,2
other_spin = iand(ispin,1)+1
if (abort_here) then
exit
endif
! !$OMP DO SCHEDULE (static)
do ii=1,ia_ja_pairs(1,0,ispin)
if (abort_here) then
cycle
endif
i_a = ia_ja_pairs(1,ii,ispin)
ASSERT (i_a > 0)
ASSERT (i_a <= mo_tot_num)
@ -202,9 +196,6 @@ subroutine H_apply_dressed_pert_diexc(key_in, hole_1,particl_1, hole_2, particl_
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
if (abort_here) then
exit
endif
enddo
endif
@ -253,9 +244,6 @@ subroutine H_apply_dressed_pert_diexc(key_in, hole_1,particl_1, hole_2, particl_
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
if (abort_here) then
exit
endif
enddo ! kk
enddo ! ii
@ -467,22 +455,12 @@ subroutine H_apply_dressed_pert(delta_ij_generators_, Ndet_generators,psi_det_g
! !$ call omp_init_lock(lck)
call start_progress(Ndet_generators,'Selection (norm)',0.d0)
call wall_time(wall_0)
iproc = 0
allocate( mask(N_int,2,6) )
do i_generator=1,nmax
progress_bar(1) = i_generator
if (abort_here) then
exit
endif
! ! Create bit masks for holes and particles
do ispin=1,2
do k=1,N_int
@ -535,14 +513,6 @@ subroutine H_apply_dressed_pert(delta_ij_generators_, Ndet_generators,psi_det_g
allocate( mask(N_int,2,6) )
! !$OMP DO SCHEDULE(dynamic,1)
do i_generator=nmax+1,Ndet_generators
if (iproc == 0) then
progress_bar(1) = i_generator
endif
if (abort_here) then
cycle
endif
! Create bit masks for holes and particles
do ispin=1,2
@ -594,11 +564,6 @@ subroutine H_apply_dressed_pert(delta_ij_generators_, Ndet_generators,psi_det_g
! !$OMP END PARALLEL
! !$ call omp_destroy_lock(lck)
abort_here = abort_all
call stop_progress
end

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

@ -4,39 +4,47 @@ from generate_h_apply import *
s = H_apply("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.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

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

@ -84,9 +84,6 @@ program full_ci
endif
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

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

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)

13
plugins/MRCC_CASSD/EZFIO.cfg
View File

@ -2,3 +2,16 @@
type: double precision
doc: Calculated energy
interface: ezfio
[thresh_mrcc]
type: Threshold
doc: Threshold on the convergence of the MRCC energy
interface: ezfio,provider,ocaml
default: 1.e-7
[n_it_mrcc_max]
type: Strictly_positive_int
doc: Maximum number of MRCC iterations
interface: ezfio,provider,ocaml
default: 20

42
plugins/MRCC_Utils/H_apply.irp.f
View File

@ -3,19 +3,19 @@ BEGIN_SHELL [ /usr/bin/env python ]
from generate_h_apply import *
s = H_apply("mrcc")
s.data["parameters"] = ", delta_ij_, delta_ii_,Ndet_ref, Ndet_non_ref"
s.data["parameters"] = ", delta_ij_, delta_ii_, Nstates, Ndet_non_ref, Ndet_ref"
s.data["declarations"] += """
integer, intent(in) :: Ndet_ref,Ndet_non_ref
double precision, intent(in) :: delta_ij_(Ndet_ref,Ndet_non_ref,*)
double precision, intent(in) :: delta_ii_(Ndet_ref,*)
integer, intent(in) :: Nstates, Ndet_ref, Ndet_non_ref
double precision, intent(in) :: delta_ij_(Nstates, Ndet_non_ref, Ndet_ref)
double precision, intent(in) :: delta_ii_(Nstates, Ndet_ref)
"""
s.data["keys_work"] = "call mrcc_dress(delta_ij_,delta_ii_,Ndet_ref,Ndet_non_ref,i_generator,key_idx,keys_out,N_int,iproc,key_mask)"
s.data["params_post"] += ", delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref"
s.data["params_main"] += "delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref"
s.data["keys_work"] = "call mrcc_dress(delta_ij_,delta_ii_,Nstates,Ndet_non_ref,Ndet_ref,i_generator,key_idx,keys_out,N_int,iproc,key_mask)"
s.data["params_post"] += ", delta_ij_, delta_ii_, Nstates, Ndet_non_ref, Ndet_ref"
s.data["params_main"] += "delta_ij_, delta_ii_, Nstates, Ndet_non_ref, Ndet_ref"
s.data["decls_main"] += """
integer, intent(in) :: Ndet_ref,Ndet_non_ref
double precision, intent(in) :: delta_ij_(Ndet_ref,Ndet_non_ref,*)
double precision, intent(in) :: delta_ii_(Ndet_ref,*)
integer, intent(in) :: Ndet_ref, Ndet_non_ref, Nstates
double precision, intent(in) :: delta_ij_(Nstates,Ndet_non_ref,Ndet_ref)
double precision, intent(in) :: delta_ii_(Nstates,Ndet_ref)
"""
s.data["finalization"] = ""
s.data["copy_buffer"] = ""
@ -24,27 +24,5 @@ s.data["size_max"] = "3072"
print s
s = H_apply("mrcepa")
s.data["parameters"] = ", delta_ij_, delta_ii_,Ndet_ref, Ndet_non_ref"
s.data["declarations"] += """
integer, intent(in) :: Ndet_ref,Ndet_non_ref
double precision, intent(in) :: delta_ij_(Ndet_ref,Ndet_non_ref,*)
double precision, intent(in) :: delta_ii_(Ndet_ref,*)
"""
s.data["keys_work"] = "call mrcepa_dress(delta_ij_,delta_ii_,Ndet_ref,Ndet_non_ref,i_generator,key_idx,keys_out,N_int,iproc,key_mask)"
s.data["params_post"] += ", delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref"
s.data["params_main"] += "delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref"
s.data["decls_main"] += """
integer, intent(in) :: Ndet_ref,Ndet_non_ref
double precision, intent(in) :: delta_ij_(Ndet_ref,Ndet_non_ref,*)
double precision, intent(in) :: delta_ii_(Ndet_ref,*)
"""
s.data["finalization"] = ""
s.data["copy_buffer"] = ""
s.data["generate_psi_guess"] = ""
s.data["size_max"] = "3072"
# print s
END_SHELL

447
plugins/MRCC_Utils/mrcc_dress.irp.f
View File

@ -14,17 +14,17 @@ BEGIN_PROVIDER [ integer(omp_lock_kind), psi_ref_lock, (psi_det_size) ]
END_PROVIDER
subroutine mrcc_dress(delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref,i_generator,n_selected,det_buffer,Nint,iproc,key_mask)
subroutine mrcc_dress(delta_ij_, delta_ii_, Nstates, Ndet_non_ref, Ndet_ref,i_generator,n_selected,det_buffer,Nint,iproc,key_mask)
use bitmasks
implicit none
integer, intent(in) :: i_generator,n_selected, Nint, iproc
integer, intent(in) :: Ndet_ref, Ndet_non_ref
double precision, intent(inout) :: delta_ij_(Ndet_ref,Ndet_non_ref,*)
double precision, intent(inout) :: delta_ii_(Ndet_ref,*)
integer, intent(in) :: Nstates, Ndet_ref, Ndet_non_ref
double precision, intent(inout) :: delta_ij_(Nstates,Ndet_non_ref,Ndet_ref)
double precision, intent(inout) :: delta_ii_(Nstates,Ndet_ref)
integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected)
integer :: i,j,k,l
integer :: i,j,k,l,m
integer :: degree_alpha(psi_det_size)
integer :: idx_alpha(0:psi_det_size)
logical :: good, fullMatch
@ -32,10 +32,10 @@ subroutine mrcc_dress(delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref,i_generator,n
integer(bit_kind) :: tq(Nint,2,n_selected)
integer :: N_tq, c_ref ,degree
double precision :: hIk, hla, hIl, dIk(N_states), dka(N_states), dIa(N_states)
double precision :: hIk, hla, hIl, dIk(Nstates), dka(Nstates), dIa(Nstates)
double precision, allocatable :: dIa_hla(:,:)
double precision :: haj, phase, phase2
double precision :: f(N_states), ci_inv(N_states)
double precision :: f(Nstates), ci_inv(Nstates)
integer :: exc(0:2,2,2)
integer :: h1,h2,p1,p2,s1,s2
integer(bit_kind) :: tmp_det(Nint,2)
@ -46,10 +46,16 @@ subroutine mrcc_dress(delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref,i_generator,n
integer(bit_kind),intent(in) :: key_mask(Nint, 2)
integer,allocatable :: idx_miniList(:)
integer :: N_miniList, ni, leng
double precision, allocatable :: hij_cache(:)
integer(bit_kind), allocatable :: microlist(:,:,:), microlist_zero(:,:,:)
integer, allocatable :: idx_microlist(:), N_microlist(:), ptr_microlist(:), idx_microlist_zero(:)
integer :: mobiles(2), smallerlist
leng = max(N_det_generators, N_det_non_ref)
allocate(miniList(Nint, 2, leng), idx_miniList(leng))
allocate(miniList(Nint, 2, leng), idx_minilist(leng), hij_cache(N_det_non_ref))
!create_minilist_find_previous(key_mask, fullList, miniList, N_fullList, N_miniList, fullMatch, Nint)
call create_minilist_find_previous(key_mask, psi_det_generators, miniList, i_generator-1, N_miniList, fullMatch, Nint)
@ -58,140 +64,248 @@ subroutine mrcc_dress(delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref,i_generator,n
return
end if
allocate(ptr_microlist(0:mo_tot_num*2+1), &
N_microlist(0:mo_tot_num*2) )
allocate( microlist(Nint,2,N_minilist*4), &
idx_microlist(N_minilist*4))
if(key_mask(1,1) /= 0) then
call create_microlist(miniList, N_minilist, key_mask, microlist, idx_microlist, N_microlist, ptr_microlist, Nint)
call find_triples_and_quadruples_micro(i_generator,n_selected,det_buffer,Nint,tq,N_tq,microlist,ptr_microlist,N_microlist,key_mask)
else
call find_triples_and_quadruples(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist)
end if
deallocate(microlist, idx_microlist)
allocate (dIa_hla(Nstates,Ndet_non_ref))
call find_triples_and_quadruples(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist)
allocate (dIa_hla(N_states,Ndet_non_ref))
! |I>
! |alpha>
if(N_tq > 0) then
call create_minilist(key_mask, psi_non_ref, miniList, idx_miniList, N_det_non_ref, N_minilist, Nint)
end if
do i_alpha=1,N_tq
! call get_excitation_degree_vector(psi_non_ref,tq(1,1,i_alpha),degree_alpha,Nint,N_det_non_ref,idx_alpha)
call get_excitation_degree_vector(miniList,tq(1,1,i_alpha),degree_alpha,Nint,N_minilist,idx_alpha)
if(N_tq > 0) then
call create_minilist(key_mask, psi_non_ref, miniList, idx_minilist, N_det_non_ref, N_minilist, Nint)
if(N_minilist == 0) return
do j=1,idx_alpha(0)
idx_alpha(j) = idx_miniList(idx_alpha(j))
end do
if(key_mask(1,1) /= 0) then !!!!!!!!!!! PAS GENERAL !!!!!!!!!
allocate(microlist_zero(Nint,2,N_minilist), idx_microlist_zero(N_minilist))
allocate( microlist(Nint,2,N_minilist*4), &
idx_microlist(N_minilist*4))
call create_microlist(miniList, N_minilist, key_mask, microlist, idx_microlist, N_microlist, ptr_microlist, Nint)
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
end do
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
do i_alpha=1,N_tq
if(key_mask(1,1) /= 0) then
call getMobiles(tq(1,1,i_alpha), key_mask, mobiles, Nint)
if(N_microlist(mobiles(1)) < N_microlist(mobiles(2))) then
smallerlist = mobiles(1)
else
smallerlist = mobiles(2)
end if
do l=0,N_microlist(smallerlist)-1
microlist_zero(:,:,ptr_microlist(1) + l) = microlist(:,:,ptr_microlist(smallerlist) + l)
idx_microlist_zero(ptr_microlist(1) + l) = idx_microlist(ptr_microlist(smallerlist) + l)
end do
call get_excitation_degree_vector(microlist_zero,tq(1,1,i_alpha),degree_alpha,Nint,N_microlist(smallerlist)+N_microlist(0),idx_alpha)
do j=1,idx_alpha(0)
idx_alpha(j) = idx_microlist_zero(idx_alpha(j))
end do
! i = 1
! j = 2
! do j = 2, idx_alpha_tmp(0)
! if(idx_alpha_tmp(j) < idx_alpha_tmp(j-1)) exit
! end do
!
! m = j
!
! idx_alpha(0) = idx_alpha_tmp(0)
!
! do l = 1, idx_alpha(0)
! if(j > idx_alpha_tmp(0)) then
! k = i
! i += 1
! else if(i >= m) then
! k = j
! j += 1
! else if(idx_alpha_tmp(i) < idx_alpha_tmp(j)) then
! k = i
! i += 1
! else
! k = j
! j += 1
! end if
! ! k=l
! idx_alpha(l) = idx_alpha_tmp(k)
! degree_alpha(l) = degree_alpha_tmp(k)
! end do
!
else
call get_excitation_degree_vector(miniList,tq(1,1,i_alpha),degree_alpha,Nint,N_minilist,idx_alpha)
do j=1,idx_alpha(0)
idx_alpha(j) = idx_miniList(idx_alpha(j))
end do
end if
! call get_excitation_degree_vector(miniList,tq(1,1,i_alpha),degree_alpha,Nint,N_minilist,idx_alpha)
! do j=1,idx_alpha(0)
! idx_alpha(j) = idx_miniList(idx_alpha(j))
! end do
!print *, idx_alpha(:idx_alpha(0))
do l_sd=1,idx_alpha(0)
k_sd = idx_alpha(l_sd)
call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hij_cache(k_sd))
enddo
! |I>
do i_I=1,N_det_ref
! Find triples and quadruple grand parents
call get_excitation_degree(tq(1,1,i_alpha),psi_ref(1,1,i_I),degree,Nint)
if (degree > 4) then
cycle
endif
! Find triples and quadruple grand parents
call get_excitation_degree(tq(1,1,i_alpha),psi_ref(1,1,i_I),degree,Nint)
if (degree > 4) then
cycle
endif
do i_state=1,Nstates
dIa(i_state) = 0.d0
enddo
! <I| <> |alpha>
do k_sd=1,idx_alpha(0)
! Loop if lambda == 0
logical :: loop
loop = .True.
do i_state=1,Nstates
if (lambda_mrcc(i_state,idx_alpha(k_sd)) /= 0.d0) then
loop = .False.
exit
endif
enddo
if (loop) then
cycle
endif
call get_excitation_degree(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),degree,Nint)
if (degree > 2) then
cycle
endif
! <I| /k\ |alpha>
! <I|H|k>
hIk = hij_mrcc(idx_alpha(k_sd),i_I)
! call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),Nint,hIk)
do i_state=1,Nstates
dIk(i_state) = hIk * lambda_mrcc(i_state,idx_alpha(k_sd))
enddo
! |l> = Exc(k -> alpha) |I>
call get_excitation(psi_non_ref(1,1,idx_alpha(k_sd)),tq(1,1,i_alpha),exc,degree,phase,Nint)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
do k=1,N_int
tmp_det(k,1) = psi_ref(k,1,i_I)
tmp_det(k,2) = psi_ref(k,2,i_I)
enddo
logical :: ok
call apply_excitation(psi_ref(1,1,i_I), exc, tmp_det, ok, Nint)
if(.not. ok) cycle
! <I| \l/ |alpha>
do i_state=1,Nstates
dka(i_state) = 0.d0
enddo
do l_sd=k_sd+1,idx_alpha(0)
do i_state=1,N_states
dIa(i_state) = 0.d0
enddo
call get_excitation_degree(tmp_det,psi_non_ref(1,1,idx_alpha(l_sd)),degree,Nint)
if (degree == 0) then
loop = .True.
do i_state=1,Nstates
if (lambda_mrcc(i_state,idx_alpha(l_sd)) /= 0.d0) then
loop = .False.
exit
endif
enddo
if (.not.loop) then
call get_excitation(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),exc,degree,phase2,Nint)
hIl = hij_mrcc(idx_alpha(l_sd),i_I)
! call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hIl)
do i_state=1,Nstates
dka(i_state) = hIl * lambda_mrcc(i_state,idx_alpha(l_sd)) * phase * phase2
enddo
endif
! <I| <> |alpha>
do k_sd=1,idx_alpha(0)
call get_excitation_degree(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),degree,Nint)
if (degree > 2) then
cycle
endif
! <I| /k\ |alpha>
! <I|H|k>
call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),Nint,hIk)
do i_state=1,N_states
dIk(i_state) = hIk * lambda_mrcc(i_state,idx_alpha(k_sd))
enddo
! |l> = Exc(k -> alpha) |I>
call get_excitation(psi_non_ref(1,1,idx_alpha(k_sd)),tq(1,1,i_alpha),exc,degree,phase,Nint)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
do k=1,N_int
tmp_det(k,1) = psi_ref(k,1,i_I)
tmp_det(k,2) = psi_ref(k,2,i_I)
enddo
! Hole (see list_to_bitstring)
iint = ishft(h1-1,-bit_kind_shift) + 1
ipos = h1-ishft((iint-1),bit_kind_shift)-1
tmp_det(iint,s1) = ibclr(tmp_det(iint,s1),ipos)
! Particle
iint = ishft(p1-1,-bit_kind_shift) + 1
ipos = p1-ishft((iint-1),bit_kind_shift)-1
tmp_det(iint,s1) = ibset(tmp_det(iint,s1),ipos)
if (degree_alpha(k_sd) == 2) then
! Hole (see list_to_bitstring)
iint = ishft(h2-1,-bit_kind_shift) + 1
ipos = h2-ishft((iint-1),bit_kind_shift)-1
tmp_det(iint,s2) = ibclr(tmp_det(iint,s2),ipos)
! Particle
iint = ishft(p2-1,-bit_kind_shift) + 1
ipos = p2-ishft((iint-1),bit_kind_shift)-1
tmp_det(iint,s2) = ibset(tmp_det(iint,s2),ipos)
endif
! <I| \l/ |alpha>
do i_state=1,N_states
dka(i_state) = 0.d0
enddo
do l_sd=k_sd+1,idx_alpha(0)
call get_excitation_degree(tmp_det,psi_non_ref(1,1,idx_alpha(l_sd)),degree,Nint)
if (degree == 0) then
call get_excitation(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),exc,degree,phase2,Nint)
call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hIl)
do i_state=1,N_states
dka(i_state) = hIl * lambda_mrcc(i_state,idx_alpha(l_sd)) * phase * phase2
enddo
exit
endif
enddo
do i_state=1,N_states
dIa(i_state) = dIa(i_state) + dIk(i_state) * dka(i_state)
enddo
enddo
do i_state=1,N_states
ci_inv(i_state) = 1.d0/psi_ref_coef(i_I,i_state)
enddo
do l_sd=1,idx_alpha(0)
k_sd = idx_alpha(l_sd)
call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hla)
do i_state=1,N_states
dIa_hla(i_state,k_sd) = dIa(i_state) * hla
enddo
enddo
call omp_set_lock( psi_ref_lock(i_I) )
do l_sd=1,idx_alpha(0)
k_sd = idx_alpha(l_sd)
do i_state=1,N_states
delta_ij_(i_I,k_sd,i_state) += dIa_hla(i_state,k_sd)
if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5)then
delta_ii_(i_I,i_state) -= dIa_hla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef(k_sd,i_state)
else
delta_ii_(i_I,i_state) = 0.d0
endif
enddo
enddo
call omp_unset_lock( psi_ref_lock(i_I) )
exit
endif
enddo
do i_state=1,Nstates
dIa(i_state) = dIa(i_state) + dIk(i_state) * dka(i_state)
enddo
enddo
do i_state=1,Nstates
ci_inv(i_state) = 1.d0/psi_ref_coef(i_I,i_state)
enddo
do l_sd=1,idx_alpha(0)
k_sd = idx_alpha(l_sd)
hla = hij_cache(k_sd)
! call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hla)
do i_state=1,Nstates
dIa_hla(i_state,k_sd) = dIa(i_state) * hla
enddo
enddo
call omp_set_lock( psi_ref_lock(i_I) )
do l_sd=1,idx_alpha(0)
k_sd = idx_alpha(l_sd)
do i_state=1,Nstates
delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + dIa_hla(i_state,k_sd)
if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5)then
delta_ii_(i_state,i_I) = delta_ii_(i_state,i_I) - dIa_hla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd)
else
delta_ii_(i_state,i_I) = 0.d0
endif
enddo
enddo
call omp_unset_lock( psi_ref_lock(i_I) )
enddo
enddo
deallocate (dIa_hla)
deallocate(miniList, idx_miniList)
!deallocate (dIa_hla,hij_cache)
!deallocate(miniList, idx_miniList)
end
BEGIN_PROVIDER [ integer(bit_kind), gen_det_sorted, (N_int,2,N_det_generators,2) ]
&BEGIN_PROVIDER [ integer, gen_det_shortcut, (0:N_det_generators,2) ]
&BEGIN_PROVIDER [ integer, gen_det_version, (N_int, N_det_generators,2) ]
&BEGIN_PROVIDER [ integer, gen_det_idx, (N_det_generators,2) ]
gen_det_sorted(:,:,:,1) = psi_det_generators(:,:,:N_det_generators)
gen_det_sorted(:,:,:,2) = psi_det_generators(:,:,:N_det_generators)
call sort_dets_ab_v(gen_det_sorted(:,:,:,1), gen_det_idx(:,1), gen_det_shortcut(0:,1), gen_det_version(:,:,1), N_det_generators, N_int)
call sort_dets_ba_v(gen_det_sorted(:,:,:,2), gen_det_idx(:,2), gen_det_shortcut(0:,2), gen_det_version(:,:,2), N_det_generators, N_int)
END_PROVIDER
subroutine find_triples_and_quadruples(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_miniList)
@ -224,6 +338,7 @@ subroutine find_triples_and_quadruples(i_generator,n_selected,det_buffer,Nint,tq
N_tq = 0
i_loop : do i=1,N_selected
if(is_connected_to(det_buffer(1,1,i), miniList, Nint, N_miniList)) then
cycle
@ -253,8 +368,84 @@ subroutine find_triples_and_quadruples(i_generator,n_selected,det_buffer,Nint,tq
end
subroutine find_triples_and_quadruples_micro(i_generator,n_selected,det_buffer,Nint,tq,N_tq,microlist,ptr_microlist,N_microlist,key_mask)
use bitmasks
implicit none
integer, intent(in) :: i_generator,n_selected, Nint
integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected)
integer :: i,j,k,m
logical :: is_in_wavefunction
integer :: degree(psi_det_size)
integer :: idx(0:psi_det_size)
logical :: good
integer(bit_kind), intent(out) :: tq(Nint,2,n_selected)
integer, intent(out) :: N_tq
integer :: nt,ni
logical, external :: is_connected_to
integer(bit_kind),intent(in) :: microlist(Nint,2,*)
integer,intent(in) :: ptr_microlist(0:*)
integer,intent(in) :: N_microlist(0:*)
integer(bit_kind),intent(in) :: key_mask(Nint, 2)
integer :: mobiles(2), smallerlist
N_tq = 0
i_loop : do i=1,N_selected
call getMobiles(det_buffer(1,1,i), key_mask, mobiles, Nint)
if(N_microlist(mobiles(1)) < N_microlist(mobiles(2))) then
smallerlist = mobiles(1)
else
smallerlist = mobiles(2)
end if
if(N_microlist(smallerlist) > 0) then
if(is_connected_to(det_buffer(1,1,i), microlist(1,1,ptr_microlist(smallerlist)), Nint, N_microlist(smallerlist))) then
cycle
end if
end if
if(N_microlist(0) > 0) then
if(is_connected_to(det_buffer(1,1,i), microlist, Nint, N_microlist(0))) then
cycle
end if
end if
! Select determinants that are triple or quadruple excitations
! from the ref
good = .True.
call get_excitation_degree_vector(psi_ref,det_buffer(1,1,i),degree,Nint,N_det_ref,idx)
!good=(idx(0) == 0) tant que degree > 2 pas retourné par get_excitation_degree_vector
do k=1,idx(0)
if (degree(k) < 3) then
good = .False.
exit
endif
enddo
if (good) then
if (.not. is_in_wavefunction(det_buffer(1,1,i),Nint,N_det)) then
N_tq += 1
do k=1,N_int
tq(k,1,N_tq) = det_buffer(k,1,i)
tq(k,2,N_tq) = det_buffer(k,2,i)
enddo
endif
endif
enddo i_loop
end

16
plugins/MRCC_Utils/mrcc_general.irp.f
View File

@ -31,23 +31,7 @@ subroutine mrcc_iterations
E_past(j) = E_new
j +=1
if(j>4)then
j=1
endif
if(iteration > 4) then
if(delta_E > 1.d-10)then
if(dabs(E_past(1) - E_past(3)) .le. delta_E .and. dabs(E_past(2) - E_past(4)).le. delta_E)then
print*,'OSCILLATIONS !!!'
oscillations = .True.
i_oscillations +=1
lambda_mrcc_tmp = lambda_mrcc
endif
endif
endif
call save_wavefunction
! if (i_oscillations > 5) then
! exit
! endif
if (iteration > 200) then
exit
endif

217
plugins/MRCC_Utils/mrcc_utils.irp.f
View File

@ -1,106 +1,81 @@
! BEGIN_PROVIDER [ double precision, lambda_mrcc, (N_states,psi_det_size) ]
! implicit none
! BEGIN_DOC
! ! cm/<Psi_0|H|D_m> or perturbative 1/Delta_E(m)
! END_DOC
! integer :: i,k
! double precision :: ihpsi(N_states),ihpsi_current(N_states)
! integer :: i_pert_count
!
! i_pert_count = 0
! lambda_mrcc = 0.d0
!
! do i=1,N_det_non_ref
! call i_h_psi(psi_non_ref(1,1,i), psi_ref, psi_ref_coef, N_int, N_det_ref,size(psi_ref_coef,1), n_states, ihpsi_current)
! do k=1,N_states
! if (ihpsi_current(k) == 0.d0) then
! ihpsi_current(k) = 1.d-32
! endif
! if(dabs(ihpsi_current(k) * psi_non_ref_coef(i,k)) < 1d-6) then
! i_pert_count +=1
! else
! lambda_mrcc(k,i) = psi_non_ref_coef(i,k)/ihpsi_current(k)
! endif
! enddo
! enddo
!
! print*,'N_det_non_ref = ',N_det_non_ref
! print*,'Number of ignored determinants = ',i_pert_count
! print*,'psi_coef_ref_ratio = ',psi_ref_coef(2,1)/psi_ref_coef(1,1)
! END_PROVIDER
BEGIN_PROVIDER [integer, pert_determinants, (N_states, psi_det_size) ]
END_PROVIDER
BEGIN_PROVIDER [ double precision, lambda_mrcc, (N_states,psi_det_size) ]
&BEGIN_PROVIDER [ double precision, lambda_pert, (N_states,psi_det_size) ]
BEGIN_PROVIDER [ double precision, lambda_mrcc, (N_states,psi_det_size) ]
implicit none
BEGIN_DOC
! cm/<Psi_0|H|D_m> or perturbative 1/Delta_E(m)
END_DOC
integer :: i,k,j
double precision :: ihpsi(N_states), hii,delta_e_eff,ihpsi_current(N_states),hij
integer :: i_ok,i_pert,i_pert_count
i_ok = 0
double precision :: phase_restart(N_states),tmp
do k = 1, N_states
phase_restart(k) = dsign(1.d0,psi_ref_coef_restart(1,k)/psi_ref_coef(1,k))
enddo
i_pert_count = 0
integer :: i,k
double precision :: ihpsi_current(N_states)
integer :: i_pert_count
double precision :: hii, lambda_pert
i_pert_count = 0
lambda_mrcc = 0.d0
do i=1,N_det_non_ref
call i_h_psi(psi_non_ref(1,1,i), psi_ref, psi_ref_coef, N_int, N_det_ref, &
size(psi_ref_coef,1), N_states,ihpsi_current)
call i_H_j(psi_non_ref(1,1,i),psi_non_ref(1,1,i),N_int,hii)
do k=1,N_states
if (ihpsi_current(k) == 0.d0) then
ihpsi_current(k) = 1.d-32
endif
lambda_mrcc(k,i) = psi_non_ref_coef(i,k)/ihpsi_current(k)
if ( dabs(psi_non_ref_coef(i,k)*ihpsi_current(k)) < 1.d-6 ) then
i_pert_count += 1
lambda_mrcc(k,i) = 0.d0
! lambda_pert = 1.d0 / (psi_ref_energy_diagonalized(k)-hii)
! if((ihpsi_current(k) * lambda_pert) < 0.5d0 * psi_non_ref_coef_restart(i,k) ) then
! lambda_mrcc(k,i) = 0.d0
! endif
endif
double precision, parameter :: x = 2.d0
if (lambda_mrcc(k,i) > x) then
lambda_mrcc(k,i) = x
else if (lambda_mrcc(k,i) < -x) then
lambda_mrcc(k,i) = -x
endif
enddo
enddo
do i=1,N_det_non_ref
call i_h_psi(psi_non_ref(1,1,i), psi_ref_restart, psi_ref_coef_restart, N_int, N_det_ref,&
size(psi_ref_coef_restart,1), n_states, ihpsi)
call i_H_j(psi_non_ref(1,1,i),psi_non_ref(1,1,i),N_int,hii)
! TODO --- Test perturbatif ------
do k=1,N_states
lambda_pert(k,i) = 1.d0 / (psi_ref_energy_diagonalized(k)-hii)
! TODO : i_h_psi peut sortir de la boucle?
call i_h_psi(psi_non_ref(1,1,i), psi_ref, psi_ref_coef, N_int, N_det_ref,size(psi_ref_coef,1), n_states, ihpsi_current)
if (ihpsi_current(k) == 0.d0) then
ihpsi_current(k) = 1.d-32
endif
tmp = psi_non_ref_coef(i,k)/ihpsi_current(k)
i_pert = 0
! Perturbation only if 1st order < 0.5 x second order
if((ihpsi(k) * lambda_pert(k,i)) < 0.5d0 * psi_non_ref_coef_restart(i,k) )then
i_pert = 1
else
do j = 1, N_det_ref
call i_H_j(psi_non_ref(1,1,i),psi_ref(1,1,j),N_int,hij)
! Perturbation diverges when hij*tmp > 0.5
if(dabs(hij * tmp).ge.0.5d0)then
i_pert_count +=1
i_pert = 1
exit
endif
enddo
endif
i_pert = 0
if( i_pert == 1)then
pert_determinants(k,i) = i_pert
endif
if(pert_determinants(k,i) == 1)then
i_ok +=1
lambda_mrcc(k,i) = lambda_pert(k,i)
else
lambda_mrcc(k,i) = psi_non_ref_coef(i,k)/ihpsi_current(k)
endif
enddo
! TODO --- Fin test perturbatif ------
enddo
!if(oscillations)then
! print*,'AVERAGING the lambda_mrcc with those of the previous iterations'
! do i = 1, N_det_non_ref
! do k = 1, N_states
! double precision :: tmp
! tmp = lambda_mrcc(k,i)
! lambda_mrcc(k,i) += lambda_mrcc_tmp(k,i)
! lambda_mrcc(k,i) = lambda_mrcc(k,i) * 0.5d0
! if(dabs(tmp - lambda_mrcc(k,i)).ge.1.d-9)then
! print*,''
! print*,'i = ',i
! print*,'psi_non_ref_coef(i,k) = ',psi_non_ref_coef(i,k)
! print*,'lambda_mrcc(k,i) = ',lambda_mrcc(k,i)
! print*,' tmp = ',tmp
! endif
! enddo
! enddo
!endif
print*,'N_det_non_ref = ',N_det_non_ref
print*,'Number of Perturbatively treated determinants = ',i_ok
print*,'i_pert_count = ',i_pert_count
print*,'psi_coef_ref_ratio = ',psi_ref_coef(2,1)/psi_ref_coef(1,1)
print*,'N_det_non_ref = ',N_det_non_ref
print*,'Number of ignored determinants = ',i_pert_count
print*,'psi_coef_ref_ratio = ',psi_ref_coef(2,1)/psi_ref_coef(1,1)
print*,'lambda min/max = ',maxval(dabs(lambda_mrcc)), minval(dabs(lambda_mrcc))
END_PROVIDER
BEGIN_PROVIDER [ double precision, lambda_mrcc_tmp, (N_states,psi_det_size) ]
implicit none
lambda_mrcc_tmp = 0.d0
END_PROVIDER
BEGIN_PROVIDER [ logical, oscillations ]
implicit none
oscillations = .False.
END_PROVIDER
!BEGIN_PROVIDER [ double precision, delta_ij_non_ref, (N_det_non_ref, N_det_non_ref,N_states) ]
!implicit none
!BEGIN_DOC
@ -110,8 +85,22 @@ END_PROVIDER
!call H_apply_mrcc_simple(delta_ij_non_ref,N_det_non_ref)
!END_PROVIDER
BEGIN_PROVIDER [ double precision, delta_ij, (N_det_ref,N_det_non_ref,N_states) ]
&BEGIN_PROVIDER [ double precision, delta_ii, (N_det_ref,N_states) ]
BEGIN_PROVIDER [ double precision, hij_mrcc, (N_det_non_ref,N_det_ref) ]
implicit none
BEGIN_DOC
! < ref | H | Non-ref > matrix
END_DOC
integer :: i_I, k_sd
do i_I=1,N_det_ref
do k_sd=1,N_det_non_ref
call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,k_sd),N_int,hij_mrcc(k_sd,i_I))
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, delta_ij, (N_states,N_det_non_ref,N_det_ref) ]
&BEGIN_PROVIDER [ double precision, delta_ii, (N_states,N_det_ref) ]
implicit none
BEGIN_DOC
! Dressing matrix in N_det basis
@ -119,33 +108,7 @@ END_PROVIDER
integer :: i,j,m
delta_ij = 0.d0
delta_ii = 0.d0
call H_apply_mrcc(delta_ij,delta_ii,N_det_ref,N_det_non_ref)
double precision :: max_delta
double precision :: accu
integer :: imax,jmax
max_delta = 0.d0
accu = 0.d0
do i = 1, N_det_ref
do j = 1, N_det_non_ref
accu += psi_non_ref_coef(j,1) * psi_ref_coef(i,1) * delta_ij(i,j,1)
if(dabs(delta_ij(i,j,1)).gt.max_delta)then
max_delta = dabs(delta_ij(i,j,1))
imax = i
jmax = j
endif
enddo
enddo
!stop "movais delta"
print*,''
print*,''
print*,'<psi| Delta H |psi> = ',accu
print*,'MAX VAL OF DRESING = ',delta_ij(imax,jmax,1)
print*,'imax,jmax = ',imax,jmax
print*,'psi_ref_coef(imax,1) = ',psi_ref_coef(imax,1)
print*,'psi_non_ref_coef(jmax,1) = ',psi_non_ref_coef(jmax,1)
do i = 1, N_det_ref
print*,'delta_ii(i,1) = ',delta_ii(i,1)
enddo
call H_apply_mrcc(delta_ij,delta_ii,N_states,N_det_non_ref,N_det_ref)
END_PROVIDER
BEGIN_PROVIDER [ double precision, h_matrix_dressed, (N_det,N_det,N_states) ]
@ -162,11 +125,11 @@ BEGIN_PROVIDER [ double precision, h_matrix_dressed, (N_det,N_det,N_states) ]
enddo
do ii = 1, N_det_ref
i =idx_ref(ii)
h_matrix_dressed(i,i,istate) += delta_ii(ii,istate)
h_matrix_dressed(i,i,istate) += delta_ii(istate,ii)
do jj = 1, N_det_non_ref
j =idx_non_ref(jj)
h_matrix_dressed(i,j,istate) += delta_ij(ii,jj,istate)
h_matrix_dressed(j,i,istate) += delta_ij(ii,jj,istate)
h_matrix_dressed(i,j,istate) += delta_ij(istate,jj,ii)
h_matrix_dressed(j,i,istate) += delta_ij(istate,jj,ii)
enddo
enddo
enddo
@ -262,11 +225,9 @@ subroutine diagonalize_CI_dressed
! eigenstates of the CI matrix
END_DOC
integer :: i,j
double precision, parameter :: speed = 1d0
do j=1,N_states_diag
do i=1,N_det
psi_coef(i,j) = CI_eigenvectors_dressed(i,j) * speed + psi_coef(i,j) * (1d0 - speed)
psi_coef(i,j) = CI_eigenvectors_dressed(i,j)
enddo
enddo
SOFT_TOUCH psi_coef

260
plugins/MRCC_Utils/mrcepa_dress.irp.f
View File

@ -1,260 +0,0 @@
use omp_lib
use bitmasks
subroutine mrcepa_dress(delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref,i_generator,n_selected,det_buffer,Nint,iproc,key_mask)
use bitmasks
implicit none
integer, intent(in) :: i_generator,n_selected, Nint, iproc
integer, intent(in) :: Ndet_ref, Ndet_non_ref
double precision, intent(inout) :: delta_ij_(Ndet_ref,Ndet_non_ref,*)
double precision, intent(inout) :: delta_ii_(Ndet_ref,*)
integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected)
integer :: i,j,k,l
integer :: degree_alpha(psi_det_size)
integer :: idx_alpha(0:psi_det_size)
logical :: good, fullMatch
integer(bit_kind) :: tq(Nint,2,n_selected)
integer :: N_tq, c_ref ,degree
double precision :: hIk, hla, hIl, dIk(N_states), dka(N_states), dIa(N_states)
double precision, allocatable :: dIa_hia(:,:)
double precision :: haj, phase, phase2
double precision :: f(N_states), ci_inv(N_states)
integer :: exc(0:2,2,2)
integer :: h1,h2,p1,p2,s1,s2
integer(bit_kind) :: tmp_det(Nint,2)
integer(bit_kind) :: tmp_det_0(Nint,2)
integer :: iint, ipos
integer :: i_state, i_sd, k_sd, l_sd, i_I, i_alpha
integer(bit_kind),allocatable :: miniList(:,:,:)
integer(bit_kind),intent(in) :: key_mask(Nint, 2)
integer,allocatable :: idx_miniList(:)
integer :: N_miniList, ni, leng
integer(bit_kind) :: isum
double precision :: hia
integer, allocatable :: index_sorted(:)
leng = max(N_det_generators, N_det_non_ref)
allocate(miniList(Nint, 2, leng), idx_miniList(leng), index_sorted(N_det))
!create_minilist_find_previous(key_mask, fullList, miniList, N_fullList, N_miniList, fullMatch, Nint)
call create_minilist_find_previous(key_mask, psi_det_generators, miniList, i_generator-1, N_miniList, fullMatch, Nint)
if(fullMatch) then
return
end if
call find_triples_and_quadruples(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist)
allocate (dIa_hia(N_states,Ndet_non_ref))
! |I>
! |alpha>
if(N_tq > 0) then
call create_minilist(key_mask, psi_non_ref, miniList, idx_miniList, N_det_non_ref, N_minilist, Nint)
end if
do i_alpha=1,N_tq
! call get_excitation_degree_vector(psi_non_ref,tq(1,1,i_alpha),degree_alpha,Nint,N_det_non_ref,idx_alpha)
call get_excitation_degree_vector(miniList,tq(1,1,i_alpha),degree_alpha,Nint,N_minilist,idx_alpha)
integer, external :: get_index_in_psi_det_sorted_bit
index_sorted = huge(-1)
do j=1,idx_alpha(0)
idx_alpha(j) = idx_miniList(idx_alpha(j))
index_sorted( get_index_in_psi_det_sorted_bit( psi_non_ref(1,1,idx_alpha(j)), N_int ) ) = idx_alpha(j)
end do
! |I>
do i_I=1,N_det_ref
! Find triples and quadruple grand parents
call get_excitation_degree(tq(1,1,i_alpha),psi_ref(1,1,i_I),degree,Nint)
if (degree > 4) then
cycle
endif
do i_state=1,N_states
dIa(i_state) = 0.d0
enddo
!TODO: MR
do i_sd=1,idx_alpha(0)
call get_excitation_degree(psi_non_ref(1,1,idx_alpha(i_sd)),tq(1,1,i_alpha),degree,Nint)
if (degree > 2) then
cycle
endif
call get_excitation(psi_non_ref(1,1,idx_alpha(i_sd)),tq(1,1,i_alpha),exc,degree,phase,Nint)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
tmp_det_0 = 0_bit_kind
! Hole (see list_to_bitstring)
iint = ishft(h1-1,-bit_kind_shift) + 1
ipos = h1-ishft((iint-1),bit_kind_shift)-1
tmp_det_0(iint,s1) = ibset(tmp_det_0(iint,s1),ipos)
! Particle
iint = ishft(p1-1,-bit_kind_shift) + 1
ipos = p1-ishft((iint-1),bit_kind_shift)-1
tmp_det_0(iint,s1) = ibset(tmp_det_0(iint,s1),ipos)
if (degree == 2) then
! Hole (see list_to_bitstring)
iint = ishft(h2-1,-bit_kind_shift) + 1
ipos = h2-ishft((iint-1),bit_kind_shift)-1
tmp_det_0(iint,s2) = ibset(tmp_det_0(iint,s2),ipos)
! Particle
iint = ishft(p2-1,-bit_kind_shift) + 1
ipos = p2-ishft((iint-1),bit_kind_shift)-1
tmp_det_0(iint,s2) = ibset(tmp_det_0(iint,s2),ipos)
endif
call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(i_sd)),Nint,hia)
! <I| <> |alpha>
do k_sd=1,idx_alpha(0)
call get_excitation_degree(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),degree,Nint)
if (degree > 2) then
cycle
endif
call get_excitation(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),exc,degree,phase,Nint)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
tmp_det = 0_bit_kind
! Hole (see list_to_bitstring)
iint = ishft(h1-1,-bit_kind_shift) + 1
ipos = h1-ishft((iint-1),bit_kind_shift)-1
tmp_det(iint,s1) = ibset(tmp_det(iint,s1),ipos)
! Particle
iint = ishft(p1-1,-bit_kind_shift) + 1
ipos = p1-ishft((iint-1),bit_kind_shift)-1
tmp_det(iint,s1) = ibset(tmp_det(iint,s1),ipos)
if (degree == 2) then
! Hole (see list_to_bitstring)
iint = ishft(h2-1,-bit_kind_shift) + 1
ipos = h2-ishft((iint-1),bit_kind_shift)-1
tmp_det(iint,s2) = ibset(tmp_det(iint,s2),ipos)
! Particle
iint = ishft(p2-1,-bit_kind_shift) + 1
ipos = p2-ishft((iint-1),bit_kind_shift)-1
tmp_det(iint,s2) = ibset(tmp_det(iint,s2),ipos)
endif
isum = 0_bit_kind
do iint = 1,N_int
isum = isum + iand(tmp_det(iint,1), tmp_det_0(iint,1)) &
+ iand(tmp_det(iint,2), tmp_det_0(iint,2))
enddo
if (isum /= 0_bit_kind) then
cycle
endif
! <I| /k\ |alpha>
! <I|H|k>
call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),Nint,hIk)
do i_state=1,N_states
dIk(i_state) = hIk * lambda_mrcc(i_state,idx_alpha(k_sd))
enddo
! |l> = Exc(k -> alpha) |I>
call get_excitation(psi_non_ref(1,1,idx_alpha(k_sd)),tq(1,1,i_alpha),exc,degree,phase,Nint)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
do k=1,N_int
tmp_det(k,1) = psi_ref(k,1,i_I)
tmp_det(k,2) = psi_ref(k,2,i_I)
enddo
! Hole (see list_to_bitstring)
iint = ishft(h1-1,-bit_kind_shift) + 1
ipos = h1-ishft((iint-1),bit_kind_shift)-1
tmp_det(iint,s1) = ibclr(tmp_det(iint,s1),ipos)
! Particle
iint = ishft(p1-1,-bit_kind_shift) + 1
ipos = p1-ishft((iint-1),bit_kind_shift)-1
tmp_det(iint,s1) = ibset(tmp_det(iint,s1),ipos)
if (degree == 2) then
! Hole (see list_to_bitstring)
iint = ishft(h2-1,-bit_kind_shift) + 1
ipos = h2-ishft((iint-1),bit_kind_shift)-1
tmp_det(iint,s2) = ibclr(tmp_det(iint,s2),ipos)
! Particle
iint = ishft(p2-1,-bit_kind_shift) + 1
ipos = p2-ishft((iint-1),bit_kind_shift)-1
tmp_det(iint,s2) = ibset(tmp_det(iint,s2),ipos)
endif
! <I| \l/ |alpha>
do i_state=1,N_states
dka(i_state) = 0.d0
enddo
! l_sd = index_sorted( get_index_in_psi_det_sorted_bit( tmp_det, N_int ) )
! call get_excitation(psi_ref(1,1,i_I),psi_non_ref(1,1,l_sd),exc,degree,phase2,Nint)
! call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,l_sd),Nint,hIl)
! do i_state=1,N_states
! dka(i_state) = hIl * lambda_mrcc(i_state,l_sd) * phase * phase2
! enddo
do l_sd=1,idx_alpha(0)
call get_excitation_degree(tmp_det,psi_non_ref(1,1,idx_alpha(l_sd)),degree,Nint)
if (degree == 0) then
call get_excitation(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),exc,degree,phase2,Nint)
call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hIl)
do i_state=1,N_states
dka(i_state) = hIl * lambda_mrcc(i_state,idx_alpha(l_sd)) * phase * phase2
enddo
exit
endif
enddo
do i_state=1,N_states
dIa(i_state) = dIa(i_state) + dIk(i_state) * dka(i_state)
enddo
enddo
do i_state=1,N_states
ci_inv(i_state) = 1.d0/psi_ref_coef(i_I,i_state)
enddo
k_sd = idx_alpha(i_sd)
do i_state=1,N_states
dIa_hia(i_state,k_sd) = dIa(i_state) * hia
enddo
call omp_set_lock( psi_ref_lock(i_I) )
do i_state=1,N_states
delta_ij_(i_I,k_sd,i_state) += dIa_hia(i_state,k_sd)
if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5)then
delta_ii_(i_I,i_state) -= dIa_hia(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef(k_sd,i_state)
else
delta_ii_(i_I,i_state) = 0.d0
endif
enddo
call omp_unset_lock( psi_ref_lock(i_I) )
enddo
enddo
enddo
deallocate (dIa_hia,index_sorted)
deallocate(miniList, idx_miniList)
end

97
plugins/MRCC_Utils/mrcepa_general.irp.f
View File

@ -1,97 +0,0 @@
subroutine run_mrcepa
implicit none
call set_generators_bitmasks_as_holes_and_particles
call mrcepa_iterations
end
subroutine mrcepa_iterations
implicit none
integer :: i,j
double precision :: E_new, E_old, delta_e
integer :: iteration,i_oscillations
double precision :: E_past(4)
E_new = 0.d0
delta_E = 1.d0
iteration = 0
j = 1
i_oscillations = 0
do while (delta_E > 1.d-7)
iteration += 1
print *, '==========================='
print *, 'MRCEPA Iteration', iteration
print *, '==========================='
print *, ''
E_old = sum(ci_energy_dressed)
call write_double(6,ci_energy_dressed(1),"MRCEPA energy")
call diagonalize_ci_dressed
E_new = sum(ci_energy_dressed)
delta_E = dabs(E_new - E_old)
E_past(j) = E_new
j +=1
if(j>4)then
j=1
endif
if(iteration > 4) then
if(delta_E > 1.d-10)then
if(dabs(E_past(1) - E_past(3)) .le. delta_E .and. dabs(E_past(2) - E_past(4)).le. delta_E)then
print*,'OSCILLATIONS !!!'
oscillations = .True.
i_oscillations +=1
lambda_mrcc_tmp = lambda_mrcc
endif
endif
endif
call save_wavefunction
! if (i_oscillations > 5) then
! exit
! endif
if (iteration > 200) then
exit
endif
print*,'------------'
print*,'VECTOR'
do i = 1, N_det_ref
print*,''
print*,'psi_ref_coef(i,1) = ',psi_ref_coef(i,1)
print*,'delta_ii(i,1) = ',delta_ii(i,1)
enddo
print*,'------------'
enddo
call write_double(6,ci_energy_dressed(1),"Final MRCEPA energy")
call ezfio_set_mrcc_cassd_energy(ci_energy_dressed(1))
call save_wavefunction
end
subroutine set_generators_bitmasks_as_holes_and_particles
implicit none
integer :: i,k
do k = 1, N_generators_bitmask
do i = 1, N_int
! Pure single part
generators_bitmask(i,1,1,k) = holes_operators(i,1) ! holes for pure single exc alpha
generators_bitmask(i,1,2,k) = particles_operators(i,1) ! particles for pure single exc alpha
generators_bitmask(i,2,1,k) = holes_operators(i,2) ! holes for pure single exc beta
generators_bitmask(i,2,2,k) = particles_operators(i,2) ! particles for pure single exc beta
! Double excitation
generators_bitmask(i,1,3,k) = holes_operators(i,1) ! holes for first single exc alpha
generators_bitmask(i,1,4,k) = particles_operators(i,1) ! particles for first single exc alpha
generators_bitmask(i,2,3,k) = holes_operators(i,2) ! holes for first single exc beta
generators_bitmask(i,2,4,k) = particles_operators(i,2) ! particles for first single exc beta
generators_bitmask(i,1,5,k) = holes_operators(i,1) ! holes for second single exc alpha
generators_bitmask(i,1,6,k) = particles_operators(i,1) ! particles for second single exc alpha
generators_bitmask(i,2,5,k) = holes_operators(i,2) ! holes for second single exc beta
generators_bitmask(i,2,6,k) = particles_operators(i,2) ! particles for second single exc beta
enddo
enddo
touch generators_bitmask
end

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

25
plugins/Psiref_Utils/psi_ref_utils.irp.f
View File

@ -14,6 +14,31 @@ use bitmasks
END_PROVIDER
BEGIN_PROVIDER [ double precision, psi_ref_coef_transp, (n_states,psi_det_size) ]
implicit none
BEGIN_DOC
! Transposed psi_ref_coef
END_DOC
integer :: i,j
do j=1,N_det_ref
do i=1, n_states
psi_ref_coef_transp(i,j) = psi_ref_coef(j,i)
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, psi_non_ref_coef_transp, (n_states,psi_det_size) ]
implicit none
BEGIN_DOC
! Transposed psi_non_ref_coef
END_DOC
integer :: i,j
do j=1,N_det_non_ref
do i=1, n_states
psi_non_ref_coef_transp(i,j) = psi_non_ref_coef(j,i)
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), psi_non_ref, (N_int,2,psi_det_size) ]
&BEGIN_PROVIDER [ double precision, psi_non_ref_coef, (psi_det_size,n_states) ]

97
plugins/Selectors_full/selectors.irp.f
View File

@ -61,100 +61,3 @@ END_PROVIDER
END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), psi_selectors_ab, (N_int,2,psi_selectors_size) ]
&BEGIN_PROVIDER [ double precision, psi_selectors_coef_ab, (psi_selectors_size,N_states) ]
&BEGIN_PROVIDER [ integer, psi_selectors_next_ab, (2,psi_selectors_size) ]
implicit none
BEGIN_DOC
! Determinants on which we apply <i|H|j>.
! They are sorted by the 3 highest electrons in the alpha part,
! then by the 3 highest electrons in the beta part to accelerate
! the research of connected determinants.
END_DOC
integer :: i,j,k
integer, allocatable :: iorder(:)
integer*8, allocatable :: bit_tmp(:)
integer*8, external :: det_search_key
allocate ( iorder(N_det_selectors), bit_tmp(N_det_selectors) )
! Sort alpha dets
! ---------------
integer(bit_kind) :: det_tmp(N_int)
do i=1,N_det_selectors
iorder(i) = i
call int_of_3_highest_electrons(psi_selectors(1,1,i),bit_tmp(i),N_int)
enddo
call i8sort(bit_tmp,iorder,N_det_selectors)
!DIR$ IVDEP
do i=1,N_det_selectors
do j=1,N_int
psi_selectors_ab(j,1,i) = psi_selectors(j,1,iorder(i))
psi_selectors_ab(j,2,i) = psi_selectors(j,2,iorder(i))
enddo
do k=1,N_states
psi_coef_sorted_ab(i,k) = psi_selectors_coef(iorder(i),k)
enddo
enddo
! Find next alpha
! ---------------
integer :: next
next = N_det_selectors+1
psi_selectors_next_ab(1,N_det_selectors) = next
do i=N_det_selectors-1,1,-1
if (bit_tmp(i) /= bit_tmp(i+1)) then
next = i+1
endif
psi_selectors_next_ab(1,i) = next
enddo
! Sort beta dets
! --------------
integer :: istart, iend
integer(bit_kind), allocatable :: psi_selectors_ab_temp (:,:)
allocate ( psi_selectors_ab_temp (N_int,N_det_selectors) )
do i=1,N_det_selectors
do j=1,N_int
psi_selectors_ab_temp(j,i) = psi_selectors_ab(j,2,i)
enddo
iorder(i) = i
call int_of_3_highest_electrons(psi_selectors_ab_temp(1,i),bit_tmp(i),N_int)
enddo
istart=1
do while ( istart<N_det_selectors )
iend = psi_selectors_next_ab(1,istart)
call i8sort(bit_tmp(istart),iorder(istart),iend-istart)
!DIR$ IVDEP
do i=istart,iend-1
do j=1,N_int
psi_selectors_ab(j,2,i) = psi_selectors_ab_temp(j,iorder(i))
enddo
do k=1,N_states
psi_coef_sorted_ab(i,k) = psi_coef(iorder(i),k)
enddo
enddo
next = iend
psi_selectors_next_ab(2,iend-1) = next
do i=iend-2,1,-1
if (bit_tmp(i) /= bit_tmp(i+1)) then
next = i+1
endif
psi_selectors_next_ab(2,i) = next
enddo
istart = iend
enddo
deallocate(iorder, bit_tmp, psi_selectors_ab_temp)
END_PROVIDER

105
plugins/Selectors_full/zmq.irp.f Normal file
View File

@ -0,0 +1,105 @@
subroutine zmq_put_psi(zmq_to_qp_run_socket,worker_id)
use f77_zmq
implicit none
BEGIN_DOC
! Put the wave function on the qp_run scheduler
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
integer, intent(in) :: worker_id
integer :: rc
character*(256) :: msg
write(msg,*) 'put_psi ', worker_id, N_states, N_det, psi_det_size, n_det_generators, n_det_selectors
rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),ZMQ_SNDMORE)
if (rc /= len(trim(msg))) then
print *, 'f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),ZMQ_SNDMORE)'
stop 'error'
endif
rc = f77_zmq_send(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)
if (rc /= N_int*2*N_det*bit_kind) then
print *, 'f77_zmq_send(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)'
stop 'error'
endif
rc = f77_zmq_send(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,0)
if (rc /= psi_det_size*N_states*8) then
print *, 'f77_zmq_send(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,0)'
stop 'error'
endif
rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0)
if (msg(1:rc) /= 'put_psi_reply 1') then
print *, rc, trim(msg)
print *, 'Error in put_psi_reply'
stop 'error'
endif
end
subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id)
use f77_zmq
implicit none
BEGIN_DOC
! Get the wave function from the qp_run scheduler
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
integer, intent(in) :: worker_id
integer :: rc
character*(64) :: msg
write(msg,*) 'get_psi ', worker_id
rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),0)
if (rc /= len(trim(msg))) then
print *, 'f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),0)'
stop 'error'
endif
rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0)
if (msg(1:13) /= 'get_psi_reply') then
print *, rc, trim(msg)
print *, 'Error in get_psi_reply'
stop 'error'
endif
integer :: N_states_read, N_det_read, psi_det_size_read
integer :: N_det_selectors_read, N_det_generators_read
read(msg(14:rc),*) rc, N_states_read, N_det_read, psi_det_size_read, &
N_det_selectors_read, N_det_generators_read
if (rc /= worker_id) then
print *, 'Wrong worker ID'
stop 'error'
endif
N_states = N_states_read
N_det = N_det_read
psi_det_size = psi_det_size_read
TOUCH psi_det_size N_det N_states
rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)
if (rc /= N_int*2*N_det*bit_kind) then
print *, 'f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)'
stop 'error'
endif
rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,0)
if (rc /= psi_det_size*N_states*8) then
print *, '77_zmq_recv(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,0)'
stop 'error'
endif
if (N_det_generators_read > 0) then
N_det_generators = N_det_generators_read
endif
if (N_det_selectors_read > 0) then
N_det_selectors = N_det_selectors_read
endif
SOFT_TOUCH psi_det psi_coef N_det_selectors N_det_generators
end

97
plugins/Selectors_no_sorted/selectors.irp.f
View File

@ -57,100 +57,3 @@ END_PROVIDER
END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), psi_selectors_ab, (N_int,2,psi_selectors_size) ]
&BEGIN_PROVIDER [ double precision, psi_selectors_coef_ab, (psi_selectors_size,N_states) ]
&BEGIN_PROVIDER [ integer, psi_selectors_next_ab, (2,psi_selectors_size) ]
implicit none
BEGIN_DOC
! Determinants on which we apply <i|H|j>.
! They are sorted by the 3 highest electrons in the alpha part,
! then by the 3 highest electrons in the beta part to accelerate
! the research of connected determinants.
END_DOC
integer :: i,j,k
integer, allocatable :: iorder(:)
integer*8, allocatable :: bit_tmp(:)
integer*8, external :: det_search_key
allocate ( iorder(N_det_selectors), bit_tmp(N_det_selectors) )
! Sort alpha dets
! ---------------
integer(bit_kind) :: det_tmp(N_int)
do i=1,N_det_selectors
iorder(i) = i
call int_of_3_highest_electrons(psi_selectors(1,1,i),bit_tmp(i),N_int)
enddo
call i8sort(bit_tmp,iorder,N_det_selectors)
!DIR$ IVDEP
do i=1,N_det_selectors
do j=1,N_int
psi_selectors_ab(j,1,i) = psi_selectors(j,1,iorder(i))
psi_selectors_ab(j,2,i) = psi_selectors(j,2,iorder(i))
enddo
do k=1,N_states
psi_coef_sorted_ab(i,k) = psi_selectors_coef(iorder(i),k)
enddo
enddo
! Find next alpha
! ---------------
integer :: next
next = N_det_selectors+1
psi_selectors_next_ab(1,N_det_selectors) = next
do i=N_det_selectors-1,1,-1
if (bit_tmp(i) /= bit_tmp(i+1)) then
next = i+1
endif
psi_selectors_next_ab(1,i) = next
enddo
! Sort beta dets
! --------------
integer :: istart, iend
integer(bit_kind), allocatable :: psi_selectors_ab_temp (:,:)
allocate ( psi_selectors_ab_temp (N_int,N_det_selectors) )
do i=1,N_det_selectors
do j=1,N_int
psi_selectors_ab_temp(j,i) = psi_selectors_ab(j,2,i)
enddo
iorder(i) = i
call int_of_3_highest_electrons(psi_selectors_ab_temp(1,i),bit_tmp(i),N_int)
enddo
istart=1
do while ( istart<N_det_selectors )
iend = psi_selectors_next_ab(1,istart)
call i8sort(bit_tmp(istart),iorder(istart),iend-istart)
!DIR$ IVDEP
do i=istart,iend-1
do j=1,N_int
psi_selectors_ab(j,2,i) = psi_selectors_ab_temp(j,iorder(i))
enddo
do k=1,N_states
psi_coef_sorted_ab(i,k) = psi_coef(iorder(i),k)
enddo
enddo
next = iend
psi_selectors_next_ab(2,iend-1) = next
do i=iend-2,1,-1
if (bit_tmp(i) /= bit_tmp(i+1)) then
next = i+1
endif
psi_selectors_next_ab(2,i) = next
enddo
istart = iend
enddo
deallocate(iorder, bit_tmp, psi_selectors_ab_temp)
END_PROVIDER

63
plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py
View File

@ -9,6 +9,7 @@ print "#QP -> QMCPACK"
from ezfio import ezfio
import os
import sys
ezfio_path = sys.argv[1]
@ -17,7 +18,15 @@ ezfio.set_file(ezfio_path)
do_pseudo = ezfio.get_pseudo_do_pseudo()
if do_pseudo:
print "do_pseudo True"
zcore = ezfio.get_pseudo_nucl_charge_remove()
from qp_path import QP_ROOT
l_ele_path = os.path.join(QP_ROOT,"data","list_element.txt")
with open(l_ele_path, "r") as f:
data_raw = f.read()
l_element_raw = data_raw.split("\n")
l_element = [element_raw.split() for element_raw in l_element_raw]
d_z = dict((abr, z) for (z, abr, ele) in l_element)
else:
print "do_pseudo False"
@ -68,11 +77,10 @@ print "nucl_num", len(l_label)
print "Atomic coord in Bohr"
for i, t in enumerate(zip(l_label, l_charge, l_coord_str)):
try:
l = (t[0], t[1] + zcore[i], t[2])
except NameError:
l = t
print list_to_string(l)
t_1 = d_z[t[0]] if do_pseudo else t[1]
t_new = [t[0],t_1,t[2]]
print list_to_string(t_new)
#
# Call externet process to get the sysmetry
@ -83,7 +91,7 @@ process = subprocess.Popen(
stdout=subprocess.PIPE)
out, err = process.communicate()
basis_raw, sym_raw, _= out.split("\n\n\n")
basis_raw, sym_raw, _ , det_raw, _ = out.split("\n\n\n")
# _ __
# |_) _. _ o _ (_ _ _|_
@ -306,7 +314,7 @@ if do_pseudo:
l_str.append(l_dump)
str_ = "PARAMETERS FOR {0} ON ATOM {1} WITH ZCORE {2} AND LMAX {3} ARE"
print str_.format(a, i + 1, int(zcore[i]), int(len(l_str) - 1))
print str_.format(a, i + 1, int(d_z[a])-int(l_charge[i]), int(len(l_str) - 1))
for i, l in enumerate(l_str):
str_ = "FOR L= {0} COEFF N ZETA"
@ -315,7 +323,7 @@ if do_pseudo:
print " ", ii + 1, ll
str_ = "THE ECP RUN REMOVES {0} CORE ELECTRONS, AND THE SAME NUMBER OF PROTONS."
print str_.format(sum(zcore))
print str_.format(sum([int(d_z[a])-int(l_charge[i]) for i,a in enumerate(l_label)]))
print "END_PSEUDO"
# _
@ -329,31 +337,26 @@ print "mo_num", mo_num
print "det_num", n_det
print ""
psi_det = ezfio.get_determinants_psi_det()
psi_coef = ezfio.get_determinants_psi_coef()[0]
for c, (l_det_bit_alpha, l_det_bit_beta) in zip(psi_coef, psi_det):
print c
bin_det = ""
for i,int_det in enumerate(l_det_bit_alpha):
bin_det_raw = "{0:b}".format(int_det)[::-1]
if mo_num - 64*(i+1) > 0:
bin_det += bin_det_raw + "0" * (64*(i+1) - len(bin_det_raw))
else:
bin_det += bin_det_raw + "0" * (mo_num-64*i - len(bin_det_raw))
token = "Determinants ::"
pos = det_raw.rfind(token) + len(token)
print bin_det
det_without_header = det_raw[pos+2::]
bin_det = ""
for i,int_det in enumerate(l_det_bit_beta):
bin_det_raw = "{0:b}".format(int_det)[::-1]
if mo_num - 64*(i+1) > 0:
bin_det += bin_det_raw + "0" * (64*(i+1) - len(bin_det_raw))
else:
bin_det += bin_det_raw + "0" * (mo_num-64*i - len(bin_det_raw))
d_rep={"+":"1","-":"0"}
print bin_det
print ""
det_without_header = det_raw[pos+2::]
for line_raw in det_without_header.split("\n"):
line = line_raw
if line_raw:
try:
float(line)
except ValueError:
line= "".join([d_rep[x] if x in d_rep else x for x in line_raw])
print line.strip()
print "END_DET"

6
plugins/qmcpack/save_for_qmcpack.irp.f
View File

@ -14,6 +14,12 @@ program qmcpack
enddo
enddo
call ezfio_set_ao_basis_ao_coef(ao_coef)
do j=1,mo_tot_num
do i=1,ao_num
mo_coef(i,j) *= 1.d0/ao_coef_normalization_factor(i)
enddo
enddo
call save_mos
call system('rm '//trim(ezfio_filename)//'/mo_basis/ao_md5')
call system('$QP_ROOT/src/qmcpack/qp_convert_qmcpack_to_ezfio.py '//trim(ezfio_filename))

2
scripts/ezfio_interface/ei_handler.py
View File

@ -126,6 +126,7 @@ def get_type_dict():
fancy_type['integer*8'] = Type(None, "int", "integer*8")
fancy_type['int'] = Type(None, "int", "integer")
fancy_type['int64'] = Type(None, "int64", "integer*8")
fancy_type['float'] = Type(None, "float", "double precision")
fancy_type['double precision'] = Type(None, "float", "double precision")
@ -143,6 +144,7 @@ def get_type_dict():
# Dict to change ocaml LowLevel type into FortranLowLevel type
ocaml_to_fortran = {"int": "integer",
"int64": "integer*8",
"float": "double precision",
"logical": "logical",
"string": "character*32"}

2
scripts/ezfio_interface/qp_edit_template
View File

@ -75,7 +75,7 @@ let get s =
| Ao_basis ->
f Ao_basis.(read, to_rst)
| Determinants_by_hand ->
f Determinants_by_hand.(read, to_rst)
f Determinants_by_hand.(read_maybe, to_rst)
{section_to_rst}
end
with

147
scripts/generate_h_apply.py
View File

@ -1,46 +1,59 @@
#!/usr/bin/env python
import os
file = open(os.environ["QP_ROOT"]+'/src/Determinants/H_apply.template.f','r')
template = file.read()
file.close()
keywords = """
subroutine
parameters
params_main
initialization
check_double_excitation
copy_buffer
declarations
decls_main
keys_work
copy_buffer
finalization
generate_psi_guess
init_thread
printout_now
printout_always
deinit_thread
skip
init_main
filter_integrals
filter2p
filter2h2p
do_double_excitations
filter1h
filter1p
only_2p_single
only_2p_double
filter_only_1h1p_single
filter_only_1h1p_double
filter2h2p
filter2p
filterhole
filter_integrals
filter_only_1h1p_double
filter_only_1h1p_single
filterparticle
do_double_excitations
check_double_excitation
filter_vvvv_excitation
finalization
generate_psi_guess
initialization
init_main
init_thread
keys_work
omp_barrier
omp_do
omp_enddo
omp_end_master
omp_end_parallel
omp_master
omp_parallel
only_2p_double
only_2p_single
parameters
params_main
printout_always
printout_now
skip
subroutine
""".split()
class H_apply(object):
def read_template(self):
file = open(os.environ["QP_ROOT"]+'/src/Determinants/H_apply.template.f','r')
self.template = file.read()
file.close()
file = open(os.environ["QP_ROOT"]+'/src/Determinants/H_apply_nozmq.template.f','r')
self.template += file.read()
file.close()
def __init__(self,sub,SingleRef=False,do_mono_exc=True, do_double_exc=True):
self.read_template()
s = {}
for k in keywords:
s[k] = ""
@ -124,7 +137,7 @@ class H_apply(object):
return self.data[key]
def __repr__(self):
buffer = template
buffer = self.template
for key,value in self.data.items():
buffer = buffer.replace('$'+key, value)
return buffer
@ -176,11 +189,11 @@ class H_apply(object):
def filter_only_2p(self):
self["only_2p_single"] = """
! ! DIR$ FORCEINLINE
if (is_a_2p(hole).eq..False.) cycle
if (.not. is_a_2p(hole)) cycle
"""
self["only_2p_double"] = """
! ! DIR$ FORCEINLINE
if (is_a_2p(key).eq..False.) cycle
if (.not. is_a_2p(key)) cycle
"""
@ -248,20 +261,16 @@ class H_apply(object):
PROVIDE psi_selectors_coef psi_selectors E_corr_per_selectors psi_det_sorted_bit
"""
if self.do_double_exc == True:
self.data["keys_work"] = """
! if(check_double_excitation)then
call perturb_buffer_%s(i_generator,keys_out,key_idx,e_2_pert_buffer,coef_pert_buffer,sum_e_2_pert, &
sum_norm_pert,sum_H_pert_diag,N_st,N_int,key_mask,fock_diag_tmp)
! else
! call perturb_buffer_by_mono_%s(i_generator,keys_out,key_idx,e_2_pert_buffer,coef_pert_buffer,sum_e_2_pert, &
! sum_norm_pert,sum_H_pert_diag,N_st,N_int,key_mask,fock_diag_tmp)
! endif
"""%(pert,pert)
self.data["keys_work"] = """
! if(check_double_excitation)then
call perturb_buffer_%s(i_generator,keys_out,key_idx,e_2_pert_buffer,coef_pert_buffer,sum_e_2_pert, &
sum_norm_pert,sum_H_pert_diag,N_st,N_int,key_mask,fock_diag_tmp)
"""%(pert)
else:
self.data["keys_work"] = """
call perturb_buffer_by_mono_%s(i_generator,keys_out,key_idx,e_2_pert_buffer,coef_pert_buffer,sum_e_2_pert, &
sum_norm_pert,sum_H_pert_diag,N_st,N_int,key_mask,fock_diag_tmp)
"""%(pert)
self.data["keys_work"] = """
call perturb_buffer_by_mono_%s(i_generator,keys_out,key_idx,e_2_pert_buffer,coef_pert_buffer,sum_e_2_pert, &
sum_norm_pert,sum_H_pert_diag,N_st,N_int,key_mask,fock_diag_tmp)
"""%(pert)
self.data["finalization"] = """
@ -285,9 +294,9 @@ class H_apply(object):
delta_pt2(k) = 0.d0
pt2_old(k) = 0.d0
enddo
write(output_determinants,'(A12, X, A8, 3(2X, A9), 2X, A8, 2X, A8, 2X, A8)') &
write(output_determinants,'(A12, 1X, A8, 3(2X, A9), 2X, A8, 2X, A8, 2X, A8)') &
'N_generators', 'Norm', 'Delta PT2', 'PT2', 'Est. PT2', 'secs'
write(output_determinants,'(A12, X, A8, 3(2X, A9), 2X, A8, 2X, A8, 2X, A8)') &
write(output_determinants,'(A12, 1X, A8, 3(2X, A9), 2X, A8, 2X, A8, 2X, A8)') &
'============', '========', '=========', '=========', '=========', &
'========='
"""
@ -306,7 +315,6 @@ class H_apply(object):
wall_1-wall_0
pt2_old(k) = pt2(k)
enddo
progress_value = norm_psi(1)
"""
self.data["omp_parallel"] += """&
!$OMP SHARED(N_st) PRIVATE(e_2_pert_buffer,coef_pert_buffer) &
@ -350,9 +358,7 @@ class H_apply(object):
!$ call omp_set_lock(lck)
do k=1,N_st
norm_psi(k) = norm_psi(k) + psi_coef_generators(i_generator,k)*psi_coef_generators(i_generator,k)
! delta_pt2(k) = 0.d0
pt2_old(k) = 0.d0
! pt2(k) = select_max(i_generator)
pt2_old(k) = 0.d0
enddo
!$ call omp_unset_lock(lck)
cycle
@ -362,3 +368,50 @@ class H_apply(object):
"""
def unset_openmp(self):
for k in keywords:
if k.startswith("omp_"):
self[k] = ""
class H_apply_zmq(H_apply):
def read_template(self):
file = open(os.environ["QP_ROOT"]+'/src/Determinants/H_apply.template.f','r')
self.template = file.read()
file.close()
file = open(os.environ["QP_ROOT"]+'/src/Determinants/H_apply_zmq.template.f','r')
self.template += file.read()
file.close()
def set_perturbation(self,pert):
H_apply.set_perturbation(self,pert)
self.data["printout_now"] = ""
self.data["printout_always"] = ""
self.data["decls_main"] = """ integer, intent(in) :: N_st
double precision, intent(inout):: pt2(N_st)
double precision, intent(inout):: norm_pert(N_st)
double precision, intent(inout):: H_pert_diag(N_st)
double precision :: delta_pt2(N_st), norm_psi(N_st), pt2_old(N_st)
PROVIDE N_det_generators
do k=1,N_st
pt2(k) = 0.d0
norm_pert(k) = 0.d0
H_pert_diag(k) = 0.d0
norm_psi(k) = 0.d0
enddo
"""
def set_selection_pt2(self,pert):
H_apply.set_selection_pt2(self,pert)
self.data["skip"] = """
if (i_generator < size_select_max) then
if (select_max(i_generator) < selection_criterion_min*selection_criterion_factor) then
do k=1,N_st
pt2(k) = select_max(i_generator)
enddo
cycle
endif
select_max(i_generator) = 0.d0
endif
"""

3
scripts/module/qp_module.py
View File

@ -59,7 +59,8 @@ def save_new_module(path, l_child):
with open(os.path.join(path, "%s.main.irp.f"%(module_name) ), "w") as f:
f.write("program {0}".format(module_name) )
f.write(""" implicit none
f.write("""
implicit none
BEGIN_DOC
! TODO
END_DOC

3
src/AO_Basis/aos.irp.f
View File

@ -50,9 +50,6 @@ END_PROVIDER
enddo
enddo
ao_coef_normalization_factor(i) = 1.d0/sqrt(norm)
do j=1,ao_prim_num(i)
ao_coef_normalized(i,j) = ao_coef_normalized(i,j) * ao_coef_normalization_factor(i)
enddo
enddo
END_PROVIDER

98
src/Bitmask/bitmasks.irp.f
View File

@ -9,7 +9,7 @@ BEGIN_PROVIDER [ integer, N_int ]
END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), full_ijkl_bitmask, (N_int,4) ]
BEGIN_PROVIDER [ integer(bit_kind), full_ijkl_bitmask, (N_int) ]
implicit none
BEGIN_DOC
! Bitmask to include all possible MOs
@ -18,29 +18,26 @@ BEGIN_PROVIDER [ integer(bit_kind), full_ijkl_bitmask, (N_int,4) ]
integer :: i,j,n
n = mod(mo_tot_num-1,bit_kind_size)+1
full_ijkl_bitmask = 0_bit_kind
do j=1,4
do i=1,N_int-1
full_ijkl_bitmask(i,j) = not(0_bit_kind)
enddo
do i=1,n
full_ijkl_bitmask(N_int,j) = ibset(full_ijkl_bitmask(N_int,j),i-1)
enddo
do i=1,N_int-1
full_ijkl_bitmask(i) = not(0_bit_kind)
enddo
do i=1,n
full_ijkl_bitmask(N_int) = ibset(full_ijkl_bitmask(N_int),i-1)
enddo
END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), full_ijkl_bitmask_4, (N_int,4) ]
implicit none
integer :: i
do i=1,N_int
full_ijkl_bitmask_4(i,1) = full_ijkl_bitmask(i)
full_ijkl_bitmask_4(i,2) = full_ijkl_bitmask(i)
full_ijkl_bitmask_4(i,3) = full_ijkl_bitmask(i)
full_ijkl_bitmask_4(i,4) = full_ijkl_bitmask(i)
enddo
END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), cis_ijkl_bitmask, (N_int,4) ]
implicit none
BEGIN_DOC
! Bitmask to include all possible single excitations from Hartree-Fock
END_DOC
integer :: i,j,n
cis_ijkl_bitmask = full_ijkl_bitmask
cis_ijkl_bitmask(:,1) = HF_bitmask(:,1)
END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), HF_bitmask, (N_int,2)]
implicit none
BEGIN_DOC
@ -131,12 +128,14 @@ BEGIN_PROVIDER [ integer(bit_kind), generators_bitmask_restart, (N_int,2,6,N_gen
integer :: k, ispin
do k=1,N_generators_bitmask
do ispin=1,2
generators_bitmask_restart(:,ispin,s_hole ,k) = full_ijkl_bitmask(:,d_hole1)
generators_bitmask_restart(:,ispin,s_part ,k) = full_ijkl_bitmask(:,d_part1)
generators_bitmask_restart(:,ispin,d_hole1,k) = full_ijkl_bitmask(:,d_hole1)
generators_bitmask_restart(:,ispin,d_part1,k) = full_ijkl_bitmask(:,d_part1)
generators_bitmask_restart(:,ispin,d_hole2,k) = full_ijkl_bitmask(:,d_hole2)
generators_bitmask_restart(:,ispin,d_part2,k) = full_ijkl_bitmask(:,d_part2)
do i=1,N_int
generators_bitmask_restart(i,ispin,s_hole ,k) = full_ijkl_bitmask(i)
generators_bitmask_restart(i,ispin,s_part ,k) = full_ijkl_bitmask(i)
generators_bitmask_restart(i,ispin,d_hole1,k) = full_ijkl_bitmask(i)
generators_bitmask_restart(i,ispin,d_part1,k) = full_ijkl_bitmask(i)
generators_bitmask_restart(i,ispin,d_hole2,k) = full_ijkl_bitmask(i)
generators_bitmask_restart(i,ispin,d_part2,k) = full_ijkl_bitmask(i)
enddo
enddo
enddo
endif
@ -145,12 +144,12 @@ BEGIN_PROVIDER [ integer(bit_kind), generators_bitmask_restart, (N_int,2,6,N_gen
do k=1,N_generators_bitmask
do ispin=1,2
do i=1,N_int
generators_bitmask_restart(i,ispin,s_hole ,k) = iand(full_ijkl_bitmask(i,d_hole1),generators_bitmask_restart(i,ispin,s_hole,k) )
generators_bitmask_restart(i,ispin,s_part ,k) = iand(full_ijkl_bitmask(i,d_part1),generators_bitmask_restart(i,ispin,s_part,k) )
generators_bitmask_restart(i,ispin,d_hole1,k) = iand(full_ijkl_bitmask(i,d_hole1),generators_bitmask_restart(i,ispin,d_hole1,k) )
generators_bitmask_restart(i,ispin,d_part1,k) = iand(full_ijkl_bitmask(i,d_part1),generators_bitmask_restart(i,ispin,d_part1,k) )
generators_bitmask_restart(i,ispin,d_hole2,k) = iand(full_ijkl_bitmask(i,d_hole2),generators_bitmask_restart(i,ispin,d_hole2,k) )
generators_bitmask_restart(i,ispin,d_part2,k) = iand(full_ijkl_bitmask(i,d_part2),generators_bitmask_restart(i,ispin,d_part2,k) )
generators_bitmask_restart(i,ispin,s_hole ,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,s_hole,k) )
generators_bitmask_restart(i,ispin,s_part ,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,s_part,k) )
generators_bitmask_restart(i,ispin,d_hole1,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,d_hole1,k) )
generators_bitmask_restart(i,ispin,d_part1,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,d_part1,k) )
generators_bitmask_restart(i,ispin,d_hole2,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,d_hole2,k) )
generators_bitmask_restart(i,ispin,d_part2,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,d_part2,k) )
enddo
enddo
enddo
@ -188,12 +187,14 @@ BEGIN_PROVIDER [ integer(bit_kind), generators_bitmask, (N_int,2,6,N_generators_
integer :: k, ispin, i
do k=1,N_generators_bitmask
do ispin=1,2
generators_bitmask(:,ispin,s_hole ,k) = full_ijkl_bitmask(:,d_hole1)
generators_bitmask(:,ispin,s_part ,k) = full_ijkl_bitmask(:,d_part1)
generators_bitmask(:,ispin,d_hole1,k) = full_ijkl_bitmask(:,d_hole1)
generators_bitmask(:,ispin,d_part1,k) = full_ijkl_bitmask(:,d_part1)
generators_bitmask(:,ispin,d_hole2,k) = full_ijkl_bitmask(:,d_hole2)
generators_bitmask(:,ispin,d_part2,k) = full_ijkl_bitmask(:,d_part2)
do i=1,N_int
generators_bitmask(i,ispin,s_hole ,k) = full_ijkl_bitmask(i)
generators_bitmask(i,ispin,s_part ,k) = full_ijkl_bitmask(i)
generators_bitmask(i,ispin,d_hole1,k) = full_ijkl_bitmask(i)
generators_bitmask(i,ispin,d_part1,k) = full_ijkl_bitmask(i)
generators_bitmask(i,ispin,d_hole2,k) = full_ijkl_bitmask(i)
generators_bitmask(i,ispin,d_part2,k) = full_ijkl_bitmask(i)
enddo
enddo
enddo
endif
@ -201,12 +202,12 @@ BEGIN_PROVIDER [ integer(bit_kind), generators_bitmask, (N_int,2,6,N_generators_
do k=1,N_generators_bitmask
do ispin=1,2
do i=1,N_int
generators_bitmask(i,ispin,s_hole ,k) = iand(full_ijkl_bitmask(i,d_hole1),generators_bitmask(i,ispin,s_hole,k) )
generators_bitmask(i,ispin,s_part ,k) = iand(full_ijkl_bitmask(i,d_part1),generators_bitmask(i,ispin,s_part,k) )
generators_bitmask(i,ispin,d_hole1,k) = iand(full_ijkl_bitmask(i,d_hole1),generators_bitmask(i,ispin,d_hole1,k) )
generators_bitmask(i,ispin,d_part1,k) = iand(full_ijkl_bitmask(i,d_part1),generators_bitmask(i,ispin,d_part1,k) )
generators_bitmask(i,ispin,d_hole2,k) = iand(full_ijkl_bitmask(i,d_hole2),generators_bitmask(i,ispin,d_hole2,k) )
generators_bitmask(i,ispin,d_part2,k) = iand(full_ijkl_bitmask(i,d_part2),generators_bitmask(i,ispin,d_part2,k) )
generators_bitmask(i,ispin,s_hole ,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,s_hole,k) )
generators_bitmask(i,ispin,s_part ,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,s_part,k) )
generators_bitmask(i,ispin,d_hole1,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,d_hole1,k) )
generators_bitmask(i,ispin,d_part1,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,d_part1,k) )
generators_bitmask(i,ispin,d_hole2,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,d_hole2,k) )
generators_bitmask(i,ispin,d_part2,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,d_part2,k) )
enddo
enddo
enddo
@ -259,8 +260,11 @@ BEGIN_PROVIDER [ integer(bit_kind), cas_bitmask, (N_int,2,N_cas_bitmask) ]
print*,'---------------------'
else
if(N_generators_bitmask == 1)then
do i=1,N_cas_bitmask
cas_bitmask(:,:,i) = iand(not(HF_bitmask(:,:)),full_ijkl_bitmask(:,:))
do j=1, N_cas_bitmask
do i=1, N_int
cas_bitmask(i,1,j) = iand(not(HF_bitmask(i,1)),full_ijkl_bitmask(i))
cas_bitmask(i,2,j) = iand(not(HF_bitmask(i,2)),full_ijkl_bitmask(i))
enddo
enddo
else
i_part = 2
@ -276,7 +280,7 @@ BEGIN_PROVIDER [ integer(bit_kind), cas_bitmask, (N_int,2,N_cas_bitmask) ]
do i=1,N_cas_bitmask
do j = 1, N_cas_bitmask
do k=1,N_int
cas_bitmask(k,j,i) = iand(cas_bitmask(k,j,i),full_ijkl_bitmask(k,j))
cas_bitmask(k,j,i) = iand(cas_bitmask(k,j,i),full_ijkl_bitmask(k))
enddo
enddo
enddo

114
src/Determinants/H_apply.irp.f
View File

@ -263,6 +263,7 @@ subroutine remove_duplicates_in_psi_det(found_duplicates)
deallocate (duplicate,bit_tmp)
end
subroutine fill_H_apply_buffer_no_selection(n_selected,det_buffer,Nint,iproc)
use bitmasks
implicit none
@ -306,3 +307,116 @@ subroutine fill_H_apply_buffer_no_selection(n_selected,det_buffer,Nint,iproc)
end
subroutine push_pt2(zmq_socket_push,pt2,norm_pert,H_pert_diag,N_st,task_id)
use f77_zmq
implicit none
BEGIN_DOC
! Push PT2 calculation to the collector
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_socket_push
integer, intent(in) :: N_st
double precision, intent(in) :: pt2(N_st), norm_pert(N_st), H_pert_diag(N_st)
integer, intent(in) :: task_id
integer :: rc
rc = f77_zmq_send( zmq_socket_push, 1, 4, ZMQ_SNDMORE)
if (rc /= 4) then
print *, irp_here, 'f77_zmq_send( zmq_socket_push, 1, 4, ZMQ_SNDMORE)'
stop 'error'
endif
rc = f77_zmq_send( zmq_socket_push, pt2, 8*N_st, ZMQ_SNDMORE)
if (rc /= 8*N_st) then
print *, irp_here, 'f77_zmq_send( zmq_socket_push, pt2, 8*N_st, ZMQ_SNDMORE)'
stop 'error'
endif
rc = f77_zmq_send( zmq_socket_push, norm_pert, 8*N_st, ZMQ_SNDMORE)
if (rc /= 8*N_st) then
print *, irp_here, 'f77_zmq_send( zmq_socket_push, norm_pert, 8*N_st, ZMQ_SNDMORE)'
stop 'error'
endif
rc = f77_zmq_send( zmq_socket_push, H_pert_diag, 8*N_st, ZMQ_SNDMORE)
if (rc /= 8*N_st) then
print *, irp_here, 'f77_zmq_send( zmq_socket_push, H_pert_diag, 8*N_st, ZMQ_SNDMORE)'
stop 'error'
endif
rc = f77_zmq_send( zmq_socket_push, task_id, 4, 0)
if (rc /= 4) then
print *, irp_here, 'f77_zmq_send( zmq_socket_push, task_id, 4, 0)'
stop 'error'
endif
! Activate if zmq_socket_push is a REQ
! integer :: idummy
! rc = f77_zmq_recv( zmq_socket_push, idummy, 4, 0)
! if (rc /= 4) then
! print *, irp_here, 'f77_zmq_send( zmq_socket_push, idummy, 4, 0)'
! stop 'error'
! endif
end
subroutine pull_pt2(zmq_socket_pull,pt2,norm_pert,H_pert_diag,N_st,n,task_id)
use f77_zmq
implicit none
BEGIN_DOC
! Pull PT2 calculation in the collector
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
integer, intent(in) :: N_st
double precision, intent(out) :: pt2(N_st), norm_pert(N_st), H_pert_diag(N_st)
integer, intent(out) :: task_id
integer, intent(out) :: n
integer :: rc
n=0
rc = f77_zmq_recv( zmq_socket_pull, n, 4, 0)
if (rc == -1) then
n=9
return
endif
if (rc /= 4) then
print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, n, 4, 0)'
stop 'error'
endif
if (n > 0) then
rc = f77_zmq_recv( zmq_socket_pull, pt2(1), 8*N_st, 0)
if (rc /= 8*N_st) then
print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, pt2(1,1) , 8*N_st, 0)'
stop 'error'
endif
rc = f77_zmq_recv( zmq_socket_pull, norm_pert(1), 8*N_st, 0)
if (rc /= 8*N_st) then
print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, norm_pert(1,1), 8*N_st)'
stop 'error'
endif
rc = f77_zmq_recv( zmq_socket_pull, H_pert_diag(1), 8*N_st, 0)
if (rc /= 8*N_st) then
print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, H_pert_diag(1,1), 8*N_st)'
stop 'error'
endif
rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0)
if (rc /= 4) then
print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, task_id, 4, 0)'
stop 'error'
endif
endif
! Activate if zmq_socket_pull is a REP
! rc = f77_zmq_send( zmq_socket_pull, 0, 4, 0)
! if (rc /= 4) then
! print *, irp_here, 'f77_zmq_send( zmq_socket_pull, 0, 4, 0)'
! stop 'error'
! endif
end

215
src/Determinants/H_apply.template.f
View File

@ -1,13 +1,12 @@
subroutine $subroutine_diexc(key_in, key_prev, hole_1,particl_1, hole_2, particl_2, fock_diag_tmp, i_generator, iproc_in $parameters )
implicit none
integer(bit_kind), intent(in) :: key_in(N_int, 2), hole_1(N_int, 2), hole_2(N_int, 2)
integer(bit_kind), intent(in) :: particl_1(N_int, 2), particl_2(N_int, 2)
integer(bit_kind) :: p1_mask(N_int, 2), p2_mask(N_int, 2), tmp
integer,intent(in) :: i_generator,iproc_in
integer(bit_kind) :: status(N_int*bit_kind_size, 2)
integer :: highest, p1,p2,sp,ni,i,mi,nt,ns
integer :: status(N_int*bit_kind_size, 2)
integer :: highest, p1,p2,sp,ni,i,mi,nt,ns,k
double precision, intent(in) :: fock_diag_tmp(2,mo_tot_num+1)
integer(bit_kind), intent(in) :: key_prev(N_int, 2, *)
PROVIDE N_int
@ -17,16 +16,19 @@ subroutine $subroutine_diexc(key_in, key_prev, hole_1,particl_1, hole_2, particl
highest = 0
status(:,:) = 0
do k=1,N_int*bit_kind_size
status(k,1) = 0
status(k,2) = 0
enddo
do sp=1,2
do ni=1,N_int
do i=1,bit_kind_size
if(iand(1,ishft(key_in(ni, sp), -(i-1))) == 0) then
if(iand(1_bit_kind,ishft(key_in(ni, sp), -(i-1))) == 0) then
cycle
end if
mi = (ni-1)*bit_kind_size+i
status(mi, sp) = iand(1,ishft(hole_1(ni, sp), -(i-1)))
status(mi, sp) = status(mi, sp) + 2*iand(1,ishft(hole_2(ni, sp), -(i-1)))
status(mi, sp) = int(iand(1_bit_kind,ishft(hole_1(ni, sp), -(i-1))),4)
status(mi, sp) = status(mi, sp) + 2*int(iand(1_bit_kind,ishft(hole_2(ni, sp), -(i-1))),4)
if(status(mi, sp) /= 0 .and. mi > highest) then
highest = mi
end if
@ -103,16 +105,23 @@ subroutine $subroutine_diexcP(key_in, fs1, fh1, particl_1, fs2, fh2, particl_2,
integer(bit_kind) :: p1_mask(N_int, 2), p2_mask(N_int, 2), key_mask(N_int, 2)
integer,intent(in) :: fs1,fs2,i_generator,iproc_in, fh1,fh2
integer(bit_kind) :: miniList(N_int, 2, N_det)
integer :: n_minilist, n_alpha, n_beta, deg(2), i, ni
integer :: n_minilist, n_alpha, n_beta, deg(2), i, ni, k
$declarations
integer(bit_kind), parameter :: one = 1_bit_kind
p1_mask(:,:) = 0_bit_kind
p2_mask(:,:) = 0_bit_kind
do k=1,N_int
p1_mask(k,1) = 0_bit_kind
p1_mask(k,2) = 0_bit_kind
p2_mask(k,1) = 0_bit_kind
p2_mask(k,2) = 0_bit_kind
enddo
p1_mask(ishft(fh1-1,-bit_kind_shift) + 1, fs1) = ishft(one,iand(fh1-1,bit_kind_size-1))
p2_mask(ishft(fh2-1,-bit_kind_shift) + 1, fs2) = ishft(one,iand(fh2-1,bit_kind_size-1))
key_mask(:,:) = key_in(:,:)
do k=1,N_int
key_mask(k,1) = key_in(k,1)
key_mask(k,2) = key_in(k,2)
enddo
key_mask(ishft(fh1-1,-bit_kind_shift) + 1, fs1) -= ishft(one,iand(fh1-1,bit_kind_size-1))
key_mask(ishft(fh2-1,-bit_kind_shift) + 1, fs2) -= ishft(one,iand(fh2-1,bit_kind_size-1))
@ -229,14 +238,8 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl
accu = 0.d0
do ispin=1,2
other_spin = iand(ispin,1)+1
if (abort_here) then
exit
endif
$omp_do
do ii=1,ia_ja_pairs(1,0,ispin)
if (abort_here) then
cycle
endif
i_a = ia_ja_pairs(1,ii,ispin)
ASSERT (i_a > 0)
ASSERT (i_a <= mo_tot_num)
@ -314,9 +317,6 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl
$keys_work
key_idx = 0
endif
if (abort_here) then
exit
endif
enddo
endif
@ -366,9 +366,6 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl
$keys_work
key_idx = 0
endif
if (abort_here) then
exit
endif
enddo ! kk
enddo ! ii
@ -431,7 +428,10 @@ subroutine $subroutine_monoexc(key_in, hole_1,particl_1,fock_diag_tmp,i_generato
logical :: is_a_1p
logical :: is_a_2p
key_mask(:,:) = 0_bit_kind
do k=1,N_int
key_mask(k,1) = 0_bit_kind
key_mask(k,2) = 0_bit_kind
enddo
iproc = iproc_in
@ -533,168 +533,3 @@ subroutine $subroutine_monoexc(key_in, hole_1,particl_1,fock_diag_tmp,i_generato
end
subroutine $subroutine($params_main)
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
$decls_main
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
double precision, allocatable :: fock_diag_tmp(:,:)
$initialization
PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators
nmax = mod( N_det_generators,nproc )
!$ call omp_init_lock(lck)
call start_progress(N_det_generators,'Selection (norm)',0.d0)
call wall_time(wall_0)
iproc = 0
allocate( mask(N_int,2,6), fock_diag_tmp(2,mo_tot_num+1) )
do i_generator=1,nmax
progress_bar(1) = i_generator
if (abort_here) then
exit
endif
$skip
! Compute diagonal of the Fock matrix
call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int)
! 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(k,ispin,i_generator) )
mask(k,ispin,s_part) = &
iand(generators_bitmask(k,ispin,s_part,i_bitmask_gen), &
not(psi_det_generators(k,ispin,i_generator)) )
mask(k,ispin,d_hole1) = &
iand(generators_bitmask(k,ispin,d_hole1,i_bitmask_gen), &
psi_det_generators(k,ispin,i_generator) )
mask(k,ispin,d_part1) = &
iand(generators_bitmask(k,ispin,d_part1,i_bitmask_gen), &
not(psi_det_generators(k,ispin,i_generator)) )
mask(k,ispin,d_hole2) = &
iand(generators_bitmask(k,ispin,d_hole2,i_bitmask_gen), &
psi_det_generators(k,ispin,i_generator) )
mask(k,ispin,d_part2) = &
iand(generators_bitmask(k,ispin,d_part2,i_bitmask_gen), &
not(psi_det_generators(k,ispin,i_generator)) )
enddo
enddo
if($do_double_excitations)then
call $subroutine_diexc(psi_det_generators(1,1,i_generator), &
psi_det_generators(1,1,1), &
mask(1,1,d_hole1), mask(1,1,d_part1), &
mask(1,1,d_hole2), mask(1,1,d_part2), &
fock_diag_tmp, i_generator, iproc $params_post)
endif
if($do_mono_excitations)then
call $subroutine_monoexc(psi_det_generators(1,1,i_generator), &
mask(1,1,s_hole ), mask(1,1,s_part ), &
fock_diag_tmp, i_generator, iproc $params_post)
endif
call wall_time(wall_1)
$printout_always
if (wall_1 - wall_0 > 2.d0) then
$printout_now
wall_0 = wall_1
endif
enddo
deallocate( mask, fock_diag_tmp )
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(i_generator,wall_1,wall_0,ispin,k,mask,iproc,fock_diag_tmp)
call wall_time(wall_0)
!$ iproc = omp_get_thread_num()
allocate( mask(N_int,2,6), fock_diag_tmp(2,mo_tot_num+1) )
!$OMP DO SCHEDULE(dynamic,1)
do i_generator=nmax+1,N_det_generators
if (iproc == 0) then
progress_bar(1) = i_generator
endif
if (abort_here) then
cycle
endif
$skip
! Compute diagonal of the Fock matrix
call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int)
! 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(k,ispin,i_generator) )
mask(k,ispin,s_part) = &
iand(generators_bitmask(k,ispin,s_part,i_bitmask_gen), &
not(psi_det_generators(k,ispin,i_generator)) )
mask(k,ispin,d_hole1) = &
iand(generators_bitmask(k,ispin,d_hole1,i_bitmask_gen), &
psi_det_generators(k,ispin,i_generator) )
mask(k,ispin,d_part1) = &
iand(generators_bitmask(k,ispin,d_part1,i_bitmask_gen), &
not(psi_det_generators(k,ispin,i_generator)) )
mask(k,ispin,d_hole2) = &
iand(generators_bitmask(k,ispin,d_hole2,i_bitmask_gen), &
psi_det_generators(k,ispin,i_generator) )
mask(k,ispin,d_part2) = &
iand(generators_bitmask(k,ispin,d_part2,i_bitmask_gen), &
not (psi_det_generators(k,ispin,i_generator)) )
enddo
enddo
if($do_double_excitations)then
call $subroutine_diexc(psi_det_generators(1,1,i_generator), &
psi_det_generators(1,1,1), &
mask(1,1,d_hole1), mask(1,1,d_part1), &
mask(1,1,d_hole2), mask(1,1,d_part2), &
fock_diag_tmp, i_generator, iproc $params_post)
endif
if($do_mono_excitations)then
call $subroutine_monoexc(psi_det_generators(1,1,i_generator), &
mask(1,1,s_hole ), mask(1,1,s_part ), &
fock_diag_tmp, i_generator, iproc $params_post)
endif
!$ call omp_set_lock(lck)
call wall_time(wall_1)
$printout_always
if (wall_1 - wall_0 > 2.d0) then
$printout_now
wall_0 = wall_1
endif
!$ call omp_unset_lock(lck)
enddo
!$OMP END DO
deallocate( mask, fock_diag_tmp )
!$OMP END PARALLEL
!$ call omp_destroy_lock(lck)
abort_here = abort_all
call stop_progress
$copy_buffer
$generate_psi_guess
end

150
src/Determinants/H_apply_nozmq.template.f Normal file
View File

@ -0,0 +1,150 @@
subroutine $subroutine($params_main)
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
$decls_main
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
double precision, allocatable :: fock_diag_tmp(:,:)
$initialization
PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators
nmax = mod( N_det_generators,nproc )
!$ call omp_init_lock(lck)
call wall_time(wall_0)
iproc = 0
allocate( mask(N_int,2,6), fock_diag_tmp(2,mo_tot_num+1) )
do i_generator=1,nmax
$skip
! Compute diagonal of the Fock matrix
call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int)
! 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(k,ispin,i_generator) )
mask(k,ispin,s_part) = &
iand(generators_bitmask(k,ispin,s_part,i_bitmask_gen), &
not(psi_det_generators(k,ispin,i_generator)) )
mask(k,ispin,d_hole1) = &
iand(generators_bitmask(k,ispin,d_hole1,i_bitmask_gen), &
psi_det_generators(k,ispin,i_generator) )
mask(k,ispin,d_part1) = &
iand(generators_bitmask(k,ispin,d_part1,i_bitmask_gen), &
not(psi_det_generators(k,ispin,i_generator)) )
mask(k,ispin,d_hole2) = &
iand(generators_bitmask(k,ispin,d_hole2,i_bitmask_gen), &
psi_det_generators(k,ispin,i_generator) )
mask(k,ispin,d_part2) = &
iand(generators_bitmask(k,ispin,d_part2,i_bitmask_gen), &
not(psi_det_generators(k,ispin,i_generator)) )
enddo
enddo
if($do_double_excitations)then
call $subroutine_diexc(psi_det_generators(1,1,i_generator), &
psi_det_generators(1,1,1), &
mask(1,1,d_hole1), mask(1,1,d_part1), &
mask(1,1,d_hole2), mask(1,1,d_part2), &
fock_diag_tmp, i_generator, iproc $params_post)
endif
if($do_mono_excitations)then
call $subroutine_monoexc(psi_det_generators(1,1,i_generator), &
mask(1,1,s_hole ), mask(1,1,s_part ), &
fock_diag_tmp, i_generator, iproc $params_post)
endif
call wall_time(wall_1)
$printout_always
if (wall_1 - wall_0 > 2.d0) then
$printout_now
wall_0 = wall_1
endif
enddo
deallocate( mask, fock_diag_tmp )
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(i_generator,wall_1,wall_0,ispin,k,mask,iproc,fock_diag_tmp)
call wall_time(wall_0)
!$ iproc = omp_get_thread_num()
allocate( mask(N_int,2,6), fock_diag_tmp(2,mo_tot_num+1) )
!$OMP DO SCHEDULE(dynamic,1)
do i_generator=nmax+1,N_det_generators
$skip
! Compute diagonal of the Fock matrix
call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int)
! 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(k,ispin,i_generator) )
mask(k,ispin,s_part) = &
iand(generators_bitmask(k,ispin,s_part,i_bitmask_gen), &
not(psi_det_generators(k,ispin,i_generator)) )
mask(k,ispin,d_hole1) = &
iand(generators_bitmask(k,ispin,d_hole1,i_bitmask_gen), &
psi_det_generators(k,ispin,i_generator) )
mask(k,ispin,d_part1) = &
iand(generators_bitmask(k,ispin,d_part1,i_bitmask_gen), &
not(psi_det_generators(k,ispin,i_generator)) )
mask(k,ispin,d_hole2) = &
iand(generators_bitmask(k,ispin,d_hole2,i_bitmask_gen), &
psi_det_generators(k,ispin,i_generator) )
mask(k,ispin,d_part2) = &
iand(generators_bitmask(k,ispin,d_part2,i_bitmask_gen), &
not (psi_det_generators(k,ispin,i_generator)) )
enddo
enddo
if($do_double_excitations)then
call $subroutine_diexc(psi_det_generators(1,1,i_generator), &
psi_det_generators(1,1,1), &
mask(1,1,d_hole1), mask(1,1,d_part1), &
mask(1,1,d_hole2), mask(1,1,d_part2), &
fock_diag_tmp, i_generator, iproc $params_post)
endif
if($do_mono_excitations)then
call $subroutine_monoexc(psi_det_generators(1,1,i_generator), &
mask(1,1,s_hole ), mask(1,1,s_part ), &
fock_diag_tmp, i_generator, iproc $params_post)
endif
!$ call omp_set_lock(lck)
call wall_time(wall_1)
$printout_always
if (wall_1 - wall_0 > 2.d0) then
$printout_now
wall_0 = wall_1
endif
!$ call omp_unset_lock(lck)
enddo
!$OMP END DO
deallocate( mask, fock_diag_tmp )
!$OMP END PARALLEL
!$ call omp_destroy_lock(lck)
$copy_buffer
$generate_psi_guess
end

245
src/Determinants/H_apply_zmq.template.f Normal file
View File

@ -0,0 +1,245 @@
subroutine $subroutine($params_main)
implicit none
use omp_lib
use bitmasks
use f77_zmq
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
$decls_main
integer :: i_generator
double precision :: wall_0, wall_1
integer(omp_lock_kind) :: lck
integer(bit_kind), allocatable :: mask(:,:,:)
integer :: ispin, k
integer :: rc
character*(512) :: task
double precision, allocatable :: fock_diag_tmp(:,:)
$initialization
PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators
integer(ZMQ_PTR), external :: new_zmq_pair_socket
integer(ZMQ_PTR) :: zmq_socket_pair
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
call new_parallel_job(zmq_to_qp_run_socket,'$subroutine')
zmq_socket_pair = new_zmq_pair_socket(.True.)
call zmq_put_psi(zmq_to_qp_run_socket,1)
do i_generator=N_det_generators,1,-1
$skip
write(task,*) i_generator
call add_task_to_taskserver(zmq_to_qp_run_socket,task)
enddo
integer(ZMQ_PTR) :: collector_thread
external :: $subroutine_collector
rc = pthread_create(collector_thread, $subroutine_collector)
!$OMP PARALLEL DEFAULT(private)
!$OMP TASK PRIVATE(rc)
rc = omp_get_thread_num()
call $subroutine_slave_inproc(rc)
!$OMP END TASK
!$OMP TASKWAIT
!$OMP END PARALLEL
integer :: n, task_id
call pull_pt2(zmq_socket_pair, pt2, norm_pert, H_pert_diag, N_st, n, task_id)
rc = pthread_join(collector_thread)
call end_zmq_pair_socket(zmq_socket_pair)
call end_parallel_job(zmq_to_qp_run_socket,'$subroutine')
$copy_buffer
$generate_psi_guess
end
subroutine $subroutine_slave_tcp(iproc)
implicit none
integer, intent(in) :: iproc
BEGIN_DOC
! Computes a buffer over the network
END_DOC
call $subroutine_slave(0,iproc)
end
subroutine $subroutine_slave_inproc(iproc)
implicit none
integer, intent(in) :: iproc
BEGIN_DOC
! Computes a buffer using threads
END_DOC
call $subroutine_slave(1,iproc)
end
subroutine $subroutine_slave(thread, iproc)
implicit none
use omp_lib
use bitmasks
use f77_zmq
integer, intent(in) :: thread
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) :: iproc
integer :: i_generator
double precision :: wall_0, wall_1
integer(bit_kind), allocatable :: mask(:,:,:)
integer :: ispin, k
double precision, allocatable :: fock_diag_tmp(:,:)
double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:)
integer :: worker_id, task_id, rc, N_st
character*(512) :: task
integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
integer(ZMQ_PTR),external :: new_zmq_push_socket
integer(ZMQ_PTR) :: zmq_socket_push
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
zmq_socket_push = new_zmq_push_socket(thread)
N_st = N_states
allocate( pt2(N_st), norm_pert(N_st), H_pert_diag(N_st), &
mask(N_int,2,6), fock_diag_tmp(2,mo_tot_num+1) )
call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread)
do
call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task)
if (task_id == 0) exit
read(task,*) i_generator
! Compute diagonal of the Fock matrix
call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int)
pt2 = 0.d0
norm_pert = 0.d0
H_pert_diag = 0.d0
! 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(k,ispin,i_generator) )
mask(k,ispin,s_part) = &
iand(generators_bitmask(k,ispin,s_part,i_bitmask_gen), &
not(psi_det_generators(k,ispin,i_generator)) )
mask(k,ispin,d_hole1) = &
iand(generators_bitmask(k,ispin,d_hole1,i_bitmask_gen), &
psi_det_generators(k,ispin,i_generator) )
mask(k,ispin,d_part1) = &
iand(generators_bitmask(k,ispin,d_part1,i_bitmask_gen), &
not(psi_det_generators(k,ispin,i_generator)) )
mask(k,ispin,d_hole2) = &
iand(generators_bitmask(k,ispin,d_hole2,i_bitmask_gen), &
psi_det_generators(k,ispin,i_generator) )
mask(k,ispin,d_part2) = &
iand(generators_bitmask(k,ispin,d_part2,i_bitmask_gen), &
not (psi_det_generators(k,ispin,i_generator)) )
enddo
enddo
if($do_double_excitations)then
call $subroutine_diexc(psi_det_generators(1,1,i_generator), &
psi_det_generators(1,1,1), &
mask(1,1,d_hole1), mask(1,1,d_part1), &
mask(1,1,d_hole2), mask(1,1,d_part2), &
fock_diag_tmp, i_generator, iproc $params_post)
endif
if($do_mono_excitations)then
call $subroutine_monoexc(psi_det_generators(1,1,i_generator), &
mask(1,1,s_hole ), mask(1,1,s_part ), &
fock_diag_tmp, i_generator, iproc $params_post)
endif
call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id,1)
call push_pt2(zmq_socket_push,pt2,norm_pert,H_pert_diag,N_st,task_id)
enddo
call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id)
deallocate( mask, fock_diag_tmp, pt2, norm_pert, H_pert_diag )
call end_zmq_push_socket(zmq_socket_push,thread)
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
end
subroutine $subroutine_collector
use f77_zmq
implicit none
BEGIN_DOC
! Collects results from the selection
END_DOC
integer :: k, rc
integer(ZMQ_PTR), external :: new_zmq_pull_socket
integer(ZMQ_PTR) :: zmq_socket_pull
integer*8 :: control, accu
integer :: n, more, task_id
integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
zmq_socket_pull = new_zmq_pull_socket()
double precision, allocatable :: pt2(:,:), norm_pert(:,:), H_pert_diag(:,:)
allocate ( pt2(N_states,2), norm_pert(N_states,2), H_pert_diag(N_states,2))
pt2 = 0.d0
norm_pert = 0.d0
H_pert_diag = 0.d0
accu = 0_8
more = 1
do while (more == 1)
call pull_pt2(zmq_socket_pull, pt2, norm_pert, H_pert_diag, N_states, n, task_id)
if (n > 0) then
do k=1,N_states
pt2(k,2) = pt2(k,1) + pt2(k,2)
norm_pert(k,2) = norm_pert(k,1) + norm_pert(k,2)
H_pert_diag(k,2) = H_pert_diag(k,1) + H_pert_diag(k,2)
enddo
accu = accu + 1_8
call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more)
endif
enddo
call end_zmq_pull_socket(zmq_socket_pull)
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
integer(ZMQ_PTR), external :: new_zmq_pair_socket
integer(ZMQ_PTR) :: socket_result
socket_result = new_zmq_pair_socket(.False.)
call push_pt2(socket_result, pt2(1,2), norm_pert(1,2), H_pert_diag(1,2), N_states,0)
deallocate ( pt2, norm_pert, H_pert_diag)
call end_zmq_pair_socket(socket_result)
end

7
src/Determinants/SC2.irp.f
View File

@ -91,9 +91,6 @@ subroutine CISD_SC2(dets_in,u_in,energies,dim_in,sze,N_st,Nint,convergence)
e_corr_double_before = e_corr_double
iter = 0
do while (.not.converged)
if (abort_here) then
exit
endif
iter +=1
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP PRIVATE(i,j,degree,accu) &
@ -191,14 +188,14 @@ subroutine CISD_SC2(dets_in,u_in,energies,dim_in,sze,N_st,Nint,convergence)
write(output_determinants,'(A)') 'State Energy '
write(output_determinants,'(A)') '===== ================'
do i=1,N_st
write(output_determinants,'(I5,X,F16.10)') i, energies(i)+nuclear_repulsion
write(output_determinants,'(I5,1X,F16.10)') i, energies(i)+nuclear_repulsion
enddo
write(output_determinants,'(A)') '===== ================'
write(output_determinants,'(A)') ''
call write_double(output_determinants,(e_corr_double - e_corr_double_before),&
'Delta(E_corr)')
converged = dabs(e_corr_double - e_corr_double_before) < convergence
converged = converged .or. abort_here
converged = converged
if (converged) then
exit
endif

8
src/Determinants/davidson.irp.f
View File

@ -69,8 +69,8 @@ end
logical function det_inf(key1, key2, Nint)
use bitmasks
implicit none
integer(bit_kind),intent(in) :: key1(Nint, 2), key2(Nint, 2)
integer,intent(in) :: Nint
integer(bit_kind),intent(in) :: key1(Nint, 2), key2(Nint, 2)
integer :: i,j
det_inf = .false.
@ -239,10 +239,10 @@ subroutine sort_dets_ab(key, idx, shortcut, N_key, Nint)
BEGIN_DOC
! Uncodumented : TODO
END_DOC
integer, intent(in) :: Nint, N_key
integer(bit_kind),intent(inout) :: key(Nint,2,N_key)
integer,intent(out) :: idx(N_key)
integer,intent(out) :: shortcut(0:N_key+1)
integer, intent(in) :: Nint, N_key
integer(bit_kind) :: tmp(Nint, 2)
integer :: tmpidx,i,ni
@ -498,7 +498,7 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nint,iun
to_print(2,k) = residual_norm(k)
enddo
write(iunit,'(X,I3,X,100(X,F16.10,X,E16.6))'), iter, to_print(:,1:N_st)
write(iunit,'(X,I3,X,100(X,F16.10,X,E16.6))') iter, to_print(:,1:N_st)
call davidson_converged(lambda,residual_norm,wall,iter,cpu,N_st,converged)
if (converged) then
exit
@ -590,7 +590,6 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nint,iun
y, &
lambda &
)
abort_here = abort_all
end
BEGIN_PROVIDER [ character(64), davidson_criterion ]
@ -636,5 +635,4 @@ subroutine davidson_converged(energy,residual,wall,iterations,cpu,N_st,converged
else if (davidson_criterion == 'iterations') then
converged = iterations >= int(threshold_davidson)
endif
converged = converged.or.abort_here
end

188
src/Determinants/determinants.irp.f
View File

@ -386,66 +386,6 @@ subroutine sort_dets_by_det_search_key(Ndet, det_in, coef_in, det_out, coef_out)
end
subroutine int_of_3_highest_electrons( det_in, res, Nint )
implicit none
use bitmasks
integer,intent(in) :: Nint
integer(bit_kind) :: det_in(Nint)
integer*8 :: res
BEGIN_DOC
! Returns an integer*8 as :
!
! |_<--- 21 bits ---><--- 21 bits ---><--- 21 bits --->|
!
! |0<--- i1 ---><--- i2 ---><--- i3 --->|
!
! It encodes the value of the indices of the 3 highest MOs
! in descending order
!
END_DOC
integer :: i, k, icount
integer(bit_kind) :: ix
res = 0_8
icount = 3
do k=Nint,1,-1
ix = det_in(k)
do while (ix /= 0_bit_kind)
i = bit_kind_size-1-leadz(ix)
ix = ibclr(ix,i)
res = ior(ishft(res, 21), i+ishft(k-1,bit_kind_shift))
icount -= 1
if (icount == 0) then
return
endif
enddo
enddo
end
subroutine filter_3_highest_electrons( det_in, det_out, Nint )
implicit none
use bitmasks
integer,intent(in) :: Nint
integer(bit_kind) :: det_in(Nint), det_out(Nint)
BEGIN_DOC
! Returns a determinant with only the 3 highest electrons
END_DOC
integer :: i, k, icount
integer(bit_kind) :: ix
det_out = 0_8
icount = 3
do k=Nint,1,-1
ix = det_in(k)
do while (ix /= 0_bit_kind)
i = bit_kind_size-1-leadz(ix)
ix = ibclr(ix,i)
det_out(k) = ibset(det_out(k),i)
icount -= 1
if (icount == 0) then
return
endif
enddo
enddo
end
BEGIN_PROVIDER [ double precision, psi_coef_max, (N_states) ]
&BEGIN_PROVIDER [ double precision, psi_coef_min, (N_states) ]
@ -465,130 +405,6 @@ end
END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_ab, (N_int,2,psi_det_size) ]
&BEGIN_PROVIDER [ double precision, psi_coef_sorted_ab, (N_det,N_states) ]
&BEGIN_PROVIDER [ integer, psi_det_sorted_next_ab, (2,psi_det_size) ]
implicit none
BEGIN_DOC
! Determinants on which we apply <i|H|j>.
! They are sorted by the 3 highest electrons in the alpha part,
! then by the 3 highest electrons in the beta part to accelerate
! the research of connected determinants.
END_DOC
call sort_dets_by_3_highest_electrons( &
psi_det, &
psi_coef, &
psi_det_sorted_ab, &
psi_coef_sorted_ab, &
psi_det_sorted_next_ab, &
N_det, N_states, N_int, &
psi_det_size )
END_PROVIDER
subroutine sort_dets_by_3_highest_electrons(det_in,coef_in,det_out,coef_out, &
det_next, Ndet, Nstates, Nint, LDA)
implicit none
integer, intent(in) :: Ndet, Nstates, Nint, LDA
integer(bit_kind), intent(in) :: det_in (Nint,2,Ndet)
integer(bit_kind), intent(out) :: det_out (Nint,2,Ndet)
integer, intent(out) :: det_next (2,Ndet)
double precision, intent(in) :: coef_in (LDA,Nstates)
double precision, intent(out) :: coef_out (LDA,Nstates)
BEGIN_DOC
! Determinants on which we apply <i|H|j>.
! They are sorted by the 3 highest electrons in the alpha part,
! then by the 3 highest electrons in the beta part to accelerate
! the research of connected determinants.
END_DOC
integer :: i,j,k
integer, allocatable :: iorder(:)
integer*8, allocatable :: bit_tmp(:)
integer*8, external :: det_search_key
allocate ( iorder(Ndet), bit_tmp(Ndet) )
! Sort alpha dets
! ---------------
integer(bit_kind) :: det_tmp(Nint)
do i=1,Ndet
iorder(i) = i
call int_of_3_highest_electrons(psi_det(1,1,i),bit_tmp(i),N_int)
enddo
call i8sort(bit_tmp,iorder,Ndet)
!DIR$ IVDEP
do i=1,Ndet
do j=1,N_int
det_out(j,1,i) = psi_det(j,1,iorder(i))
det_out(j,2,i) = psi_det(j,2,iorder(i))
enddo
do k=1,Nstates
coef_out(i,k) = psi_coef(iorder(i),k)
enddo
enddo
! Find next alpha
! ---------------
integer :: next
next = Ndet+1
det_next(1,Ndet) = next
do i=Ndet-1,1,-1
if (bit_tmp(i) /= bit_tmp(i+1)) then
next = i+1
endif
det_next(1,i) = next
enddo
! Sort beta dets
! --------------
integer :: istart, iend
integer(bit_kind), allocatable :: det_sorted_temp (:,:)
allocate ( det_sorted_temp (N_int,Ndet) )
do i=1,Ndet
do j=1,N_int
det_sorted_temp(j,i) = det_out(j,2,i)
enddo
iorder(i) = i
call int_of_3_highest_electrons(det_sorted_temp(1,i),bit_tmp(i),N_int)
enddo
istart=1
do while ( istart<Ndet )
iend = det_next(1,istart)
call i8sort(bit_tmp(istart),iorder(istart),iend-istart)
!DIR$ IVDEP
do i=istart,iend-1
do j=1,N_int
det_out(j,2,i) = det_sorted_temp(j,iorder(i))
enddo
do k=1,Nstates
coef_out(i,k) = psi_coef(iorder(i),k)
enddo
enddo
next = iend
det_next(2,iend-1) = next
do i=iend-2,1,-1
if (bit_tmp(i) /= bit_tmp(i+1)) then
next = i+1
endif
det_next(2,i) = next
enddo
istart = iend
enddo
deallocate(iorder, bit_tmp, det_sorted_temp)
end
!==============================================================================!
! !
@ -645,7 +461,9 @@ end
subroutine save_ref_determinant
implicit none
use bitmasks
call save_wavefunction_general(1,1,ref_bitmask,1,1.d0)
double precision :: buffer(1,1)
buffer(1,1) = 1.d0
call save_wavefunction_general(1,1,ref_bitmask,1,buffer)
end

52
src/Determinants/filter_connected.irp.f
View File

@ -112,16 +112,16 @@ subroutine getMobiles(key,key_mask, mobiles,Nint)
mobileMask(j,2) = xor(key(j,2), key_mask(j,2))
end do
call bitstring_to_list(mobileMask(:,1), list(:), nel, Nint)
call bitstring_to_list(mobileMask(1,1), list, nel, Nint)
if(nel == 2) then
mobiles(1) = list(1)
mobiles(2) = list(2)
else if(nel == 1) then
mobiles(1) = list(1)
call bitstring_to_list(mobileMask(:,2), list(:), nel, Nint)
call bitstring_to_list(mobileMask(1,2), list, nel, Nint)
mobiles(2) = list(1) + mo_tot_num
else
call bitstring_to_list(mobileMask(:,2), list(:), nel, Nint)
call bitstring_to_list(mobileMask(1,2), list, nel, Nint)
mobiles(1) = list(1) + mo_tot_num
mobiles(2) = list(2) + mo_tot_num
end if
@ -139,6 +139,8 @@ subroutine create_microlist(minilist, N_minilist, key_mask, microlist, idx_micro
integer :: i,j,k,nt,n_element(2)
integer :: list(Nint*bit_kind_size,2), cur_microlist(0:mo_tot_num*2+1)
integer(bit_kind) :: key_mask_neg(Nint,2), mobileMask(Nint,2)
integer :: mo_tot_num_2
mo_tot_num_2 = mo_tot_num+mo_tot_num
do i=1,Nint
@ -146,7 +148,9 @@ subroutine create_microlist(minilist, N_minilist, key_mask, microlist, idx_micro
key_mask_neg(i,2) = not(key_mask(i,2))
end do
N_microlist(:) = 0
do i=0,mo_tot_num_2
N_microlist(i) = 0
enddo
do i=1, N_minilist
do j=1,Nint
@ -154,8 +158,8 @@ subroutine create_microlist(minilist, N_minilist, key_mask, microlist, idx_micro
mobileMask(j,2) = iand(key_mask_neg(j,2), minilist(j,2,i))
end do
call bitstring_to_list(mobileMask(:,1), list(:,1), n_element(1), Nint)
call bitstring_to_list(mobileMask(:,2), list(:,2), n_element(2), Nint)
call bitstring_to_list(mobileMask(1,1), list(1,1), n_element(1), Nint)
call bitstring_to_list(mobileMask(1,2), list(1,2), n_element(2), Nint)
if(n_element(1) + n_element(2) /= 4) then
N_microlist(0) = N_microlist(0) + 1
@ -173,11 +177,14 @@ subroutine create_microlist(minilist, N_minilist, key_mask, microlist, idx_micro
end do
ptr_microlist(0) = 1
do i=1,mo_tot_num*2+1
do i=1,mo_tot_num_2+1
ptr_microlist(i) = ptr_microlist(i-1) + N_microlist(i-1)
end do
do i=0,mo_tot_num_2+1
cur_microlist(i) = ptr_microlist(i)
end do
cur_microlist(:) = ptr_microlist(:)
do i=1, N_minilist
do j=1,Nint
@ -185,26 +192,35 @@ subroutine create_microlist(minilist, N_minilist, key_mask, microlist, idx_micro
mobileMask(j,2) = iand(key_mask_neg(j,2), minilist(j,2,i))
end do
call bitstring_to_list(mobileMask(:,1), list(:,1), n_element(1), Nint)
call bitstring_to_list(mobileMask(:,2), list(:,2), n_element(2), Nint)
call bitstring_to_list(mobileMask(1,1), list(1,1), n_element(1), Nint)
call bitstring_to_list(mobileMask(1,2), list(1,2), n_element(2), Nint)
if(n_element(1) + n_element(2) /= 4) then
idx_microlist(cur_microlist(0)) = i
microlist(:,:,cur_microlist(0)) = minilist(:,:,i)
do k=1,Nint
microlist(k,1,cur_microlist(0)) = minilist(k,1,i)
microlist(k,2,cur_microlist(0)) = minilist(k,2,i)
enddo
cur_microlist(0) = cur_microlist(0) + 1
else
do j=1,n_element(1)
nt = list(j,1)
idx_microlist(cur_microlist(nt)) = i
microlist(:,:,cur_microlist(nt)) = minilist(:,:,i)
do k=1,Nint
microlist(k,1,cur_microlist(nt)) = minilist(k,1,i)
microlist(k,2,cur_microlist(nt)) = minilist(k,2,i)
enddo
cur_microlist(nt) = cur_microlist(nt) + 1
end do
do j=1,n_element(2)
nt = list(j,2) + mo_tot_num
idx_microlist(cur_microlist(nt)) = i
microlist(:,:,cur_microlist(nt)) = minilist(:,:,i)
do k=1,Nint
microlist(k,1,cur_microlist(nt)) = minilist(k,1,i)
microlist(k,2,cur_microlist(nt)) = minilist(k,2,i)
enddo
cur_microlist(nt) = cur_microlist(nt) + 1
end do
end if
@ -212,16 +228,6 @@ subroutine create_microlist(minilist, N_minilist, key_mask, microlist, idx_micro
end subroutine
subroutine merdge(mic, idx_mic, N_mic, mic0, idx_mic0, N_mic0, Nint)
use bitmasks
integer(bit_kind) :: mic(Nint,2,N_mic), mic0(Nint,2,*)
integer :: idx_mic(N_mic), idx_mic0(N_mic0), N_mic, N_mic0
mic0(:,:,N_mic0+1:N_mic0+N_mic) = mic(:,:,:)
idx_mic0(N_mic0+1:N_mic0+N_mic) = idx_mic(:)
end subroutine
subroutine filter_connected_i_H_psi0(key1,key2,Nint,sze,idx)
use bitmasks
BEGIN_DOC

4
src/Determinants/s2.irp.f
View File

@ -82,8 +82,8 @@ END_PROVIDER
subroutine get_s2_u0_old(psi_keys_tmp,psi_coefs_tmp,n,nmax,s2)
implicit none
use bitmasks
integer(bit_kind), intent(in) :: psi_keys_tmp(N_int,2,nmax)
integer, intent(in) :: n,nmax
integer(bit_kind), intent(in) :: psi_keys_tmp(N_int,2,nmax)
double precision, intent(in) :: psi_coefs_tmp(nmax)
double precision, intent(out) :: s2
integer :: i,j,l
@ -109,8 +109,8 @@ end
subroutine get_s2_u0(psi_keys_tmp,psi_coefs_tmp,n,nmax,s2)
implicit none
use bitmasks
integer(bit_kind), intent(in) :: psi_keys_tmp(N_int,2,nmax)
integer, intent(in) :: n,nmax
integer(bit_kind), intent(in) :: psi_keys_tmp(N_int,2,nmax)
double precision, intent(in) :: psi_coefs_tmp(nmax)
double precision, intent(out) :: s2
double precision :: s2_tmp

249
src/Determinants/slater_rules.irp.f
View File

@ -443,7 +443,7 @@ subroutine i_H_j(key_i,key_j,Nint,hij)
integer :: exc(0:2,2,2)
integer :: degree
double precision :: get_mo_bielec_integral_schwartz
double precision :: get_mo_bielec_integral
integer :: m,n,p,q
integer :: i,j,k
integer :: occ(Nint*bit_kind_size,2)
@ -468,31 +468,31 @@ subroutine i_H_j(key_i,key_j,Nint,hij)
call get_double_excitation(key_i,key_j,exc,phase,Nint)
if (exc(0,1,1) == 1) then
! Mono alpha, mono beta
hij = phase*get_mo_bielec_integral_schwartz( &
hij = phase*get_mo_bielec_integral( &
exc(1,1,1), &
exc(1,1,2), &
exc(1,2,1), &
exc(1,2,2) ,mo_integrals_map)
else if (exc(0,1,1) == 2) then
! Double alpha
hij = phase*(get_mo_bielec_integral_schwartz( &
hij = phase*(get_mo_bielec_integral( &
exc(1,1,1), &
exc(2,1,1), &
exc(1,2,1), &
exc(2,2,1) ,mo_integrals_map) - &
get_mo_bielec_integral_schwartz( &
get_mo_bielec_integral( &
exc(1,1,1), &
exc(2,1,1), &
exc(2,2,1), &
exc(1,2,1) ,mo_integrals_map) )
else if (exc(0,1,2) == 2) then
! Double beta
hij = phase*(get_mo_bielec_integral_schwartz( &
hij = phase*(get_mo_bielec_integral( &
exc(1,1,2), &
exc(2,1,2), &
exc(1,2,2), &
exc(2,2,2) ,mo_integrals_map) - &
get_mo_bielec_integral_schwartz( &
get_mo_bielec_integral( &
exc(1,1,2), &
exc(2,1,2), &
exc(2,2,2), &
@ -510,15 +510,15 @@ subroutine i_H_j(key_i,key_j,Nint,hij)
do k = 1, elec_alpha_num
i = occ(k,1)
if (.not.has_mipi(i)) then
mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map)
miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map)
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
do k = 1, elec_beta_num
i = occ(k,2)
if (.not.has_mipi(i)) then
mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map)
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
@ -537,15 +537,15 @@ subroutine i_H_j(key_i,key_j,Nint,hij)
do k = 1, elec_beta_num
i = occ(k,2)
if (.not.has_mipi(i)) then
mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map)
miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map)
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
do k = 1, elec_alpha_num
i = occ(k,1)
if (.not.has_mipi(i)) then
mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map)
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
@ -579,7 +579,7 @@ subroutine i_H_j_phase_out(key_i,key_j,Nint,hij,phase,exc,degree)
integer,intent(out) :: exc(0:2,2,2)
integer,intent(out) :: degree
double precision :: get_mo_bielec_integral_schwartz
double precision :: get_mo_bielec_integral
integer :: m,n,p,q
integer :: i,j,k
integer :: occ(Nint*bit_kind_size,2)
@ -604,31 +604,31 @@ subroutine i_H_j_phase_out(key_i,key_j,Nint,hij,phase,exc,degree)
call get_double_excitation(key_i,key_j,exc,phase,Nint)
if (exc(0,1,1) == 1) then
! Mono alpha, mono beta
hij = phase*get_mo_bielec_integral_schwartz( &
hij = phase*get_mo_bielec_integral( &
exc(1,1,1), &
exc(1,1,2), &
exc(1,2,1), &
exc(1,2,2) ,mo_integrals_map)
else if (exc(0,1,1) == 2) then
! Double alpha
hij = phase*(get_mo_bielec_integral_schwartz( &
hij = phase*(get_mo_bielec_integral( &
exc(1,1,1), &
exc(2,1,1), &
exc(1,2,1), &
exc(2,2,1) ,mo_integrals_map) - &
get_mo_bielec_integral_schwartz( &
get_mo_bielec_integral( &
exc(1,1,1), &
exc(2,1,1), &
exc(2,2,1), &
exc(1,2,1) ,mo_integrals_map) )
else if (exc(0,1,2) == 2) then
! Double beta
hij = phase*(get_mo_bielec_integral_schwartz( &
hij = phase*(get_mo_bielec_integral( &
exc(1,1,2), &
exc(2,1,2), &
exc(1,2,2), &
exc(2,2,2) ,mo_integrals_map) - &
get_mo_bielec_integral_schwartz( &
get_mo_bielec_integral( &
exc(1,1,2), &
exc(2,1,2), &
exc(2,2,2), &
@ -646,15 +646,15 @@ subroutine i_H_j_phase_out(key_i,key_j,Nint,hij,phase,exc,degree)
do k = 1, elec_alpha_num
i = occ(k,1)
if (.not.has_mipi(i)) then
mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map)
miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map)
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
do k = 1, elec_beta_num
i = occ(k,2)
if (.not.has_mipi(i)) then
mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map)
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
@ -673,15 +673,15 @@ subroutine i_H_j_phase_out(key_i,key_j,Nint,hij,phase,exc,degree)
do k = 1, elec_beta_num
i = occ(k,2)
if (.not.has_mipi(i)) then
mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map)
miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map)
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
do k = 1, elec_alpha_num
i = occ(k,1)
if (.not.has_mipi(i)) then
mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map)
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
@ -715,7 +715,7 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble)
integer :: exc(0:2,2,2)
integer :: degree
double precision :: get_mo_bielec_integral_schwartz
double precision :: get_mo_bielec_integral
integer :: m,n,p,q
integer :: i,j,k
integer :: occ(Nint*bit_kind_size,2)
@ -742,31 +742,31 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble)
call get_double_excitation(key_i,key_j,exc,phase,Nint)
if (exc(0,1,1) == 1) then
! Mono alpha, mono beta
hij = phase*get_mo_bielec_integral_schwartz( &
hij = phase*get_mo_bielec_integral( &
exc(1,1,1), &
exc(1,1,2), &
exc(1,2,1), &
exc(1,2,2) ,mo_integrals_map)
else if (exc(0,1,1) == 2) then
! Double alpha
hij = phase*(get_mo_bielec_integral_schwartz( &
hij = phase*(get_mo_bielec_integral( &
exc(1,1,1), &
exc(2,1,1), &
exc(1,2,1), &
exc(2,2,1) ,mo_integrals_map) - &
get_mo_bielec_integral_schwartz( &
get_mo_bielec_integral( &
exc(1,1,1), &
exc(2,1,1), &
exc(2,2,1), &
exc(1,2,1) ,mo_integrals_map) )
else if (exc(0,1,2) == 2) then
! Double beta
hij = phase*(get_mo_bielec_integral_schwartz( &
hij = phase*(get_mo_bielec_integral( &
exc(1,1,2), &
exc(2,1,2), &
exc(1,2,2), &
exc(2,2,2) ,mo_integrals_map) - &
get_mo_bielec_integral_schwartz( &
get_mo_bielec_integral( &
exc(1,1,2), &
exc(2,1,2), &
exc(2,2,2), &
@ -784,15 +784,15 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble)
do k = 1, elec_alpha_num
i = occ(k,1)
if (.not.has_mipi(i)) then
mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map)
miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map)
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
do k = 1, elec_beta_num
i = occ(k,2)
if (.not.has_mipi(i)) then
mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map)
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
@ -811,15 +811,15 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble)
do k = 1, elec_beta_num
i = occ(k,2)
if (.not.has_mipi(i)) then
mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map)
miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map)
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
do k = 1, elec_alpha_num
i = occ(k,1)
if (.not.has_mipi(i)) then
mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map)
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
@ -845,25 +845,30 @@ subroutine create_minilist(key_mask, fullList, miniList, idx_miniList, N_fullLis
use bitmasks
implicit none
integer(bit_kind), intent(in) :: fullList(Nint, 2, N_fullList)
integer, intent(in) :: N_fullList
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: fullList(Nint, 2, N_fullList)
integer(bit_kind),intent(out) :: miniList(Nint, 2, N_fullList)
integer,intent(out) :: idx_miniList(N_fullList), N_miniList
integer, intent(in) :: Nint
integer(bit_kind) :: key_mask(Nint, 2)
integer :: ni, i, n_a, n_b, e_a, e_b
integer :: ni, k, i, n_a, n_b, e_a, e_b
n_a = 0
n_b = 0
do ni=1,nint
n_a = popcnt(key_mask(1,1))
n_b = popcnt(key_mask(1,2))
do ni=2,nint
n_a = n_a + popcnt(key_mask(ni,1))
n_b = n_b + popcnt(key_mask(ni,2))
end do
if(n_a == 0) then
N_miniList = N_fullList
miniList(:,:,:) = fullList(:,:,:)
do k=1,N_fullList
do ni=1,Nint
miniList(ni,1,k) = fullList(ni,1,k)
miniList(ni,2,k) = fullList(ni,2,k)
enddo
enddo
do i=1,N_fullList
idx_miniList(i) = i
end do
@ -873,16 +878,19 @@ subroutine create_minilist(key_mask, fullList, miniList, idx_miniList, N_fullLis
N_miniList = 0
do i=1,N_fullList
e_a = n_a
e_b = n_b
do ni=1,nint
e_a = n_a - popcnt(iand(fullList(1, 1, i), key_mask(1, 1)))
e_b = n_b - popcnt(iand(fullList(1, 2, i), key_mask(1, 2)))
do ni=2,nint
e_a -= popcnt(iand(fullList(ni, 1, i), key_mask(ni, 1)))
e_b -= popcnt(iand(fullList(ni, 2, i), key_mask(ni, 2)))
end do
if(e_a + e_b <= 2) then
N_miniList = N_miniList + 1
miniList(:,:,N_miniList) = fullList(:,:,i)
do ni=1,Nint
miniList(ni,1,N_miniList) = fullList(ni,1,i)
miniList(ni,2,N_miniList) = fullList(ni,2,i)
enddo
idx_miniList(N_miniList) = i
end if
end do
@ -892,29 +900,34 @@ subroutine create_minilist_find_previous(key_mask, fullList, miniList, N_fullLis
use bitmasks
implicit none
integer(bit_kind), intent(in) :: fullList(Nint, 2, N_fullList)
integer, intent(in) :: N_fullList
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: fullList(Nint, 2, N_fullList)
integer(bit_kind),intent(out) :: miniList(Nint, 2, N_fullList)
integer(bit_kind) :: subList(Nint, 2, N_fullList)
logical,intent(out) :: fullMatch
integer,intent(out) :: N_miniList
integer, intent(in) :: Nint
integer(bit_kind) :: key_mask(Nint, 2)
integer :: ni, i, k, l, N_subList
fullMatch = .false.
l = 0
N_miniList = 0
N_subList = 0
do ni = 1,Nint
l += popcnt(key_mask(ni,1)) + popcnt(key_mask(ni,2))
l = popcnt(key_mask(1,1)) + popcnt(key_mask(1,2))
do ni = 2,Nint
l = l + popcnt(key_mask(ni,1)) + popcnt(key_mask(ni,2))
end do
if(l == 0) then
N_miniList = N_fullList
miniList(:,:,:N_miniList) = fullList(:,:,:N_minilist)
do k=1,N_fullList
do ni=1,Nint
miniList(ni,1,k) = fullList(ni,1,k)
miniList(ni,2,k) = fullList(ni,2,k)
enddo
enddo
else
do i=N_fullList,1,-1
k = l
@ -923,10 +936,16 @@ subroutine create_minilist_find_previous(key_mask, fullList, miniList, N_fullLis
end do
if(k == 2) then
N_subList += 1
subList(:,:,N_subList) = fullList(:,:,i)
do ni=1,Nint
subList(ni,1,N_subList) = fullList(ni,1,i)
subList(ni,2,N_subList) = fullList(ni,2,i)
enddo
else if(k == 1) then
N_minilist += 1
miniList(:,:,N_minilist) = fullList(:,:,i)
do ni=1,Nint
miniList(ni,1,N_minilist) = fullList(ni,1,i)
miniList(ni,2,N_minilist) = fullList(ni,2,i)
enddo
else if(k == 0) then
fullMatch = .true.
return
@ -935,7 +954,12 @@ subroutine create_minilist_find_previous(key_mask, fullList, miniList, N_fullLis
end if
if(N_subList > 0) then
miniList(:,:,N_minilist+1:N_minilist+N_subList) = sublist(:,:,:N_subList)
do k=1,N_subList
do ni=1,Nint
miniList(ni,1,N_minilist+k) = sublist(ni,1,k)
miniList(ni,2,N_minilist+k) = sublist(ni,2,k)
enddo
enddo
N_minilist = N_minilist + N_subList
end if
end subroutine
@ -972,14 +996,28 @@ subroutine i_H_psi(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array)
i_H_psi_array = 0.d0
call filter_connected_i_H_psi0(keys,key,Nint,Ndet,idx)
do ii=1,idx(0)
i = idx(ii)
!DIR$ FORCEINLINE
call i_H_j(keys(1,1,i),key,Nint,hij)
do j = 1, Nstate
i_H_psi_array(j) = i_H_psi_array(j) + coef(i,j)*hij
if (Nstate == 1) then
do ii=1,idx(0)
i = idx(ii)
!DIR$ FORCEINLINE
call i_H_j(keys(1,1,i),key,Nint,hij)
i_H_psi_array(1) = i_H_psi_array(1) + coef(i,1)*hij
enddo
enddo
else
do ii=1,idx(0)
i = idx(ii)
!DIR$ FORCEINLINE
call i_H_j(keys(1,1,i),key,Nint,hij)
do j = 1, Nstate
i_H_psi_array(j) = i_H_psi_array(j) + coef(i,j)*hij
enddo
enddo
endif
end
@ -1012,15 +1050,30 @@ subroutine i_H_psi_minilist(key,keys,idx_key,N_minilist,coef,Nint,Ndet,Ndet_max,
i_H_psi_array = 0.d0
call filter_connected_i_H_psi0(keys,key,Nint,N_minilist,idx)
do ii=1,idx(0)
i_in_key = idx(ii)
i_in_coef = idx_key(idx(ii))
!DIR$ FORCEINLINE
call i_H_j(keys(1,1,i_in_key),key,Nint,hij)
do j = 1, Nstate
i_H_psi_array(j) = i_H_psi_array(j) + coef(i_in_coef,j)*hij
if (Nstate == 1) then
do ii=1,idx(0)
i_in_key = idx(ii)
i_in_coef = idx_key(idx(ii))
!DIR$ FORCEINLINE
call i_H_j(keys(1,1,i_in_key),key,Nint,hij)
i_H_psi_array(1) = i_H_psi_array(1) + coef(i_in_coef,1)*hij
enddo
enddo
else
do ii=1,idx(0)
i_in_key = idx(ii)
i_in_coef = idx_key(idx(ii))
!DIR$ FORCEINLINE
call i_H_j(keys(1,1,i_in_key),key,Nint,hij)
do j = 1, Nstate
i_H_psi_array(j) = i_H_psi_array(j) + coef(i_in_coef,j)*hij
enddo
enddo
endif
end
subroutine i_H_psi_sec_ord(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array,idx_interaction,interactions)
@ -1497,8 +1550,8 @@ subroutine get_occ_from_key(key,occ,Nint)
BEGIN_DOC
! Returns a list of occupation numbers from a bitstring
END_DOC
integer(bit_kind), intent(in) :: key(Nint,2)
integer , intent(in) :: Nint
integer(bit_kind), intent(in) :: key(Nint,2)
integer , intent(out) :: occ(Nint*bit_kind_size,2)
integer :: tmp(2)
@ -1675,3 +1728,55 @@ subroutine H_u_0(v_0,u_0,H_jj,n,keys_tmp,Nint)
deallocate (shortcut, sort_idx, sorted, version)
end
subroutine apply_excitation(det, exc, res, ok, Nint)
use bitmasks
implicit none
integer, intent(in) :: Nint
integer, intent(in) :: exc(0:2,2,2)
integer(bit_kind),intent(in) :: det(Nint, 2)
integer(bit_kind),intent(out) :: res(Nint, 2)
logical, intent(out) :: ok
integer :: h1,p1,h2,p2,s1,s2,degree
integer :: ii, pos
ok = .false.
degree = exc(0,1,1) + exc(0,1,2)
if(.not. (degree > 0 .and. degree <= 2)) then
print *, degree
print *, "apply ex"
STOP
endif
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
res = det
ii = (h1-1)/bit_kind_size + 1
pos = mod(h1-1, 64)!iand(h1-1,bit_kind_size-1) ! mod 64
if(iand(det(ii, s1), ishft(1_bit_kind, pos)) == 0_8) return
res(ii, s1) = ibclr(res(ii, s1), pos)
ii = (p1-1)/bit_kind_size + 1
pos = mod(p1-1, 64)!iand(p1-1,bit_kind_size-1)
if(iand(det(ii, s1), ishft(1_bit_kind, pos)) /= 0_8) return
res(ii, s1) = ibset(res(ii, s1), pos)
if(degree == 2) then
ii = (h2-1)/bit_kind_size + 1
pos = mod(h2-1, 64)!iand(h2-1,bit_kind_size-1)
if(iand(det(ii, s2), ishft(1_bit_kind, pos)) == 0_8) return
res(ii, s2) = ibclr(res(ii, s2), pos)
ii = (p2-1)/bit_kind_size + 1
pos = mod(p2-1, 64)!iand(p2-1,bit_kind_size-1)
if(iand(det(ii, s2), ishft(1_bit_kind, pos)) /= 0_8) return
res(ii, s2) = ibset(res(ii, s2), pos)
endif
ok = .true.
end subroutine

4
src/Determinants/spindeterminants.irp.f
View File

@ -14,13 +14,13 @@ integer*8 function spin_det_search_key(det,Nint)
END_DOC
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: det(Nint)
integer(bit_kind), parameter :: unsigned_shift = not(huge(1_bit_kind)) ! 100...00
integer(bit_kind), parameter :: unsigned_shift = -huge(1_bit_kind) ! 100...00
integer :: i
spin_det_search_key = det(1)
do i=2,Nint
spin_det_search_key = ieor(spin_det_search_key,det(i))
enddo
spin_det_search_key = spin_det_search_key-unsigned_shift
spin_det_search_key = spin_det_search_key+1_bit_kind-unsigned_shift
end

25
src/Integrals_Bielec/ao_bi_integrals.irp.f
View File

@ -365,20 +365,31 @@ BEGIN_PROVIDER [ logical, ao_bielec_integrals_in_map ]
call cpu_time(cpu_1)
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
call new_parallel_job(zmq_to_qp_run_socket,'ao_integrals')
character*(32) :: task
call new_parallel_job(zmq_to_qp_run_socket,'ao_integrals')
do l=1,ao_num
write(task,*) 'triangle', l
write(task,*) l
call add_task_to_taskserver(zmq_to_qp_run_socket,task)
enddo
external :: ao_bielec_integrals_in_map_slave_inproc, ao_bielec_integrals_in_map_collector
call new_parallel_threads(ao_bielec_integrals_in_map_slave_inproc, ao_bielec_integrals_in_map_collector)
integer(ZMQ_PTR) :: collector_thread
external :: ao_bielec_integrals_in_map_collector
rc = pthread_create(collector_thread, ao_bielec_integrals_in_map_collector)
!$OMP PARALLEL DEFAULT(private)
!$OMP TASK PRIVATE(i)
i = omp_get_thread_num()
call ao_bielec_integrals_in_map_slave_inproc(i)
!$OMP END TASK
!$OMP TASKWAIT
!$OMP END PARALLEL
rc = pthread_join(collector_thread)
call end_parallel_job(zmq_to_qp_run_socket, 'ao_integrals')
call end_parallel_job(zmq_to_qp_run_socket,'ao_integrals')
print*, 'Sorting the map'
call map_sort(ao_integrals_map)

211
src/Integrals_Bielec/ao_bielec_integrals_in_map_slave.irp.f
View File

@ -1,20 +1,73 @@
subroutine ao_bielec_integrals_in_map_slave_tcp
subroutine ao_bielec_integrals_in_map_slave_tcp(i)
implicit none
integer, intent(in) :: i
BEGIN_DOC
! Computes a buffer of integrals
! Computes a buffer of integrals. i is the ID of the current thread.
END_DOC
call ao_bielec_integrals_in_map_slave(0)
call ao_bielec_integrals_in_map_slave(0,i)
end
subroutine ao_bielec_integrals_in_map_slave_inproc
subroutine ao_bielec_integrals_in_map_slave_inproc(i)
implicit none
integer, intent(in) :: i
BEGIN_DOC
! Computes a buffer of integrals
! Computes a buffer of integrals. i is the ID of the current thread.
END_DOC
call ao_bielec_integrals_in_map_slave(1)
call ao_bielec_integrals_in_map_slave(1,i)
end
subroutine ao_bielec_integrals_in_map_slave(thread)
subroutine push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, task_id)
use f77_zmq
use map_module
implicit none
BEGIN_DOC
! Push integrals in the push socket
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_socket_push
integer, intent(in) :: n_integrals
integer(key_kind), intent(in) :: buffer_i(*)
real(integral_kind), intent(in) :: buffer_value(*)
integer, intent(in) :: task_id
integer :: rc
rc = f77_zmq_send( zmq_socket_push, n_integrals, 4, ZMQ_SNDMORE)
if (rc /= 4) then
print *, irp_here, 'f77_zmq_send( zmq_socket_push, n_integrals, 4, ZMQ_SNDMORE)'
stop 'error'
endif
rc = f77_zmq_send( zmq_socket_push, buffer_i, key_kind*n_integrals, ZMQ_SNDMORE)
if (rc /= key_kind*n_integrals) then
print *, irp_here, 'f77_zmq_send( zmq_socket_push, buffer_i, key_kind*n_integrals, ZMQ_SNDMORE)'
stop 'error'
endif
rc = f77_zmq_send( zmq_socket_push, buffer_value, integral_kind*n_integrals, ZMQ_SNDMORE)
if (rc /= integral_kind*n_integrals) then
print *, irp_here, 'f77_zmq_send( zmq_socket_push, buffer_value, integral_kind*n_integrals, 0)'
stop 'error'
endif
rc = f77_zmq_send( zmq_socket_push, task_id, 4, 0)
if (rc /= 4) then
print *, irp_here, 'f77_zmq_send( zmq_socket_push, task_id, 4, 0)'
stop 'error'
endif
! Activate is zmq_socket_push is a REQ
! integer :: idummy
! rc = f77_zmq_recv( zmq_socket_push, idummy, 4, 0)
! if (rc /= 4) then
! print *, irp_here, 'f77_zmq_send( zmq_socket_push, idummy, 4, 0)'
! stop 'error'
! endif
end
subroutine ao_bielec_integrals_in_map_slave(thread,iproc)
use map_module
use f77_zmq
implicit none
@ -22,7 +75,7 @@ subroutine ao_bielec_integrals_in_map_slave(thread)
! Computes a buffer of integrals
END_DOC
integer, intent(in) :: thread
integer, intent(in) :: thread, iproc
integer :: j,l,n_integrals
integer :: rc
@ -35,19 +88,11 @@ subroutine ao_bielec_integrals_in_map_slave(thread)
integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
integer(ZMQ_PTR), external :: new_zmq_push_socket
integer(ZMQ_PTR) :: zmq_socket_push
! zmq_socket_push = f77_zmq_socket(zmq_context, ZMQ_PUSH)
zmq_socket_push = f77_zmq_socket(zmq_context, ZMQ_REQ )
if (thread == 1) then
rc = f77_zmq_connect(zmq_socket_push, trim(zmq_socket_pull_inproc_address))
else
rc = f77_zmq_connect(zmq_socket_push, trim(zmq_socket_push_tcp_address))
endif
if (rc /= 0) then
stop 'Unable to connect zmq_socket_push_tcp'
endif
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
zmq_socket_push = new_zmq_push_socket(thread)
allocate ( buffer_i(ao_num*ao_num), buffer_value(ao_num*ao_num) )
@ -55,31 +100,78 @@ subroutine ao_bielec_integrals_in_map_slave(thread)
do
call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task)
if (task_id == 0) then
exit
endif
read(task,*) j, l
call compute_ao_integrals_jl(j,l,n_integrals,buffer_i,buffer_value)
rc = f77_zmq_send( zmq_socket_push, n_integrals, 4, ZMQ_SNDMORE)
rc = f77_zmq_send( zmq_socket_push, buffer_i, key_kind*n_integrals, ZMQ_SNDMORE)
rc = f77_zmq_send( zmq_socket_push, buffer_value, integral_kind*n_integrals, 0)
call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id)
character*(2) :: ok
rc = f77_zmq_recv( zmq_socket_push, ok, 2, 0)
if (task_id == 0) exit
read(task,*) l
do j=1,l-1
call compute_ao_integrals_jl(j,l,n_integrals,buffer_i,buffer_value)
call push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, 0)
enddo
call compute_ao_integrals_jl(l,l,n_integrals,buffer_i,buffer_value)
call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id,n_integrals)
call push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, task_id)
enddo
deallocate( buffer_i, buffer_value )
integer :: finished
call disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id,finished)
call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id)
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
call end_zmq_push_socket(zmq_socket_push,thread)
if (finished /= 0) then
rc = f77_zmq_send( zmq_socket_push, -1, 4, 0)
rc = f77_zmq_recv( zmq_socket_push, ok, 2, ZMQ_NOBLOCK)
end
subroutine pull_integrals(zmq_socket_pull, n_integrals, buffer_i, buffer_value, task_id)
use f77_zmq
use map_module
implicit none
BEGIN_DOC
! How the collector pulls the computed integrals
END_DOC
integer(ZMQ_PTR), intent(out) :: zmq_socket_pull
integer, intent(out) :: n_integrals
integer(key_kind), intent(out) :: buffer_i(*)
real(integral_kind), intent(out) :: buffer_value(*)
integer, intent(out) :: task_id
integer :: rc
rc = f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0)
if (rc == -1) then
n_integrals = 0
return
endif
if (rc /= 4) then
print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0)'
stop 'error'
endif
if (n_integrals >= 0) then
rc = f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0)
if (rc /= key_kind*n_integrals) then
print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0)'
stop 'error'
endif
rc = f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0)
if (rc /= integral_kind*n_integrals) then
print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0)'
stop 'error'
endif
rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0)
if (rc /= 4) then
print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, task_id, 4, 0)'
stop 'error'
endif
endif
rc = f77_zmq_disconnect(zmq_socket_push,trim(zmq_socket_push_tcp_address))
rc = f77_zmq_close(zmq_socket_push)
! Activate if zmq_socket_pull is a REP
! rc = f77_zmq_send( zmq_socket_pull, 0, 4, 0)
! if (rc /= 4) then
! print *, irp_here, ' f77_zmq_send (zmq_socket_pull,...'
! stop 'error'
! endif
end
@ -94,27 +186,54 @@ subroutine ao_bielec_integrals_in_map_collector
integer :: j,l,n_integrals
integer :: rc
real(integral_kind), allocatable :: buffer_value(:)
integer(key_kind), allocatable :: buffer_i(:)
integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
integer(ZMQ_PTR), external :: new_zmq_pull_socket
integer(ZMQ_PTR) :: zmq_socket_pull
integer*8 :: control, accu
integer :: task_id, more
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
zmq_socket_pull = new_zmq_pull_socket()
allocate ( buffer_i(ao_num*ao_num), buffer_value(ao_num*ao_num) )
n_integrals = 0
do while (n_integrals >= 0)
accu = 0_8
more = 1
do while (more == 1)
rc = f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0)
call pull_integrals(zmq_socket_pull, n_integrals, buffer_i, buffer_value, task_id)
if (n_integrals >= 0) then
rc = f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0)
rc = f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0)
rc = f77_zmq_send( zmq_socket_pull, 'ok', 2, 0)
call insert_into_ao_integrals_map(n_integrals,buffer_i,buffer_value)
else
rc = f77_zmq_send( zmq_socket_pull, 'ok', 2, 0)
accu += n_integrals
if (task_id /= 0) then
call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more)
endif
endif
enddo
deallocate( buffer_i, buffer_value )
integer (map_size_kind) :: get_ao_map_size
control = get_ao_map_size(ao_integrals_map)
if (control /= accu) then
print *, irp_here, 'Control : ', control
print *, 'Accu : ', accu
print *, 'Some integrals were lost during the parallel computation. (2)'
print *, 'Try to reduce the number of threads.'
stop
endif
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
call end_zmq_pull_socket(zmq_socket_pull)
end

4
src/Integrals_Bielec/map_integrals.irp.f
View File

@ -324,9 +324,9 @@ double precision function mo_bielec_integral(i,j,k,l)
! Returns one integral <ij|kl> in the MO basis
END_DOC
integer, intent(in) :: i,j,k,l
double precision :: get_mo_bielec_integral_schwartz
double precision :: get_mo_bielec_integral
PROVIDE mo_bielec_integrals_in_map
mo_bielec_integral = get_mo_bielec_integral_schwartz(i,j,k,l,mo_integrals_map)
mo_bielec_integral = get_mo_bielec_integral(i,j,k,l,mo_integrals_map)
return
end

48
src/Integrals_Bielec/mo_bi_integrals.irp.f
View File

@ -36,7 +36,7 @@ BEGIN_PROVIDER [ logical, mo_bielec_integrals_in_map ]
endif
endif
call add_integrals_to_map(full_ijkl_bitmask)
call add_integrals_to_map(full_ijkl_bitmask_4)
END_PROVIDER
subroutine add_integrals_to_map(mask_ijkl)
@ -90,8 +90,6 @@ subroutine add_integrals_to_map(mask_ijkl)
call wall_time(wall_1)
call cpu_time(cpu_1)
PROVIDE progress_bar
call start_progress(ao_num,'MO integrals (MB)',0.d0)
!$OMP PARALLEL PRIVATE(l1,k1,j1,i1,i2,i3,i4,i,j,k,l,c, ii1,kmax, &
!$OMP bielec_tmp_0_idx, bielec_tmp_0, bielec_tmp_1,bielec_tmp_2,bielec_tmp_3,&
@ -101,9 +99,10 @@ subroutine add_integrals_to_map(mask_ijkl)
!$OMP SHARED(size_buffer,ao_num,mo_tot_num,n_i,n_j,n_k,n_l,mo_tot_num_align,&
!$OMP mo_coef_transp, &
!$OMP mo_coef_transp_is_built, list_ijkl, &
!$OMP mo_coef_is_built, wall_1, abort_here, &
!$OMP mo_coef,mo_integrals_threshold,mo_integrals_map,progress_bar,progress_value)
!$OMP mo_coef_is_built, wall_1, &
!$OMP mo_coef,mo_integrals_threshold,mo_integrals_map)
n_integrals = 0
wall_0 = wall_1
allocate(bielec_tmp_3(mo_tot_num_align, n_j, n_k), &
bielec_tmp_1(mo_tot_num_align), &
bielec_tmp_0(ao_num,ao_num), &
@ -112,20 +111,15 @@ subroutine add_integrals_to_map(mask_ijkl)
buffer_i(size_buffer), &
buffer_value(size_buffer) )
thread_num = 0
!$ thread_num = omp_get_thread_num()
!$OMP DO SCHEDULE(guided)
do l1 = 1,ao_num
if (thread_num == 0) then
progress_bar(1) = l1
endif
IRP_IF COARRAY
if (mod(l1-this_image(),num_images()) /= 0 ) then
cycle
endif
IRP_ENDIF
if (abort_here) then
cycle
endif
!IRP_IF COARRAY
! if (mod(l1-this_image(),num_images()) /= 0 ) then
! cycle
! endif
!IRP_ENDIF
!DEC$ VECTOR ALIGNED
bielec_tmp_3 = 0.d0
do k1 = 1,ao_num
@ -274,8 +268,6 @@ IRP_ENDIF
wall_0 = wall_2
print*, 100.*float(l1)/float(ao_num), '% in ', &
wall_2-wall_1, 's', map_mb(mo_integrals_map) ,'MB'
progress_value = dble(map_mb(mo_integrals_map))
endif
endif
enddo
@ -286,14 +278,10 @@ IRP_ENDIF
real(mo_integrals_threshold,integral_kind))
deallocate(buffer_i, buffer_value)
!$OMP END PARALLEL
call stop_progress
if (abort_here) then
stop 'Aborting in MO integrals calculation'
endif
IRP_IF COARRAY
print*, 'Communicating the map'
call communicate_mo_integrals()
IRP_ENDIF
!IRP_IF COARRAY
! print*, 'Communicating the map'
! call communicate_mo_integrals()
!IRP_ENDIF
call map_unique(mo_integrals_map)
call wall_time(wall_2)
@ -354,7 +342,7 @@ end
!$OMP PRIVATE (i,j,p,q,r,s,integral,c,n,pp,int_value,int_idx, &
!$OMP iqrs, iqsr,iqri,iqis) &
!$OMP SHARED(mo_tot_num,mo_coef_transp,mo_tot_num_align,ao_num,&
!$OMP ao_integrals_threshold,do_direct_integrals,abort_here) &
!$OMP ao_integrals_threshold,do_direct_integrals) &
!$OMP REDUCTION(+:mo_bielec_integral_jj_from_ao,mo_bielec_integral_jj_exchange_from_ao)
allocate( int_value(ao_num), int_idx(ao_num), &
@ -363,9 +351,6 @@ end
!$OMP DO SCHEDULE (guided)
do s=1,ao_num
if (abort_here) then
cycle
endif
do q=1,ao_num
do j=1,ao_num
@ -451,9 +436,6 @@ end
!$OMP END DO NOWAIT
deallocate(iqrs,iqsr,int_value,int_idx)
!$OMP END PARALLEL
if (abort_here) then
stop 'Aborting in MO integrals calculation'
endif
mo_bielec_integral_jj_anti_from_ao = mo_bielec_integral_jj_from_ao - mo_bielec_integral_jj_exchange_from_ao

10
src/Integrals_Bielec/qp_ao_ints.irp.f
View File

@ -1,9 +1,14 @@
program qp_ao_ints
use omp_lib
implicit none
BEGIN_DOC
! Increments a running calculation to compute AO integrals
END_DOC
integer :: i
call switch_qp_run_to_master
PROVIDE zmq_context
! Set the state of the ZMQ
zmq_state = 'ao_integrals'
@ -11,8 +16,9 @@ program qp_ao_ints
double precision :: integral, ao_bielec_integral
integral = ao_bielec_integral(1,1,1,1)
!$OMP PARALLEL DEFAULT(PRIVATE)
call ao_bielec_integrals_in_map_slave_tcp
!$OMP PARALLEL DEFAULT(PRIVATE) PRIVATE(i)
i = omp_get_thread_num()
call ao_bielec_integrals_in_map_slave_tcp(i)
!$OMP END PARALLEL
print *, 'Done'

5
src/Integrals_Monoelec/pot_ao_ints.irp.f
View File

@ -139,6 +139,7 @@ double precision function NAI_pol_mult(A_center,B_center,power_A,power_B,alpha,b
! int{dr} of (x-A_x)^ax (x-B_X)^bx exp(-alpha (x-A_x)^2 - beta (x-B_x)^2 ) 1/(r-R_c)
implicit none
integer, intent(in) :: n_pt_in
double precision,intent(in) :: C_center(3),A_center(3),B_center(3),alpha,beta
integer :: power_A(3),power_B(3)
integer :: i,j,k,l,n_pt
@ -146,6 +147,8 @@ double precision :: P_center(3)
double precision :: d(0:n_pt_in),pouet,coeff,rho,dist,const,pouet_2,p,p_inv,factor
double precision :: I_n_special_exact,integrate_bourrin,I_n_bibi
double precision :: V_e_n,const_factor,dist_integral,tmp
double precision :: accu,epsilo,rint
integer :: n_pt_out,lmax
include 'Utils/constants.include.F'
if ( (A_center(1)/=B_center(1)).or. &
(A_center(2)/=B_center(2)).or. &
@ -198,8 +201,6 @@ include 'Utils/constants.include.F'
NAI_pol_mult = 0.d0
return
endif
double precision :: accu,epsilo,rint
integer :: n_pt_in,n_pt_out,lmax
accu = 0.d0
! 1/r1 standard attraction integral

6
src/MO_Basis/mos.irp.f
View File

@ -146,9 +146,9 @@ subroutine ao_to_mo(A_ao,LDA_ao,A_mo,LDA_mo)
BEGIN_DOC
! Transform A from the AO basis to the MO basis
END_DOC
integer, intent(in) :: LDA_ao,LDA_mo
double precision, intent(in) :: A_ao(LDA_ao)
double precision, intent(out) :: A_mo(LDA_mo)
integer, intent(in) :: LDA_ao,LDA_mo
double precision, allocatable :: T(:,:)
allocate ( T(ao_num_align,mo_tot_num) )
@ -172,9 +172,9 @@ subroutine mo_to_ao(A_mo,LDA_mo,A_ao,LDA_ao)
BEGIN_DOC
! Transform A from the MO basis to the AO basis
END_DOC
integer, intent(in) :: LDA_ao,LDA_mo
double precision, intent(in) :: A_mo(LDA_mo)
double precision, intent(out) :: A_ao(LDA_ao)
integer, intent(in) :: LDA_ao,LDA_mo
double precision, allocatable :: T(:,:), SC(:,:)
allocate ( SC(ao_num_align,mo_tot_num) )
@ -204,9 +204,9 @@ subroutine mo_to_ao_no_overlap(A_mo,LDA_mo,A_ao,LDA_ao)
BEGIN_DOC
! Transform A from the MO basis to the S^-1 AO basis
END_DOC
integer, intent(in) :: LDA_ao,LDA_mo
double precision, intent(in) :: A_mo(LDA_mo)
double precision, intent(out) :: A_ao(LDA_ao)
integer, intent(in) :: LDA_ao,LDA_mo
double precision, allocatable :: T(:,:)
allocate ( T(mo_tot_num_align,ao_num) )

58
src/MO_Basis/utils.irp.f
View File

@ -76,22 +76,22 @@ subroutine mo_as_eigvectors_of_mo_matrix(matrix,n,m,label,sign)
mo_coef_new = mo_coef
call lapack_diag(eigvalues,R,A,n,m)
write (output_mo_basis,'(A)'), 'MOs are now **'//trim(label)//'**'
write (output_mo_basis,'(A)'), ''
write (output_mo_basis,'(A)'), 'Eigenvalues'
write (output_mo_basis,'(A)'), '-----------'
write (output_mo_basis,'(A)'), ''
write (output_mo_basis,'(A)'), '======== ================'
write (output_mo_basis,'(A)') 'MOs are now **'//trim(label)//'**'
write (output_mo_basis,'(A)') ''
write (output_mo_basis,'(A)') 'Eigenvalues'
write (output_mo_basis,'(A)') '-----------'
write (output_mo_basis,'(A)') ''
write (output_mo_basis,'(A)') '======== ================'
if (sign == -1) then
do i=1,m
eigvalues(i) = -eigvalues(i)
enddo
endif
do i=1,m
write (output_mo_basis,'(I8,X,F16.10)'), i,eigvalues(i)
write (output_mo_basis,'(I8,X,F16.10)') i,eigvalues(i)
enddo
write (output_mo_basis,'(A)'), '======== ================'
write (output_mo_basis,'(A)'), ''
write (output_mo_basis,'(A)') '======== ================'
write (output_mo_basis,'(A)') ''
call dgemm('N','N',ao_num,m,m,1.d0,mo_coef_new,size(mo_coef_new,1),R,size(R,1),0.d0,mo_coef,size(mo_coef,1))
deallocate(A,mo_coef_new,R,eigvalues)
@ -127,18 +127,18 @@ subroutine mo_as_svd_vectors_of_mo_matrix(matrix,lda,m,n,label)
call svd(A,lda,U,lda,D,Vt,lda,m,n)
write (output_mo_basis,'(A)'), 'MOs are now **'//trim(label)//'**'
write (output_mo_basis,'(A)'), ''
write (output_mo_basis,'(A)'), 'Eigenvalues'
write (output_mo_basis,'(A)'), '-----------'
write (output_mo_basis,'(A)'), ''
write (output_mo_basis,'(A)'), '======== ================'
write (output_mo_basis,'(A)') 'MOs are now **'//trim(label)//'**'
write (output_mo_basis,'(A)') ''
write (output_mo_basis,'(A)') 'Eigenvalues'
write (output_mo_basis,'(A)') '-----------'
write (output_mo_basis,'(A)') ''
write (output_mo_basis,'(A)') '======== ================'
do i=1,m
write (output_mo_basis,'(I8,X,F16.10)'), i,D(i)
write (output_mo_basis,'(I8,X,F16.10)') i,D(i)
enddo
write (output_mo_basis,'(A)'), '======== ================'
write (output_mo_basis,'(A)'), ''
write (output_mo_basis,'(A)') '======== ================'
write (output_mo_basis,'(A)') ''
call dgemm('N','N',ao_num,m,m,1.d0,mo_coef_new,size(mo_coef_new,1),U,size(U,1),0.d0,mo_coef,size(mo_coef,1))
deallocate(A,mo_coef_new,U,Vt,D)
@ -208,17 +208,17 @@ subroutine mo_as_eigvectors_of_mo_matrix_sort_by_observable(matrix,observable,n,
print*,''
enddo
write (output_mo_basis,'(A)'), 'MOs are now **'//trim(label)//'**'
write (output_mo_basis,'(A)'), ''
write (output_mo_basis,'(A)'), 'Eigenvalues'
write (output_mo_basis,'(A)'), '-----------'
write (output_mo_basis,'(A)'), ''
write (output_mo_basis,'(A)'), '======== ================'
write (output_mo_basis,'(A)') 'MOs are now **'//trim(label)//'**'
write (output_mo_basis,'(A)') ''
write (output_mo_basis,'(A)') 'Eigenvalues'
write (output_mo_basis,'(A)') '-----------'
write (output_mo_basis,'(A)') ''
write (output_mo_basis,'(A)') '======== ================'
do i = 1, m
write (output_mo_basis,'(I8,X,F16.10)'), i,eigvalues(i)
write (output_mo_basis,'(I8,X,F16.10)') i,eigvalues(i)
enddo
write (output_mo_basis,'(A)'), '======== ================'
write (output_mo_basis,'(A)'), ''
write (output_mo_basis,'(A)') '======== ================'
write (output_mo_basis,'(A)') ''
call dgemm('N','N',ao_num,m,m,1.d0,mo_coef_new,size(mo_coef_new,1),R,size(R,1),0.d0,mo_coef,size(mo_coef,1))
deallocate(mo_coef_new,R,eigvalues)
@ -256,8 +256,8 @@ subroutine mo_sort_by_observable(observable,label)
enddo
enddo
write (output_mo_basis,'(A)'), 'MOs are now **'//trim(label)//'**'
write (output_mo_basis,'(A)'), ''
write (output_mo_basis,'(A)') 'MOs are now **'//trim(label)//'**'
write (output_mo_basis,'(A)') ''
deallocate(mo_coef_new,value)

2
src/Utils/LinearAlgebra.irp.f
View File

@ -277,10 +277,10 @@ subroutine apply_rotation(A,LDA,R,LDR,B,LDB,m,n)
BEGIN_DOC
! Apply the rotation found by find_rotation
END_DOC
integer, intent(in) :: m,n, LDA, LDB, LDR
double precision, intent(in) :: R(LDR,n)
double precision, intent(in) :: A(LDA,n)
double precision, intent(out) :: B(LDB,n)
integer, intent(in) :: m,n, LDA, LDB, LDR
call dgemm('N','N',m,n,n,1.d0,A,LDA,R,LDR,0.d0,B,LDB)
end

47
src/Utils/abort.irp.f
View File

@ -1,47 +0,0 @@
BEGIN_PROVIDER [ logical, abort_all ]
implicit none
BEGIN_DOC
! If True, all the calculation is aborted
END_DOC
call trap_signals
abort_all = .False.
END_PROVIDER
BEGIN_PROVIDER [ logical, abort_here ]
implicit none
BEGIN_DOC
! If True, all the calculation is aborted
END_DOC
abort_here = abort_all
END_PROVIDER
subroutine trap_signals
implicit none
BEGIN_DOC
! What to do when a signal is caught. Here, trap Ctrl-C and call the control_C subroutine.
END_DOC
integer, external :: catch_signal
integer :: sigusr2, status
sigusr2 = 12
call signal (sigusr2, catch_signal,status)
end subroutine trap_signals
integer function catch_signal(signum)
implicit none
integer, intent(in) :: signum
BEGIN_DOC
! What to do on Ctrl-C. If two Ctrl-C are pressed within 1 sec, the calculation if aborted.
END_DOC
double precision, save :: last_time
double precision :: this_time
catch_signal = 0
call wall_time(this_time)
if (this_time - last_time < 1.d0) then
print *, 'Caught Signal ', signum
abort_all = .True.
endif
last_time = this_time
abort_here = .True.
end

1
src/Utils/map_module.f90
View File

@ -76,7 +76,6 @@ subroutine cache_map_init(map,sze)
NULLIFY(map%value, map%key)
call cache_map_reallocate(map,sze)
call omp_unset_lock(map%lock)
end
subroutine map_init(map,keymax)

4
src/Utils/progress.irp.f
View File

@ -59,8 +59,8 @@ recursive subroutine run_progress
write(unit=0,fmt="(a1,a1,a70)") '+',char(13), bar
else
prog = int( progress_bar(1)*100./progress_bar(2) )
write(bar(1:25),'(A)'),progress_title
write(bar(29:47),'(G17.10)'),progress_value
write(bar(1:25),'(A)') progress_title
write(bar(29:47),'(G17.10)') progress_value
write(bar(72:74),'(i3)') prog
integer :: k,j

16
src/Utils/sort.irp.f
View File

@ -6,9 +6,9 @@ BEGIN_TEMPLATE
! iorder in input should be (1,2,3,...,isize), and in output
! contains the new order of the elements.
END_DOC
integer,intent(in) :: isize
$type,intent(inout) :: x(isize)
integer,intent(inout) :: iorder(isize)
integer,intent(in) :: isize
$type :: xtmp
integer :: i, i0, j, jmax
@ -36,9 +36,9 @@ BEGIN_TEMPLATE
! iorder in input should be (1,2,3,...,isize), and in output
! contains the new order of the elements.
END_DOC
integer,intent(in) :: isize
$type,intent(inout) :: x(isize)
integer,intent(inout) :: iorder(isize)
integer,intent(in) :: isize
integer :: i, k, j, l, i0
$type :: xtemp
@ -101,9 +101,9 @@ BEGIN_TEMPLATE
! This is a version for very large arrays where the indices need
! to be in integer*8 format
END_DOC
integer*8,intent(in) :: isize
$type,intent(inout) :: x(isize)
integer*8,intent(inout) :: iorder(isize)
integer*8,intent(in) :: isize
integer*8 :: i, k, j, l, i0
$type :: xtemp
@ -165,9 +165,9 @@ BEGIN_TEMPLATE
! iorder in input should be (1,2,3,...,isize), and in output
! contains the new order of the elements.
END_DOC
integer,intent(in) :: isize
$type,intent(inout) :: x(isize)
integer,intent(inout) :: iorder(isize)
integer,intent(in) :: isize
if (isize < 32) then
call insertion_$Xsort(x,iorder,isize)
else
@ -226,9 +226,9 @@ BEGIN_TEMPLATE
! This is a version for very large arrays where the indices need
! to be in integer*8 format
END_DOC
integer*8,intent(in) :: isize
$type,intent(inout) :: x(isize)
integer*8,intent(inout) :: iorder(isize)
integer*8,intent(in) :: isize
$type :: xtmp
integer*8 :: i, i0, j, jmax
@ -298,6 +298,7 @@ BEGIN_TEMPLATE
integer, intent(in) :: iradix
integer :: iradix_new
$type, allocatable :: x2(:), x1(:)
$type :: i4
$int_type, allocatable :: iorder1(:),iorder2(:)
$int_type :: i0, i1, i2, i3, i
integer, parameter :: integer_size=$octets
@ -311,11 +312,12 @@ BEGIN_TEMPLATE
! Find most significant bit
i0 = 0_8
i3 = -1_8
i4 = -1_8
do i=1,isize
i3 = max(i3,x(i))
i4 = max(i4,x(i))
enddo
i3 = i4 ! Type conversion
iradix_new = integer_size-1-leadz(i3)
mask = ibset(zero,iradix_new)

30
src/Utils/util.irp.f
View File

@ -295,6 +295,18 @@ BEGIN_PROVIDER [ integer, nproc ]
!$OMP END PARALLEL
END_PROVIDER
BEGIN_PROVIDER [ integer, iproc_save, (nproc) ]
implicit none
BEGIN_DOC
! iproc_save(i) = i-1. Used to start threads with pthreads.
END_DOC
integer :: i
do i=1,nproc
iproc_save(i) = i-1
enddo
END_PROVIDER
double precision function u_dot_v(u,v,sze)
implicit none
@ -401,5 +413,21 @@ end
subroutine lowercase(txt,n)
implicit none
BEGIN_DOC
! Transform to lower case
END_DOC
character*(*), intent(inout) :: txt
integer, intent(in) :: n
character( * ), PARAMETER :: LOWER_CASE = 'abcdefghijklmnopqrstuvwxyz'
character( * ), PARAMETER :: UPPER_CASE = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
integer :: i, ic
do i=1,n
ic = index( UPPER_CASE, txt(i:i) )
if (ic /= 0) then
txt(i:i) = LOWER_CASE(ic:ic)
endif
enddo
end

759
src/ZMQ/utils.irp.f Normal file
View File

@ -0,0 +1,759 @@
use f77_zmq
use omp_lib
integer, pointer :: thread_id
integer(omp_lock_kind) :: zmq_lock
BEGIN_PROVIDER [ integer(ZMQ_PTR), zmq_context ]
use f77_zmq
implicit none
BEGIN_DOC
! Context for the ZeroMQ library
END_DOC
call omp_init_lock(zmq_lock)
zmq_context = 0_ZMQ_PTR
END_PROVIDER
BEGIN_PROVIDER [ character*(128), qp_run_address ]
&BEGIN_PROVIDER [ integer, zmq_port_start ]
use f77_zmq
implicit none
BEGIN_DOC
! Address of the qp_run socket
! Example : tcp://130.120.229.139:12345
END_DOC
character*(128) :: buffer
call getenv('QP_RUN_ADDRESS',buffer)
if (trim(buffer) == '') then
print *, 'This run should be started with the qp_run command'
stop -1
endif
integer :: i
do i=len(buffer),1,-1
if ( buffer(i:i) == ':') then
qp_run_address = trim(buffer(1:i-1))
read(buffer(i+1:), *) zmq_port_start
exit
endif
enddo
END_PROVIDER
BEGIN_PROVIDER [ character*(128), zmq_socket_pull_tcp_address ]
&BEGIN_PROVIDER [ character*(128), zmq_socket_pair_inproc_address ]
&BEGIN_PROVIDER [ character*(128), zmq_socket_push_tcp_address ]
&BEGIN_PROVIDER [ character*(128), zmq_socket_pull_inproc_address ]
&BEGIN_PROVIDER [ character*(128), zmq_socket_push_inproc_address ]
use f77_zmq
implicit none
BEGIN_DOC
! Socket which pulls the results (2)
END_DOC
character*(8), external :: zmq_port
zmq_socket_pull_tcp_address = 'tcp://*:'//zmq_port(1)//' '
zmq_socket_push_tcp_address = trim(qp_run_address)//':'//zmq_port(1)//' '
zmq_socket_pull_inproc_address = 'inproc://'//zmq_port(1)//' '
zmq_socket_push_inproc_address = zmq_socket_pull_inproc_address
zmq_socket_pair_inproc_address = 'inproc://'//zmq_port(2)//' '
END_PROVIDER
subroutine reset_zmq_addresses
use f77_zmq
implicit none
character*(8), external :: zmq_port
zmq_socket_pull_tcp_address = 'tcp://*:'//zmq_port(1)//' '
zmq_socket_push_tcp_address = trim(qp_run_address)//':'//zmq_port(1)//' '
zmq_socket_pull_inproc_address = 'inproc://'//zmq_port(1)//' '
zmq_socket_push_inproc_address = zmq_socket_pull_inproc_address
zmq_socket_pair_inproc_address = 'inproc://'//zmq_port(2)//' '
end
subroutine switch_qp_run_to_master
use f77_zmq
implicit none
BEGIN_DOC
! Address of the master qp_run socket
! Example : tcp://130.120.229.139:12345
END_DOC
character*(128) :: buffer
call getenv('QP_RUN_ADDRESS_MASTER',buffer)
if (trim(buffer) == '') then
print *, 'This run should be started with the qp_run command'
stop -1
endif
qp_run_address = trim(buffer)
integer :: i
do i=len(buffer),1,-1
if ( buffer(i:i) == ':') then
qp_run_address = trim(buffer(1:i-1))
read(buffer(i+1:), *) zmq_port_start
exit
endif
enddo
call reset_zmq_addresses
end
function zmq_port(ishift)
use f77_zmq
implicit none
BEGIN_DOC
! Return the value of the ZMQ port from the corresponding integer
END_DOC
integer, intent(in) :: ishift
character*(8) :: zmq_port
write(zmq_port,'(I8)') zmq_port_start+ishift
zmq_port = adjustl(trim(zmq_port))
end
function new_zmq_to_qp_run_socket()
use f77_zmq
implicit none
BEGIN_DOC
! Socket on which the qp_run process replies
END_DOC
integer :: rc
character*(8), external :: zmq_port
integer(ZMQ_PTR) :: new_zmq_to_qp_run_socket
call omp_set_lock(zmq_lock)
new_zmq_to_qp_run_socket = f77_zmq_socket(zmq_context, ZMQ_REQ)
call omp_unset_lock(zmq_lock)
if (new_zmq_to_qp_run_socket == 0_ZMQ_PTR) then
stop 'Unable to create zmq req socket'
endif
rc = f77_zmq_connect(new_zmq_to_qp_run_socket, trim(qp_run_address)//':'//trim(zmq_port(0)))
if (rc /= 0) then
stop 'Unable to connect new_zmq_to_qp_run_socket'
endif
rc = f77_zmq_setsockopt(new_zmq_to_qp_run_socket, ZMQ_SNDTIMEO, 120000, 4)
if (rc /= 0) then
stop 'Unable to set send timout in new_zmq_to_qp_run_socket'
endif
rc = f77_zmq_setsockopt(new_zmq_to_qp_run_socket, ZMQ_RCVTIMEO, 120000, 4)
if (rc /= 0) then
stop 'Unable to set recv timout in new_zmq_to_qp_run_socket'
endif
end
function new_zmq_pair_socket(bind)
use f77_zmq
implicit none
BEGIN_DOC
! Socket on which the collector and the main communicate
END_DOC
logical :: bind
integer :: rc
character*(8), external :: zmq_port
integer(ZMQ_PTR) :: new_zmq_pair_socket
call omp_set_lock(zmq_lock)
new_zmq_pair_socket = f77_zmq_socket(zmq_context, ZMQ_PAIR)
call omp_unset_lock(zmq_lock)
if (new_zmq_pair_socket == 0_ZMQ_PTR) then
stop 'Unable to create zmq pair socket'
endif
if (bind) then
rc = f77_zmq_bind(new_zmq_pair_socket,zmq_socket_pair_inproc_address)
if (rc /= 0) then
print *, 'f77_zmq_bind(new_zmq_pair_socket, zmq_socket_pair_inproc_address)'
stop 'error'
endif
else
rc = f77_zmq_connect(new_zmq_pair_socket,zmq_socket_pair_inproc_address)
if (rc /= 0) then
stop 'Unable to connect new_zmq_pair_socket'
endif
endif
rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_SNDHWM, 0, 4)
if (rc /= 0) then
stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_SNDHWM, 0, 4)'
endif
rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_RCVHWM, 0, 4)
if (rc /= 0) then
stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_RCVHWM, 0, 4)'
endif
rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_IMMEDIATE, 1, 4)
if (rc /= 0) then
stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_IMMEDIATE, 1, 4)'
endif
rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_LINGER, 600000, 4)
if (rc /= 0) then
stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_LINGER, 60000, 4)'
endif
end
function new_zmq_pull_socket()
use f77_zmq
implicit none
BEGIN_DOC
! Socket on which the results are sent. If thread is 1, use inproc
END_DOC
integer :: rc
character*(8), external :: zmq_port
integer(ZMQ_PTR) :: new_zmq_pull_socket
call omp_set_lock(zmq_lock)
new_zmq_pull_socket = f77_zmq_socket(zmq_context, ZMQ_PULL)
! new_zmq_pull_socket = f77_zmq_socket(zmq_context, ZMQ_REP)
call omp_unset_lock(zmq_lock)
if (new_zmq_pull_socket == 0_ZMQ_PTR) then
stop 'Unable to create zmq pull socket'
endif
rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_LINGER,300000,4)
if (rc /= 0) then
stop 'Unable to set ZMQ_LINGER on pull socket'
endif
rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_RCVHWM,100000,4)
if (rc /= 0) then
stop 'Unable to set ZMQ_RCVHWM on pull socket'
endif
rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_IMMEDIATE,1,4)
if (rc /= 0) then
stop 'Unable to set ZMQ_IMMEDIATE on pull socket'
endif
rc = f77_zmq_bind(new_zmq_pull_socket, zmq_socket_pull_tcp_address)
if (rc /= 0) then
print *, 'Unable to bind new_zmq_pull_socket (tcp)', zmq_socket_pull_tcp_address
stop
endif
rc = f77_zmq_bind(new_zmq_pull_socket, zmq_socket_pull_inproc_address)
if (rc /= 0) then
stop 'Unable to bind new_zmq_pull_socket (inproc)'
endif
end
function new_zmq_push_socket(thread)
use f77_zmq
implicit none
BEGIN_DOC
! Socket on which the results are sent. If thread is 1, use inproc
END_DOC
integer, intent(in) :: thread
integer :: rc
character*(8), external :: zmq_port
integer(ZMQ_PTR) :: new_zmq_push_socket
call omp_set_lock(zmq_lock)
new_zmq_push_socket = f77_zmq_socket(zmq_context, ZMQ_PUSH)
! new_zmq_push_socket = f77_zmq_socket(zmq_context, ZMQ_REQ)
call omp_unset_lock(zmq_lock)
if (new_zmq_push_socket == 0_ZMQ_PTR) then
stop 'Unable to create zmq push socket'
endif
rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_LINGER,300000,4)
if (rc /= 0) then
stop 'Unable to set ZMQ_LINGER on push socket'
endif
rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_SNDHWM,100,4)
if (rc /= 0) then
stop 'Unable to set ZMQ_SNDHWM on push socket'
endif
rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_IMMEDIATE,1,4)
if (rc /= 0) then
stop 'Unable to set ZMQ_IMMEDIATE on push socket'
endif
rc = f77_zmq_setsockopt(new_zmq_push_socket, ZMQ_SNDTIMEO, 100000, 4)
if (rc /= 0) then
stop 'Unable to set send timout in new_zmq_push_socket'
endif
if (thread == 1) then
rc = f77_zmq_connect(new_zmq_push_socket, zmq_socket_push_inproc_address)
else
rc = f77_zmq_connect(new_zmq_push_socket, zmq_socket_push_tcp_address)
endif
if (rc /= 0) then
stop 'Unable to connect new_zmq_push_socket'
endif
end
subroutine end_zmq_pair_socket(zmq_socket_pair)
use f77_zmq
implicit none
BEGIN_DOC
! Terminate socket on which the results are sent.
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_socket_pair
integer :: rc
character*(8), external :: zmq_port
rc = f77_zmq_unbind(zmq_socket_pair,zmq_socket_pair_inproc_address)
! if (rc /= 0) then
! print *, rc
! print *, irp_here, 'f77_zmq_unbind(zmq_socket_pair,zmq_socket_pair_inproc_address)'
! stop 'error'
! endif
rc = f77_zmq_setsockopt(zmq_socket_pair,ZMQ_LINGER,0,4)
if (rc /= 0) then
stop 'Unable to set ZMQ_LINGER on zmq_socket_pair'
endif
rc = f77_zmq_close(zmq_socket_pair)
if (rc /= 0) then
print *, 'f77_zmq_close(zmq_socket_pair)'
stop 'error'
endif
end
subroutine end_zmq_pull_socket(zmq_socket_pull)
use f77_zmq
implicit none
BEGIN_DOC
! Terminate socket on which the results are sent.
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
integer :: rc
character*(8), external :: zmq_port
rc = f77_zmq_unbind(zmq_socket_pull,zmq_socket_pull_inproc_address)
! if (rc /= 0) then
! print *, rc
! print *, irp_here, 'f77_zmq_unbind(zmq_socket_pull,zmq_socket_pull_inproc_address)'
! stop 'error'
! endif
rc = f77_zmq_unbind(zmq_socket_pull,zmq_socket_pull_tcp_address)
if (rc /= 0) then
print *, rc
print *, irp_here, 'f77_zmq_unbind(zmq_socket_pull,zmq_socket_pull_tcp_address)'
stop 'error'
endif
rc = f77_zmq_setsockopt(zmq_socket_pull,ZMQ_LINGER,0,4)
if (rc /= 0) then
stop 'Unable to set ZMQ_LINGER on zmq_socket_pull'
endif
rc = f77_zmq_close(zmq_socket_pull)
if (rc /= 0) then
print *, 'f77_zmq_close(zmq_socket_pull)'
stop 'error'
endif
end
subroutine end_zmq_push_socket(zmq_socket_push,thread)
implicit none
use f77_zmq
BEGIN_DOC
! Terminate socket on which the results are sent.
END_DOC
integer, intent(in) :: thread
integer(ZMQ_PTR), intent(in) :: zmq_socket_push
integer :: rc
character*(8), external :: zmq_port
if (thread == 1) then
rc = f77_zmq_disconnect(zmq_socket_push,zmq_socket_push_inproc_address)
! if (rc /= 0) then
! print *, 'f77_zmq_disconnect(zmq_socket_push,zmq_socket_push_inproc_address)'
! stop 'error'
! endif
else
rc = f77_zmq_disconnect(zmq_socket_push,zmq_socket_push_tcp_address)
if (rc /= 0) then
print *, 'f77_zmq_disconnect(zmq_socket_push,zmq_socket_push_tcp_address)'
stop 'error'
endif
endif
rc = f77_zmq_setsockopt(zmq_socket_push,ZMQ_LINGER,0,4)
if (rc /= 0) then
stop 'Unable to set ZMQ_LINGER on push socket'
endif
rc = f77_zmq_close(zmq_socket_push)
if (rc /= 0) then
print *, 'f77_zmq_close(zmq_socket_push)'
stop 'error'
endif
end
BEGIN_PROVIDER [ character*(128), zmq_state ]
implicit none
BEGIN_DOC
! Threads executing work through the ZeroMQ interface
END_DOC
zmq_state = 'No_state'
END_PROVIDER
subroutine new_parallel_job(zmq_to_qp_run_socket,name_in)
use f77_zmq
implicit none
BEGIN_DOC
! Start a new parallel job with name 'name'. The slave tasks execute subroutine 'slave'
END_DOC
character*(*), intent(in) :: name_in
character*(512) :: message, name
integer :: rc, sze
integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
integer(ZMQ_PTR), intent(out) :: zmq_to_qp_run_socket
zmq_context = f77_zmq_ctx_new ()
if (zmq_context == 0_ZMQ_PTR) then
stop 'ZMQ_PTR is null'
endif
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
name = name_in
sze = len(trim(name))
call lowercase(name,sze)
message = 'new_job '//trim(name)//' '//zmq_socket_push_tcp_address//' '//zmq_socket_pull_inproc_address
sze = len(trim(message))
rc = f77_zmq_send(zmq_to_qp_run_socket,message,sze,0)
if (rc /= sze) then
print *, irp_here, ':f77_zmq_send(zmq_to_qp_run_socket,message,sze,0)'
stop 'error'
endif
rc = f77_zmq_recv(zmq_to_qp_run_socket,message,510,0)
message = trim(message(1:rc))
if (message(1:2) /= 'ok') then
print *, message
print *, 'Unable to start parallel job : '//name
stop 1
endif
zmq_state = trim(name)
end
subroutine end_parallel_job(zmq_to_qp_run_socket,name_in)
use f77_zmq
implicit none
BEGIN_DOC
! End a new parallel job with name 'name'. The slave tasks execute subroutine 'slave'
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
character*(*), intent(in) :: name_in
character*(512) :: message, name
integer :: i,rc, sze
name = name_in
sze = len(trim(name))
call lowercase(name,sze)
if (name /= zmq_state) then
stop 'Wrong end of job'
endif
rc = f77_zmq_send(zmq_to_qp_run_socket, 'end_job '//trim(zmq_state),8+len(trim(zmq_state)),0)
rc = f77_zmq_recv(zmq_to_qp_run_socket, zmq_state, 2, 0)
if (rc /= 2) then
print *, 'f77_zmq_recv(zmq_to_qp_run_socket, zmq_state, 2, 0)'
stop 'error'
endif
zmq_state = 'No_state'
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
rc = f77_zmq_ctx_term(zmq_context)
if (rc /= 0) then
print *, 'Unable to terminate ZMQ context'
stop 'error'
endif
end
subroutine connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread)
use f77_zmq
implicit none
BEGIN_DOC
! Connect to the task server and obtain the worker ID
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
integer, intent(out) :: worker_id
integer, intent(in) :: thread
character*(512) :: message
character*(128) :: reply, state, address
integer :: rc
if (thread == 1) then
rc = f77_zmq_send(zmq_to_qp_run_socket, "connect inproc", 14, 0)
if (rc /= 14) then
print *, 'f77_zmq_send(zmq_to_qp_run_socket, "connect inproc", 14, 0)'
stop 'error'
endif
else
rc = f77_zmq_send(zmq_to_qp_run_socket, "connect tcp", 11, 0)
if (rc /= 11) then
print *, 'f77_zmq_send(zmq_to_qp_run_socket, "connect tcp", 11, 0)'
stop 'error'
endif
endif
rc = f77_zmq_recv(zmq_to_qp_run_socket, message, 510, 0)
message = trim(message(1:rc))
read(message,*) reply, state, worker_id, address
if ( (trim(reply) /= 'connect_reply') .and. &
(trim(state) /= trim(zmq_state)) ) then
print *, 'Reply: ', trim(reply)
print *, 'State: ', trim(state), '/', trim(zmq_state)
print *, 'Address: ', trim(address)
stop -1
endif
end
subroutine disconnect_from_taskserver(zmq_to_qp_run_socket, &
zmq_socket_push, worker_id)
use f77_zmq
implicit none
BEGIN_DOC
! Disconnect from the task server
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
integer(ZMQ_PTR), intent(in) :: zmq_socket_push
integer, intent(in) :: worker_id
integer :: rc, sze
character*(64) :: message, reply, state
write(message,*) 'disconnect '//trim(zmq_state), worker_id
sze = len(trim(message))
rc = f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0)
if (rc /= sze) then
print *, rc, sze
print *, irp_here, 'f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0)'
stop 'error'
endif
rc = f77_zmq_recv(zmq_to_qp_run_socket, message, 510, 0)
message = trim(message(1:rc))
read(message,*) reply, state
if ( (trim(reply) /= 'disconnect_reply').or. &
(trim(state) /= zmq_state) ) then
print *, 'Unable to disconnect : ', zmq_state
print *, trim(message)
stop -1
endif
end
subroutine add_task_to_taskserver(zmq_to_qp_run_socket,task)
use f77_zmq
implicit none
BEGIN_DOC
! Get a task from the task server
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
character*(*), intent(in) :: task
integer :: rc, sze
character*(512) :: message
write(message,*) 'add_task '//trim(zmq_state)//' '//trim(task)
sze = len(trim(message))
rc = f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0)
if (rc /= sze) then
print *, rc, sze
print *, irp_here,': f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0)'
stop 'error'
endif
rc = f77_zmq_recv(zmq_to_qp_run_socket, message, 510, 0)
message = trim(message(1:rc))
if (trim(message) /= 'ok') then
print *, trim(task)
print *, 'Unable to add the next task'
stop -1
endif
end
subroutine task_done_to_taskserver(zmq_to_qp_run_socket,worker_id, task_id)
use f77_zmq
implicit none
BEGIN_DOC
! Get a task from the task server
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
integer, intent(in) :: worker_id, task_id
integer :: rc, sze
character*(512) :: message
write(message,*) 'task_done '//trim(zmq_state), worker_id, task_id
sze = len(trim(message))
rc = f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0)
if (rc /= sze) then
print *, irp_here, 'f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0)'
stop 'error'
endif
rc = f77_zmq_recv(zmq_to_qp_run_socket, message, 510, 0)
message = trim(message(1:rc))
if (trim(message) /= 'ok') then
print *, 'Unable to send task_done message'
stop -1
endif
end
subroutine get_task_from_taskserver(zmq_to_qp_run_socket,worker_id,task_id,task)
use f77_zmq
implicit none
BEGIN_DOC
! Get a task from the task server
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
integer, intent(in) :: worker_id
integer, intent(out) :: task_id
character*(512), intent(out) :: task
character*(512) :: message
character*(64) :: reply
integer :: rc, sze
write(message,*) 'get_task '//trim(zmq_state), worker_id
sze = len(trim(message))
rc = f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0)
if (rc /= sze) then
print *, irp_here, ':f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0)'
stop 'error'
endif
rc = f77_zmq_recv(zmq_to_qp_run_socket, message, 510, 0)
message = trim(message(1:rc))
read(message,*) reply
if (trim(reply) == 'get_task_reply') then
read(message,*) reply, task_id
rc = 15
do while (message(rc:rc) == ' ')
rc += 1
enddo
do while (message(rc:rc) /= ' ')
rc += 1
enddo
rc += 1
task = message(rc:)
else if (trim(reply) == 'terminate') then
task_id = 0
task = 'terminate'
else
print *, 'Unable to get the next task'
print *, trim(message)
stop -1
endif
end
subroutine end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
use f77_zmq
implicit none
BEGIN_DOC
! Terminate the socket from the application to qp_run
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
character*(8), external :: zmq_port
integer :: rc
rc = f77_zmq_disconnect(zmq_to_qp_run_socket, trim(qp_run_address)//':'//trim(zmq_port(0)))
! if (rc /= 0) then
! print *, 'f77_zmq_disconnect(zmq_to_qp_run_socket, trim(qp_run_address)//'':''//trim(zmq_port(0)))'
! stop 'error'
! endif
rc = f77_zmq_setsockopt(zmq_to_qp_run_socket,ZMQ_LINGER,0,4)
if (rc /= 0) then
stop 'Unable to set ZMQ_LINGER on zmq_to_qp_run_socket'
endif
rc = f77_zmq_close(zmq_to_qp_run_socket)
if (rc /= 0) then
print *, 'f77_zmq_close(zmq_to_qp_run_socket)'
stop 'error'
endif
end
subroutine zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more)
use f77_zmq
implicit none
BEGIN_DOC
! When a task is done, it has to be removed from the list of tasks on the qp_run
! queue. This guarantees that the results have been received in the pull.
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
integer(ZMQ_PTR) :: zmq_socket_pull
integer, intent(in) :: task_id
integer, intent(out) :: more
integer :: rc
character*(512) :: msg
write(msg,*) 'del_task ', zmq_state, task_id
rc = f77_zmq_send(zmq_to_qp_run_socket,msg,512,0)
if (rc /= 512) then
print *, 'f77_zmq_send(zmq_to_qp_run_socket,task_id,4,0)'
stop 'error'
endif
character*(64) :: reply
reply = ''
rc = f77_zmq_recv(zmq_to_qp_run_socket,reply,64,0)
if (reply(16:19) == 'more') then
more = 1
else if (reply(16:19) == 'done') then
more = 0
rc = f77_zmq_setsockopt(zmq_socket_pull, ZMQ_RCVTIMEO, 1000, 4)
if (rc /= 0) then
print *, 'f77_zmq_setsockopt(zmq_socket_pull, ZMQ_RCVTIMEO, 3000, 4)'
stop 'error'
endif
else
print *, reply
print *, 'f77_zmq_recv(zmq_to_qp_run_socket,reply,64,0)'
stop 'error'
endif
end

344
src/ZMQ/zmq.irp.f
View File

@ -1,344 +0,0 @@
use f77_zmq
BEGIN_PROVIDER [ integer(ZMQ_PTR), zmq_context ]
implicit none
BEGIN_DOC
! Context for the ZeroMQ library
END_DOC
zmq_context = f77_zmq_ctx_new ()
END_PROVIDER
BEGIN_PROVIDER [ character*(128), qp_run_address ]
&BEGIN_PROVIDER [ integer, zmq_port_start ]
implicit none
BEGIN_DOC
! Address of the qp_run socket
! Example : tcp://130.120.229.139:12345
END_DOC
character*(128) :: buffer
call getenv('QP_RUN_ADDRESS',buffer)
if (trim(buffer) == '') then
print *, 'This run should be started with the qp_run command'
stop -1
endif
integer :: i
do i=len(buffer),1,-1
if ( buffer(i:i) == ':') then
qp_run_address = trim(buffer(1:i-1))
read(buffer(i+1:), *) zmq_port_start
exit
endif
enddo
END_PROVIDER
function zmq_port(ishift)
implicit none
integer, intent(in) :: ishift
character*(8) :: zmq_port
write(zmq_port,'(I8)') zmq_port_start+ishift
zmq_port = adjustl(trim(zmq_port))
end
function new_zmq_to_qp_run_socket()
implicit none
BEGIN_DOC
! Socket on which the qp_run process replies
END_DOC
integer :: rc
character*(8), external :: zmq_port
integer(ZMQ_PTR) :: new_zmq_to_qp_run_socket
new_zmq_to_qp_run_socket = f77_zmq_socket(zmq_context, ZMQ_REQ)
rc = f77_zmq_connect(new_zmq_to_qp_run_socket, trim(qp_run_address)//':'//trim(zmq_port(0)))
if (rc /= 0) then
stop 'Unable to connect new_zmq_to_qp_run_socket'
endif
integer :: i
i=4
rc = f77_zmq_setsockopt(new_zmq_to_qp_run_socket, ZMQ_SNDTIMEO, 120000, i)
if (rc /= 0) then
stop 'Unable to set send timout in new_zmq_to_qp_run_socket'
endif
rc = f77_zmq_setsockopt(new_zmq_to_qp_run_socket, ZMQ_RCVTIMEO, 120000, i)
if (rc /= 0) then
stop 'Unable to set recv timout in new_zmq_to_qp_run_socket'
endif
end
BEGIN_PROVIDER [ integer(ZMQ_PTR), zmq_socket_pull ]
&BEGIN_PROVIDER [ character*(128), zmq_socket_pull_tcp_address ]
&BEGIN_PROVIDER [ character*(128), zmq_socket_push_tcp_address ]
&BEGIN_PROVIDER [ character*(128), zmq_socket_pull_inproc_address ]
implicit none
BEGIN_DOC
! Socket which pulls the results (2)
END_DOC
integer :: rc
character*(8), external :: zmq_port
integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
zmq_socket_pull_tcp_address = 'tcp://*:'//zmq_port(1)
zmq_socket_push_tcp_address = trim(qp_run_address)//':'//zmq_port(1)
zmq_socket_pull_inproc_address = 'inproc://'//zmq_port(1)
! zmq_socket_pull = f77_zmq_socket(zmq_context, ZMQ_PULL)
zmq_socket_pull = f77_zmq_socket(zmq_context, ZMQ_REP )
rc = f77_zmq_bind(zmq_socket_pull, zmq_socket_pull_tcp_address)
rc = f77_zmq_bind(zmq_socket_pull, zmq_socket_pull_inproc_address)
if (rc /= 0) then
stop 'Unable to bind zmq_socket_pull (tcp)'
endif
END_PROVIDER
BEGIN_PROVIDER [ integer(ZMQ_PTR), zmq_thread, (0:nproc) ]
&BEGIN_PROVIDER [ character*(128), zmq_state ]
implicit none
BEGIN_DOC
! Threads executing work through the ZeroMQ interface
END_DOC
zmq_thread = 0_ZMQ_PTR
zmq_state = 'No_state'
END_PROVIDER
subroutine new_parallel_job(zmq_to_qp_run_socket,name)
implicit none
BEGIN_DOC
! Start a new parallel job with name 'name'. The slave tasks execute subroutine 'slave'
END_DOC
character*(*), intent(in) :: name
character*(512) :: message
integer :: rc
integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
integer(ZMQ_PTR), intent(out) :: zmq_to_qp_run_socket
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
message = 'new_job '//name//' '//zmq_socket_push_tcp_address//' '//zmq_socket_pull_inproc_address
rc = f77_zmq_send(zmq_to_qp_run_socket,message,len(trim(message)),0)
rc = f77_zmq_recv(zmq_to_qp_run_socket,message,510,0)
message = trim(message(1:rc))
if (message(1:2) /= 'ok') then
print *, 'Unable to start parallel job : '//name
stop 1
endif
zmq_state = name
SOFT_TOUCH zmq_state zmq_thread
end
subroutine new_parallel_threads(slave,collector)
implicit none
BEGIN_DOC
! Start a new parallel job with name 'name'. The slave tasks execute subroutine 'slave'
END_DOC
external :: slave, collector
integer :: i,rc
rc = pthread_create( zmq_thread(0), collector)
do i=1,nproc
rc = pthread_create( zmq_thread(i), slave )
enddo
SOFT_TOUCH zmq_thread zmq_state
end
subroutine connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread)
implicit none
BEGIN_DOC
! Connect to the task server and obtain the worker ID
END_DOC
integer, intent(out) :: worker_id
integer, intent(in) :: thread
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
character*(512) :: message
character*(128) :: reply, state, address
integer :: rc
if (thread == 1) then
rc = f77_zmq_send(zmq_to_qp_run_socket, "connect inproc", 14, 0)
else
rc = f77_zmq_send(zmq_to_qp_run_socket, "connect tcp", 11, 0)
endif
rc = f77_zmq_recv(zmq_to_qp_run_socket, message, 510, 0)
message = trim(message(1:rc))
read(message,*) reply, state, worker_id, address
if ( (trim(reply) /= 'connect_reply') .and. &
(trim(state) /= trim(zmq_state)) ) then
print *, 'Reply: ', trim(reply)
print *, 'State: ', trim(state), '/', trim(zmq_state)
print *, 'Address: ', trim(address)
stop -1
endif
end
subroutine disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id,finished)
implicit none
BEGIN_DOC
! Disconnect from the task server
END_DOC
integer, intent(in) :: worker_id
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
integer, intent(out) :: finished
integer :: rc
character*(64) :: message, reply, state
write(message,*) 'disconnect '//trim(zmq_state), worker_id
rc = f77_zmq_send(zmq_to_qp_run_socket, trim(message), len(trim(message)), 0)
rc = f77_zmq_recv(zmq_to_qp_run_socket, message, 510, 0)
message = trim(message(1:rc))
read(message,*) reply, state, finished
if ( (trim(reply) /= 'disconnect_reply').or. &
(trim(state) /= zmq_state) ) then
print *, 'Unable to disconnect'
print *, trim(message)
stop -1
endif
end
subroutine add_task_to_taskserver(zmq_to_qp_run_socket,task)
implicit none
BEGIN_DOC
! Get a task from the task server
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
character*(*), intent(in) :: task
integer :: rc
character*(512) :: message
write(message,*) 'add_task '//trim(zmq_state)//' '//trim(task)
rc = f77_zmq_send(zmq_to_qp_run_socket, trim(message), len(trim(message)), 0)
rc = f77_zmq_recv(zmq_to_qp_run_socket, message, 510, 0)
message = trim(message(1:rc))
if (trim(message) /= 'ok') then
print *, trim(task)
print *, 'Unable to add the next task'
stop -1
endif
end
subroutine task_done_to_taskserver(zmq_to_qp_run_socket,worker_id, task_id)
implicit none
BEGIN_DOC
! Get a task from the task server
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
integer, intent(in) :: worker_id, task_id
integer :: rc
character*(512) :: message
write(message,*) 'task_done '//trim(zmq_state), worker_id, task_id
rc = f77_zmq_send(zmq_to_qp_run_socket, trim(message), len(trim(message)), 0)
rc = f77_zmq_recv(zmq_to_qp_run_socket, message, 510, 0)
message = trim(message(1:rc))
if (trim(message) /= 'ok') then
print *, 'Unable to send task_done message'
stop -1
endif
end
subroutine get_task_from_taskserver(zmq_to_qp_run_socket,worker_id,task_id,task)
implicit none
BEGIN_DOC
! Get a task from the task server
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
integer, intent(in) :: worker_id
integer, intent(out) :: task_id
character*(512), intent(out) :: task
character*(512) :: message
character*(64) :: reply
integer :: rc
write(message,*) 'get_task '//trim(zmq_state), worker_id
rc = f77_zmq_send(zmq_to_qp_run_socket, trim(message), len(trim(message)), 0)
rc = f77_zmq_recv(zmq_to_qp_run_socket, message, 510, 0)
message = trim(message(1:rc))
read(message,*) reply
if (trim(reply) == 'get_task_reply') then
read(message,*) reply, task_id
rc = 15
do while (message(rc:rc) == ' ')
rc += 1
enddo
do while (message(rc:rc) /= ' ')
rc += 1
enddo
rc += 1
task = message(rc:)
else if (trim(reply) == 'terminate') then
task_id = 0
task = 'terminate'
else
print *, 'Unable to get the next task'
print *, trim(message)
stop -1
endif
end
subroutine end_parallel_job(zmq_to_qp_run_socket,name)
implicit none
BEGIN_DOC
! End a new parallel job with name 'name'. The slave tasks execute subroutine 'slave'
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
character*(*), intent(in) :: name
character*(512) :: message
integer :: i,rc
if (name /= zmq_state) then
stop 'Wrong end of job'
endif
! Wait for Slaves
do i=1,nproc
rc = pthread_join( zmq_thread(i) )
if (rc /= 0) then
print *, 'Unable to join thread : ', i
stop -1
endif
zmq_thread(i) = 0
print *, 'joined ', i
enddo
! Wait for collector
rc = pthread_join( zmq_thread(0) )
zmq_thread(0) = 0
print *, 'joined ', 0
zmq_state = 'No_state'
character*(8), external :: zmq_port
rc = f77_zmq_disconnect(zmq_to_qp_run_socket, trim(qp_run_address)//':'//trim(zmq_port(0)))
rc = f77_zmq_close(zmq_to_qp_run_socket)
SOFT_TOUCH zmq_thread zmq_state
end

26
tests/bats/qp.bats
View File

@ -24,8 +24,6 @@ function eq() {
}
# ___
# | ._ o _|_
# _|_ | | | |_
@ -59,20 +57,20 @@ function run_HF() {
test_exe SCF || skip
ezfio set_file $1
ezfio set hartree_fock thresh_scf 1.e-10
qp_run SCF $1
qp_run SCF $1
energy="$(ezfio get hartree_fock energy)"
eq $energy $2 $thresh
}
function run_FCI() {
thresh=1.e-5
thresh=5.e-5
test_exe full_ci || skip
ezfio set_file $1
ezfio set perturbation do_pt2_end True
ezfio set determinants n_det_max $2
ezfio set determinants threshold_davidson 1.e-10
qp_run full_ci $1
qp_run full_ci $1
energy="$(ezfio get full_ci energy)"
eq $energy $3 $thresh
energy_pt2="$(ezfio get full_ci energy_pt2)"
@ -132,7 +130,8 @@ function run_all_1h_1p() {
}
@test "FCI H2O cc-pVDZ" {
run_FCI h2o.ezfio 10000 -0.762382562429778E+02 -0.762433933485226E+02
qp_set_mo_class h2o.ezfio -core "[1]" -act "[2-12]" -del "[13-24]"
run_FCI h2o.ezfio 2000 -0.761255633582109E+02 -0.761258377850042E+02
}
@test "CAS_SD H2O cc-pVDZ" {
@ -141,8 +140,8 @@ function run_all_1h_1p() {
ezfio set_file $INPUT
ezfio set perturbation do_pt2_end False
ezfio set determinants n_det_max 1000
qp_set_mo_class $INPUT -core "[1]" -inact "[2,5]" -act "[3,4,6,7]" -virt "[8-24]"
qp_run cas_sd_selected $INPUT
qp_set_mo_class $INPUT -core "[1]" -inact "[2,5]" -act "[3,4,6,7]" -virt "[8-24]"
qp_run cas_sd_selected $INPUT
energy="$(ezfio get cas_sd energy)"
eq $energy -0.762219854008117E+02 1.E-5
}
@ -154,9 +153,9 @@ function run_all_1h_1p() {
ezfio set determinants threshold_generators 1.
ezfio set determinants threshold_selectors 1.
ezfio set determinants read_wf True
qp_run mrcc_cassd $INPUT
qp_run mrcc_cassd $INPUT
energy="$(ezfio get mrcc_cassd energy)"
eq $energy -0.762303253805911E+02 1.E-3
eq $energy -76.2289109271715 1.E-3
}
@ -171,7 +170,8 @@ function run_all_1h_1p() {
}
@test "FCI H2O VDZ pseudo" {
run_FCI h2o_pseudo.ezfio 2000 -0.171550015498807E+02 -0.171645044185009E+02
qp_set_mo_class h2o_pseudo.ezfio -core "[1]" -act "[2-12]" -del "[13-23]"
run_FCI h2o_pseudo.ezfio 2000 -0.170399597228904E+02 -0.170400168816800E+02
}
#=== Convert
@ -179,7 +179,7 @@ function run_all_1h_1p() {
cp ${QP_ROOT}/tests/input/HBO.out .
qp_convert_output_to_ezfio.py HBO.out
ezfio set_file HBO.out.ezfio
qp_run SCF HBO.out.ezfio
qp_run SCF HBO.out.ezfio
# Check energy
energy="$(ezfio get hartree_fock energy)"
eq $energy -100.0185822590964 1.e-10
@ -189,7 +189,7 @@ function run_all_1h_1p() {
cp ${QP_ROOT}/tests/input/h2o.log .
qp_convert_output_to_ezfio.py h2o.log
ezfio set_file h2o.log.ezfio
qp_run SCF h2o.log.ezfio
qp_run SCF h2o.log.ezfio
# Check energy
energy="$(ezfio get hartree_fock energy)"
eq $energy -76.0270218704265 1E-10

27
tests/bats_to_sh.py Executable file
View File

@ -0,0 +1,27 @@
#!/usr/bin/env python
with open('bats/qp.bats','r') as f:
raw_data = f.read()
output = []
inside = False
level = 0
for i in raw_data:
new_i = i
if i == "@":
inside = True
elif i == "{" and inside and level == 0:
new_i = ""
elif i == "}" and inside and level == 1:
inside = False
new_i = ""
if i == "{":
level += 1
elif i == "}":
level -= 1
output.append(new_i)
print "".join(output).replace("@test","echo").replace("|| skip","|| return")

16
tests/run_tests.sh
View File

@ -1,6 +1,18 @@
#!/bin/bash
rm -rf work
exec bats bats/qp.bats
export QP_PREFIX="timeout -s 9 300"
export QP_TASK_DEBUG=1
BATS_FILE=bats/qp.bats
rm -rf work output
if [[ "$1" == "-v" ]]
then
echo "Verbose mode"
./bats_to_sh.py $BATS_FILE | bash
else
bats $BATS_FILE
fi