LCPQ
/
quantum_package
mirror of https://github.com/LCPQ/quantum_package
10
0
Fork 0
Code Issues Releases Wiki Activity

Distributed PT2

This commit is contained in:
Anthony Scemama 2016-02-19 00:20:28 +01:00
parent e5c668deef
commit 20a857c446
72 changed files with 4190 additions and 1461 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

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

61
ocaml/.gitignore vendored
View File

@ -1,61 +0,0 @@
_build
ezfio.ml
.gitignore
Git.ml
Input_auto_generated.ml
Input_determinants.ml
Input_foboci.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

47
ocaml/Bitlist.ml
View File

@ -1,5 +1,5 @@
open Qptypes;;
open Core.Std;;
open Qptypes
open Core.Std
(*
Type for bits strings
@ -19,15 +19,16 @@ 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 ") ) )
(* Create a bit list from an int64 *)
let of_int64 i =
@ -43,15 +44,15 @@ let of_int64 i =
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)
;;
(* Create an int64 from a bit list *)
let to_int64 l =
@ -61,26 +62,26 @@ 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
;;
(* 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 +101,7 @@ let to_int64_list l =
let l = do_work [] [] 1 l
in
List.rev_map ~f:to_int64 l
;;
(* Create a bit list from a list of MO indices *)
let of_mo_number_list n_int l =
@ -109,7 +110,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 +128,7 @@ let to_mo_number_list l =
end
in
do_work [] (List.length l)
;;
@ -142,7 +143,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,12 +154,12 @@ 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 =
@ -167,6 +168,6 @@ let popcnt b =
| Bit.One::rest -> popcnt (accu+1) rest
| Bit.Zero::rest -> popcnt (accu) rest
in popcnt 0 b
;;

13
ocaml/Determinant.ml
View File

@ -4,14 +4,14 @@ 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
@ -22,7 +22,7 @@ let to_bitlist_couple x =
|> Array.to_list
|> Bitlist.of_int64_list
in (xa,xb)
;;
let bitlist_to_string ~mo_tot_num x =
List.map x ~f:(fun i -> match i with
@ -30,7 +30,7 @@ let bitlist_to_string ~mo_tot_num x =
| Bit.One -> "+" )
|> String.concat
|> String.sub ~pos:0 ~len:(MO_number.to_int mo_tot_num)
;;
let of_int64_array ~n_int ~alpha ~beta x =
@ -54,20 +54,19 @@ 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 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"
;;

55
ocaml/Input_determinants_by_hand.ml
View File

@ -29,6 +29,8 @@ end = struct
let get_default = Qpackage.get_ezfio_default "determinants";;
let n_det_read_max = 50_000_000 ;;
let read_n_int () =
if not (Ezfio.has_determinants_n_int()) then
Ezfio.get_mo_basis_mo_tot_num ()
@ -207,14 +209,20 @@ end = struct
let read () =
if (Ezfio.has_mo_basis_mo_tot_num ()) then
Some
{ n_int = read_n_int () ;
bit_kind = read_bit_kind () ;
n_det = read_n_det () ;
expected_s2 = read_expected_s2 () ;
psi_coef = read_psi_coef () ;
psi_det = read_psi_det () ;
}
let n_det =
read_n_det ()
in
if ( (Det_number.to_int n_det) > n_det_read_max ) then
None
else
Some
{ n_int = read_n_int () ;
bit_kind = read_bit_kind () ;
n_det = read_n_det () ;
expected_s2 = read_expected_s2 () ;
psi_coef = read_psi_coef () ;
psi_det = read_psi_det () ;
}
else
None
;;
@ -393,22 +401,35 @@ 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

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

795
ocaml/TaskServer.ml
View File

@ -1,25 +1,35 @@
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
@ -32,16 +42,14 @@ let bind_socket ~socket_type ~socket ~address =
| other_exception -> raise other_exception
(** 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 +75,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;

89
ocaml/qp_run.ml
View File

@ -1,14 +1,53 @@
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
TaskServer.bind_socket "REP" dummy_socket address ;
ZMQ.Socket.unbind dummy_socket address;
);
port_number
with
| Failure _ -> 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");
@ -26,16 +65,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 +90,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
| None -> assert false
| Some (_,x) -> x
| 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 +109,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 +133,9 @@ Executes a Quantum Package binary file among these:\n\n"
)
)
spec
(fun exe ezfio_file () ->
run exe ezfio_file
(fun master exe ezfio_file () ->
run ~master exe ezfio_file
)
|> Command.run ~version: Git.sha1 ~build_info: Git.message
;;

3
ocaml/qptypes_generator.ml
View File

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

59
ocaml/test_task_server.py
View File

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

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

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

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

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)

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

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

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

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

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

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

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

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

@ -0,0 +1,248 @@
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
zmq_socket_pair = new_zmq_pair_socket(.True.)
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
call new_parallel_job(zmq_to_qp_run_socket,'$subroutine')
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_parallel_job(zmq_to_qp_run_socket,'$subroutine')
rc = f77_zmq_close(zmq_socket_pair)
if (rc /= 0) then
print *, 'f77_zmq_close(zmq_socket_pair)'
stop 'error'
endif
$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)
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

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

@ -412,7 +412,7 @@ subroutine int_of_3_highest_electrons( det_in, res, Nint )
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))
res = ior(ishft(res, 21_8), i+ishft(k-1,bit_kind_shift))
icount -= 1
if (icount == 0) then
return
@ -645,7 +645,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

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

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

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)

210
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,77 @@ 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_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 +185,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

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

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

@ -0,0 +1,730 @@
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 = f77_zmq_ctx_new ()
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_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_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_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_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)
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_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

24
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,7 +153,7 @@ 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
@ -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