mirror of
https://github.com/LCPQ/quantum_package
synced 2024-08-25 05:51:46 +02:00
Merge branch 'master' into mrcepa0
Conflicts: ocaml/.gitignore ocaml/qp_edit.ml plugins/MRCC_Utils/mrcc_utils.irp.f
This commit is contained in:
commit
306a86d33b
@ -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
|
||||
|
@ -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
62
config/gfortran_avx.cfg
Normal 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
62
config/gfortran_debug.cfg
Normal 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
|
||||
|
@ -31,7 +31,7 @@ OPENMP : 1 ; Append OpenMP flags
|
||||
# -ftz : Flushes denormal results to zero
|
||||
#
|
||||
[OPT]
|
||||
FCFLAGS : -xHost -O2 -ip -ftz -g
|
||||
FCFLAGS : -xSSE4.2 -O2 -ip -ftz -g
|
||||
|
||||
# Profiling flags
|
||||
#################
|
||||
|
9
configure
vendored
9
configure
vendored
@ -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}"',
|
||||
|
@ -1,3 +1,735 @@
|
||||
BORON
|
||||
S 11
|
||||
1 210400.0000000 0.00000583
|
||||
2 31500.0000000 0.00004532
|
||||
3 7169.0000000 0.00023838
|
||||
4 2030.0000000 0.00100570
|
||||
5 662.5000000 0.00364496
|
||||
6 239.2000000 0.01173628
|
||||
7 93.2600000 0.03380702
|
||||
8 38.6400000 0.08556593
|
||||
9 16.7800000 0.18260322
|
||||
10 7.5410000 0.30583760
|
||||
11 3.4820000 0.34080347
|
||||
S 11
|
||||
1 210400.0000000 -0.00000118
|
||||
2 31500.0000000 -0.00000915
|
||||
3 7169.0000000 -0.00004819
|
||||
4 2030.0000000 -0.00020306
|
||||
5 662.5000000 -0.00073917
|
||||
6 239.2000000 -0.00238603
|
||||
7 93.2600000 -0.00698654
|
||||
8 38.6400000 -0.01811594
|
||||
9 16.7800000 -0.04123129
|
||||
10 7.5410000 -0.07781353
|
||||
11 3.4820000 -0.12123181
|
||||
S 1
|
||||
1 1.6180000 1.0000000
|
||||
S 1
|
||||
1 0.6270000 1.0000000
|
||||
S 1
|
||||
1 0.2934000 1.0000000
|
||||
S 1
|
||||
1 0.1310000 1.0000000
|
||||
S 1
|
||||
1 0.0581500 1.0000000
|
||||
S 1
|
||||
1 127.6200000 1.0000000
|
||||
S 1
|
||||
1 63.6510000 1.0000000
|
||||
S 1
|
||||
1 31.7460000 1.0000000
|
||||
S 1
|
||||
1 15.8330000 1.0000000
|
||||
S 1
|
||||
1 7.8970000 1.0000000
|
||||
P 5
|
||||
1 192.5000000 0.00013490
|
||||
2 45.6400000 0.00114741
|
||||
3 14.7500000 0.00584793
|
||||
4 5.5030000 0.02117091
|
||||
5 2.2220000 0.06266872
|
||||
P 1
|
||||
1 0.9590000 1.0000000
|
||||
P 1
|
||||
1 0.4314000 1.0000000
|
||||
P 1
|
||||
1 0.1969000 1.0000000
|
||||
P 1
|
||||
1 0.0903300 1.0000000
|
||||
P 1
|
||||
1 0.0406600 1.0000000
|
||||
P 1
|
||||
1 144.2110000 1.0000000
|
||||
P 1
|
||||
1 63.6980000 1.0000000
|
||||
P 1
|
||||
1 28.1350000 1.0000000
|
||||
P 1
|
||||
1 12.4270000 1.0000000
|
||||
P 1
|
||||
1 5.4890000 1.0000000
|
||||
D 1
|
||||
1 2.8860000 1.0000000
|
||||
D 1
|
||||
1 1.2670000 1.0000000
|
||||
D 1
|
||||
1 0.5560000 1.0000000
|
||||
D 1
|
||||
1 0.2440000 1.0000000
|
||||
D 1
|
||||
1 0.1070000 1.0000000
|
||||
D 1
|
||||
1 100.3980000 1.0000000
|
||||
D 1
|
||||
1 43.1630000 1.0000000
|
||||
D 1
|
||||
1 18.5570000 1.0000000
|
||||
D 1
|
||||
1 7.9780000 1.0000000
|
||||
F 1
|
||||
1 1.6510000 1.0000000
|
||||
F 1
|
||||
1 0.8002000 1.0000000
|
||||
F 1
|
||||
1 0.3878000 1.0000000
|
||||
F 1
|
||||
1 0.1880000 1.0000000
|
||||
F 1
|
||||
1 56.0930000 1.0000000
|
||||
F 1
|
||||
1 20.3090000 1.0000000
|
||||
F 1
|
||||
1 7.3530000 1.0000000
|
||||
G 1
|
||||
1 1.6469000 1.0000000
|
||||
G 1
|
||||
1 0.7889000 1.0000000
|
||||
G 1
|
||||
1 0.3779000 1.0000000
|
||||
G 1
|
||||
1 43.0160000 1.0000000
|
||||
G 1
|
||||
1 14.4690000 1.0000000
|
||||
H 1
|
||||
1 1.3120000 1.0000000
|
||||
H 1
|
||||
1 0.5806000 1.0000000
|
||||
H 1
|
||||
1 29.5550000 1.0000000
|
||||
I 1
|
||||
1 0.9847000 1.0000000
|
||||
|
||||
CARBON
|
||||
S 11
|
||||
1 312100.0000000 0.00000567
|
||||
2 46740.0000000 0.00004410
|
||||
3 10640.0000000 0.00023190
|
||||
4 3013.0000000 0.00097897
|
||||
5 982.8000000 0.00355163
|
||||
6 354.8000000 0.01144061
|
||||
7 138.4000000 0.03299855
|
||||
8 57.3500000 0.08405347
|
||||
9 24.9200000 0.18067613
|
||||
10 11.2300000 0.30491140
|
||||
11 5.2010000 0.34141570
|
||||
S 11
|
||||
1 312100.0000000 -0.00000121
|
||||
2 46740.0000000 -0.00000939
|
||||
3 10640.0000000 -0.00004947
|
||||
4 3013.0000000 -0.00020857
|
||||
5 982.8000000 -0.00076015
|
||||
6 354.8000000 -0.00245469
|
||||
7 138.4000000 -0.00720153
|
||||
8 57.3500000 -0.01880742
|
||||
9 24.9200000 -0.04325001
|
||||
10 11.2300000 -0.08259733
|
||||
11 5.2010000 -0.12857592
|
||||
S 1
|
||||
1 2.4260000 1.0000000
|
||||
S 1
|
||||
1 0.9673000 1.0000000
|
||||
S 1
|
||||
1 0.4456000 1.0000000
|
||||
S 1
|
||||
1 0.1971000 1.0000000
|
||||
S 1
|
||||
1 0.0863500 1.0000000
|
||||
S 1
|
||||
1 183.0760000 1.0000000
|
||||
S 1
|
||||
1 91.9980000 1.0000000
|
||||
S 1
|
||||
1 46.2300000 1.0000000
|
||||
S 1
|
||||
1 23.2310000 1.0000000
|
||||
S 1
|
||||
1 11.6740000 1.0000000
|
||||
P 5
|
||||
1 295.2000000 0.00014249
|
||||
2 69.9800000 0.00122010
|
||||
3 22.6400000 0.00633696
|
||||
4 8.4850000 0.02351875
|
||||
5 3.4590000 0.06990447
|
||||
P 1
|
||||
1 1.5040000 1.0000000
|
||||
P 1
|
||||
1 0.6783000 1.0000000
|
||||
P 1
|
||||
1 0.3087000 1.0000000
|
||||
P 1
|
||||
1 0.1400000 1.0000000
|
||||
P 1
|
||||
1 0.0617800 1.0000000
|
||||
P 1
|
||||
1 206.5670000 1.0000000
|
||||
P 1
|
||||
1 92.5890000 1.0000000
|
||||
P 1
|
||||
1 41.5010000 1.0000000
|
||||
P 1
|
||||
1 18.6020000 1.0000000
|
||||
P 1
|
||||
1 8.3380000 1.0000000
|
||||
D 1
|
||||
1 4.5420000 1.0000000
|
||||
D 1
|
||||
1 1.9790000 1.0000000
|
||||
D 1
|
||||
1 0.8621000 1.0000000
|
||||
D 1
|
||||
1 0.3756000 1.0000000
|
||||
D 1
|
||||
1 0.1636000 1.0000000
|
||||
D 1
|
||||
1 145.5240000 1.0000000
|
||||
D 1
|
||||
1 62.9160000 1.0000000
|
||||
D 1
|
||||
1 27.2010000 1.0000000
|
||||
D 1
|
||||
1 11.7600000 1.0000000
|
||||
F 1
|
||||
1 2.6310000 1.0000000
|
||||
F 1
|
||||
1 1.2550000 1.0000000
|
||||
F 1
|
||||
1 0.5988000 1.0000000
|
||||
F 1
|
||||
1 0.2857000 1.0000000
|
||||
F 1
|
||||
1 78.5650000 1.0000000
|
||||
F 1
|
||||
1 28.0590000 1.0000000
|
||||
F 1
|
||||
1 10.0210000 1.0000000
|
||||
G 1
|
||||
1 2.6520000 1.0000000
|
||||
G 1
|
||||
1 1.2040000 1.0000000
|
||||
G 1
|
||||
1 0.5470000 1.0000000
|
||||
G 1
|
||||
1 55.1450000 1.0000000
|
||||
G 1
|
||||
1 17.6070000 1.0000000
|
||||
H 1
|
||||
1 2.0300000 1.0000000
|
||||
H 1
|
||||
1 0.8511000 1.0000000
|
||||
H 1
|
||||
1 40.7100000 1.0000000
|
||||
I 1
|
||||
1 1.4910000 1.0000000
|
||||
|
||||
NITROGEN
|
||||
S 11
|
||||
1 432300.0000000 0.00000559
|
||||
2 64700.0000000 0.00004351
|
||||
3 14720.0000000 0.00022893
|
||||
4 4170.0000000 0.00096502
|
||||
5 1361.0000000 0.00350219
|
||||
6 491.2000000 0.01129212
|
||||
7 191.6000000 0.03261283
|
||||
8 79.4100000 0.08329727
|
||||
9 34.5300000 0.17998566
|
||||
10 15.5800000 0.30500351
|
||||
11 7.2320000 0.34115932
|
||||
S 11
|
||||
1 432300.0000000 -0.00000123
|
||||
2 64700.0000000 -0.00000958
|
||||
3 14720.0000000 -0.00005051
|
||||
4 4170.0000000 -0.00021264
|
||||
5 1361.0000000 -0.00077534
|
||||
6 491.2000000 -0.00250624
|
||||
7 191.6000000 -0.00736529
|
||||
8 79.4100000 -0.01930167
|
||||
9 34.5300000 -0.04471738
|
||||
10 15.5800000 -0.08606647
|
||||
11 7.2320000 -0.13329627
|
||||
S 1
|
||||
1 3.3820000 1.0000000
|
||||
S 1
|
||||
1 1.3690000 1.0000000
|
||||
S 1
|
||||
1 0.6248000 1.0000000
|
||||
S 1
|
||||
1 0.2747000 1.0000000
|
||||
S 1
|
||||
1 0.1192000 1.0000000
|
||||
S 1
|
||||
1 246.2620000 1.0000000
|
||||
S 1
|
||||
1 124.1870000 1.0000000
|
||||
S 1
|
||||
1 62.6260000 1.0000000
|
||||
S 1
|
||||
1 31.5810000 1.0000000
|
||||
S 1
|
||||
1 15.9260000 1.0000000
|
||||
P 5
|
||||
1 415.9000000 0.00014841
|
||||
2 98.6100000 0.00127634
|
||||
3 31.9200000 0.00670242
|
||||
4 12.0000000 0.02526170
|
||||
5 4.9190000 0.07518943
|
||||
P 1
|
||||
1 2.1480000 1.0000000
|
||||
P 1
|
||||
1 0.9696000 1.0000000
|
||||
P 1
|
||||
1 0.4399000 1.0000000
|
||||
P 1
|
||||
1 0.1978000 1.0000000
|
||||
P 1
|
||||
1 0.0860300 1.0000000
|
||||
P 1
|
||||
1 270.1420000 1.0000000
|
||||
P 1
|
||||
1 123.4650000 1.0000000
|
||||
P 1
|
||||
1 56.4280000 1.0000000
|
||||
P 1
|
||||
1 25.7900000 1.0000000
|
||||
P 1
|
||||
1 11.7870000 1.0000000
|
||||
D 1
|
||||
1 6.7170000 1.0000000
|
||||
D 1
|
||||
1 2.8960000 1.0000000
|
||||
D 1
|
||||
1 1.2490000 1.0000000
|
||||
D 1
|
||||
1 0.5380000 1.0000000
|
||||
D 1
|
||||
1 0.2320000 1.0000000
|
||||
D 1
|
||||
1 199.9200000 1.0000000
|
||||
D 1
|
||||
1 87.1110000 1.0000000
|
||||
D 1
|
||||
1 37.9570000 1.0000000
|
||||
D 1
|
||||
1 16.5390000 1.0000000
|
||||
F 1
|
||||
1 3.8290000 1.0000000
|
||||
F 1
|
||||
1 1.7950000 1.0000000
|
||||
F 1
|
||||
1 0.8410000 1.0000000
|
||||
F 1
|
||||
1 0.3940000 1.0000000
|
||||
F 1
|
||||
1 105.3460000 1.0000000
|
||||
F 1
|
||||
1 37.5300000 1.0000000
|
||||
F 1
|
||||
1 13.3700000 1.0000000
|
||||
G 1
|
||||
1 3.8560000 1.0000000
|
||||
G 1
|
||||
1 1.7020000 1.0000000
|
||||
G 1
|
||||
1 0.7510000 1.0000000
|
||||
G 1
|
||||
1 67.1880000 1.0000000
|
||||
G 1
|
||||
1 20.3600000 1.0000000
|
||||
H 1
|
||||
1 2.8750000 1.0000000
|
||||
H 1
|
||||
1 1.1700000 1.0000000
|
||||
H 1
|
||||
1 52.0500000 1.0000000
|
||||
I 1
|
||||
1 2.0990000 1.0000000
|
||||
|
||||
OXYGEN
|
||||
S 11
|
||||
1 570800.0000000 0.00000555
|
||||
2 85480.0000000 0.00004311
|
||||
3 19460.0000000 0.00022667
|
||||
4 5512.0000000 0.00095637
|
||||
5 1798.0000000 0.00347320
|
||||
6 648.9000000 0.01119778
|
||||
7 253.1000000 0.03238766
|
||||
8 104.9000000 0.08285977
|
||||
9 45.6500000 0.17958381
|
||||
10 20.6200000 0.30522110
|
||||
11 9.5870000 0.34089349
|
||||
S 11
|
||||
1 570800.0000000 -0.00000126
|
||||
2 85480.0000000 -0.00000977
|
||||
3 19460.0000000 -0.00005148
|
||||
4 5512.0000000 -0.00021696
|
||||
5 1798.0000000 -0.00079162
|
||||
6 648.9000000 -0.00255900
|
||||
7 253.1000000 -0.00753313
|
||||
8 104.9000000 -0.01978897
|
||||
9 45.6500000 -0.04606288
|
||||
10 20.6200000 -0.08919560
|
||||
11 9.5870000 -0.13754216
|
||||
S 1
|
||||
1 4.4930000 1.0000000
|
||||
S 1
|
||||
1 1.8370000 1.0000000
|
||||
S 1
|
||||
1 0.8349000 1.0000000
|
||||
S 1
|
||||
1 0.3658000 1.0000000
|
||||
S 1
|
||||
1 0.1570000 1.0000000
|
||||
S 1
|
||||
1 317.0960000 1.0000000
|
||||
S 1
|
||||
1 160.3930000 1.0000000
|
||||
S 1
|
||||
1 81.1290000 1.0000000
|
||||
S 1
|
||||
1 41.0370000 1.0000000
|
||||
S 1
|
||||
1 20.7570000 1.0000000
|
||||
P 5
|
||||
1 525.6000000 0.00016664
|
||||
2 124.6000000 0.00143336
|
||||
3 40.3400000 0.00754762
|
||||
4 15.1800000 0.02859456
|
||||
5 6.2450000 0.08438858
|
||||
P 1
|
||||
1 2.7320000 1.0000000
|
||||
P 1
|
||||
1 1.2270000 1.0000000
|
||||
P 1
|
||||
1 0.5492000 1.0000000
|
||||
P 1
|
||||
1 0.2418000 1.0000000
|
||||
P 1
|
||||
1 0.1025000 1.0000000
|
||||
P 1
|
||||
1 358.9110000 1.0000000
|
||||
P 1
|
||||
1 161.8180000 1.0000000
|
||||
P 1
|
||||
1 72.9570000 1.0000000
|
||||
P 1
|
||||
1 32.8930000 1.0000000
|
||||
P 1
|
||||
1 14.8300000 1.0000000
|
||||
D 1
|
||||
1 8.2530000 1.0000000
|
||||
D 1
|
||||
1 3.5970000 1.0000000
|
||||
D 1
|
||||
1 1.5680000 1.0000000
|
||||
D 1
|
||||
1 0.6840000 1.0000000
|
||||
D 1
|
||||
1 0.2980000 1.0000000
|
||||
D 1
|
||||
1 250.8300000 1.0000000
|
||||
D 1
|
||||
1 108.1630000 1.0000000
|
||||
D 1
|
||||
1 46.6420000 1.0000000
|
||||
D 1
|
||||
1 20.1130000 1.0000000
|
||||
F 1
|
||||
1 5.4300000 1.0000000
|
||||
F 1
|
||||
1 2.4160000 1.0000000
|
||||
F 1
|
||||
1 1.0750000 1.0000000
|
||||
F 1
|
||||
1 0.4780000 1.0000000
|
||||
F 1
|
||||
1 136.1110000 1.0000000
|
||||
F 1
|
||||
1 48.8550000 1.0000000
|
||||
F 1
|
||||
1 17.5360000 1.0000000
|
||||
G 1
|
||||
1 5.2110000 1.0000000
|
||||
G 1
|
||||
1 2.1900000 1.0000000
|
||||
G 1
|
||||
1 0.9200000 1.0000000
|
||||
G 1
|
||||
1 81.6280000 1.0000000
|
||||
G 1
|
||||
1 24.0650000 1.0000000
|
||||
H 1
|
||||
1 3.8720000 1.0000000
|
||||
H 1
|
||||
1 1.5050000 1.0000000
|
||||
H 1
|
||||
1 62.8500000 1.0000000
|
||||
I 1
|
||||
1 2.7730000 1.0000000
|
||||
|
||||
FLUORINE
|
||||
S 11
|
||||
1 723500.0000000 0.00000556
|
||||
2 108400.0000000 0.00004318
|
||||
3 24680.0000000 0.00022700
|
||||
4 6990.0000000 0.00095803
|
||||
5 2282.0000000 0.00347015
|
||||
6 824.6000000 0.01118526
|
||||
7 321.8000000 0.03232880
|
||||
8 133.5000000 0.08279545
|
||||
9 58.1100000 0.17988024
|
||||
10 26.2800000 0.30557831
|
||||
11 12.2400000 0.34026839
|
||||
S 11
|
||||
1 723500.0000000 -0.00000129
|
||||
2 108400.0000000 -0.00000999
|
||||
3 24680.0000000 -0.00005260
|
||||
4 6990.0000000 -0.00022172
|
||||
5 2282.0000000 -0.00080692
|
||||
6 824.6000000 -0.00260817
|
||||
7 321.8000000 -0.00767402
|
||||
8 133.5000000 -0.02019353
|
||||
9 58.1100000 -0.04718752
|
||||
10 26.2800000 -0.09158009
|
||||
11 12.2400000 -0.14048558
|
||||
S 1
|
||||
1 5.7470000 1.0000000
|
||||
S 1
|
||||
1 2.3650000 1.0000000
|
||||
S 1
|
||||
1 1.0710000 1.0000000
|
||||
S 1
|
||||
1 0.4681000 1.0000000
|
||||
S 1
|
||||
1 0.1994000 1.0000000
|
||||
S 1
|
||||
1 397.5440000 1.0000000
|
||||
S 1
|
||||
1 201.5940000 1.0000000
|
||||
S 1
|
||||
1 102.2280000 1.0000000
|
||||
S 1
|
||||
1 51.8400000 1.0000000
|
||||
S 1
|
||||
1 26.2880000 1.0000000
|
||||
P 5
|
||||
1 660.0000000 0.00017721
|
||||
2 156.4000000 0.00152691
|
||||
3 50.6400000 0.00807207
|
||||
4 19.0800000 0.03074021
|
||||
5 7.8720000 0.09011914
|
||||
P 1
|
||||
1 3.4490000 1.0000000
|
||||
P 1
|
||||
1 1.5450000 1.0000000
|
||||
P 1
|
||||
1 0.6864000 1.0000000
|
||||
P 1
|
||||
1 0.2986000 1.0000000
|
||||
P 1
|
||||
1 0.1245000 1.0000000
|
||||
P 1
|
||||
1 446.5700000 1.0000000
|
||||
P 1
|
||||
1 201.3390000 1.0000000
|
||||
P 1
|
||||
1 90.7750000 1.0000000
|
||||
P 1
|
||||
1 40.9270000 1.0000000
|
||||
P 1
|
||||
1 18.4520000 1.0000000
|
||||
D 1
|
||||
1 10.5730000 1.0000000
|
||||
D 1
|
||||
1 4.6130000 1.0000000
|
||||
D 1
|
||||
1 2.0130000 1.0000000
|
||||
D 1
|
||||
1 0.8780000 1.0000000
|
||||
D 1
|
||||
1 0.3830000 1.0000000
|
||||
D 1
|
||||
1 313.7310000 1.0000000
|
||||
D 1
|
||||
1 135.4040000 1.0000000
|
||||
D 1
|
||||
1 58.4390000 1.0000000
|
||||
D 1
|
||||
1 25.2220000 1.0000000
|
||||
F 1
|
||||
1 7.5630000 1.0000000
|
||||
F 1
|
||||
1 3.3300000 1.0000000
|
||||
F 1
|
||||
1 1.4660000 1.0000000
|
||||
F 1
|
||||
1 0.6450000 1.0000000
|
||||
F 1
|
||||
1 177.2200000 1.0000000
|
||||
F 1
|
||||
1 64.3500000 1.0000000
|
||||
F 1
|
||||
1 23.3660000 1.0000000
|
||||
G 1
|
||||
1 6.7350000 1.0000000
|
||||
G 1
|
||||
1 2.7830000 1.0000000
|
||||
G 1
|
||||
1 1.1500000 1.0000000
|
||||
G 1
|
||||
1 99.3840000 1.0000000
|
||||
G 1
|
||||
1 29.5170000 1.0000000
|
||||
H 1
|
||||
1 5.0880000 1.0000000
|
||||
H 1
|
||||
1 1.9370000 1.0000000
|
||||
H 1
|
||||
1 67.8200000 1.0000000
|
||||
I 1
|
||||
1 3.5810000 1.0000000
|
||||
|
||||
NEON
|
||||
S 11
|
||||
1 902400.0000000 0.00000551
|
||||
2 135100.0000000 0.00004282
|
||||
3 30750.0000000 0.00022514
|
||||
4 8710.0000000 0.00095016
|
||||
5 2842.0000000 0.00344719
|
||||
6 1026.0000000 0.01112545
|
||||
7 400.1000000 0.03220568
|
||||
8 165.9000000 0.08259891
|
||||
9 72.2100000 0.17990564
|
||||
10 32.6600000 0.30605208
|
||||
11 15.2200000 0.34012559
|
||||
S 11
|
||||
1 902400.0000000 -0.00000129
|
||||
2 135100.0000000 -0.00001005
|
||||
3 30750.0000000 -0.00005293
|
||||
4 8710.0000000 -0.00022312
|
||||
5 2842.0000000 -0.00081338
|
||||
6 1026.0000000 -0.00263230
|
||||
7 400.1000000 -0.00775910
|
||||
8 165.9000000 -0.02045277
|
||||
9 72.2100000 -0.04797505
|
||||
10 32.6600000 -0.09340086
|
||||
11 15.2200000 -0.14277215
|
||||
S 1
|
||||
1 7.1490000 1.0000000
|
||||
S 1
|
||||
1 2.9570000 1.0000000
|
||||
S 1
|
||||
1 1.3350000 1.0000000
|
||||
S 1
|
||||
1 0.5816000 1.0000000
|
||||
S 1
|
||||
1 0.2463000 1.0000000
|
||||
S 1
|
||||
1 526.1367000 1.0000000
|
||||
S 1
|
||||
1 264.9976000 1.0000000
|
||||
S 1
|
||||
1 133.4704000 1.0000000
|
||||
S 1
|
||||
1 67.2246200 1.0000000
|
||||
S 1
|
||||
1 33.8588000 1.0000000
|
||||
P 5
|
||||
1 815.6000000 0.00018376
|
||||
2 193.3000000 0.00158509
|
||||
3 62.6000000 0.00841464
|
||||
4 23.6100000 0.03220033
|
||||
5 9.7620000 0.09396390
|
||||
P 1
|
||||
1 4.2810000 1.0000000
|
||||
P 1
|
||||
1 1.9150000 1.0000000
|
||||
P 1
|
||||
1 0.8476000 1.0000000
|
||||
P 1
|
||||
1 0.3660000 1.0000000
|
||||
P 1
|
||||
1 0.1510000 1.0000000
|
||||
P 1
|
||||
1 558.8741000 1.0000000
|
||||
P 1
|
||||
1 250.2470000 1.0000000
|
||||
P 1
|
||||
1 112.0531000 1.0000000
|
||||
P 1
|
||||
1 50.1739900 1.0000000
|
||||
P 1
|
||||
1 22.4664000 1.0000000
|
||||
D 1
|
||||
1 13.3170000 1.0000000
|
||||
D 1
|
||||
1 5.8030000 1.0000000
|
||||
D 1
|
||||
1 2.5290000 1.0000000
|
||||
D 1
|
||||
1 1.1020000 1.0000000
|
||||
D 1
|
||||
1 0.4800000 1.0000000
|
||||
D 1
|
||||
1 392.7164000 1.0000000
|
||||
D 1
|
||||
1 169.5564000 1.0000000
|
||||
D 1
|
||||
1 73.2064700 1.0000000
|
||||
D 1
|
||||
1 31.6071000 1.0000000
|
||||
F 1
|
||||
1 10.3560000 1.0000000
|
||||
F 1
|
||||
1 4.5380000 1.0000000
|
||||
F 1
|
||||
1 1.9890000 1.0000000
|
||||
F 1
|
||||
1 0.8710000 1.0000000
|
||||
F 1
|
||||
1 224.9657000 1.0000000
|
||||
F 1
|
||||
1 82.4518500 1.0000000
|
||||
F 1
|
||||
1 30.2193000 1.0000000
|
||||
G 1
|
||||
1 8.3450000 1.0000000
|
||||
G 1
|
||||
1 3.4170000 1.0000000
|
||||
G 1
|
||||
1 1.3990000 1.0000000
|
||||
G 1
|
||||
1 119.8449000 1.0000000
|
||||
G 1
|
||||
1 33.5255000 1.0000000
|
||||
H 1
|
||||
1 6.5190000 1.0000000
|
||||
H 1
|
||||
1 2.4470000 1.0000000
|
||||
H 1
|
||||
1 50.9084700 1.0000000
|
||||
I 1
|
||||
1 4.4890000 1.0000000
|
||||
|
||||
ALUMINUM
|
||||
S 11
|
||||
1 3652000.0000000 0.0000019
|
||||
|
118
data/list_element.txt
Normal file
118
data/list_element.txt
Normal file
@ -0,0 +1,118 @@
|
||||
1 H Hydrogen
|
||||
2 He Helium
|
||||
3 Li Lithium
|
||||
4 Be Beryllium
|
||||
5 B Boron
|
||||
6 C Carbon
|
||||
7 N Nitrogen
|
||||
8 O Oxygen
|
||||
9 F Fluorine
|
||||
10 Ne Neon
|
||||
11 Na Sodium
|
||||
12 Mg Magnesium
|
||||
13 Al Aluminum
|
||||
14 Si Silicon
|
||||
15 P Phosphorus
|
||||
16 S Sulfur
|
||||
17 Cl Chlorine
|
||||
18 Ar Argon
|
||||
19 K Potassium
|
||||
20 Ca Calcium
|
||||
21 Sc Scandium
|
||||
22 Ti Titanium
|
||||
23 V Vanadium
|
||||
24 Cr Chromium
|
||||
25 Mn Manganese
|
||||
26 Fe Iron
|
||||
27 Co Cobalt
|
||||
28 Ni Nickel
|
||||
29 Cu Copper
|
||||
30 Zn Zinc
|
||||
31 Ga Gallium
|
||||
32 Ge Germanium
|
||||
33 As Arsenic
|
||||
34 Se Selenium
|
||||
35 Br Bromine
|
||||
36 Kr Krypton
|
||||
37 Rb Rubidium
|
||||
38 Sr Strontium
|
||||
39 Y Yttrium
|
||||
40 Zr Zirconium
|
||||
41 Nb Niobium
|
||||
42 Mo Molybdenum
|
||||
43 Tc Technetium
|
||||
44 Ru Ruthenium
|
||||
45 Rh Rhodium
|
||||
46 Pd Palladium
|
||||
47 Ag Silver
|
||||
48 Cd Cadmium
|
||||
49 In Indium
|
||||
50 Sn Tin
|
||||
51 Sb Antimony
|
||||
52 Te Tellurium
|
||||
53 I Iodine
|
||||
54 Xe Xenon
|
||||
55 Cs Cesium
|
||||
56 Ba Barium
|
||||
57 La Lanthanum
|
||||
58 Ce Cerium
|
||||
59 Pr Praseodymium
|
||||
60 Nd Neodymium
|
||||
61 Pm Promethium
|
||||
62 Sm Samarium
|
||||
63 Eu Europium
|
||||
64 Gd Gadolinium
|
||||
65 Tb Terbium
|
||||
66 Dy Dysprosium
|
||||
67 Ho Holmium
|
||||
68 Er Erbium
|
||||
69 Tm Thulium
|
||||
70 Yb Ytterbium
|
||||
71 Lu Lutetium
|
||||
72 Hf Hafnium
|
||||
73 Ta Tantalum
|
||||
74 W Tungsten
|
||||
75 Re Rhenium
|
||||
76 Os Osmium
|
||||
77 Ir Iridium
|
||||
78 Pt Platinum
|
||||
79 Au Gold
|
||||
80 Hg Mercury
|
||||
81 Tl Thallium
|
||||
82 Pb Lead
|
||||
83 Bi Bismuth
|
||||
84 Po Polonium
|
||||
85 At Astatine
|
||||
86 Rn Radon
|
||||
87 Fr Francium
|
||||
88 Ra Radium
|
||||
89 Ac Actinium
|
||||
90 Th Thorium
|
||||
91 Pa Protactinium
|
||||
92 U Uranium
|
||||
93 Np Neptunium
|
||||
94 Pu Plutonium
|
||||
95 Am Americium
|
||||
96 Cm Curium
|
||||
97 Bk Berkelium
|
||||
98 Cf Californium
|
||||
99 Es Einsteinium
|
||||
100 Fm Fermium
|
||||
101 Md Mendelevium
|
||||
102 No Nobelium
|
||||
103 Lr Lawrencium
|
||||
104 Rf Rutherfordium
|
||||
105 Db Dubnium
|
||||
106 Sg Seaborgium
|
||||
107 Bh Bohrium
|
||||
108 Hs Hassium
|
||||
109 Mt Meitnerium
|
||||
110 Ds Darmstadtium
|
||||
111 Rg Roentgenium
|
||||
112 Cn Copernicium
|
||||
113 Uut Ununtrium
|
||||
114 Fl Flerovium
|
||||
115 Uup Ununpentium
|
||||
116 Lv Livermorium
|
||||
117 Uus Ununseptium
|
||||
118 Uuo Ununoctium
|
60
ocaml/.gitignore
vendored
60
ocaml/.gitignore
vendored
@ -1,60 +0,0 @@
|
||||
_build
|
||||
ezfio.ml
|
||||
.gitignore
|
||||
Git.ml
|
||||
Input_auto_generated.ml
|
||||
Input_determinants.ml
|
||||
Input_hartree_fock.ml
|
||||
Input_integrals_bielec.ml
|
||||
Input_perturbation.ml
|
||||
Input_properties.ml
|
||||
Input_pseudo.ml
|
||||
qp_basis_clean
|
||||
qp_basis_clean.native
|
||||
qp_create_ezfio_from_xyz
|
||||
qp_create_ezfio_from_xyz.native
|
||||
qp_edit
|
||||
qp_edit.ml
|
||||
qp_edit.native
|
||||
qp_print
|
||||
qp_print_basis
|
||||
qp_print_basis.native
|
||||
qp_print.native
|
||||
qp_run
|
||||
qp_run.native
|
||||
qp_set_ddci
|
||||
qp_set_ddci.native
|
||||
qp_set_mo_class
|
||||
qp_set_mo_class.native
|
||||
qptypes_generator.byte
|
||||
Qptypes.ml
|
||||
test_atom
|
||||
test_atom.byte
|
||||
test_basis
|
||||
test_basis.byte
|
||||
test_bitlist
|
||||
test_bitlist.byte
|
||||
test_determinants
|
||||
test_determinants.byte
|
||||
test_elements
|
||||
test_elements.byte
|
||||
test_excitation
|
||||
test_excitation.byte
|
||||
test_gto
|
||||
test_gto.byte
|
||||
test_message
|
||||
test_message.byte
|
||||
test_mo_label
|
||||
test_mo_label.byte
|
||||
test_molecule
|
||||
test_molecule.byte
|
||||
test_point3d
|
||||
test_point3d.byte
|
||||
test_pseudo
|
||||
test_pseudo.byte
|
||||
test_queuing_system
|
||||
test_queuing_system.byte
|
||||
test_symmetry
|
||||
test_symmetry.byte
|
||||
test_task_server
|
||||
test_task_server.byte
|
@ -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
|
||||
|
||||
|
@ -1,5 +1,5 @@
|
||||
open Qptypes;;
|
||||
open Core.Std;;
|
||||
open Qptypes
|
||||
open Core.Std
|
||||
|
||||
(*
|
||||
Type for bits strings
|
||||
@ -19,39 +19,50 @@ let to_string b =
|
||||
in do_work new_accu tail
|
||||
in
|
||||
do_work "" b
|
||||
;;
|
||||
|
||||
|
||||
let of_string ?(zero='0') ?(one='1') s =
|
||||
String.to_list s
|
||||
|> List.rev_map ~f:( fun c ->
|
||||
if (c = zero) then Bit.Zero
|
||||
else if (c = one) then Bit.One
|
||||
else (failwith ("Error in string "^s) ) )
|
||||
;;
|
||||
else (failwith ("Error in bitstring ") ) )
|
||||
|
||||
let of_string_mp s =
|
||||
String.to_list s
|
||||
|> List.rev_map ~f:(function
|
||||
| '-' -> Bit.Zero
|
||||
| '+' -> Bit.One
|
||||
| _ -> failwith ("Error in bitstring ") )
|
||||
|
||||
|
||||
(* Create a bit list from an int64 *)
|
||||
let of_int64 i =
|
||||
let rec do_work = function
|
||||
| 0L -> [ Bit.Zero ]
|
||||
| 1L -> [ Bit.One ]
|
||||
| i -> let b =
|
||||
match (Int64.bit_and i 1L ) with
|
||||
| 0L -> Bit.Zero
|
||||
| 1L -> Bit.One
|
||||
| _ -> raise (Failure "i land 1 not in (0,1)")
|
||||
in b:: ( do_work (Int64.shift_right_logical i 1) )
|
||||
|
||||
let rec do_work accu = function
|
||||
| 0L -> Bit.Zero :: accu |> List.rev
|
||||
| 1L -> Bit.One :: accu |> List.rev
|
||||
| i ->
|
||||
let b =
|
||||
match (Int64.bit_and i 1L ) with
|
||||
| 0L -> Bit.Zero
|
||||
| 1L -> Bit.One
|
||||
| _ -> raise (Failure "i land 1 not in (0,1)")
|
||||
in
|
||||
do_work (b :: accu) (Int64.shift_right_logical i 1)
|
||||
in
|
||||
|
||||
let adjust_length result =
|
||||
let rec do_work accu = function
|
||||
| 64 -> accu
|
||||
| 64 -> List.rev accu
|
||||
| i when i>64 -> raise (Failure "Error in of_int64 > 64")
|
||||
| i when i<0 -> raise (Failure "Error in of_int64 < 0")
|
||||
| i -> do_work (accu@[Bit.Zero]) (i+1)
|
||||
| i -> do_work (Bit.Zero :: accu) (i+1)
|
||||
in
|
||||
do_work result (List.length result)
|
||||
do_work (List.rev result) (List.length result)
|
||||
in
|
||||
adjust_length (do_work i)
|
||||
;;
|
||||
adjust_length (do_work [] i)
|
||||
|
||||
|
||||
(* Create an int64 from a bit list *)
|
||||
let to_int64 l =
|
||||
@ -61,26 +72,32 @@ let to_int64 l =
|
||||
| Bit.Zero::tail -> do_work Int64.(shift_left accu 1) tail
|
||||
| Bit.One::tail -> do_work Int64.(bit_or one (shift_left accu 1)) tail
|
||||
in do_work Int64.zero (List.rev l)
|
||||
;;
|
||||
|
||||
|
||||
(* Create a bit list from a list of int64 *)
|
||||
let of_int64_list l =
|
||||
List.map ~f:of_int64 l
|
||||
|> List.concat
|
||||
;;
|
||||
|
||||
(* Create a bit list from an array of int64 *)
|
||||
let of_int64_array l =
|
||||
Array.map ~f:of_int64 l
|
||||
|> Array.to_list
|
||||
|> List.concat
|
||||
|
||||
|
||||
(* Compute n_int *)
|
||||
let n_int_of_mo_tot_num mo_tot_num =
|
||||
let bit_kind_size = Bit_kind_size.to_int (Lazy.force Qpackage.bit_kind_size) in
|
||||
N_int_number.of_int ( (mo_tot_num-1)/bit_kind_size + 1 )
|
||||
;;
|
||||
|
||||
|
||||
(* Create a zero bit list *)
|
||||
let zero n_int =
|
||||
let n_int = N_int_number.to_int n_int in
|
||||
let a = Array.init n_int (fun i-> 0L) in
|
||||
of_int64_list ( Array.to_list a )
|
||||
;;
|
||||
|
||||
|
||||
(* Create an int64 list from a bit list *)
|
||||
let to_int64_list l =
|
||||
@ -100,7 +117,11 @@ let to_int64_list l =
|
||||
let l = do_work [] [] 1 l
|
||||
in
|
||||
List.rev_map ~f:to_int64 l
|
||||
;;
|
||||
|
||||
(* Create an array of int64 from a bit list *)
|
||||
let to_int64_array l =
|
||||
to_int64_list l
|
||||
|> Array.of_list
|
||||
|
||||
(* Create a bit list from a list of MO indices *)
|
||||
let of_mo_number_list n_int l =
|
||||
@ -109,7 +130,7 @@ let of_mo_number_list n_int l =
|
||||
let a = Array.create length (Bit.Zero) in
|
||||
List.iter ~f:(fun i-> a.((MO_number.to_int i)-1) <- Bit.One) l;
|
||||
Array.to_list a
|
||||
;;
|
||||
|
||||
|
||||
let to_mo_number_list l =
|
||||
let a = Array.of_list l in
|
||||
@ -127,7 +148,7 @@ let to_mo_number_list l =
|
||||
end
|
||||
in
|
||||
do_work [] (List.length l)
|
||||
;;
|
||||
|
||||
|
||||
|
||||
|
||||
@ -142,7 +163,7 @@ let logical_operator2 op a b =
|
||||
in do_work_binary (newbit::result) ta tb
|
||||
in
|
||||
List.rev (do_work_binary [] a b)
|
||||
;;
|
||||
|
||||
|
||||
let logical_operator1 op b =
|
||||
let rec do_work_unary result b =
|
||||
@ -153,20 +174,19 @@ let logical_operator1 op b =
|
||||
in do_work_unary (newbit::result) tb
|
||||
in
|
||||
List.rev (do_work_unary [] b)
|
||||
;;
|
||||
|
||||
let and_operator a b = logical_operator2 Bit.and_operator a b;;
|
||||
let xor_operator a b = logical_operator2 Bit.xor_operator a b;;
|
||||
let or_operator a b = logical_operator2 Bit.or_operator a b;;
|
||||
let not_operator b = logical_operator1 Bit.not_operator b ;;
|
||||
|
||||
let and_operator a b = logical_operator2 Bit.and_operator a b
|
||||
let xor_operator a b = logical_operator2 Bit.xor_operator a b
|
||||
let or_operator a b = logical_operator2 Bit.or_operator a b
|
||||
let not_operator b = logical_operator1 Bit.not_operator b
|
||||
|
||||
|
||||
let popcnt b =
|
||||
let rec popcnt accu = function
|
||||
| [] -> accu
|
||||
| Bit.One::rest -> popcnt (accu+1) rest
|
||||
| Bit.Zero::rest -> popcnt (accu) rest
|
||||
in popcnt 0 b
|
||||
;;
|
||||
List.fold_left b ~init:0 ~f:(fun accu -> function
|
||||
| Bit.One -> accu+1
|
||||
| Bit.Zero -> accu
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
@ -6,16 +6,21 @@ val zero : Qptypes.N_int_number.t -> t
|
||||
(** Convert to a string for printing *)
|
||||
val to_string : t -> string
|
||||
|
||||
(** Convert to a string for printing *)
|
||||
(** Read from a string *)
|
||||
val of_string : ?zero:char -> ?one:char -> string -> t
|
||||
|
||||
(** Read from a string with the ++-- notation *)
|
||||
val of_string_mp : string -> t
|
||||
|
||||
(** int64 conversion functions *)
|
||||
|
||||
val of_int64 : int64 -> t
|
||||
val to_int64 : t -> int64
|
||||
|
||||
val of_int64_list : int64 list -> t
|
||||
val to_int64_list : t -> int64 list
|
||||
val of_int64_list : int64 list -> t
|
||||
val of_int64_array : int64 array -> t
|
||||
val to_int64_list : t -> int64 list
|
||||
val to_int64_array : t -> int64 array
|
||||
|
||||
(** Get the number of needed int64 elements to encode the bit list *)
|
||||
val n_int_of_mo_tot_num : int -> Qptypes.N_int_number.t
|
||||
|
@ -4,33 +4,37 @@ open Qptypes;;
|
||||
type t = int64 array with sexp
|
||||
|
||||
let to_int64_array (x:t) = (x:int64 array)
|
||||
;;
|
||||
|
||||
|
||||
let to_alpha_beta x =
|
||||
let x = to_int64_array x in
|
||||
let n_int = (Array.length x)/2 in
|
||||
( Array.init n_int ~f:(fun i -> x.(i)) ,
|
||||
Array.init n_int ~f:(fun i -> x.(i+n_int)) )
|
||||
;;
|
||||
|
||||
|
||||
let to_bitlist_couple x =
|
||||
let (xa,xb) = to_alpha_beta x in
|
||||
let xa = to_int64_array xa
|
||||
|> Array.to_list
|
||||
|> Bitlist.of_int64_list
|
||||
and xb = to_int64_array xb
|
||||
|> Array.to_list
|
||||
|> Bitlist.of_int64_list
|
||||
let xa =
|
||||
to_int64_array xa
|
||||
|> Bitlist.of_int64_array
|
||||
and xb =
|
||||
to_int64_array xb
|
||||
|> Bitlist.of_int64_array
|
||||
in (xa,xb)
|
||||
;;
|
||||
|
||||
|
||||
let bitlist_to_string ~mo_tot_num x =
|
||||
List.map x ~f:(fun i -> match i with
|
||||
| Bit.Zero -> "-"
|
||||
| Bit.One -> "+" )
|
||||
let len =
|
||||
MO_number.to_int mo_tot_num
|
||||
in
|
||||
List.map x ~f:(function
|
||||
| Bit.Zero -> "-"
|
||||
| Bit.One -> "+"
|
||||
)
|
||||
|> String.concat
|
||||
|> String.sub ~pos:0 ~len:(MO_number.to_int mo_tot_num)
|
||||
;;
|
||||
|> String.sub ~pos:0 ~len
|
||||
|
||||
|
||||
|
||||
let of_int64_array ~n_int ~alpha ~beta x =
|
||||
@ -54,20 +58,25 @@ let of_int64_array ~n_int ~alpha ~beta x =
|
||||
%s" beta (bitlist_to_string ~mo_tot_num:mo_tot_num b) )
|
||||
end;
|
||||
x
|
||||
;;
|
||||
|
||||
let of_bitlist_couple ~alpha ~beta (xa,xb) =
|
||||
let ba = Bitlist.to_int64_list xa in
|
||||
let bb = Bitlist.to_int64_list xb in
|
||||
let n_int = Bitlist.n_int_of_mo_tot_num (List.length xa) in
|
||||
of_int64_array ~n_int:n_int ~alpha:alpha ~beta:beta (Array.of_list (ba@bb))
|
||||
;;
|
||||
let of_int64_array_no_check x = x
|
||||
|
||||
let of_bitlist_couple ?n_int ~alpha ~beta (xa,xb) =
|
||||
let ba, bb =
|
||||
Bitlist.to_int64_array xa ,
|
||||
Bitlist.to_int64_array xb
|
||||
and n_int =
|
||||
match n_int with
|
||||
| Some x -> x
|
||||
| None -> Bitlist.n_int_of_mo_tot_num (List.length xa)
|
||||
in
|
||||
of_int64_array ~n_int ~alpha ~beta (Array.concat [ba;bb])
|
||||
|
||||
|
||||
let to_string ~mo_tot_num x =
|
||||
let (xa,xb) = to_bitlist_couple x in
|
||||
[ bitlist_to_string ~mo_tot_num:mo_tot_num xa ;
|
||||
bitlist_to_string ~mo_tot_num:mo_tot_num xb ]
|
||||
|> String.concat ~sep:"\n"
|
||||
;;
|
||||
[ " " ; bitlist_to_string ~mo_tot_num xa ; "\n" ;
|
||||
" " ; bitlist_to_string ~mo_tot_num xb ]
|
||||
|> String.concat
|
||||
|
||||
|
||||
|
@ -24,7 +24,8 @@ val to_alpha_beta : t -> (int64 array)*(int64 array)
|
||||
val to_bitlist_couple : t -> Bitlist.t * Bitlist.t
|
||||
|
||||
(** Create from a bit list *)
|
||||
val of_bitlist_couple : alpha:Qptypes.Elec_alpha_number.t ->
|
||||
val of_bitlist_couple : ?n_int:Qptypes.N_int_number.t ->
|
||||
alpha:Qptypes.Elec_alpha_number.t ->
|
||||
beta:Qptypes.Elec_beta_number.t ->
|
||||
Bitlist.t * Bitlist.t -> t
|
||||
|
||||
|
@ -11,11 +11,13 @@ module Determinants_by_hand : sig
|
||||
psi_coef : Det_coef.t array;
|
||||
psi_det : Determinant.t array;
|
||||
} with sexp
|
||||
val read : unit -> t option
|
||||
val read : unit -> t
|
||||
val read_maybe : unit -> t option
|
||||
val write : t -> unit
|
||||
val to_string : t -> string
|
||||
val to_rst : t -> Rst_string.t
|
||||
val of_rst : Rst_string.t -> t option
|
||||
val read_n_int : unit -> N_int_number.t
|
||||
end = struct
|
||||
type t =
|
||||
{ n_int : N_int_number.t;
|
||||
@ -29,6 +31,8 @@ end = struct
|
||||
|
||||
let get_default = Qpackage.get_ezfio_default "determinants";;
|
||||
|
||||
let n_det_read_max = 10_000 ;;
|
||||
|
||||
let read_n_int () =
|
||||
if not (Ezfio.has_determinants_n_int()) then
|
||||
Ezfio.get_mo_basis_mo_tot_num ()
|
||||
@ -207,14 +211,24 @@ end = struct
|
||||
|
||||
let read () =
|
||||
if (Ezfio.has_mo_basis_mo_tot_num ()) then
|
||||
Some
|
||||
{ n_int = read_n_int () ;
|
||||
bit_kind = read_bit_kind () ;
|
||||
n_det = read_n_det () ;
|
||||
expected_s2 = read_expected_s2 () ;
|
||||
psi_coef = read_psi_coef () ;
|
||||
psi_det = read_psi_det () ;
|
||||
}
|
||||
{ n_int = read_n_int () ;
|
||||
bit_kind = read_bit_kind () ;
|
||||
n_det = read_n_det () ;
|
||||
expected_s2 = read_expected_s2 () ;
|
||||
psi_coef = read_psi_coef () ;
|
||||
psi_det = read_psi_det () ;
|
||||
}
|
||||
else
|
||||
failwith "No molecular orbitals, so no determinants"
|
||||
;;
|
||||
|
||||
let read_maybe () =
|
||||
let n_det =
|
||||
read_n_det ()
|
||||
in
|
||||
if ( (Det_number.to_int n_det) < n_det_read_max ) then
|
||||
try Some (read ()) with
|
||||
| Failure _ -> None
|
||||
else
|
||||
None
|
||||
;;
|
||||
@ -236,11 +250,16 @@ end = struct
|
||||
|
||||
|
||||
let to_rst b =
|
||||
let mo_tot_num = Ezfio.get_mo_basis_mo_tot_num () in
|
||||
let mo_tot_num = MO_number.of_int mo_tot_num ~max:mo_tot_num in
|
||||
let max =
|
||||
Ezfio.get_mo_basis_mo_tot_num ()
|
||||
in
|
||||
let mo_tot_num =
|
||||
MO_number.of_int ~max max
|
||||
in
|
||||
let det_text =
|
||||
let nstates =
|
||||
read_n_states () |> States_number.to_int
|
||||
read_n_states ()
|
||||
|> States_number.to_int
|
||||
and ndet =
|
||||
Det_number.to_int b.n_det
|
||||
in
|
||||
@ -393,29 +412,47 @@ psi_det = %s
|
||||
in
|
||||
let rec read_dets accu = function
|
||||
| [] -> List.rev accu
|
||||
| ""::c::alpha::beta::tail ->
|
||||
| ""::_::alpha::beta::tail ->
|
||||
begin
|
||||
let alpha = String.rev alpha |> Bitlist.of_string ~zero:'-' ~one:'+'
|
||||
and beta = String.rev beta |> Bitlist.of_string ~zero:'-' ~one:'+'
|
||||
in
|
||||
let newdet = Determinant.of_bitlist_couple
|
||||
~alpha:n_alpha ~beta:n_beta (alpha,beta)
|
||||
|> Determinant.sexp_of_t |> Sexplib.Sexp.to_string
|
||||
let newdet =
|
||||
(Bitlist.of_string ~zero:'-' ~one:'+' alpha ,
|
||||
Bitlist.of_string ~zero:'-' ~one:'+' beta)
|
||||
|> Determinant.of_bitlist_couple ~alpha:n_alpha ~beta:n_beta
|
||||
|> Determinant.sexp_of_t
|
||||
|> Sexplib.Sexp.to_string
|
||||
in
|
||||
read_dets (newdet::accu) tail
|
||||
end
|
||||
| _::tail -> read_dets accu tail
|
||||
in
|
||||
let a = read_dets [] dets
|
||||
|> String.concat
|
||||
let dets =
|
||||
List.map ~f:String.rev dets
|
||||
in
|
||||
let sze =
|
||||
List.fold ~init:0 ~f:(fun accu x -> accu + (String.length x)) dets
|
||||
in
|
||||
let control =
|
||||
Gc.get ()
|
||||
in
|
||||
Gc.tune ~minor_heap_size:(sze) ~space_overhead:(sze/10)
|
||||
~max_overhead:100000 ~major_heap_increment:(sze/10) ();
|
||||
let a =
|
||||
read_dets [] dets
|
||||
|> String.concat
|
||||
in
|
||||
Gc.set control;
|
||||
"(psi_det ("^a^"))"
|
||||
in
|
||||
|
||||
let bitkind = Printf.sprintf "(bit_kind %d)" (Lazy.force Qpackage.bit_kind
|
||||
|
||||
let bitkind =
|
||||
Printf.sprintf "(bit_kind %d)" (Lazy.force Qpackage.bit_kind
|
||||
|> Bit_kind.to_int)
|
||||
and n_int = Printf.sprintf "(n_int %d)" (N_int_number.get_max ()) in
|
||||
let s = String.concat [ header ; bitkind ; n_int ; psi_coef ; psi_det]
|
||||
and n_int =
|
||||
Printf.sprintf "(n_int %d)" (N_int_number.get_max ())
|
||||
in
|
||||
let s =
|
||||
String.concat [ header ; bitkind ; n_int ; psi_coef ; psi_det]
|
||||
in
|
||||
|
||||
Generic_input_of_rst.evaluate_sexp t_of_sexp s
|
||||
|
401
ocaml/Message.ml
401
ocaml/Message.ml
@ -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
108
ocaml/Progress_bar.ml
Normal 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
|
||||
|
||||
|
||||
|
@ -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
|
||||
|
@ -1,47 +1,60 @@
|
||||
open Core.Std
|
||||
open Qptypes
|
||||
|
||||
(**
|
||||
The tasks server listens on a REQ socket and accepts the following commands:
|
||||
|
||||
* "new_job %s %s %s" state push_address_tcp push_address_inproc -> "OK"
|
||||
-> "OK"
|
||||
type t =
|
||||
{
|
||||
queue : Queuing_system.t ;
|
||||
state : Message.State.t option ;
|
||||
address_tcp : Address.Tcp.t option ;
|
||||
address_inproc : Address.Inproc.t option ;
|
||||
psi : Message.Psi.t option;
|
||||
progress_bar : Progress_bar.t option ;
|
||||
running : bool;
|
||||
}
|
||||
|
||||
* "connect %s" ["tcp"|"inproc"]
|
||||
-> "%d %s %s" id state push_address
|
||||
|
||||
* "disconnect %d" id
|
||||
-> "OK"
|
||||
|
||||
* "get_task %d %s" id state
|
||||
-> "%d %s" task_id task
|
||||
let debug_env =
|
||||
match Sys.getenv "QP_TASK_DEBUG" with
|
||||
| Some x -> x <> ""
|
||||
| None -> false
|
||||
|
||||
* "task_done %d task_id %s" id state
|
||||
-> "%d %s" task_id task
|
||||
|
||||
*)
|
||||
let debug str =
|
||||
if debug_env then
|
||||
Printf.printf "TASK : %s%!" str
|
||||
|
||||
|
||||
|
||||
let zmq_context =
|
||||
ZMQ.Context.create ()
|
||||
|
||||
|
||||
let bind_socket ~socket_type ~socket ~address =
|
||||
try
|
||||
ZMQ.Socket.bind socket address
|
||||
with
|
||||
| Unix.Unix_error (_, message, f) ->
|
||||
failwith @@ Printf.sprintf
|
||||
"\n%s\nUnable to bind the %s socket :\n %s\n%s"
|
||||
f socket_type address message
|
||||
| other_exception -> raise other_exception
|
||||
let rec loop = function
|
||||
| 0 -> failwith @@ Printf.sprintf
|
||||
"Unable to bind the %s socket : %s "
|
||||
socket_type address
|
||||
| -1 -> ()
|
||||
| i ->
|
||||
try
|
||||
ZMQ.Socket.bind socket address;
|
||||
loop (-1)
|
||||
with
|
||||
| Unix.Unix_error _ -> (Time.pause @@ Time.Span.of_float 1. ; loop (i-1) )
|
||||
| other_exception -> raise other_exception
|
||||
in loop 10
|
||||
|
||||
|
||||
(** Name of the host on which the server runs *)
|
||||
let hostname = lazy (
|
||||
try
|
||||
Unix.gethostname ()
|
||||
with
|
||||
| _ -> "localhost"
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
(** IP address *)
|
||||
let ip_address = lazy (
|
||||
match Sys.getenv "QP_NIC" with
|
||||
| None ->
|
||||
@ -67,271 +80,540 @@ let ip_address = lazy (
|
||||
)
|
||||
|
||||
|
||||
let reply_ok rep_socket =
|
||||
Message.Ok_msg.create ()
|
||||
|> Message.Ok_msg.to_string
|
||||
|> ZMQ.Socket.send rep_socket
|
||||
|
||||
let reply_wrong_state rep_socket =
|
||||
Printf.printf "WRONG STATE\n%!";
|
||||
Message.Error_msg.create "Wrong state"
|
||||
|> Message.Error_msg.to_string
|
||||
|> ZMQ.Socket.send rep_socket
|
||||
|
||||
|
||||
|
||||
let stop ~port =
|
||||
let zmq_context =
|
||||
ZMQ.Context.create ()
|
||||
in
|
||||
let req_socket =
|
||||
ZMQ.Socket.create zmq_context ZMQ.Socket.req
|
||||
and address =
|
||||
Printf.sprintf "tcp://%s:%d" (Lazy.force ip_address) port
|
||||
in
|
||||
ZMQ.Socket.connect req_socket address;
|
||||
debug "STOP";
|
||||
let req_socket =
|
||||
ZMQ.Socket.create zmq_context ZMQ.Socket.req
|
||||
and address =
|
||||
Printf.sprintf "tcp://%s:%d" (Lazy.force ip_address) port
|
||||
in
|
||||
ZMQ.Socket.set_linger_period req_socket 1_000_000;
|
||||
ZMQ.Socket.connect req_socket address;
|
||||
|
||||
Message.Terminate (Message.Terminate_msg.create ())
|
||||
|> Message.to_string
|
||||
|> ZMQ.Socket.send ~block:false req_socket ;
|
||||
Message.Terminate (Message.Terminate_msg.create ())
|
||||
|> Message.to_string
|
||||
|> ZMQ.Socket.send req_socket ;
|
||||
|
||||
let msg =
|
||||
ZMQ.Socket.recv req_socket
|
||||
|> Message.of_string
|
||||
in
|
||||
let () =
|
||||
match msg with
|
||||
| Message.Ok _ -> ()
|
||||
| _ -> failwith "Problem in termination"
|
||||
in
|
||||
ZMQ.Socket.set_linger_period req_socket 1000;
|
||||
ZMQ.Socket.close req_socket
|
||||
let msg =
|
||||
ZMQ.Socket.recv req_socket
|
||||
|> Message.of_string
|
||||
in
|
||||
let () =
|
||||
match msg with
|
||||
| Message.Ok _ -> ()
|
||||
| _ -> failwith "Problem in termination"
|
||||
in
|
||||
ZMQ.Socket.set_linger_period req_socket 1_000;
|
||||
ZMQ.Socket.close req_socket
|
||||
|
||||
|
||||
(** Run the task server *)
|
||||
let run ~port =
|
||||
let new_job msg program_state rep_socket =
|
||||
|
||||
let zmq_context =
|
||||
ZMQ.Context.create ()
|
||||
in
|
||||
|
||||
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
|
||||
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 =
|
||||
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 =
|
||||
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 ->
|
||||
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)
|
||||
reply_ok rep_socket;
|
||||
result
|
||||
in
|
||||
|
||||
done;
|
||||
ZMQ.Socket.set_linger_period rep_socket 1000;
|
||||
ZMQ.Socket.close rep_socket
|
||||
match program_state.state with
|
||||
| None -> assert false
|
||||
| Some state' ->
|
||||
begin
|
||||
if (state = state') then
|
||||
success ()
|
||||
else
|
||||
failure ()
|
||||
end
|
||||
|
||||
|
||||
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;
|
||||
|
||||
|
||||
(*
|
||||
let () =
|
||||
Printf.printf "export QP_RUN_ADDRESS=tcp://%s:%d\n%!" (Lazy.force ip_address) (Lazy.force port)
|
||||
*)
|
||||
|
||||
|
||||
|
@ -1,2 +1,3 @@
|
||||
true: package(core,sexplib.syntax,cryptokit,ZMQ)
|
||||
true: thread
|
||||
false: profile
|
||||
|
308
ocaml/qp_edit.ml
308
ocaml/qp_edit.ml
@ -1,308 +0,0 @@
|
||||
open Qputils;;
|
||||
open Qptypes;;
|
||||
open Core.Std;;
|
||||
|
||||
(** Interactive editing of the input.
|
||||
|
||||
WARNING
|
||||
This file is autogenerad by
|
||||
`${QP_ROOT}/script/ezfio_interface/ei_handler.py`
|
||||
*)
|
||||
|
||||
|
||||
(** Keywords used to define input sections *)
|
||||
type keyword =
|
||||
| Ao_basis
|
||||
| Determinants_by_hand
|
||||
| Electrons
|
||||
| Mo_basis
|
||||
| Nuclei
|
||||
| Determinants
|
||||
| Integrals_bielec
|
||||
| Pseudo
|
||||
| Perturbation
|
||||
| Hartree_fock
|
||||
| Properties
|
||||
;;
|
||||
|
||||
|
||||
let keyword_to_string = function
|
||||
| Ao_basis -> "AO basis"
|
||||
| Determinants_by_hand -> "Determinants_by_hand"
|
||||
| Electrons -> "Electrons"
|
||||
| Mo_basis -> "MO basis"
|
||||
| Nuclei -> "Molecule"
|
||||
| Determinants -> "Determinants"
|
||||
| Integrals_bielec -> "Integrals_bielec"
|
||||
| Pseudo -> "Pseudo"
|
||||
| Perturbation -> "Perturbation"
|
||||
| Hartree_fock -> "Hartree_fock"
|
||||
| Properties -> "Properties"
|
||||
;;
|
||||
|
||||
|
||||
|
||||
(** Create the header of the temporary file *)
|
||||
let file_header filename =
|
||||
Printf.sprintf "
|
||||
==================================================================
|
||||
Quantum Package
|
||||
==================================================================
|
||||
|
||||
Editing file `%s`
|
||||
|
||||
" filename
|
||||
;;
|
||||
|
||||
|
||||
(** Creates the header of a section *)
|
||||
let make_header kw =
|
||||
let s = keyword_to_string kw in
|
||||
let l = String.length s in
|
||||
"\n\n"^s^"\n"^(String.init l ~f:(fun _ -> '='))^"\n\n"
|
||||
;;
|
||||
|
||||
|
||||
(** Returns the rst string of section [s] *)
|
||||
let get s =
|
||||
let header = (make_header s) in
|
||||
let f (read,to_rst) =
|
||||
match read () with
|
||||
| Some text -> header ^ (Rst_string.to_string (to_rst text))
|
||||
| None -> ""
|
||||
in
|
||||
let rst =
|
||||
try
|
||||
begin
|
||||
let open Input in
|
||||
match s with
|
||||
| Mo_basis ->
|
||||
f Mo_basis.(read, to_rst)
|
||||
| Electrons ->
|
||||
f Electrons.(read, to_rst)
|
||||
| Nuclei ->
|
||||
f Nuclei.(read, to_rst)
|
||||
| Ao_basis ->
|
||||
f Ao_basis.(read, to_rst)
|
||||
| Determinants_by_hand ->
|
||||
f Determinants_by_hand.(read, to_rst)
|
||||
| Determinants ->
|
||||
f Determinants.(read, to_rst)
|
||||
| Integrals_bielec ->
|
||||
f Integrals_bielec.(read, to_rst)
|
||||
| Pseudo ->
|
||||
f Pseudo.(read, to_rst)
|
||||
| Perturbation ->
|
||||
f Perturbation.(read, to_rst)
|
||||
| Hartree_fock ->
|
||||
f Hartree_fock.(read, to_rst)
|
||||
| Properties ->
|
||||
f Properties.(read, to_rst)
|
||||
end
|
||||
with
|
||||
| Sys_error msg -> (Printf.eprintf "Info: %s\n%!" msg ; "")
|
||||
in
|
||||
rst
|
||||
;;
|
||||
|
||||
|
||||
(** Applies the changes from the string [str] corresponding to section [s] *)
|
||||
let set str s =
|
||||
let header = (make_header s) in
|
||||
match String.substr_index ~pos:0 ~pattern:header str with
|
||||
| None -> ()
|
||||
| Some idx ->
|
||||
begin
|
||||
let index_begin = idx + (String.length header) in
|
||||
let index_end =
|
||||
match ( String.substr_index ~pos:(index_begin+(String.length header)+1)
|
||||
~pattern:"==" str) with
|
||||
| Some i -> i
|
||||
| None -> String.length str
|
||||
in
|
||||
let l = index_end - index_begin in
|
||||
let str = String.sub ~pos:index_begin ~len:l str
|
||||
|> Rst_string.of_string
|
||||
in
|
||||
let write (of_rst,w) s =
|
||||
try
|
||||
match of_rst str with
|
||||
| Some data -> w data
|
||||
| None -> ()
|
||||
with
|
||||
| _ -> (Printf.eprintf "Info: Read error in %s\n%!"
|
||||
(keyword_to_string s); ignore (of_rst str) )
|
||||
in
|
||||
let open Input in
|
||||
match s with
|
||||
| Determinants -> write Determinants.(of_rst, write) s
|
||||
| Integrals_bielec -> write Integrals_bielec.(of_rst, write) s
|
||||
| Pseudo -> write Pseudo.(of_rst, write) s
|
||||
| Perturbation -> write Perturbation.(of_rst, write) s
|
||||
| Hartree_fock -> write Hartree_fock.(of_rst, write) s
|
||||
| Properties -> write Properties.(of_rst, write) s
|
||||
| Electrons -> write Electrons.(of_rst, write) s
|
||||
| Determinants_by_hand -> write Determinants_by_hand.(of_rst, write) s
|
||||
| Nuclei -> write Nuclei.(of_rst, write) s
|
||||
| Ao_basis -> () (* TODO *)
|
||||
| Mo_basis -> () (* TODO *)
|
||||
end
|
||||
;;
|
||||
|
||||
|
||||
(** Creates the temporary file for interactive editing *)
|
||||
let create_temp_file ezfio_filename fields =
|
||||
let temp_filename = Filename.temp_file "qp_edit_" ".rst" in
|
||||
begin
|
||||
Out_channel.with_file temp_filename ~f:(fun out_channel ->
|
||||
(file_header ezfio_filename) :: (List.map ~f:get fields)
|
||||
|> String.concat ~sep:"\n"
|
||||
|> Out_channel.output_string out_channel
|
||||
)
|
||||
end
|
||||
; temp_filename
|
||||
;;
|
||||
|
||||
|
||||
|
||||
let run check_only ezfio_filename =
|
||||
|
||||
(* Open EZFIO *)
|
||||
if (not (Sys.file_exists_exn ezfio_filename)) then
|
||||
failwith (ezfio_filename^" does not exists");
|
||||
|
||||
Ezfio.set_file ezfio_filename;
|
||||
|
||||
(*
|
||||
let output = (file_header ezfio_filename) :: (
|
||||
List.map ~f:get [
|
||||
Ao_basis ;
|
||||
Mo_basis ;
|
||||
])
|
||||
in
|
||||
String.concat output
|
||||
|> print_string
|
||||
*)
|
||||
|
||||
let tasks = [
|
||||
Nuclei ;
|
||||
Ao_basis;
|
||||
Electrons ;
|
||||
Determinants ;
|
||||
Integrals_bielec ;
|
||||
Pseudo ;
|
||||
Perturbation ;
|
||||
Hartree_fock ;
|
||||
Properties ;
|
||||
Mo_basis;
|
||||
Determinants_by_hand ;
|
||||
]
|
||||
in
|
||||
|
||||
(* Create the temp file *)
|
||||
let temp_filename = create_temp_file ezfio_filename tasks in
|
||||
|
||||
(* Open the temp file with external editor *)
|
||||
let editor =
|
||||
match Sys.getenv "EDITOR" with
|
||||
| Some editor -> editor
|
||||
| None -> "vi"
|
||||
in
|
||||
|
||||
match check_only with
|
||||
| true -> ()
|
||||
| false ->
|
||||
Printf.sprintf "%s %s" editor temp_filename
|
||||
|> Sys.command_exn
|
||||
;
|
||||
|
||||
(* Re-read the temp file *)
|
||||
let temp_string =
|
||||
In_channel.with_file temp_filename ~f:(fun in_channel ->
|
||||
In_channel.input_all in_channel)
|
||||
in
|
||||
List.iter ~f:(fun x -> set temp_string x) tasks;
|
||||
|
||||
(* Remove temp_file *)
|
||||
Sys.remove temp_filename;
|
||||
;;
|
||||
|
||||
|
||||
(** Create a backup file in case of an exception *)
|
||||
let create_backup ezfio_filename =
|
||||
Printf.sprintf "
|
||||
rm -f %s/backup.tgz ;
|
||||
tar -zcf .backup.tgz %s && mv .backup.tgz %s/backup.tgz
|
||||
"
|
||||
ezfio_filename ezfio_filename ezfio_filename
|
||||
|> Sys.command_exn
|
||||
;;
|
||||
|
||||
|
||||
(** Restore the backup file when an exception occuprs *)
|
||||
let restore_backup ezfio_filename =
|
||||
Printf.sprintf "tar -zxf %s/backup.tgz"
|
||||
ezfio_filename
|
||||
|> Sys.command_exn
|
||||
;;
|
||||
|
||||
|
||||
let spec =
|
||||
let open Command.Spec in
|
||||
empty
|
||||
+> flag "-c" no_arg
|
||||
~doc:"Checks the input data"
|
||||
(*
|
||||
+> flag "o" (optional string)
|
||||
~doc:"Prints output data"
|
||||
*)
|
||||
+> anon ("ezfio_file" %: string)
|
||||
;;
|
||||
|
||||
let command =
|
||||
Command.basic
|
||||
~summary: "Quantum Package command"
|
||||
~readme:(fun () ->
|
||||
"
|
||||
Edit input data
|
||||
")
|
||||
spec
|
||||
(* (fun i o ezfio_file () -> *)
|
||||
(*fun ezfio_file () ->
|
||||
try
|
||||
run ezfio_file
|
||||
with
|
||||
| _ msg -> print_string ("\n\nError\n\n"^msg^"\n\n")
|
||||
*)
|
||||
(fun c ezfio_file () ->
|
||||
try
|
||||
run c ezfio_file ;
|
||||
(* create_backup ezfio_file; *)
|
||||
with
|
||||
| Failure exc
|
||||
| Invalid_argument exc as e ->
|
||||
begin
|
||||
Printf.eprintf "=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n\n";
|
||||
Printf.eprintf "%s\n\n" exc;
|
||||
Printf.eprintf "=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n\n";
|
||||
(* restore_backup ezfio_file; *)
|
||||
raise e
|
||||
end
|
||||
| Assert_failure (file, line, ch) as e ->
|
||||
begin
|
||||
Printf.eprintf "=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n\n";
|
||||
Printf.eprintf "Assert error in file $QP_ROOT/ocaml/%s, line %d, character %d\n\n" file line ch;
|
||||
Printf.eprintf "=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n\n";
|
||||
(* restore_backup ezfio_file; *)
|
||||
raise e
|
||||
end
|
||||
)
|
||||
;;
|
||||
|
||||
let () =
|
||||
Command.run command;
|
||||
exit 0
|
||||
;;
|
||||
|
||||
|
||||
|
@ -35,7 +35,24 @@ let mo () =
|
||||
|> print_endline
|
||||
|
||||
|
||||
let psi_det () =
|
||||
let ezfio_filename =
|
||||
Sys.argv.(1)
|
||||
in
|
||||
if (not (Sys.file_exists_exn ezfio_filename)) then
|
||||
failwith "Error reading EZFIO file";
|
||||
Ezfio.set_file ezfio_filename;
|
||||
let psi_det =
|
||||
Input.Determinants_by_hand.read ()
|
||||
in
|
||||
Input.Determinants_by_hand.to_rst psi_det
|
||||
|> Rst_string.to_string
|
||||
|> print_endline
|
||||
|
||||
|
||||
|
||||
let () =
|
||||
basis ();
|
||||
mo ()
|
||||
mo ();
|
||||
psi_det ()
|
||||
|
||||
|
@ -1,21 +1,64 @@
|
||||
open Core.Std;;
|
||||
open Qputils;;
|
||||
open Core.Std
|
||||
open Qputils
|
||||
|
||||
(* Environment variables :
|
||||
|
||||
QP_PREFIX=gdb : to run gdb (or valgrind, or whatever)
|
||||
QP_TASK_DEBUG=1 : debug task server
|
||||
|
||||
*)
|
||||
|
||||
let print_list () =
|
||||
Lazy.force Qpackage.executables
|
||||
|> List.iter ~f:(fun (x,_) -> Printf.printf " * %s\n" x)
|
||||
;;
|
||||
|
||||
let run exe ezfio_file =
|
||||
let () =
|
||||
Random.self_init ()
|
||||
|
||||
let time_start = Time.now() in
|
||||
let run ~master exe ezfio_file =
|
||||
|
||||
|
||||
(** Check availability of the ports *)
|
||||
let port_number =
|
||||
let zmq_context =
|
||||
ZMQ.Context.create ()
|
||||
in
|
||||
let dummy_socket =
|
||||
ZMQ.Socket.create zmq_context ZMQ.Socket.rep
|
||||
in
|
||||
let rec try_new_port port_number =
|
||||
try
|
||||
List.iter [ 0;1;2;3;4 ] ~f:(fun i ->
|
||||
let address =
|
||||
Printf.sprintf "tcp://%s:%d" (Lazy.force TaskServer.ip_address) (port_number+i)
|
||||
in
|
||||
ZMQ.Socket.bind dummy_socket address;
|
||||
ZMQ.Socket.unbind dummy_socket address;
|
||||
);
|
||||
port_number
|
||||
with
|
||||
| Unix.Unix_error _ -> try_new_port (port_number+100)
|
||||
in
|
||||
let result =
|
||||
try_new_port 41279
|
||||
in
|
||||
ZMQ.Socket.close dummy_socket;
|
||||
result
|
||||
in
|
||||
let time_start =
|
||||
Time.now ()
|
||||
in
|
||||
|
||||
if (not (Sys.file_exists_exn ezfio_file)) then
|
||||
failwith ("EZFIO directory "^ezfio_file^" not found");
|
||||
|
||||
let executables = Lazy.force Qpackage.executables in
|
||||
if (not (List.exists ~f:(fun (x,_) -> x = exe) executables)) then
|
||||
failwith ("Executable "^exe^" not found");
|
||||
begin
|
||||
Printf.printf "\nPossible choices:\n";
|
||||
List.iter executables ~f:(fun (x,_) -> Printf.printf "* %s\n%!" x);
|
||||
failwith ("Executable "^exe^" not found")
|
||||
end;
|
||||
|
||||
Printf.printf "%s\n" (Time.to_string time_start);
|
||||
Printf.printf "===============\nQuantum Package\n===============\n\n";
|
||||
@ -26,16 +69,18 @@ let run exe ezfio_file =
|
||||
|
||||
|
||||
(** Check input *)
|
||||
match (Sys.command ("qp_edit -c "^ezfio_file)) with
|
||||
| 0 -> ()
|
||||
| i -> failwith "Error: Input inconsistent\n";
|
||||
;
|
||||
|
||||
begin
|
||||
match (Sys.command ("qp_edit -c "^ezfio_file)) with
|
||||
| 0 -> ()
|
||||
| i -> failwith "Error: Input inconsistent\n"
|
||||
end;
|
||||
begin
|
||||
match master with
|
||||
| Some address -> Unix.putenv ~key:"QP_RUN_ADDRESS_MASTER" ~data:address
|
||||
| None -> ()
|
||||
end;
|
||||
|
||||
(** Start task server *)
|
||||
let port_number =
|
||||
12345
|
||||
in
|
||||
let address =
|
||||
Printf.sprintf "tcp://%s:%d" (Lazy.force TaskServer.ip_address) port_number
|
||||
in
|
||||
@ -49,12 +94,16 @@ let run exe ezfio_file =
|
||||
Unix.putenv ~key:"QP_RUN_ADDRESS" ~data:address;
|
||||
|
||||
(** Run executable *)
|
||||
let exe =
|
||||
let prefix =
|
||||
match Sys.getenv "QP_PREFIX" with
|
||||
| Some x -> x^" "
|
||||
| None -> ""
|
||||
and exe =
|
||||
match (List.find ~f:(fun (x,_) -> x = exe) executables) with
|
||||
| Some (_,x) -> x^" "
|
||||
| None -> assert false
|
||||
| Some (_,x) -> x
|
||||
in
|
||||
match (Sys.command (exe^" "^ezfio_file)) with
|
||||
match (Sys.command (prefix^exe^ezfio_file)) with
|
||||
| 0 -> ()
|
||||
| i -> Printf.printf "Program exited with code %d.\n%!" i;
|
||||
;
|
||||
@ -64,16 +113,19 @@ let run exe ezfio_file =
|
||||
|
||||
let duration = Time.diff (Time.now()) time_start
|
||||
|> Core.Span.to_string in
|
||||
Printf.printf "Wall time : %s\n\n" duration;
|
||||
;;
|
||||
Printf.printf "Wall time : %s\n\n" duration
|
||||
|
||||
let spec =
|
||||
let open Command.Spec in
|
||||
empty
|
||||
+> flag "master" (optional string)
|
||||
~doc:("address Address of the master process")
|
||||
+> anon ("executable" %: string)
|
||||
+> anon ("ezfio_file" %: string)
|
||||
;;
|
||||
|
||||
|
||||
|
||||
let () =
|
||||
Command.basic
|
||||
~summary: "Quantum Package command"
|
||||
@ -85,10 +137,9 @@ Executes a Quantum Package binary file among these:\n\n"
|
||||
)
|
||||
)
|
||||
spec
|
||||
(fun exe ezfio_file () ->
|
||||
run exe ezfio_file
|
||||
(fun master exe ezfio_file () ->
|
||||
run ~master exe ezfio_file
|
||||
)
|
||||
|> Command.run ~version: Git.sha1 ~build_info: Git.message
|
||||
;;
|
||||
|
||||
|
||||
|
@ -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) ;
|
||||
|
||||
|
@ -1,7 +1,7 @@
|
||||
open Core.Std
|
||||
|
||||
let () =
|
||||
Message.of_string "new_job tcp://127.0.0.1 inproc://ao_ints:12345 ao_integrals"
|
||||
Message.of_string "new_job ao_integrals tcp://127.0.0.1 inproc://ao_ints:12345"
|
||||
|> Message.to_string
|
||||
|> print_endline
|
||||
;
|
||||
@ -37,7 +37,7 @@ let () =
|
||||
;
|
||||
|
||||
try
|
||||
Message.of_string "new_job inproc://ao_ints tcp://127.0.0.1:12345 ao_integrals"
|
||||
Message.of_string "new_job ao_integrals inproc://ao_ints tcp://127.0.0.1:12345"
|
||||
|> Message.to_string
|
||||
|> print_endline
|
||||
;
|
||||
|
@ -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__':
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
||||
|
@ -4,39 +4,47 @@ from generate_h_apply import *
|
||||
|
||||
s = H_apply("FCI")
|
||||
s.set_selection_pt2("epstein_nesbet_2x2")
|
||||
#s.unset_openmp()
|
||||
print s
|
||||
|
||||
s = H_apply("FCI_PT2")
|
||||
s = H_apply_zmq("FCI_PT2")
|
||||
s.set_perturbation("epstein_nesbet_2x2")
|
||||
#s.unset_openmp()
|
||||
print s
|
||||
|
||||
s = H_apply("FCI_no_skip")
|
||||
s.set_selection_pt2("epstein_nesbet_2x2")
|
||||
s.unset_skip()
|
||||
#s.unset_openmp()
|
||||
print s
|
||||
|
||||
s = H_apply("FCI_mono")
|
||||
s.set_selection_pt2("epstein_nesbet_2x2")
|
||||
s.unset_double_excitations()
|
||||
s.unset_openmp()
|
||||
print s
|
||||
|
||||
|
||||
s = H_apply("select_mono_delta_rho")
|
||||
s.unset_double_excitations()
|
||||
s.set_selection_pt2("delta_rho_one_point")
|
||||
s.unset_openmp()
|
||||
print s
|
||||
|
||||
s = H_apply("pt2_mono_delta_rho")
|
||||
s.unset_double_excitations()
|
||||
s.set_perturbation("delta_rho_one_point")
|
||||
s.unset_openmp()
|
||||
print s
|
||||
|
||||
s = H_apply("select_mono_di_delta_rho")
|
||||
s.set_selection_pt2("delta_rho_one_point")
|
||||
s.unset_openmp()
|
||||
print s
|
||||
|
||||
s = H_apply("pt2_mono_di_delta_rho")
|
||||
s.set_perturbation("delta_rho_one_point")
|
||||
s.unset_openmp()
|
||||
print s
|
||||
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
42
plugins/Full_CI/micro_pt2.irp.f
Normal 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
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -2,3 +2,16 @@
|
||||
type: double precision
|
||||
doc: Calculated energy
|
||||
interface: ezfio
|
||||
|
||||
[thresh_mrcc]
|
||||
type: Threshold
|
||||
doc: Threshold on the convergence of the MRCC energy
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 1.e-7
|
||||
|
||||
[n_it_mrcc_max]
|
||||
type: Strictly_positive_int
|
||||
doc: Maximum number of MRCC iterations
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 20
|
||||
|
||||
|
@ -3,19 +3,19 @@ BEGIN_SHELL [ /usr/bin/env python ]
|
||||
from generate_h_apply import *
|
||||
|
||||
s = H_apply("mrcc")
|
||||
s.data["parameters"] = ", delta_ij_, delta_ii_,Ndet_ref, Ndet_non_ref"
|
||||
s.data["parameters"] = ", delta_ij_, delta_ii_, Nstates, Ndet_non_ref, Ndet_ref"
|
||||
s.data["declarations"] += """
|
||||
integer, intent(in) :: Ndet_ref,Ndet_non_ref
|
||||
double precision, intent(in) :: delta_ij_(Ndet_ref,Ndet_non_ref,*)
|
||||
double precision, intent(in) :: delta_ii_(Ndet_ref,*)
|
||||
integer, intent(in) :: Nstates, Ndet_ref, Ndet_non_ref
|
||||
double precision, intent(in) :: delta_ij_(Nstates, Ndet_non_ref, Ndet_ref)
|
||||
double precision, intent(in) :: delta_ii_(Nstates, Ndet_ref)
|
||||
"""
|
||||
s.data["keys_work"] = "call mrcc_dress(delta_ij_,delta_ii_,Ndet_ref,Ndet_non_ref,i_generator,key_idx,keys_out,N_int,iproc,key_mask)"
|
||||
s.data["params_post"] += ", delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref"
|
||||
s.data["params_main"] += "delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref"
|
||||
s.data["keys_work"] = "call mrcc_dress(delta_ij_,delta_ii_,Nstates,Ndet_non_ref,Ndet_ref,i_generator,key_idx,keys_out,N_int,iproc,key_mask)"
|
||||
s.data["params_post"] += ", delta_ij_, delta_ii_, Nstates, Ndet_non_ref, Ndet_ref"
|
||||
s.data["params_main"] += "delta_ij_, delta_ii_, Nstates, Ndet_non_ref, Ndet_ref"
|
||||
s.data["decls_main"] += """
|
||||
integer, intent(in) :: Ndet_ref,Ndet_non_ref
|
||||
double precision, intent(in) :: delta_ij_(Ndet_ref,Ndet_non_ref,*)
|
||||
double precision, intent(in) :: delta_ii_(Ndet_ref,*)
|
||||
integer, intent(in) :: Ndet_ref, Ndet_non_ref, Nstates
|
||||
double precision, intent(in) :: delta_ij_(Nstates,Ndet_non_ref,Ndet_ref)
|
||||
double precision, intent(in) :: delta_ii_(Nstates,Ndet_ref)
|
||||
"""
|
||||
s.data["finalization"] = ""
|
||||
s.data["copy_buffer"] = ""
|
||||
@ -24,27 +24,5 @@ s.data["size_max"] = "3072"
|
||||
print s
|
||||
|
||||
|
||||
s = H_apply("mrcepa")
|
||||
s.data["parameters"] = ", delta_ij_, delta_ii_,Ndet_ref, Ndet_non_ref"
|
||||
s.data["declarations"] += """
|
||||
integer, intent(in) :: Ndet_ref,Ndet_non_ref
|
||||
double precision, intent(in) :: delta_ij_(Ndet_ref,Ndet_non_ref,*)
|
||||
double precision, intent(in) :: delta_ii_(Ndet_ref,*)
|
||||
"""
|
||||
s.data["keys_work"] = "call mrcepa_dress(delta_ij_,delta_ii_,Ndet_ref,Ndet_non_ref,i_generator,key_idx,keys_out,N_int,iproc,key_mask)"
|
||||
s.data["params_post"] += ", delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref"
|
||||
s.data["params_main"] += "delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref"
|
||||
s.data["decls_main"] += """
|
||||
integer, intent(in) :: Ndet_ref,Ndet_non_ref
|
||||
double precision, intent(in) :: delta_ij_(Ndet_ref,Ndet_non_ref,*)
|
||||
double precision, intent(in) :: delta_ii_(Ndet_ref,*)
|
||||
"""
|
||||
s.data["finalization"] = ""
|
||||
s.data["copy_buffer"] = ""
|
||||
s.data["generate_psi_guess"] = ""
|
||||
s.data["size_max"] = "3072"
|
||||
# print s
|
||||
|
||||
|
||||
END_SHELL
|
||||
|
||||
|
@ -14,17 +14,17 @@ BEGIN_PROVIDER [ integer(omp_lock_kind), psi_ref_lock, (psi_det_size) ]
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
subroutine mrcc_dress(delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref,i_generator,n_selected,det_buffer,Nint,iproc,key_mask)
|
||||
subroutine mrcc_dress(delta_ij_, delta_ii_, Nstates, Ndet_non_ref, Ndet_ref,i_generator,n_selected,det_buffer,Nint,iproc,key_mask)
|
||||
use bitmasks
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: i_generator,n_selected, Nint, iproc
|
||||
integer, intent(in) :: Ndet_ref, Ndet_non_ref
|
||||
double precision, intent(inout) :: delta_ij_(Ndet_ref,Ndet_non_ref,*)
|
||||
double precision, intent(inout) :: delta_ii_(Ndet_ref,*)
|
||||
integer, intent(in) :: Nstates, Ndet_ref, Ndet_non_ref
|
||||
double precision, intent(inout) :: delta_ij_(Nstates,Ndet_non_ref,Ndet_ref)
|
||||
double precision, intent(inout) :: delta_ii_(Nstates,Ndet_ref)
|
||||
|
||||
integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected)
|
||||
integer :: i,j,k,l
|
||||
integer :: i,j,k,l,m
|
||||
integer :: degree_alpha(psi_det_size)
|
||||
integer :: idx_alpha(0:psi_det_size)
|
||||
logical :: good, fullMatch
|
||||
@ -32,10 +32,10 @@ subroutine mrcc_dress(delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref,i_generator,n
|
||||
integer(bit_kind) :: tq(Nint,2,n_selected)
|
||||
integer :: N_tq, c_ref ,degree
|
||||
|
||||
double precision :: hIk, hla, hIl, dIk(N_states), dka(N_states), dIa(N_states)
|
||||
double precision :: hIk, hla, hIl, dIk(Nstates), dka(Nstates), dIa(Nstates)
|
||||
double precision, allocatable :: dIa_hla(:,:)
|
||||
double precision :: haj, phase, phase2
|
||||
double precision :: f(N_states), ci_inv(N_states)
|
||||
double precision :: f(Nstates), ci_inv(Nstates)
|
||||
integer :: exc(0:2,2,2)
|
||||
integer :: h1,h2,p1,p2,s1,s2
|
||||
integer(bit_kind) :: tmp_det(Nint,2)
|
||||
@ -46,10 +46,16 @@ subroutine mrcc_dress(delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref,i_generator,n
|
||||
integer(bit_kind),intent(in) :: key_mask(Nint, 2)
|
||||
integer,allocatable :: idx_miniList(:)
|
||||
integer :: N_miniList, ni, leng
|
||||
double precision, allocatable :: hij_cache(:)
|
||||
|
||||
integer(bit_kind), allocatable :: microlist(:,:,:), microlist_zero(:,:,:)
|
||||
integer, allocatable :: idx_microlist(:), N_microlist(:), ptr_microlist(:), idx_microlist_zero(:)
|
||||
integer :: mobiles(2), smallerlist
|
||||
|
||||
|
||||
|
||||
leng = max(N_det_generators, N_det_non_ref)
|
||||
allocate(miniList(Nint, 2, leng), idx_miniList(leng))
|
||||
allocate(miniList(Nint, 2, leng), idx_minilist(leng), hij_cache(N_det_non_ref))
|
||||
|
||||
!create_minilist_find_previous(key_mask, fullList, miniList, N_fullList, N_miniList, fullMatch, Nint)
|
||||
call create_minilist_find_previous(key_mask, psi_det_generators, miniList, i_generator-1, N_miniList, fullMatch, Nint)
|
||||
@ -58,140 +64,248 @@ subroutine mrcc_dress(delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref,i_generator,n
|
||||
return
|
||||
end if
|
||||
|
||||
allocate(ptr_microlist(0:mo_tot_num*2+1), &
|
||||
N_microlist(0:mo_tot_num*2) )
|
||||
allocate( microlist(Nint,2,N_minilist*4), &
|
||||
idx_microlist(N_minilist*4))
|
||||
|
||||
call find_triples_and_quadruples(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist)
|
||||
if(key_mask(1,1) /= 0) then
|
||||
call create_microlist(miniList, N_minilist, key_mask, microlist, idx_microlist, N_microlist, ptr_microlist, Nint)
|
||||
call find_triples_and_quadruples_micro(i_generator,n_selected,det_buffer,Nint,tq,N_tq,microlist,ptr_microlist,N_microlist,key_mask)
|
||||
else
|
||||
call find_triples_and_quadruples(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist)
|
||||
end if
|
||||
|
||||
allocate (dIa_hla(N_states,Ndet_non_ref))
|
||||
|
||||
|
||||
deallocate(microlist, idx_microlist)
|
||||
|
||||
allocate (dIa_hla(Nstates,Ndet_non_ref))
|
||||
|
||||
! |I>
|
||||
|
||||
! |alpha>
|
||||
|
||||
if(N_tq > 0) then
|
||||
call create_minilist(key_mask, psi_non_ref, miniList, idx_miniList, N_det_non_ref, N_minilist, Nint)
|
||||
end if
|
||||
if(N_tq > 0) then
|
||||
call create_minilist(key_mask, psi_non_ref, miniList, idx_minilist, N_det_non_ref, N_minilist, Nint)
|
||||
if(N_minilist == 0) return
|
||||
|
||||
|
||||
if(key_mask(1,1) /= 0) then !!!!!!!!!!! PAS GENERAL !!!!!!!!!
|
||||
allocate(microlist_zero(Nint,2,N_minilist), idx_microlist_zero(N_minilist))
|
||||
|
||||
allocate( microlist(Nint,2,N_minilist*4), &
|
||||
idx_microlist(N_minilist*4))
|
||||
call create_microlist(miniList, N_minilist, key_mask, microlist, idx_microlist, N_microlist, ptr_microlist, Nint)
|
||||
|
||||
|
||||
do i=0,mo_tot_num*2
|
||||
do k=ptr_microlist(i),ptr_microlist(i+1)-1
|
||||
idx_microlist(k) = idx_minilist(idx_microlist(k))
|
||||
end do
|
||||
end do
|
||||
|
||||
do l=1,N_microlist(0)
|
||||
do k=1,Nint
|
||||
microlist_zero(k,1,l) = microlist(k,1,l)
|
||||
microlist_zero(k,2,l) = microlist(k,2,l)
|
||||
enddo
|
||||
idx_microlist_zero(l) = idx_microlist(l)
|
||||
enddo
|
||||
end if
|
||||
end if
|
||||
|
||||
|
||||
|
||||
|
||||
do i_alpha=1,N_tq
|
||||
! call get_excitation_degree_vector(psi_non_ref,tq(1,1,i_alpha),degree_alpha,Nint,N_det_non_ref,idx_alpha)
|
||||
call get_excitation_degree_vector(miniList,tq(1,1,i_alpha),degree_alpha,Nint,N_minilist,idx_alpha)
|
||||
if(key_mask(1,1) /= 0) then
|
||||
call getMobiles(tq(1,1,i_alpha), key_mask, mobiles, Nint)
|
||||
|
||||
do j=1,idx_alpha(0)
|
||||
idx_alpha(j) = idx_miniList(idx_alpha(j))
|
||||
end do
|
||||
if(N_microlist(mobiles(1)) < N_microlist(mobiles(2))) then
|
||||
smallerlist = mobiles(1)
|
||||
else
|
||||
smallerlist = mobiles(2)
|
||||
end if
|
||||
|
||||
|
||||
do l=0,N_microlist(smallerlist)-1
|
||||
microlist_zero(:,:,ptr_microlist(1) + l) = microlist(:,:,ptr_microlist(smallerlist) + l)
|
||||
idx_microlist_zero(ptr_microlist(1) + l) = idx_microlist(ptr_microlist(smallerlist) + l)
|
||||
end do
|
||||
|
||||
call get_excitation_degree_vector(microlist_zero,tq(1,1,i_alpha),degree_alpha,Nint,N_microlist(smallerlist)+N_microlist(0),idx_alpha)
|
||||
do j=1,idx_alpha(0)
|
||||
idx_alpha(j) = idx_microlist_zero(idx_alpha(j))
|
||||
end do
|
||||
|
||||
|
||||
! i = 1
|
||||
! j = 2
|
||||
! do j = 2, idx_alpha_tmp(0)
|
||||
! if(idx_alpha_tmp(j) < idx_alpha_tmp(j-1)) exit
|
||||
! end do
|
||||
!
|
||||
! m = j
|
||||
!
|
||||
! idx_alpha(0) = idx_alpha_tmp(0)
|
||||
!
|
||||
! do l = 1, idx_alpha(0)
|
||||
! if(j > idx_alpha_tmp(0)) then
|
||||
! k = i
|
||||
! i += 1
|
||||
! else if(i >= m) then
|
||||
! k = j
|
||||
! j += 1
|
||||
! else if(idx_alpha_tmp(i) < idx_alpha_tmp(j)) then
|
||||
! k = i
|
||||
! i += 1
|
||||
! else
|
||||
! k = j
|
||||
! j += 1
|
||||
! end if
|
||||
! ! k=l
|
||||
! idx_alpha(l) = idx_alpha_tmp(k)
|
||||
! degree_alpha(l) = degree_alpha_tmp(k)
|
||||
! end do
|
||||
!
|
||||
else
|
||||
call get_excitation_degree_vector(miniList,tq(1,1,i_alpha),degree_alpha,Nint,N_minilist,idx_alpha)
|
||||
do j=1,idx_alpha(0)
|
||||
idx_alpha(j) = idx_miniList(idx_alpha(j))
|
||||
end do
|
||||
end if
|
||||
|
||||
|
||||
! call get_excitation_degree_vector(miniList,tq(1,1,i_alpha),degree_alpha,Nint,N_minilist,idx_alpha)
|
||||
! do j=1,idx_alpha(0)
|
||||
! idx_alpha(j) = idx_miniList(idx_alpha(j))
|
||||
! end do
|
||||
!print *, idx_alpha(:idx_alpha(0))
|
||||
|
||||
do l_sd=1,idx_alpha(0)
|
||||
k_sd = idx_alpha(l_sd)
|
||||
call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hij_cache(k_sd))
|
||||
enddo
|
||||
|
||||
! |I>
|
||||
do i_I=1,N_det_ref
|
||||
! Find triples and quadruple grand parents
|
||||
call get_excitation_degree(tq(1,1,i_alpha),psi_ref(1,1,i_I),degree,Nint)
|
||||
if (degree > 4) then
|
||||
cycle
|
||||
endif
|
||||
! Find triples and quadruple grand parents
|
||||
call get_excitation_degree(tq(1,1,i_alpha),psi_ref(1,1,i_I),degree,Nint)
|
||||
if (degree > 4) then
|
||||
cycle
|
||||
endif
|
||||
|
||||
do i_state=1,N_states
|
||||
dIa(i_state) = 0.d0
|
||||
enddo
|
||||
do i_state=1,Nstates
|
||||
dIa(i_state) = 0.d0
|
||||
enddo
|
||||
|
||||
! <I| <> |alpha>
|
||||
do k_sd=1,idx_alpha(0)
|
||||
call get_excitation_degree(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),degree,Nint)
|
||||
if (degree > 2) then
|
||||
cycle
|
||||
endif
|
||||
! <I| /k\ |alpha>
|
||||
! <I|H|k>
|
||||
call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),Nint,hIk)
|
||||
do i_state=1,N_states
|
||||
dIk(i_state) = hIk * lambda_mrcc(i_state,idx_alpha(k_sd))
|
||||
enddo
|
||||
! |l> = Exc(k -> alpha) |I>
|
||||
call get_excitation(psi_non_ref(1,1,idx_alpha(k_sd)),tq(1,1,i_alpha),exc,degree,phase,Nint)
|
||||
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
|
||||
do k=1,N_int
|
||||
tmp_det(k,1) = psi_ref(k,1,i_I)
|
||||
tmp_det(k,2) = psi_ref(k,2,i_I)
|
||||
enddo
|
||||
! Hole (see list_to_bitstring)
|
||||
iint = ishft(h1-1,-bit_kind_shift) + 1
|
||||
ipos = h1-ishft((iint-1),bit_kind_shift)-1
|
||||
tmp_det(iint,s1) = ibclr(tmp_det(iint,s1),ipos)
|
||||
! <I| <> |alpha>
|
||||
do k_sd=1,idx_alpha(0)
|
||||
|
||||
! Particle
|
||||
iint = ishft(p1-1,-bit_kind_shift) + 1
|
||||
ipos = p1-ishft((iint-1),bit_kind_shift)-1
|
||||
tmp_det(iint,s1) = ibset(tmp_det(iint,s1),ipos)
|
||||
if (degree_alpha(k_sd) == 2) then
|
||||
! Hole (see list_to_bitstring)
|
||||
iint = ishft(h2-1,-bit_kind_shift) + 1
|
||||
ipos = h2-ishft((iint-1),bit_kind_shift)-1
|
||||
tmp_det(iint,s2) = ibclr(tmp_det(iint,s2),ipos)
|
||||
! Loop if lambda == 0
|
||||
logical :: loop
|
||||
loop = .True.
|
||||
do i_state=1,Nstates
|
||||
if (lambda_mrcc(i_state,idx_alpha(k_sd)) /= 0.d0) then
|
||||
loop = .False.
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
if (loop) then
|
||||
cycle
|
||||
endif
|
||||
|
||||
! Particle
|
||||
iint = ishft(p2-1,-bit_kind_shift) + 1
|
||||
ipos = p2-ishft((iint-1),bit_kind_shift)-1
|
||||
tmp_det(iint,s2) = ibset(tmp_det(iint,s2),ipos)
|
||||
endif
|
||||
call get_excitation_degree(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),degree,Nint)
|
||||
if (degree > 2) then
|
||||
cycle
|
||||
endif
|
||||
|
||||
! <I| \l/ |alpha>
|
||||
do i_state=1,N_states
|
||||
dka(i_state) = 0.d0
|
||||
enddo
|
||||
do l_sd=k_sd+1,idx_alpha(0)
|
||||
call get_excitation_degree(tmp_det,psi_non_ref(1,1,idx_alpha(l_sd)),degree,Nint)
|
||||
if (degree == 0) then
|
||||
call get_excitation(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),exc,degree,phase2,Nint)
|
||||
call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hIl)
|
||||
do i_state=1,N_states
|
||||
dka(i_state) = hIl * lambda_mrcc(i_state,idx_alpha(l_sd)) * phase * phase2
|
||||
enddo
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
do i_state=1,N_states
|
||||
dIa(i_state) = dIa(i_state) + dIk(i_state) * dka(i_state)
|
||||
enddo
|
||||
enddo
|
||||
! <I| /k\ |alpha>
|
||||
! <I|H|k>
|
||||
hIk = hij_mrcc(idx_alpha(k_sd),i_I)
|
||||
! call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),Nint,hIk)
|
||||
do i_state=1,Nstates
|
||||
dIk(i_state) = hIk * lambda_mrcc(i_state,idx_alpha(k_sd))
|
||||
enddo
|
||||
! |l> = Exc(k -> alpha) |I>
|
||||
call get_excitation(psi_non_ref(1,1,idx_alpha(k_sd)),tq(1,1,i_alpha),exc,degree,phase,Nint)
|
||||
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
|
||||
do k=1,N_int
|
||||
tmp_det(k,1) = psi_ref(k,1,i_I)
|
||||
tmp_det(k,2) = psi_ref(k,2,i_I)
|
||||
enddo
|
||||
|
||||
do i_state=1,N_states
|
||||
ci_inv(i_state) = 1.d0/psi_ref_coef(i_I,i_state)
|
||||
enddo
|
||||
do l_sd=1,idx_alpha(0)
|
||||
k_sd = idx_alpha(l_sd)
|
||||
call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hla)
|
||||
do i_state=1,N_states
|
||||
dIa_hla(i_state,k_sd) = dIa(i_state) * hla
|
||||
enddo
|
||||
enddo
|
||||
call omp_set_lock( psi_ref_lock(i_I) )
|
||||
do l_sd=1,idx_alpha(0)
|
||||
k_sd = idx_alpha(l_sd)
|
||||
do i_state=1,N_states
|
||||
delta_ij_(i_I,k_sd,i_state) += dIa_hla(i_state,k_sd)
|
||||
if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5)then
|
||||
delta_ii_(i_I,i_state) -= dIa_hla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef(k_sd,i_state)
|
||||
else
|
||||
delta_ii_(i_I,i_state) = 0.d0
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
call omp_unset_lock( psi_ref_lock(i_I) )
|
||||
logical :: ok
|
||||
call apply_excitation(psi_ref(1,1,i_I), exc, tmp_det, ok, Nint)
|
||||
if(.not. ok) cycle
|
||||
|
||||
! <I| \l/ |alpha>
|
||||
do i_state=1,Nstates
|
||||
dka(i_state) = 0.d0
|
||||
enddo
|
||||
do l_sd=k_sd+1,idx_alpha(0)
|
||||
|
||||
call get_excitation_degree(tmp_det,psi_non_ref(1,1,idx_alpha(l_sd)),degree,Nint)
|
||||
if (degree == 0) then
|
||||
|
||||
loop = .True.
|
||||
do i_state=1,Nstates
|
||||
if (lambda_mrcc(i_state,idx_alpha(l_sd)) /= 0.d0) then
|
||||
loop = .False.
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
if (.not.loop) then
|
||||
call get_excitation(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),exc,degree,phase2,Nint)
|
||||
hIl = hij_mrcc(idx_alpha(l_sd),i_I)
|
||||
! call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hIl)
|
||||
do i_state=1,Nstates
|
||||
dka(i_state) = hIl * lambda_mrcc(i_state,idx_alpha(l_sd)) * phase * phase2
|
||||
enddo
|
||||
endif
|
||||
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
do i_state=1,Nstates
|
||||
dIa(i_state) = dIa(i_state) + dIk(i_state) * dka(i_state)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do i_state=1,Nstates
|
||||
ci_inv(i_state) = 1.d0/psi_ref_coef(i_I,i_state)
|
||||
enddo
|
||||
do l_sd=1,idx_alpha(0)
|
||||
k_sd = idx_alpha(l_sd)
|
||||
hla = hij_cache(k_sd)
|
||||
! call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hla)
|
||||
do i_state=1,Nstates
|
||||
dIa_hla(i_state,k_sd) = dIa(i_state) * hla
|
||||
enddo
|
||||
enddo
|
||||
call omp_set_lock( psi_ref_lock(i_I) )
|
||||
do l_sd=1,idx_alpha(0)
|
||||
k_sd = idx_alpha(l_sd)
|
||||
do i_state=1,Nstates
|
||||
delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + dIa_hla(i_state,k_sd)
|
||||
if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5)then
|
||||
delta_ii_(i_state,i_I) = delta_ii_(i_state,i_I) - dIa_hla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd)
|
||||
else
|
||||
delta_ii_(i_state,i_I) = 0.d0
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
call omp_unset_lock( psi_ref_lock(i_I) )
|
||||
enddo
|
||||
enddo
|
||||
deallocate (dIa_hla)
|
||||
deallocate(miniList, idx_miniList)
|
||||
!deallocate (dIa_hla,hij_cache)
|
||||
!deallocate(miniList, idx_miniList)
|
||||
end
|
||||
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ integer(bit_kind), gen_det_sorted, (N_int,2,N_det_generators,2) ]
|
||||
&BEGIN_PROVIDER [ integer, gen_det_shortcut, (0:N_det_generators,2) ]
|
||||
&BEGIN_PROVIDER [ integer, gen_det_version, (N_int, N_det_generators,2) ]
|
||||
&BEGIN_PROVIDER [ integer, gen_det_idx, (N_det_generators,2) ]
|
||||
gen_det_sorted(:,:,:,1) = psi_det_generators(:,:,:N_det_generators)
|
||||
gen_det_sorted(:,:,:,2) = psi_det_generators(:,:,:N_det_generators)
|
||||
call sort_dets_ab_v(gen_det_sorted(:,:,:,1), gen_det_idx(:,1), gen_det_shortcut(0:,1), gen_det_version(:,:,1), N_det_generators, N_int)
|
||||
call sort_dets_ba_v(gen_det_sorted(:,:,:,2), gen_det_idx(:,2), gen_det_shortcut(0:,2), gen_det_version(:,:,2), N_det_generators, N_int)
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
|
||||
subroutine find_triples_and_quadruples(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_miniList)
|
||||
@ -224,6 +338,7 @@ subroutine find_triples_and_quadruples(i_generator,n_selected,det_buffer,Nint,tq
|
||||
N_tq = 0
|
||||
|
||||
|
||||
|
||||
i_loop : do i=1,N_selected
|
||||
if(is_connected_to(det_buffer(1,1,i), miniList, Nint, N_miniList)) then
|
||||
cycle
|
||||
@ -253,8 +368,84 @@ subroutine find_triples_and_quadruples(i_generator,n_selected,det_buffer,Nint,tq
|
||||
end
|
||||
|
||||
|
||||
subroutine find_triples_and_quadruples_micro(i_generator,n_selected,det_buffer,Nint,tq,N_tq,microlist,ptr_microlist,N_microlist,key_mask)
|
||||
|
||||
use bitmasks
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: i_generator,n_selected, Nint
|
||||
|
||||
integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected)
|
||||
integer :: i,j,k,m
|
||||
logical :: is_in_wavefunction
|
||||
integer :: degree(psi_det_size)
|
||||
integer :: idx(0:psi_det_size)
|
||||
logical :: good
|
||||
|
||||
integer(bit_kind), intent(out) :: tq(Nint,2,n_selected)
|
||||
integer, intent(out) :: N_tq
|
||||
|
||||
|
||||
integer :: nt,ni
|
||||
logical, external :: is_connected_to
|
||||
|
||||
|
||||
integer(bit_kind),intent(in) :: microlist(Nint,2,*)
|
||||
integer,intent(in) :: ptr_microlist(0:*)
|
||||
integer,intent(in) :: N_microlist(0:*)
|
||||
integer(bit_kind),intent(in) :: key_mask(Nint, 2)
|
||||
|
||||
integer :: mobiles(2), smallerlist
|
||||
|
||||
N_tq = 0
|
||||
|
||||
|
||||
|
||||
i_loop : do i=1,N_selected
|
||||
call getMobiles(det_buffer(1,1,i), key_mask, mobiles, Nint)
|
||||
if(N_microlist(mobiles(1)) < N_microlist(mobiles(2))) then
|
||||
smallerlist = mobiles(1)
|
||||
else
|
||||
smallerlist = mobiles(2)
|
||||
end if
|
||||
|
||||
if(N_microlist(smallerlist) > 0) then
|
||||
if(is_connected_to(det_buffer(1,1,i), microlist(1,1,ptr_microlist(smallerlist)), Nint, N_microlist(smallerlist))) then
|
||||
cycle
|
||||
end if
|
||||
end if
|
||||
|
||||
if(N_microlist(0) > 0) then
|
||||
if(is_connected_to(det_buffer(1,1,i), microlist, Nint, N_microlist(0))) then
|
||||
cycle
|
||||
end if
|
||||
end if
|
||||
|
||||
! Select determinants that are triple or quadruple excitations
|
||||
! from the ref
|
||||
good = .True.
|
||||
call get_excitation_degree_vector(psi_ref,det_buffer(1,1,i),degree,Nint,N_det_ref,idx)
|
||||
!good=(idx(0) == 0) tant que degree > 2 pas retourné par get_excitation_degree_vector
|
||||
do k=1,idx(0)
|
||||
if (degree(k) < 3) then
|
||||
good = .False.
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
if (good) then
|
||||
if (.not. is_in_wavefunction(det_buffer(1,1,i),Nint,N_det)) then
|
||||
N_tq += 1
|
||||
do k=1,N_int
|
||||
tq(k,1,N_tq) = det_buffer(k,1,i)
|
||||
tq(k,2,N_tq) = det_buffer(k,2,i)
|
||||
enddo
|
||||
endif
|
||||
endif
|
||||
enddo i_loop
|
||||
end
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
@ -31,23 +31,7 @@ subroutine mrcc_iterations
|
||||
|
||||
E_past(j) = E_new
|
||||
j +=1
|
||||
if(j>4)then
|
||||
j=1
|
||||
endif
|
||||
if(iteration > 4) then
|
||||
if(delta_E > 1.d-10)then
|
||||
if(dabs(E_past(1) - E_past(3)) .le. delta_E .and. dabs(E_past(2) - E_past(4)).le. delta_E)then
|
||||
print*,'OSCILLATIONS !!!'
|
||||
oscillations = .True.
|
||||
i_oscillations +=1
|
||||
lambda_mrcc_tmp = lambda_mrcc
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
call save_wavefunction
|
||||
! if (i_oscillations > 5) then
|
||||
! exit
|
||||
! endif
|
||||
if (iteration > 200) then
|
||||
exit
|
||||
endif
|
||||
|
@ -1,106 +1,81 @@
|
||||
! BEGIN_PROVIDER [ double precision, lambda_mrcc, (N_states,psi_det_size) ]
|
||||
! implicit none
|
||||
! BEGIN_DOC
|
||||
! ! cm/<Psi_0|H|D_m> or perturbative 1/Delta_E(m)
|
||||
! END_DOC
|
||||
! integer :: i,k
|
||||
! double precision :: ihpsi(N_states),ihpsi_current(N_states)
|
||||
! integer :: i_pert_count
|
||||
!
|
||||
! i_pert_count = 0
|
||||
! lambda_mrcc = 0.d0
|
||||
!
|
||||
! do i=1,N_det_non_ref
|
||||
! call i_h_psi(psi_non_ref(1,1,i), psi_ref, psi_ref_coef, N_int, N_det_ref,size(psi_ref_coef,1), n_states, ihpsi_current)
|
||||
! do k=1,N_states
|
||||
! if (ihpsi_current(k) == 0.d0) then
|
||||
! ihpsi_current(k) = 1.d-32
|
||||
! endif
|
||||
! if(dabs(ihpsi_current(k) * psi_non_ref_coef(i,k)) < 1d-6) then
|
||||
! i_pert_count +=1
|
||||
! else
|
||||
! lambda_mrcc(k,i) = psi_non_ref_coef(i,k)/ihpsi_current(k)
|
||||
! endif
|
||||
! enddo
|
||||
! enddo
|
||||
!
|
||||
! print*,'N_det_non_ref = ',N_det_non_ref
|
||||
! print*,'Number of ignored determinants = ',i_pert_count
|
||||
! print*,'psi_coef_ref_ratio = ',psi_ref_coef(2,1)/psi_ref_coef(1,1)
|
||||
! END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [integer, pert_determinants, (N_states, psi_det_size) ]
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ double precision, lambda_mrcc, (N_states,psi_det_size) ]
|
||||
&BEGIN_PROVIDER [ double precision, lambda_pert, (N_states,psi_det_size) ]
|
||||
BEGIN_PROVIDER [ double precision, lambda_mrcc, (N_states,psi_det_size) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! cm/<Psi_0|H|D_m> or perturbative 1/Delta_E(m)
|
||||
END_DOC
|
||||
integer :: i,k,j
|
||||
double precision :: ihpsi(N_states), hii,delta_e_eff,ihpsi_current(N_states),hij
|
||||
integer :: i_ok,i_pert,i_pert_count
|
||||
i_ok = 0
|
||||
integer :: i,k
|
||||
double precision :: ihpsi_current(N_states)
|
||||
integer :: i_pert_count
|
||||
double precision :: hii, lambda_pert
|
||||
|
||||
double precision :: phase_restart(N_states),tmp
|
||||
do k = 1, N_states
|
||||
phase_restart(k) = dsign(1.d0,psi_ref_coef_restart(1,k)/psi_ref_coef(1,k))
|
||||
enddo
|
||||
i_pert_count = 0
|
||||
i_pert_count = 0
|
||||
lambda_mrcc = 0.d0
|
||||
|
||||
do i=1,N_det_non_ref
|
||||
call i_h_psi(psi_non_ref(1,1,i), psi_ref_restart, psi_ref_coef_restart, N_int, N_det_ref,&
|
||||
size(psi_ref_coef_restart,1), n_states, ihpsi)
|
||||
call i_H_j(psi_non_ref(1,1,i),psi_non_ref(1,1,i),N_int,hii)
|
||||
! TODO --- Test perturbatif ------
|
||||
do k=1,N_states
|
||||
lambda_pert(k,i) = 1.d0 / (psi_ref_energy_diagonalized(k)-hii)
|
||||
! TODO : i_h_psi peut sortir de la boucle?
|
||||
call i_h_psi(psi_non_ref(1,1,i), psi_ref, psi_ref_coef, N_int, N_det_ref,size(psi_ref_coef,1), n_states, ihpsi_current)
|
||||
if (ihpsi_current(k) == 0.d0) then
|
||||
ihpsi_current(k) = 1.d-32
|
||||
endif
|
||||
tmp = psi_non_ref_coef(i,k)/ihpsi_current(k)
|
||||
i_pert = 0
|
||||
! Perturbation only if 1st order < 0.5 x second order
|
||||
if((ihpsi(k) * lambda_pert(k,i)) < 0.5d0 * psi_non_ref_coef_restart(i,k) )then
|
||||
i_pert = 1
|
||||
else
|
||||
do j = 1, N_det_ref
|
||||
call i_H_j(psi_non_ref(1,1,i),psi_ref(1,1,j),N_int,hij)
|
||||
! Perturbation diverges when hij*tmp > 0.5
|
||||
if(dabs(hij * tmp).ge.0.5d0)then
|
||||
i_pert_count +=1
|
||||
i_pert = 1
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
endif
|
||||
i_pert = 0
|
||||
if( i_pert == 1)then
|
||||
pert_determinants(k,i) = i_pert
|
||||
endif
|
||||
if(pert_determinants(k,i) == 1)then
|
||||
i_ok +=1
|
||||
lambda_mrcc(k,i) = lambda_pert(k,i)
|
||||
else
|
||||
do i=1,N_det_non_ref
|
||||
call i_h_psi(psi_non_ref(1,1,i), psi_ref, psi_ref_coef, N_int, N_det_ref, &
|
||||
size(psi_ref_coef,1), N_states,ihpsi_current)
|
||||
call i_H_j(psi_non_ref(1,1,i),psi_non_ref(1,1,i),N_int,hii)
|
||||
do k=1,N_states
|
||||
if (ihpsi_current(k) == 0.d0) then
|
||||
ihpsi_current(k) = 1.d-32
|
||||
endif
|
||||
lambda_mrcc(k,i) = psi_non_ref_coef(i,k)/ihpsi_current(k)
|
||||
endif
|
||||
enddo
|
||||
! TODO --- Fin test perturbatif ------
|
||||
enddo
|
||||
!if(oscillations)then
|
||||
! print*,'AVERAGING the lambda_mrcc with those of the previous iterations'
|
||||
! do i = 1, N_det_non_ref
|
||||
! do k = 1, N_states
|
||||
if ( dabs(psi_non_ref_coef(i,k)*ihpsi_current(k)) < 1.d-6 ) then
|
||||
i_pert_count += 1
|
||||
lambda_mrcc(k,i) = 0.d0
|
||||
! lambda_pert = 1.d0 / (psi_ref_energy_diagonalized(k)-hii)
|
||||
! if((ihpsi_current(k) * lambda_pert) < 0.5d0 * psi_non_ref_coef_restart(i,k) ) then
|
||||
! lambda_mrcc(k,i) = 0.d0
|
||||
! endif
|
||||
endif
|
||||
double precision, parameter :: x = 2.d0
|
||||
if (lambda_mrcc(k,i) > x) then
|
||||
lambda_mrcc(k,i) = x
|
||||
else if (lambda_mrcc(k,i) < -x) then
|
||||
lambda_mrcc(k,i) = -x
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! double precision :: tmp
|
||||
! tmp = lambda_mrcc(k,i)
|
||||
! lambda_mrcc(k,i) += lambda_mrcc_tmp(k,i)
|
||||
! lambda_mrcc(k,i) = lambda_mrcc(k,i) * 0.5d0
|
||||
! if(dabs(tmp - lambda_mrcc(k,i)).ge.1.d-9)then
|
||||
! print*,''
|
||||
! print*,'i = ',i
|
||||
! print*,'psi_non_ref_coef(i,k) = ',psi_non_ref_coef(i,k)
|
||||
! print*,'lambda_mrcc(k,i) = ',lambda_mrcc(k,i)
|
||||
! print*,' tmp = ',tmp
|
||||
! endif
|
||||
! enddo
|
||||
! enddo
|
||||
!endif
|
||||
print*,'N_det_non_ref = ',N_det_non_ref
|
||||
print*,'Number of Perturbatively treated determinants = ',i_ok
|
||||
print*,'i_pert_count = ',i_pert_count
|
||||
print*,'psi_coef_ref_ratio = ',psi_ref_coef(2,1)/psi_ref_coef(1,1)
|
||||
print*,'N_det_non_ref = ',N_det_non_ref
|
||||
print*,'Number of ignored determinants = ',i_pert_count
|
||||
print*,'psi_coef_ref_ratio = ',psi_ref_coef(2,1)/psi_ref_coef(1,1)
|
||||
print*,'lambda min/max = ',maxval(dabs(lambda_mrcc)), minval(dabs(lambda_mrcc))
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ double precision, lambda_mrcc_tmp, (N_states,psi_det_size) ]
|
||||
implicit none
|
||||
lambda_mrcc_tmp = 0.d0
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ logical, oscillations ]
|
||||
implicit none
|
||||
oscillations = .False.
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
|
||||
|
||||
!BEGIN_PROVIDER [ double precision, delta_ij_non_ref, (N_det_non_ref, N_det_non_ref,N_states) ]
|
||||
!implicit none
|
||||
!BEGIN_DOC
|
||||
@ -110,8 +85,22 @@ END_PROVIDER
|
||||
!call H_apply_mrcc_simple(delta_ij_non_ref,N_det_non_ref)
|
||||
!END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, delta_ij, (N_det_ref,N_det_non_ref,N_states) ]
|
||||
&BEGIN_PROVIDER [ double precision, delta_ii, (N_det_ref,N_states) ]
|
||||
BEGIN_PROVIDER [ double precision, hij_mrcc, (N_det_non_ref,N_det_ref) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! < ref | H | Non-ref > matrix
|
||||
END_DOC
|
||||
integer :: i_I, k_sd
|
||||
do i_I=1,N_det_ref
|
||||
do k_sd=1,N_det_non_ref
|
||||
call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,k_sd),N_int,hij_mrcc(k_sd,i_I))
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, delta_ij, (N_states,N_det_non_ref,N_det_ref) ]
|
||||
&BEGIN_PROVIDER [ double precision, delta_ii, (N_states,N_det_ref) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Dressing matrix in N_det basis
|
||||
@ -119,33 +108,7 @@ END_PROVIDER
|
||||
integer :: i,j,m
|
||||
delta_ij = 0.d0
|
||||
delta_ii = 0.d0
|
||||
call H_apply_mrcc(delta_ij,delta_ii,N_det_ref,N_det_non_ref)
|
||||
double precision :: max_delta
|
||||
double precision :: accu
|
||||
integer :: imax,jmax
|
||||
max_delta = 0.d0
|
||||
accu = 0.d0
|
||||
do i = 1, N_det_ref
|
||||
do j = 1, N_det_non_ref
|
||||
accu += psi_non_ref_coef(j,1) * psi_ref_coef(i,1) * delta_ij(i,j,1)
|
||||
if(dabs(delta_ij(i,j,1)).gt.max_delta)then
|
||||
max_delta = dabs(delta_ij(i,j,1))
|
||||
imax = i
|
||||
jmax = j
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
!stop "movais delta"
|
||||
print*,''
|
||||
print*,''
|
||||
print*,'<psi| Delta H |psi> = ',accu
|
||||
print*,'MAX VAL OF DRESING = ',delta_ij(imax,jmax,1)
|
||||
print*,'imax,jmax = ',imax,jmax
|
||||
print*,'psi_ref_coef(imax,1) = ',psi_ref_coef(imax,1)
|
||||
print*,'psi_non_ref_coef(jmax,1) = ',psi_non_ref_coef(jmax,1)
|
||||
do i = 1, N_det_ref
|
||||
print*,'delta_ii(i,1) = ',delta_ii(i,1)
|
||||
enddo
|
||||
call H_apply_mrcc(delta_ij,delta_ii,N_states,N_det_non_ref,N_det_ref)
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, h_matrix_dressed, (N_det,N_det,N_states) ]
|
||||
@ -162,11 +125,11 @@ BEGIN_PROVIDER [ double precision, h_matrix_dressed, (N_det,N_det,N_states) ]
|
||||
enddo
|
||||
do ii = 1, N_det_ref
|
||||
i =idx_ref(ii)
|
||||
h_matrix_dressed(i,i,istate) += delta_ii(ii,istate)
|
||||
h_matrix_dressed(i,i,istate) += delta_ii(istate,ii)
|
||||
do jj = 1, N_det_non_ref
|
||||
j =idx_non_ref(jj)
|
||||
h_matrix_dressed(i,j,istate) += delta_ij(ii,jj,istate)
|
||||
h_matrix_dressed(j,i,istate) += delta_ij(ii,jj,istate)
|
||||
h_matrix_dressed(i,j,istate) += delta_ij(istate,jj,ii)
|
||||
h_matrix_dressed(j,i,istate) += delta_ij(istate,jj,ii)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
@ -262,11 +225,9 @@ subroutine diagonalize_CI_dressed
|
||||
! eigenstates of the CI matrix
|
||||
END_DOC
|
||||
integer :: i,j
|
||||
double precision, parameter :: speed = 1d0
|
||||
|
||||
do j=1,N_states_diag
|
||||
do i=1,N_det
|
||||
psi_coef(i,j) = CI_eigenvectors_dressed(i,j) * speed + psi_coef(i,j) * (1d0 - speed)
|
||||
psi_coef(i,j) = CI_eigenvectors_dressed(i,j)
|
||||
enddo
|
||||
enddo
|
||||
SOFT_TOUCH psi_coef
|
||||
|
@ -1,260 +0,0 @@
|
||||
use omp_lib
|
||||
use bitmasks
|
||||
|
||||
subroutine mrcepa_dress(delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref,i_generator,n_selected,det_buffer,Nint,iproc,key_mask)
|
||||
use bitmasks
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: i_generator,n_selected, Nint, iproc
|
||||
integer, intent(in) :: Ndet_ref, Ndet_non_ref
|
||||
double precision, intent(inout) :: delta_ij_(Ndet_ref,Ndet_non_ref,*)
|
||||
double precision, intent(inout) :: delta_ii_(Ndet_ref,*)
|
||||
|
||||
integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected)
|
||||
integer :: i,j,k,l
|
||||
integer :: degree_alpha(psi_det_size)
|
||||
integer :: idx_alpha(0:psi_det_size)
|
||||
logical :: good, fullMatch
|
||||
|
||||
integer(bit_kind) :: tq(Nint,2,n_selected)
|
||||
integer :: N_tq, c_ref ,degree
|
||||
|
||||
double precision :: hIk, hla, hIl, dIk(N_states), dka(N_states), dIa(N_states)
|
||||
double precision, allocatable :: dIa_hia(:,:)
|
||||
double precision :: haj, phase, phase2
|
||||
double precision :: f(N_states), ci_inv(N_states)
|
||||
integer :: exc(0:2,2,2)
|
||||
integer :: h1,h2,p1,p2,s1,s2
|
||||
integer(bit_kind) :: tmp_det(Nint,2)
|
||||
integer(bit_kind) :: tmp_det_0(Nint,2)
|
||||
integer :: iint, ipos
|
||||
integer :: i_state, i_sd, k_sd, l_sd, i_I, i_alpha
|
||||
|
||||
integer(bit_kind),allocatable :: miniList(:,:,:)
|
||||
integer(bit_kind),intent(in) :: key_mask(Nint, 2)
|
||||
integer,allocatable :: idx_miniList(:)
|
||||
integer :: N_miniList, ni, leng
|
||||
integer(bit_kind) :: isum
|
||||
|
||||
double precision :: hia
|
||||
integer, allocatable :: index_sorted(:)
|
||||
|
||||
|
||||
leng = max(N_det_generators, N_det_non_ref)
|
||||
allocate(miniList(Nint, 2, leng), idx_miniList(leng), index_sorted(N_det))
|
||||
|
||||
!create_minilist_find_previous(key_mask, fullList, miniList, N_fullList, N_miniList, fullMatch, Nint)
|
||||
call create_minilist_find_previous(key_mask, psi_det_generators, miniList, i_generator-1, N_miniList, fullMatch, Nint)
|
||||
|
||||
if(fullMatch) then
|
||||
return
|
||||
end if
|
||||
|
||||
|
||||
call find_triples_and_quadruples(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist)
|
||||
|
||||
allocate (dIa_hia(N_states,Ndet_non_ref))
|
||||
|
||||
! |I>
|
||||
|
||||
! |alpha>
|
||||
|
||||
if(N_tq > 0) then
|
||||
call create_minilist(key_mask, psi_non_ref, miniList, idx_miniList, N_det_non_ref, N_minilist, Nint)
|
||||
end if
|
||||
|
||||
|
||||
do i_alpha=1,N_tq
|
||||
! call get_excitation_degree_vector(psi_non_ref,tq(1,1,i_alpha),degree_alpha,Nint,N_det_non_ref,idx_alpha)
|
||||
call get_excitation_degree_vector(miniList,tq(1,1,i_alpha),degree_alpha,Nint,N_minilist,idx_alpha)
|
||||
|
||||
integer, external :: get_index_in_psi_det_sorted_bit
|
||||
index_sorted = huge(-1)
|
||||
do j=1,idx_alpha(0)
|
||||
idx_alpha(j) = idx_miniList(idx_alpha(j))
|
||||
index_sorted( get_index_in_psi_det_sorted_bit( psi_non_ref(1,1,idx_alpha(j)), N_int ) ) = idx_alpha(j)
|
||||
end do
|
||||
|
||||
! |I>
|
||||
do i_I=1,N_det_ref
|
||||
! Find triples and quadruple grand parents
|
||||
call get_excitation_degree(tq(1,1,i_alpha),psi_ref(1,1,i_I),degree,Nint)
|
||||
if (degree > 4) then
|
||||
cycle
|
||||
endif
|
||||
|
||||
do i_state=1,N_states
|
||||
dIa(i_state) = 0.d0
|
||||
enddo
|
||||
|
||||
!TODO: MR
|
||||
do i_sd=1,idx_alpha(0)
|
||||
call get_excitation_degree(psi_non_ref(1,1,idx_alpha(i_sd)),tq(1,1,i_alpha),degree,Nint)
|
||||
if (degree > 2) then
|
||||
cycle
|
||||
endif
|
||||
call get_excitation(psi_non_ref(1,1,idx_alpha(i_sd)),tq(1,1,i_alpha),exc,degree,phase,Nint)
|
||||
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
|
||||
tmp_det_0 = 0_bit_kind
|
||||
! Hole (see list_to_bitstring)
|
||||
iint = ishft(h1-1,-bit_kind_shift) + 1
|
||||
ipos = h1-ishft((iint-1),bit_kind_shift)-1
|
||||
tmp_det_0(iint,s1) = ibset(tmp_det_0(iint,s1),ipos)
|
||||
|
||||
! Particle
|
||||
iint = ishft(p1-1,-bit_kind_shift) + 1
|
||||
ipos = p1-ishft((iint-1),bit_kind_shift)-1
|
||||
tmp_det_0(iint,s1) = ibset(tmp_det_0(iint,s1),ipos)
|
||||
if (degree == 2) then
|
||||
! Hole (see list_to_bitstring)
|
||||
iint = ishft(h2-1,-bit_kind_shift) + 1
|
||||
ipos = h2-ishft((iint-1),bit_kind_shift)-1
|
||||
tmp_det_0(iint,s2) = ibset(tmp_det_0(iint,s2),ipos)
|
||||
|
||||
! Particle
|
||||
iint = ishft(p2-1,-bit_kind_shift) + 1
|
||||
ipos = p2-ishft((iint-1),bit_kind_shift)-1
|
||||
tmp_det_0(iint,s2) = ibset(tmp_det_0(iint,s2),ipos)
|
||||
endif
|
||||
|
||||
call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(i_sd)),Nint,hia)
|
||||
|
||||
! <I| <> |alpha>
|
||||
do k_sd=1,idx_alpha(0)
|
||||
call get_excitation_degree(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),degree,Nint)
|
||||
if (degree > 2) then
|
||||
cycle
|
||||
endif
|
||||
|
||||
call get_excitation(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),exc,degree,phase,Nint)
|
||||
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
|
||||
tmp_det = 0_bit_kind
|
||||
! Hole (see list_to_bitstring)
|
||||
iint = ishft(h1-1,-bit_kind_shift) + 1
|
||||
ipos = h1-ishft((iint-1),bit_kind_shift)-1
|
||||
tmp_det(iint,s1) = ibset(tmp_det(iint,s1),ipos)
|
||||
|
||||
! Particle
|
||||
iint = ishft(p1-1,-bit_kind_shift) + 1
|
||||
ipos = p1-ishft((iint-1),bit_kind_shift)-1
|
||||
tmp_det(iint,s1) = ibset(tmp_det(iint,s1),ipos)
|
||||
if (degree == 2) then
|
||||
! Hole (see list_to_bitstring)
|
||||
iint = ishft(h2-1,-bit_kind_shift) + 1
|
||||
ipos = h2-ishft((iint-1),bit_kind_shift)-1
|
||||
tmp_det(iint,s2) = ibset(tmp_det(iint,s2),ipos)
|
||||
|
||||
! Particle
|
||||
iint = ishft(p2-1,-bit_kind_shift) + 1
|
||||
ipos = p2-ishft((iint-1),bit_kind_shift)-1
|
||||
tmp_det(iint,s2) = ibset(tmp_det(iint,s2),ipos)
|
||||
endif
|
||||
|
||||
isum = 0_bit_kind
|
||||
do iint = 1,N_int
|
||||
isum = isum + iand(tmp_det(iint,1), tmp_det_0(iint,1)) &
|
||||
+ iand(tmp_det(iint,2), tmp_det_0(iint,2))
|
||||
enddo
|
||||
|
||||
if (isum /= 0_bit_kind) then
|
||||
cycle
|
||||
endif
|
||||
|
||||
! <I| /k\ |alpha>
|
||||
! <I|H|k>
|
||||
call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),Nint,hIk)
|
||||
do i_state=1,N_states
|
||||
dIk(i_state) = hIk * lambda_mrcc(i_state,idx_alpha(k_sd))
|
||||
enddo
|
||||
! |l> = Exc(k -> alpha) |I>
|
||||
call get_excitation(psi_non_ref(1,1,idx_alpha(k_sd)),tq(1,1,i_alpha),exc,degree,phase,Nint)
|
||||
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
|
||||
do k=1,N_int
|
||||
tmp_det(k,1) = psi_ref(k,1,i_I)
|
||||
tmp_det(k,2) = psi_ref(k,2,i_I)
|
||||
enddo
|
||||
! Hole (see list_to_bitstring)
|
||||
iint = ishft(h1-1,-bit_kind_shift) + 1
|
||||
ipos = h1-ishft((iint-1),bit_kind_shift)-1
|
||||
tmp_det(iint,s1) = ibclr(tmp_det(iint,s1),ipos)
|
||||
|
||||
! Particle
|
||||
iint = ishft(p1-1,-bit_kind_shift) + 1
|
||||
ipos = p1-ishft((iint-1),bit_kind_shift)-1
|
||||
tmp_det(iint,s1) = ibset(tmp_det(iint,s1),ipos)
|
||||
if (degree == 2) then
|
||||
! Hole (see list_to_bitstring)
|
||||
iint = ishft(h2-1,-bit_kind_shift) + 1
|
||||
ipos = h2-ishft((iint-1),bit_kind_shift)-1
|
||||
tmp_det(iint,s2) = ibclr(tmp_det(iint,s2),ipos)
|
||||
|
||||
! Particle
|
||||
iint = ishft(p2-1,-bit_kind_shift) + 1
|
||||
ipos = p2-ishft((iint-1),bit_kind_shift)-1
|
||||
tmp_det(iint,s2) = ibset(tmp_det(iint,s2),ipos)
|
||||
endif
|
||||
|
||||
! <I| \l/ |alpha>
|
||||
do i_state=1,N_states
|
||||
dka(i_state) = 0.d0
|
||||
enddo
|
||||
|
||||
|
||||
! l_sd = index_sorted( get_index_in_psi_det_sorted_bit( tmp_det, N_int ) )
|
||||
! call get_excitation(psi_ref(1,1,i_I),psi_non_ref(1,1,l_sd),exc,degree,phase2,Nint)
|
||||
! call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,l_sd),Nint,hIl)
|
||||
! do i_state=1,N_states
|
||||
! dka(i_state) = hIl * lambda_mrcc(i_state,l_sd) * phase * phase2
|
||||
! enddo
|
||||
|
||||
do l_sd=1,idx_alpha(0)
|
||||
call get_excitation_degree(tmp_det,psi_non_ref(1,1,idx_alpha(l_sd)),degree,Nint)
|
||||
if (degree == 0) then
|
||||
call get_excitation(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),exc,degree,phase2,Nint)
|
||||
call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hIl)
|
||||
do i_state=1,N_states
|
||||
dka(i_state) = hIl * lambda_mrcc(i_state,idx_alpha(l_sd)) * phase * phase2
|
||||
enddo
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
do i_state=1,N_states
|
||||
dIa(i_state) = dIa(i_state) + dIk(i_state) * dka(i_state)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do i_state=1,N_states
|
||||
ci_inv(i_state) = 1.d0/psi_ref_coef(i_I,i_state)
|
||||
enddo
|
||||
|
||||
k_sd = idx_alpha(i_sd)
|
||||
do i_state=1,N_states
|
||||
dIa_hia(i_state,k_sd) = dIa(i_state) * hia
|
||||
enddo
|
||||
|
||||
call omp_set_lock( psi_ref_lock(i_I) )
|
||||
do i_state=1,N_states
|
||||
delta_ij_(i_I,k_sd,i_state) += dIa_hia(i_state,k_sd)
|
||||
|
||||
if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5)then
|
||||
delta_ii_(i_I,i_state) -= dIa_hia(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef(k_sd,i_state)
|
||||
else
|
||||
delta_ii_(i_I,i_state) = 0.d0
|
||||
endif
|
||||
enddo
|
||||
call omp_unset_lock( psi_ref_lock(i_I) )
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
deallocate (dIa_hia,index_sorted)
|
||||
deallocate(miniList, idx_miniList)
|
||||
end
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
@ -1,97 +0,0 @@
|
||||
subroutine run_mrcepa
|
||||
implicit none
|
||||
call set_generators_bitmasks_as_holes_and_particles
|
||||
call mrcepa_iterations
|
||||
end
|
||||
|
||||
subroutine mrcepa_iterations
|
||||
implicit none
|
||||
|
||||
integer :: i,j
|
||||
|
||||
double precision :: E_new, E_old, delta_e
|
||||
integer :: iteration,i_oscillations
|
||||
double precision :: E_past(4)
|
||||
E_new = 0.d0
|
||||
delta_E = 1.d0
|
||||
iteration = 0
|
||||
j = 1
|
||||
i_oscillations = 0
|
||||
do while (delta_E > 1.d-7)
|
||||
iteration += 1
|
||||
print *, '==========================='
|
||||
print *, 'MRCEPA Iteration', iteration
|
||||
print *, '==========================='
|
||||
print *, ''
|
||||
E_old = sum(ci_energy_dressed)
|
||||
call write_double(6,ci_energy_dressed(1),"MRCEPA energy")
|
||||
call diagonalize_ci_dressed
|
||||
E_new = sum(ci_energy_dressed)
|
||||
delta_E = dabs(E_new - E_old)
|
||||
|
||||
E_past(j) = E_new
|
||||
j +=1
|
||||
if(j>4)then
|
||||
j=1
|
||||
endif
|
||||
if(iteration > 4) then
|
||||
if(delta_E > 1.d-10)then
|
||||
if(dabs(E_past(1) - E_past(3)) .le. delta_E .and. dabs(E_past(2) - E_past(4)).le. delta_E)then
|
||||
print*,'OSCILLATIONS !!!'
|
||||
oscillations = .True.
|
||||
i_oscillations +=1
|
||||
lambda_mrcc_tmp = lambda_mrcc
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
call save_wavefunction
|
||||
! if (i_oscillations > 5) then
|
||||
! exit
|
||||
! endif
|
||||
if (iteration > 200) then
|
||||
exit
|
||||
endif
|
||||
print*,'------------'
|
||||
print*,'VECTOR'
|
||||
do i = 1, N_det_ref
|
||||
print*,''
|
||||
print*,'psi_ref_coef(i,1) = ',psi_ref_coef(i,1)
|
||||
print*,'delta_ii(i,1) = ',delta_ii(i,1)
|
||||
enddo
|
||||
print*,'------------'
|
||||
enddo
|
||||
call write_double(6,ci_energy_dressed(1),"Final MRCEPA energy")
|
||||
call ezfio_set_mrcc_cassd_energy(ci_energy_dressed(1))
|
||||
call save_wavefunction
|
||||
|
||||
end
|
||||
|
||||
subroutine set_generators_bitmasks_as_holes_and_particles
|
||||
implicit none
|
||||
integer :: i,k
|
||||
do k = 1, N_generators_bitmask
|
||||
do i = 1, N_int
|
||||
! Pure single part
|
||||
generators_bitmask(i,1,1,k) = holes_operators(i,1) ! holes for pure single exc alpha
|
||||
generators_bitmask(i,1,2,k) = particles_operators(i,1) ! particles for pure single exc alpha
|
||||
generators_bitmask(i,2,1,k) = holes_operators(i,2) ! holes for pure single exc beta
|
||||
generators_bitmask(i,2,2,k) = particles_operators(i,2) ! particles for pure single exc beta
|
||||
|
||||
! Double excitation
|
||||
generators_bitmask(i,1,3,k) = holes_operators(i,1) ! holes for first single exc alpha
|
||||
generators_bitmask(i,1,4,k) = particles_operators(i,1) ! particles for first single exc alpha
|
||||
generators_bitmask(i,2,3,k) = holes_operators(i,2) ! holes for first single exc beta
|
||||
generators_bitmask(i,2,4,k) = particles_operators(i,2) ! particles for first single exc beta
|
||||
|
||||
generators_bitmask(i,1,5,k) = holes_operators(i,1) ! holes for second single exc alpha
|
||||
generators_bitmask(i,1,6,k) = particles_operators(i,1) ! particles for second single exc alpha
|
||||
generators_bitmask(i,2,5,k) = holes_operators(i,2) ! holes for second single exc beta
|
||||
generators_bitmask(i,2,6,k) = particles_operators(i,2) ! particles for second single exc beta
|
||||
|
||||
enddo
|
||||
enddo
|
||||
touch generators_bitmask
|
||||
|
||||
|
||||
|
||||
end
|
@ -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
|
||||
|
||||
|
||||
|
@ -14,6 +14,31 @@ use bitmasks
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ double precision, psi_ref_coef_transp, (n_states,psi_det_size) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Transposed psi_ref_coef
|
||||
END_DOC
|
||||
integer :: i,j
|
||||
do j=1,N_det_ref
|
||||
do i=1, n_states
|
||||
psi_ref_coef_transp(i,j) = psi_ref_coef(j,i)
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, psi_non_ref_coef_transp, (n_states,psi_det_size) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Transposed psi_non_ref_coef
|
||||
END_DOC
|
||||
integer :: i,j
|
||||
do j=1,N_det_non_ref
|
||||
do i=1, n_states
|
||||
psi_non_ref_coef_transp(i,j) = psi_non_ref_coef(j,i)
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ integer(bit_kind), psi_non_ref, (N_int,2,psi_det_size) ]
|
||||
&BEGIN_PROVIDER [ double precision, psi_non_ref_coef, (psi_det_size,n_states) ]
|
||||
|
@ -61,100 +61,3 @@ END_PROVIDER
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ integer(bit_kind), psi_selectors_ab, (N_int,2,psi_selectors_size) ]
|
||||
&BEGIN_PROVIDER [ double precision, psi_selectors_coef_ab, (psi_selectors_size,N_states) ]
|
||||
&BEGIN_PROVIDER [ integer, psi_selectors_next_ab, (2,psi_selectors_size) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Determinants on which we apply <i|H|j>.
|
||||
! They are sorted by the 3 highest electrons in the alpha part,
|
||||
! then by the 3 highest electrons in the beta part to accelerate
|
||||
! the research of connected determinants.
|
||||
END_DOC
|
||||
integer :: i,j,k
|
||||
integer, allocatable :: iorder(:)
|
||||
integer*8, allocatable :: bit_tmp(:)
|
||||
integer*8, external :: det_search_key
|
||||
|
||||
allocate ( iorder(N_det_selectors), bit_tmp(N_det_selectors) )
|
||||
|
||||
! Sort alpha dets
|
||||
! ---------------
|
||||
|
||||
integer(bit_kind) :: det_tmp(N_int)
|
||||
|
||||
do i=1,N_det_selectors
|
||||
iorder(i) = i
|
||||
call int_of_3_highest_electrons(psi_selectors(1,1,i),bit_tmp(i),N_int)
|
||||
enddo
|
||||
call i8sort(bit_tmp,iorder,N_det_selectors)
|
||||
!DIR$ IVDEP
|
||||
do i=1,N_det_selectors
|
||||
do j=1,N_int
|
||||
psi_selectors_ab(j,1,i) = psi_selectors(j,1,iorder(i))
|
||||
psi_selectors_ab(j,2,i) = psi_selectors(j,2,iorder(i))
|
||||
enddo
|
||||
do k=1,N_states
|
||||
psi_coef_sorted_ab(i,k) = psi_selectors_coef(iorder(i),k)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! Find next alpha
|
||||
! ---------------
|
||||
|
||||
integer :: next
|
||||
|
||||
next = N_det_selectors+1
|
||||
psi_selectors_next_ab(1,N_det_selectors) = next
|
||||
do i=N_det_selectors-1,1,-1
|
||||
if (bit_tmp(i) /= bit_tmp(i+1)) then
|
||||
next = i+1
|
||||
endif
|
||||
psi_selectors_next_ab(1,i) = next
|
||||
enddo
|
||||
|
||||
! Sort beta dets
|
||||
! --------------
|
||||
|
||||
integer :: istart, iend
|
||||
integer(bit_kind), allocatable :: psi_selectors_ab_temp (:,:)
|
||||
|
||||
allocate ( psi_selectors_ab_temp (N_int,N_det_selectors) )
|
||||
do i=1,N_det_selectors
|
||||
do j=1,N_int
|
||||
psi_selectors_ab_temp(j,i) = psi_selectors_ab(j,2,i)
|
||||
enddo
|
||||
iorder(i) = i
|
||||
call int_of_3_highest_electrons(psi_selectors_ab_temp(1,i),bit_tmp(i),N_int)
|
||||
enddo
|
||||
|
||||
istart=1
|
||||
do while ( istart<N_det_selectors )
|
||||
|
||||
iend = psi_selectors_next_ab(1,istart)
|
||||
call i8sort(bit_tmp(istart),iorder(istart),iend-istart)
|
||||
!DIR$ IVDEP
|
||||
do i=istart,iend-1
|
||||
do j=1,N_int
|
||||
psi_selectors_ab(j,2,i) = psi_selectors_ab_temp(j,iorder(i))
|
||||
enddo
|
||||
do k=1,N_states
|
||||
psi_coef_sorted_ab(i,k) = psi_coef(iorder(i),k)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
next = iend
|
||||
psi_selectors_next_ab(2,iend-1) = next
|
||||
do i=iend-2,1,-1
|
||||
if (bit_tmp(i) /= bit_tmp(i+1)) then
|
||||
next = i+1
|
||||
endif
|
||||
psi_selectors_next_ab(2,i) = next
|
||||
enddo
|
||||
|
||||
istart = iend
|
||||
enddo
|
||||
|
||||
deallocate(iorder, bit_tmp, psi_selectors_ab_temp)
|
||||
|
||||
END_PROVIDER
|
||||
|
105
plugins/Selectors_full/zmq.irp.f
Normal file
105
plugins/Selectors_full/zmq.irp.f
Normal 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
|
||||
|
||||
|
@ -57,100 +57,3 @@ END_PROVIDER
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ integer(bit_kind), psi_selectors_ab, (N_int,2,psi_selectors_size) ]
|
||||
&BEGIN_PROVIDER [ double precision, psi_selectors_coef_ab, (psi_selectors_size,N_states) ]
|
||||
&BEGIN_PROVIDER [ integer, psi_selectors_next_ab, (2,psi_selectors_size) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Determinants on which we apply <i|H|j>.
|
||||
! They are sorted by the 3 highest electrons in the alpha part,
|
||||
! then by the 3 highest electrons in the beta part to accelerate
|
||||
! the research of connected determinants.
|
||||
END_DOC
|
||||
integer :: i,j,k
|
||||
integer, allocatable :: iorder(:)
|
||||
integer*8, allocatable :: bit_tmp(:)
|
||||
integer*8, external :: det_search_key
|
||||
|
||||
allocate ( iorder(N_det_selectors), bit_tmp(N_det_selectors) )
|
||||
|
||||
! Sort alpha dets
|
||||
! ---------------
|
||||
|
||||
integer(bit_kind) :: det_tmp(N_int)
|
||||
|
||||
do i=1,N_det_selectors
|
||||
iorder(i) = i
|
||||
call int_of_3_highest_electrons(psi_selectors(1,1,i),bit_tmp(i),N_int)
|
||||
enddo
|
||||
call i8sort(bit_tmp,iorder,N_det_selectors)
|
||||
!DIR$ IVDEP
|
||||
do i=1,N_det_selectors
|
||||
do j=1,N_int
|
||||
psi_selectors_ab(j,1,i) = psi_selectors(j,1,iorder(i))
|
||||
psi_selectors_ab(j,2,i) = psi_selectors(j,2,iorder(i))
|
||||
enddo
|
||||
do k=1,N_states
|
||||
psi_coef_sorted_ab(i,k) = psi_selectors_coef(iorder(i),k)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! Find next alpha
|
||||
! ---------------
|
||||
|
||||
integer :: next
|
||||
|
||||
next = N_det_selectors+1
|
||||
psi_selectors_next_ab(1,N_det_selectors) = next
|
||||
do i=N_det_selectors-1,1,-1
|
||||
if (bit_tmp(i) /= bit_tmp(i+1)) then
|
||||
next = i+1
|
||||
endif
|
||||
psi_selectors_next_ab(1,i) = next
|
||||
enddo
|
||||
|
||||
! Sort beta dets
|
||||
! --------------
|
||||
|
||||
integer :: istart, iend
|
||||
integer(bit_kind), allocatable :: psi_selectors_ab_temp (:,:)
|
||||
|
||||
allocate ( psi_selectors_ab_temp (N_int,N_det_selectors) )
|
||||
do i=1,N_det_selectors
|
||||
do j=1,N_int
|
||||
psi_selectors_ab_temp(j,i) = psi_selectors_ab(j,2,i)
|
||||
enddo
|
||||
iorder(i) = i
|
||||
call int_of_3_highest_electrons(psi_selectors_ab_temp(1,i),bit_tmp(i),N_int)
|
||||
enddo
|
||||
|
||||
istart=1
|
||||
do while ( istart<N_det_selectors )
|
||||
|
||||
iend = psi_selectors_next_ab(1,istart)
|
||||
call i8sort(bit_tmp(istart),iorder(istart),iend-istart)
|
||||
!DIR$ IVDEP
|
||||
do i=istart,iend-1
|
||||
do j=1,N_int
|
||||
psi_selectors_ab(j,2,i) = psi_selectors_ab_temp(j,iorder(i))
|
||||
enddo
|
||||
do k=1,N_states
|
||||
psi_coef_sorted_ab(i,k) = psi_coef(iorder(i),k)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
next = iend
|
||||
psi_selectors_next_ab(2,iend-1) = next
|
||||
do i=iend-2,1,-1
|
||||
if (bit_tmp(i) /= bit_tmp(i+1)) then
|
||||
next = i+1
|
||||
endif
|
||||
psi_selectors_next_ab(2,i) = next
|
||||
enddo
|
||||
|
||||
istart = iend
|
||||
enddo
|
||||
|
||||
deallocate(iorder, bit_tmp, psi_selectors_ab_temp)
|
||||
|
||||
END_PROVIDER
|
||||
|
@ -9,6 +9,7 @@ print "#QP -> QMCPACK"
|
||||
|
||||
from ezfio import ezfio
|
||||
|
||||
import os
|
||||
import sys
|
||||
ezfio_path = sys.argv[1]
|
||||
|
||||
@ -17,7 +18,15 @@ ezfio.set_file(ezfio_path)
|
||||
do_pseudo = ezfio.get_pseudo_do_pseudo()
|
||||
if do_pseudo:
|
||||
print "do_pseudo True"
|
||||
zcore = ezfio.get_pseudo_nucl_charge_remove()
|
||||
from qp_path import QP_ROOT
|
||||
|
||||
l_ele_path = os.path.join(QP_ROOT,"data","list_element.txt")
|
||||
with open(l_ele_path, "r") as f:
|
||||
data_raw = f.read()
|
||||
|
||||
l_element_raw = data_raw.split("\n")
|
||||
l_element = [element_raw.split() for element_raw in l_element_raw]
|
||||
d_z = dict((abr, z) for (z, abr, ele) in l_element)
|
||||
else:
|
||||
print "do_pseudo False"
|
||||
|
||||
@ -68,11 +77,10 @@ print "nucl_num", len(l_label)
|
||||
print "Atomic coord in Bohr"
|
||||
|
||||
for i, t in enumerate(zip(l_label, l_charge, l_coord_str)):
|
||||
try:
|
||||
l = (t[0], t[1] + zcore[i], t[2])
|
||||
except NameError:
|
||||
l = t
|
||||
print list_to_string(l)
|
||||
t_1 = d_z[t[0]] if do_pseudo else t[1]
|
||||
|
||||
t_new = [t[0],t_1,t[2]]
|
||||
print list_to_string(t_new)
|
||||
|
||||
#
|
||||
# Call externet process to get the sysmetry
|
||||
@ -83,7 +91,7 @@ process = subprocess.Popen(
|
||||
stdout=subprocess.PIPE)
|
||||
out, err = process.communicate()
|
||||
|
||||
basis_raw, sym_raw, _= out.split("\n\n\n")
|
||||
basis_raw, sym_raw, _ , det_raw, _ = out.split("\n\n\n")
|
||||
|
||||
# _ __
|
||||
# |_) _. _ o _ (_ _ _|_
|
||||
@ -306,7 +314,7 @@ if do_pseudo:
|
||||
l_str.append(l_dump)
|
||||
|
||||
str_ = "PARAMETERS FOR {0} ON ATOM {1} WITH ZCORE {2} AND LMAX {3} ARE"
|
||||
print str_.format(a, i + 1, int(zcore[i]), int(len(l_str) - 1))
|
||||
print str_.format(a, i + 1, int(d_z[a])-int(l_charge[i]), int(len(l_str) - 1))
|
||||
|
||||
for i, l in enumerate(l_str):
|
||||
str_ = "FOR L= {0} COEFF N ZETA"
|
||||
@ -315,7 +323,7 @@ if do_pseudo:
|
||||
print " ", ii + 1, ll
|
||||
|
||||
str_ = "THE ECP RUN REMOVES {0} CORE ELECTRONS, AND THE SAME NUMBER OF PROTONS."
|
||||
print str_.format(sum(zcore))
|
||||
print str_.format(sum([int(d_z[a])-int(l_charge[i]) for i,a in enumerate(l_label)]))
|
||||
print "END_PSEUDO"
|
||||
|
||||
# _
|
||||
@ -329,31 +337,26 @@ print "mo_num", mo_num
|
||||
print "det_num", n_det
|
||||
print ""
|
||||
|
||||
psi_det = ezfio.get_determinants_psi_det()
|
||||
psi_coef = ezfio.get_determinants_psi_coef()[0]
|
||||
|
||||
for c, (l_det_bit_alpha, l_det_bit_beta) in zip(psi_coef, psi_det):
|
||||
print c
|
||||
|
||||
bin_det = ""
|
||||
for i,int_det in enumerate(l_det_bit_alpha):
|
||||
bin_det_raw = "{0:b}".format(int_det)[::-1]
|
||||
if mo_num - 64*(i+1) > 0:
|
||||
bin_det += bin_det_raw + "0" * (64*(i+1) - len(bin_det_raw))
|
||||
else:
|
||||
bin_det += bin_det_raw + "0" * (mo_num-64*i - len(bin_det_raw))
|
||||
token = "Determinants ::"
|
||||
pos = det_raw.rfind(token) + len(token)
|
||||
|
||||
print bin_det
|
||||
det_without_header = det_raw[pos+2::]
|
||||
|
||||
bin_det = ""
|
||||
for i,int_det in enumerate(l_det_bit_beta):
|
||||
bin_det_raw = "{0:b}".format(int_det)[::-1]
|
||||
if mo_num - 64*(i+1) > 0:
|
||||
bin_det += bin_det_raw + "0" * (64*(i+1) - len(bin_det_raw))
|
||||
else:
|
||||
bin_det += bin_det_raw + "0" * (mo_num-64*i - len(bin_det_raw))
|
||||
d_rep={"+":"1","-":"0"}
|
||||
|
||||
print bin_det
|
||||
print ""
|
||||
det_without_header = det_raw[pos+2::]
|
||||
|
||||
for line_raw in det_without_header.split("\n"):
|
||||
line = line_raw
|
||||
|
||||
if line_raw:
|
||||
try:
|
||||
float(line)
|
||||
except ValueError:
|
||||
line= "".join([d_rep[x] if x in d_rep else x for x in line_raw])
|
||||
|
||||
print line.strip()
|
||||
|
||||
print "END_DET"
|
||||
|
@ -14,6 +14,12 @@ program qmcpack
|
||||
enddo
|
||||
enddo
|
||||
call ezfio_set_ao_basis_ao_coef(ao_coef)
|
||||
do j=1,mo_tot_num
|
||||
do i=1,ao_num
|
||||
mo_coef(i,j) *= 1.d0/ao_coef_normalization_factor(i)
|
||||
enddo
|
||||
enddo
|
||||
call save_mos
|
||||
call system('rm '//trim(ezfio_filename)//'/mo_basis/ao_md5')
|
||||
call system('$QP_ROOT/src/qmcpack/qp_convert_qmcpack_to_ezfio.py '//trim(ezfio_filename))
|
||||
|
||||
|
@ -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"}
|
||||
|
@ -75,7 +75,7 @@ let get s =
|
||||
| Ao_basis ->
|
||||
f Ao_basis.(read, to_rst)
|
||||
| Determinants_by_hand ->
|
||||
f Determinants_by_hand.(read, to_rst)
|
||||
f Determinants_by_hand.(read_maybe, to_rst)
|
||||
{section_to_rst}
|
||||
end
|
||||
with
|
||||
|
@ -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
|
||||
"""
|
||||
|
@ -59,7 +59,8 @@ def save_new_module(path, l_child):
|
||||
|
||||
with open(os.path.join(path, "%s.main.irp.f"%(module_name) ), "w") as f:
|
||||
f.write("program {0}".format(module_name) )
|
||||
f.write(""" implicit none
|
||||
f.write("""
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! TODO
|
||||
END_DOC
|
||||
|
@ -50,9 +50,6 @@ END_PROVIDER
|
||||
enddo
|
||||
enddo
|
||||
ao_coef_normalization_factor(i) = 1.d0/sqrt(norm)
|
||||
do j=1,ao_prim_num(i)
|
||||
ao_coef_normalized(i,j) = ao_coef_normalized(i,j) * ao_coef_normalization_factor(i)
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
|
@ -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,26 +18,23 @@ 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), cis_ijkl_bitmask, (N_int,4) ]
|
||||
BEGIN_PROVIDER [ integer(bit_kind), full_ijkl_bitmask_4, (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)
|
||||
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
|
||||
|
||||
|
||||
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
||||
|
@ -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
150
src/Determinants/H_apply_nozmq.template.f
Normal file
@ -0,0 +1,150 @@
|
||||
subroutine $subroutine($params_main)
|
||||
implicit none
|
||||
use omp_lib
|
||||
use bitmasks
|
||||
BEGIN_DOC
|
||||
! Calls H_apply on the HF determinant and selects all connected single and double
|
||||
! excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script.
|
||||
END_DOC
|
||||
|
||||
$decls_main
|
||||
|
||||
integer :: i_generator, nmax
|
||||
double precision :: wall_0, wall_1
|
||||
integer(omp_lock_kind) :: lck
|
||||
integer(bit_kind), allocatable :: mask(:,:,:)
|
||||
integer :: ispin, k
|
||||
integer :: iproc
|
||||
double precision, allocatable :: fock_diag_tmp(:,:)
|
||||
|
||||
$initialization
|
||||
PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators
|
||||
|
||||
|
||||
nmax = mod( N_det_generators,nproc )
|
||||
|
||||
!$ call omp_init_lock(lck)
|
||||
|
||||
call wall_time(wall_0)
|
||||
|
||||
iproc = 0
|
||||
allocate( mask(N_int,2,6), fock_diag_tmp(2,mo_tot_num+1) )
|
||||
do i_generator=1,nmax
|
||||
|
||||
$skip
|
||||
|
||||
! Compute diagonal of the Fock matrix
|
||||
call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int)
|
||||
|
||||
! Create bit masks for holes and particles
|
||||
do ispin=1,2
|
||||
do k=1,N_int
|
||||
mask(k,ispin,s_hole) = &
|
||||
iand(generators_bitmask(k,ispin,s_hole,i_bitmask_gen), &
|
||||
psi_det_generators(k,ispin,i_generator) )
|
||||
mask(k,ispin,s_part) = &
|
||||
iand(generators_bitmask(k,ispin,s_part,i_bitmask_gen), &
|
||||
not(psi_det_generators(k,ispin,i_generator)) )
|
||||
mask(k,ispin,d_hole1) = &
|
||||
iand(generators_bitmask(k,ispin,d_hole1,i_bitmask_gen), &
|
||||
psi_det_generators(k,ispin,i_generator) )
|
||||
mask(k,ispin,d_part1) = &
|
||||
iand(generators_bitmask(k,ispin,d_part1,i_bitmask_gen), &
|
||||
not(psi_det_generators(k,ispin,i_generator)) )
|
||||
mask(k,ispin,d_hole2) = &
|
||||
iand(generators_bitmask(k,ispin,d_hole2,i_bitmask_gen), &
|
||||
psi_det_generators(k,ispin,i_generator) )
|
||||
mask(k,ispin,d_part2) = &
|
||||
iand(generators_bitmask(k,ispin,d_part2,i_bitmask_gen), &
|
||||
not(psi_det_generators(k,ispin,i_generator)) )
|
||||
enddo
|
||||
enddo
|
||||
if($do_double_excitations)then
|
||||
call $subroutine_diexc(psi_det_generators(1,1,i_generator), &
|
||||
psi_det_generators(1,1,1), &
|
||||
mask(1,1,d_hole1), mask(1,1,d_part1), &
|
||||
mask(1,1,d_hole2), mask(1,1,d_part2), &
|
||||
fock_diag_tmp, i_generator, iproc $params_post)
|
||||
endif
|
||||
if($do_mono_excitations)then
|
||||
call $subroutine_monoexc(psi_det_generators(1,1,i_generator), &
|
||||
mask(1,1,s_hole ), mask(1,1,s_part ), &
|
||||
fock_diag_tmp, i_generator, iproc $params_post)
|
||||
endif
|
||||
call wall_time(wall_1)
|
||||
$printout_always
|
||||
if (wall_1 - wall_0 > 2.d0) then
|
||||
$printout_now
|
||||
wall_0 = wall_1
|
||||
endif
|
||||
enddo
|
||||
|
||||
deallocate( mask, fock_diag_tmp )
|
||||
|
||||
!$OMP PARALLEL DEFAULT(SHARED) &
|
||||
!$OMP PRIVATE(i_generator,wall_1,wall_0,ispin,k,mask,iproc,fock_diag_tmp)
|
||||
call wall_time(wall_0)
|
||||
!$ iproc = omp_get_thread_num()
|
||||
allocate( mask(N_int,2,6), fock_diag_tmp(2,mo_tot_num+1) )
|
||||
!$OMP DO SCHEDULE(dynamic,1)
|
||||
do i_generator=nmax+1,N_det_generators
|
||||
$skip
|
||||
|
||||
! Compute diagonal of the Fock matrix
|
||||
call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int)
|
||||
|
||||
! Create bit masks for holes and particles
|
||||
do ispin=1,2
|
||||
do k=1,N_int
|
||||
mask(k,ispin,s_hole) = &
|
||||
iand(generators_bitmask(k,ispin,s_hole,i_bitmask_gen), &
|
||||
psi_det_generators(k,ispin,i_generator) )
|
||||
mask(k,ispin,s_part) = &
|
||||
iand(generators_bitmask(k,ispin,s_part,i_bitmask_gen), &
|
||||
not(psi_det_generators(k,ispin,i_generator)) )
|
||||
mask(k,ispin,d_hole1) = &
|
||||
iand(generators_bitmask(k,ispin,d_hole1,i_bitmask_gen), &
|
||||
psi_det_generators(k,ispin,i_generator) )
|
||||
mask(k,ispin,d_part1) = &
|
||||
iand(generators_bitmask(k,ispin,d_part1,i_bitmask_gen), &
|
||||
not(psi_det_generators(k,ispin,i_generator)) )
|
||||
mask(k,ispin,d_hole2) = &
|
||||
iand(generators_bitmask(k,ispin,d_hole2,i_bitmask_gen), &
|
||||
psi_det_generators(k,ispin,i_generator) )
|
||||
mask(k,ispin,d_part2) = &
|
||||
iand(generators_bitmask(k,ispin,d_part2,i_bitmask_gen), &
|
||||
not (psi_det_generators(k,ispin,i_generator)) )
|
||||
enddo
|
||||
enddo
|
||||
|
||||
if($do_double_excitations)then
|
||||
call $subroutine_diexc(psi_det_generators(1,1,i_generator), &
|
||||
psi_det_generators(1,1,1), &
|
||||
mask(1,1,d_hole1), mask(1,1,d_part1), &
|
||||
mask(1,1,d_hole2), mask(1,1,d_part2), &
|
||||
fock_diag_tmp, i_generator, iproc $params_post)
|
||||
endif
|
||||
if($do_mono_excitations)then
|
||||
call $subroutine_monoexc(psi_det_generators(1,1,i_generator), &
|
||||
mask(1,1,s_hole ), mask(1,1,s_part ), &
|
||||
fock_diag_tmp, i_generator, iproc $params_post)
|
||||
endif
|
||||
!$ call omp_set_lock(lck)
|
||||
call wall_time(wall_1)
|
||||
$printout_always
|
||||
if (wall_1 - wall_0 > 2.d0) then
|
||||
$printout_now
|
||||
wall_0 = wall_1
|
||||
endif
|
||||
!$ call omp_unset_lock(lck)
|
||||
enddo
|
||||
!$OMP END DO
|
||||
deallocate( mask, fock_diag_tmp )
|
||||
!$OMP END PARALLEL
|
||||
!$ call omp_destroy_lock(lck)
|
||||
|
||||
$copy_buffer
|
||||
$generate_psi_guess
|
||||
|
||||
end
|
||||
|
245
src/Determinants/H_apply_zmq.template.f
Normal file
245
src/Determinants/H_apply_zmq.template.f
Normal file
@ -0,0 +1,245 @@
|
||||
subroutine $subroutine($params_main)
|
||||
implicit none
|
||||
use omp_lib
|
||||
use bitmasks
|
||||
use f77_zmq
|
||||
BEGIN_DOC
|
||||
! Calls H_apply on the HF determinant and selects all connected single and double
|
||||
! excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script.
|
||||
END_DOC
|
||||
|
||||
$decls_main
|
||||
|
||||
integer :: i_generator
|
||||
double precision :: wall_0, wall_1
|
||||
integer(omp_lock_kind) :: lck
|
||||
integer(bit_kind), allocatable :: mask(:,:,:)
|
||||
integer :: ispin, k
|
||||
integer :: rc
|
||||
character*(512) :: task
|
||||
double precision, allocatable :: fock_diag_tmp(:,:)
|
||||
|
||||
$initialization
|
||||
PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators
|
||||
|
||||
integer(ZMQ_PTR), external :: new_zmq_pair_socket
|
||||
integer(ZMQ_PTR) :: zmq_socket_pair
|
||||
|
||||
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
|
||||
call new_parallel_job(zmq_to_qp_run_socket,'$subroutine')
|
||||
zmq_socket_pair = new_zmq_pair_socket(.True.)
|
||||
|
||||
call zmq_put_psi(zmq_to_qp_run_socket,1)
|
||||
|
||||
do i_generator=N_det_generators,1,-1
|
||||
$skip
|
||||
write(task,*) i_generator
|
||||
call add_task_to_taskserver(zmq_to_qp_run_socket,task)
|
||||
enddo
|
||||
|
||||
integer(ZMQ_PTR) :: collector_thread
|
||||
external :: $subroutine_collector
|
||||
rc = pthread_create(collector_thread, $subroutine_collector)
|
||||
|
||||
!$OMP PARALLEL DEFAULT(private)
|
||||
!$OMP TASK PRIVATE(rc)
|
||||
rc = omp_get_thread_num()
|
||||
call $subroutine_slave_inproc(rc)
|
||||
!$OMP END TASK
|
||||
!$OMP TASKWAIT
|
||||
!$OMP END PARALLEL
|
||||
|
||||
|
||||
integer :: n, task_id
|
||||
call pull_pt2(zmq_socket_pair, pt2, norm_pert, H_pert_diag, N_st, n, task_id)
|
||||
|
||||
rc = pthread_join(collector_thread)
|
||||
|
||||
call end_zmq_pair_socket(zmq_socket_pair)
|
||||
call end_parallel_job(zmq_to_qp_run_socket,'$subroutine')
|
||||
|
||||
|
||||
$copy_buffer
|
||||
$generate_psi_guess
|
||||
|
||||
end
|
||||
|
||||
subroutine $subroutine_slave_tcp(iproc)
|
||||
implicit none
|
||||
integer, intent(in) :: iproc
|
||||
BEGIN_DOC
|
||||
! Computes a buffer over the network
|
||||
END_DOC
|
||||
call $subroutine_slave(0,iproc)
|
||||
end
|
||||
|
||||
subroutine $subroutine_slave_inproc(iproc)
|
||||
implicit none
|
||||
integer, intent(in) :: iproc
|
||||
BEGIN_DOC
|
||||
! Computes a buffer using threads
|
||||
END_DOC
|
||||
call $subroutine_slave(1,iproc)
|
||||
end
|
||||
|
||||
|
||||
subroutine $subroutine_slave(thread, iproc)
|
||||
implicit none
|
||||
use omp_lib
|
||||
use bitmasks
|
||||
use f77_zmq
|
||||
integer, intent(in) :: thread
|
||||
BEGIN_DOC
|
||||
! Calls H_apply on the HF determinant and selects all connected single and double
|
||||
! excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script.
|
||||
END_DOC
|
||||
|
||||
integer, intent(in) :: iproc
|
||||
integer :: i_generator
|
||||
double precision :: wall_0, wall_1
|
||||
integer(bit_kind), allocatable :: mask(:,:,:)
|
||||
integer :: ispin, k
|
||||
double precision, allocatable :: fock_diag_tmp(:,:)
|
||||
double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:)
|
||||
|
||||
integer :: worker_id, task_id, rc, N_st
|
||||
character*(512) :: task
|
||||
integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
|
||||
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
|
||||
integer(ZMQ_PTR),external :: new_zmq_push_socket
|
||||
integer(ZMQ_PTR) :: zmq_socket_push
|
||||
|
||||
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
|
||||
zmq_socket_push = new_zmq_push_socket(thread)
|
||||
|
||||
|
||||
N_st = N_states
|
||||
allocate( pt2(N_st), norm_pert(N_st), H_pert_diag(N_st), &
|
||||
mask(N_int,2,6), fock_diag_tmp(2,mo_tot_num+1) )
|
||||
|
||||
call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread)
|
||||
|
||||
do
|
||||
call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task)
|
||||
if (task_id == 0) exit
|
||||
read(task,*) i_generator
|
||||
|
||||
! Compute diagonal of the Fock matrix
|
||||
call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int)
|
||||
|
||||
pt2 = 0.d0
|
||||
norm_pert = 0.d0
|
||||
H_pert_diag = 0.d0
|
||||
|
||||
! Create bit masks for holes and particles
|
||||
do ispin=1,2
|
||||
do k=1,N_int
|
||||
mask(k,ispin,s_hole) = &
|
||||
iand(generators_bitmask(k,ispin,s_hole,i_bitmask_gen), &
|
||||
psi_det_generators(k,ispin,i_generator) )
|
||||
mask(k,ispin,s_part) = &
|
||||
iand(generators_bitmask(k,ispin,s_part,i_bitmask_gen), &
|
||||
not(psi_det_generators(k,ispin,i_generator)) )
|
||||
mask(k,ispin,d_hole1) = &
|
||||
iand(generators_bitmask(k,ispin,d_hole1,i_bitmask_gen), &
|
||||
psi_det_generators(k,ispin,i_generator) )
|
||||
mask(k,ispin,d_part1) = &
|
||||
iand(generators_bitmask(k,ispin,d_part1,i_bitmask_gen), &
|
||||
not(psi_det_generators(k,ispin,i_generator)) )
|
||||
mask(k,ispin,d_hole2) = &
|
||||
iand(generators_bitmask(k,ispin,d_hole2,i_bitmask_gen), &
|
||||
psi_det_generators(k,ispin,i_generator) )
|
||||
mask(k,ispin,d_part2) = &
|
||||
iand(generators_bitmask(k,ispin,d_part2,i_bitmask_gen), &
|
||||
not (psi_det_generators(k,ispin,i_generator)) )
|
||||
enddo
|
||||
enddo
|
||||
|
||||
if($do_double_excitations)then
|
||||
call $subroutine_diexc(psi_det_generators(1,1,i_generator), &
|
||||
psi_det_generators(1,1,1), &
|
||||
mask(1,1,d_hole1), mask(1,1,d_part1), &
|
||||
mask(1,1,d_hole2), mask(1,1,d_part2), &
|
||||
fock_diag_tmp, i_generator, iproc $params_post)
|
||||
endif
|
||||
if($do_mono_excitations)then
|
||||
call $subroutine_monoexc(psi_det_generators(1,1,i_generator), &
|
||||
mask(1,1,s_hole ), mask(1,1,s_part ), &
|
||||
fock_diag_tmp, i_generator, iproc $params_post)
|
||||
endif
|
||||
|
||||
call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id,1)
|
||||
call push_pt2(zmq_socket_push,pt2,norm_pert,H_pert_diag,N_st,task_id)
|
||||
|
||||
enddo
|
||||
|
||||
call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id)
|
||||
|
||||
deallocate( mask, fock_diag_tmp, pt2, norm_pert, H_pert_diag )
|
||||
|
||||
call end_zmq_push_socket(zmq_socket_push,thread)
|
||||
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
|
||||
|
||||
end
|
||||
|
||||
subroutine $subroutine_collector
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Collects results from the selection
|
||||
END_DOC
|
||||
|
||||
integer :: k, rc
|
||||
|
||||
integer(ZMQ_PTR), external :: new_zmq_pull_socket
|
||||
integer(ZMQ_PTR) :: zmq_socket_pull
|
||||
integer*8 :: control, accu
|
||||
integer :: n, more, task_id
|
||||
|
||||
integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
|
||||
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
|
||||
|
||||
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
|
||||
zmq_socket_pull = new_zmq_pull_socket()
|
||||
|
||||
double precision, allocatable :: pt2(:,:), norm_pert(:,:), H_pert_diag(:,:)
|
||||
allocate ( pt2(N_states,2), norm_pert(N_states,2), H_pert_diag(N_states,2))
|
||||
|
||||
pt2 = 0.d0
|
||||
norm_pert = 0.d0
|
||||
H_pert_diag = 0.d0
|
||||
accu = 0_8
|
||||
more = 1
|
||||
do while (more == 1)
|
||||
|
||||
call pull_pt2(zmq_socket_pull, pt2, norm_pert, H_pert_diag, N_states, n, task_id)
|
||||
if (n > 0) then
|
||||
do k=1,N_states
|
||||
pt2(k,2) = pt2(k,1) + pt2(k,2)
|
||||
norm_pert(k,2) = norm_pert(k,1) + norm_pert(k,2)
|
||||
H_pert_diag(k,2) = H_pert_diag(k,1) + H_pert_diag(k,2)
|
||||
enddo
|
||||
accu = accu + 1_8
|
||||
call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more)
|
||||
endif
|
||||
|
||||
enddo
|
||||
|
||||
call end_zmq_pull_socket(zmq_socket_pull)
|
||||
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
|
||||
|
||||
|
||||
integer(ZMQ_PTR), external :: new_zmq_pair_socket
|
||||
integer(ZMQ_PTR) :: socket_result
|
||||
|
||||
socket_result = new_zmq_pair_socket(.False.)
|
||||
|
||||
call push_pt2(socket_result, pt2(1,2), norm_pert(1,2), H_pert_diag(1,2), N_states,0)
|
||||
|
||||
deallocate ( pt2, norm_pert, H_pert_diag)
|
||||
|
||||
call end_zmq_pair_socket(socket_result)
|
||||
|
||||
end
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -386,66 +386,6 @@ subroutine sort_dets_by_det_search_key(Ndet, det_in, coef_in, det_out, coef_out)
|
||||
end
|
||||
|
||||
|
||||
subroutine int_of_3_highest_electrons( det_in, res, Nint )
|
||||
implicit none
|
||||
use bitmasks
|
||||
integer,intent(in) :: Nint
|
||||
integer(bit_kind) :: det_in(Nint)
|
||||
integer*8 :: res
|
||||
BEGIN_DOC
|
||||
! Returns an integer*8 as :
|
||||
!
|
||||
! |_<--- 21 bits ---><--- 21 bits ---><--- 21 bits --->|
|
||||
!
|
||||
! |0<--- i1 ---><--- i2 ---><--- i3 --->|
|
||||
!
|
||||
! It encodes the value of the indices of the 3 highest MOs
|
||||
! in descending order
|
||||
!
|
||||
END_DOC
|
||||
integer :: i, k, icount
|
||||
integer(bit_kind) :: ix
|
||||
res = 0_8
|
||||
icount = 3
|
||||
do k=Nint,1,-1
|
||||
ix = det_in(k)
|
||||
do while (ix /= 0_bit_kind)
|
||||
i = bit_kind_size-1-leadz(ix)
|
||||
ix = ibclr(ix,i)
|
||||
res = ior(ishft(res, 21), i+ishft(k-1,bit_kind_shift))
|
||||
icount -= 1
|
||||
if (icount == 0) then
|
||||
return
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
end
|
||||
|
||||
subroutine filter_3_highest_electrons( det_in, det_out, Nint )
|
||||
implicit none
|
||||
use bitmasks
|
||||
integer,intent(in) :: Nint
|
||||
integer(bit_kind) :: det_in(Nint), det_out(Nint)
|
||||
BEGIN_DOC
|
||||
! Returns a determinant with only the 3 highest electrons
|
||||
END_DOC
|
||||
integer :: i, k, icount
|
||||
integer(bit_kind) :: ix
|
||||
det_out = 0_8
|
||||
icount = 3
|
||||
do k=Nint,1,-1
|
||||
ix = det_in(k)
|
||||
do while (ix /= 0_bit_kind)
|
||||
i = bit_kind_size-1-leadz(ix)
|
||||
ix = ibclr(ix,i)
|
||||
det_out(k) = ibset(det_out(k),i)
|
||||
icount -= 1
|
||||
if (icount == 0) then
|
||||
return
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
end
|
||||
|
||||
BEGIN_PROVIDER [ double precision, psi_coef_max, (N_states) ]
|
||||
&BEGIN_PROVIDER [ double precision, psi_coef_min, (N_states) ]
|
||||
@ -465,130 +405,6 @@ end
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_ab, (N_int,2,psi_det_size) ]
|
||||
&BEGIN_PROVIDER [ double precision, psi_coef_sorted_ab, (N_det,N_states) ]
|
||||
&BEGIN_PROVIDER [ integer, psi_det_sorted_next_ab, (2,psi_det_size) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Determinants on which we apply <i|H|j>.
|
||||
! They are sorted by the 3 highest electrons in the alpha part,
|
||||
! then by the 3 highest electrons in the beta part to accelerate
|
||||
! the research of connected determinants.
|
||||
END_DOC
|
||||
|
||||
call sort_dets_by_3_highest_electrons( &
|
||||
psi_det, &
|
||||
psi_coef, &
|
||||
psi_det_sorted_ab, &
|
||||
psi_coef_sorted_ab, &
|
||||
psi_det_sorted_next_ab, &
|
||||
N_det, N_states, N_int, &
|
||||
psi_det_size )
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
subroutine sort_dets_by_3_highest_electrons(det_in,coef_in,det_out,coef_out, &
|
||||
det_next, Ndet, Nstates, Nint, LDA)
|
||||
implicit none
|
||||
integer, intent(in) :: Ndet, Nstates, Nint, LDA
|
||||
integer(bit_kind), intent(in) :: det_in (Nint,2,Ndet)
|
||||
integer(bit_kind), intent(out) :: det_out (Nint,2,Ndet)
|
||||
integer, intent(out) :: det_next (2,Ndet)
|
||||
double precision, intent(in) :: coef_in (LDA,Nstates)
|
||||
double precision, intent(out) :: coef_out (LDA,Nstates)
|
||||
BEGIN_DOC
|
||||
! Determinants on which we apply <i|H|j>.
|
||||
! They are sorted by the 3 highest electrons in the alpha part,
|
||||
! then by the 3 highest electrons in the beta part to accelerate
|
||||
! the research of connected determinants.
|
||||
END_DOC
|
||||
integer :: i,j,k
|
||||
integer, allocatable :: iorder(:)
|
||||
integer*8, allocatable :: bit_tmp(:)
|
||||
integer*8, external :: det_search_key
|
||||
|
||||
allocate ( iorder(Ndet), bit_tmp(Ndet) )
|
||||
|
||||
! Sort alpha dets
|
||||
! ---------------
|
||||
|
||||
integer(bit_kind) :: det_tmp(Nint)
|
||||
|
||||
do i=1,Ndet
|
||||
iorder(i) = i
|
||||
call int_of_3_highest_electrons(psi_det(1,1,i),bit_tmp(i),N_int)
|
||||
enddo
|
||||
call i8sort(bit_tmp,iorder,Ndet)
|
||||
!DIR$ IVDEP
|
||||
do i=1,Ndet
|
||||
do j=1,N_int
|
||||
det_out(j,1,i) = psi_det(j,1,iorder(i))
|
||||
det_out(j,2,i) = psi_det(j,2,iorder(i))
|
||||
enddo
|
||||
do k=1,Nstates
|
||||
coef_out(i,k) = psi_coef(iorder(i),k)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! Find next alpha
|
||||
! ---------------
|
||||
|
||||
integer :: next
|
||||
|
||||
next = Ndet+1
|
||||
det_next(1,Ndet) = next
|
||||
do i=Ndet-1,1,-1
|
||||
if (bit_tmp(i) /= bit_tmp(i+1)) then
|
||||
next = i+1
|
||||
endif
|
||||
det_next(1,i) = next
|
||||
enddo
|
||||
|
||||
! Sort beta dets
|
||||
! --------------
|
||||
|
||||
integer :: istart, iend
|
||||
integer(bit_kind), allocatable :: det_sorted_temp (:,:)
|
||||
|
||||
allocate ( det_sorted_temp (N_int,Ndet) )
|
||||
do i=1,Ndet
|
||||
do j=1,N_int
|
||||
det_sorted_temp(j,i) = det_out(j,2,i)
|
||||
enddo
|
||||
iorder(i) = i
|
||||
call int_of_3_highest_electrons(det_sorted_temp(1,i),bit_tmp(i),N_int)
|
||||
enddo
|
||||
|
||||
istart=1
|
||||
do while ( istart<Ndet )
|
||||
|
||||
iend = det_next(1,istart)
|
||||
call i8sort(bit_tmp(istart),iorder(istart),iend-istart)
|
||||
!DIR$ IVDEP
|
||||
do i=istart,iend-1
|
||||
do j=1,N_int
|
||||
det_out(j,2,i) = det_sorted_temp(j,iorder(i))
|
||||
enddo
|
||||
do k=1,Nstates
|
||||
coef_out(i,k) = psi_coef(iorder(i),k)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
next = iend
|
||||
det_next(2,iend-1) = next
|
||||
do i=iend-2,1,-1
|
||||
if (bit_tmp(i) /= bit_tmp(i+1)) then
|
||||
next = i+1
|
||||
endif
|
||||
det_next(2,i) = next
|
||||
enddo
|
||||
|
||||
istart = iend
|
||||
enddo
|
||||
|
||||
deallocate(iorder, bit_tmp, det_sorted_temp)
|
||||
|
||||
end
|
||||
|
||||
!==============================================================================!
|
||||
! !
|
||||
@ -645,7 +461,9 @@ end
|
||||
subroutine save_ref_determinant
|
||||
implicit none
|
||||
use bitmasks
|
||||
call save_wavefunction_general(1,1,ref_bitmask,1,1.d0)
|
||||
double precision :: buffer(1,1)
|
||||
buffer(1,1) = 1.d0
|
||||
call save_wavefunction_general(1,1,ref_bitmask,1,buffer)
|
||||
end
|
||||
|
||||
|
||||
|
@ -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
|
||||
|
||||
cur_microlist(:) = ptr_microlist(:)
|
||||
do i=0,mo_tot_num_2+1
|
||||
cur_microlist(i) = ptr_microlist(i)
|
||||
end do
|
||||
|
||||
|
||||
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
|
||||
|
@ -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
|
||||
|
@ -443,7 +443,7 @@ subroutine i_H_j(key_i,key_j,Nint,hij)
|
||||
|
||||
integer :: exc(0:2,2,2)
|
||||
integer :: degree
|
||||
double precision :: get_mo_bielec_integral_schwartz
|
||||
double precision :: get_mo_bielec_integral
|
||||
integer :: m,n,p,q
|
||||
integer :: i,j,k
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
@ -468,31 +468,31 @@ subroutine i_H_j(key_i,key_j,Nint,hij)
|
||||
call get_double_excitation(key_i,key_j,exc,phase,Nint)
|
||||
if (exc(0,1,1) == 1) then
|
||||
! Mono alpha, mono beta
|
||||
hij = phase*get_mo_bielec_integral_schwartz( &
|
||||
hij = phase*get_mo_bielec_integral( &
|
||||
exc(1,1,1), &
|
||||
exc(1,1,2), &
|
||||
exc(1,2,1), &
|
||||
exc(1,2,2) ,mo_integrals_map)
|
||||
else if (exc(0,1,1) == 2) then
|
||||
! Double alpha
|
||||
hij = phase*(get_mo_bielec_integral_schwartz( &
|
||||
hij = phase*(get_mo_bielec_integral( &
|
||||
exc(1,1,1), &
|
||||
exc(2,1,1), &
|
||||
exc(1,2,1), &
|
||||
exc(2,2,1) ,mo_integrals_map) - &
|
||||
get_mo_bielec_integral_schwartz( &
|
||||
get_mo_bielec_integral( &
|
||||
exc(1,1,1), &
|
||||
exc(2,1,1), &
|
||||
exc(2,2,1), &
|
||||
exc(1,2,1) ,mo_integrals_map) )
|
||||
else if (exc(0,1,2) == 2) then
|
||||
! Double beta
|
||||
hij = phase*(get_mo_bielec_integral_schwartz( &
|
||||
hij = phase*(get_mo_bielec_integral( &
|
||||
exc(1,1,2), &
|
||||
exc(2,1,2), &
|
||||
exc(1,2,2), &
|
||||
exc(2,2,2) ,mo_integrals_map) - &
|
||||
get_mo_bielec_integral_schwartz( &
|
||||
get_mo_bielec_integral( &
|
||||
exc(1,1,2), &
|
||||
exc(2,1,2), &
|
||||
exc(2,2,2), &
|
||||
@ -510,15 +510,15 @@ subroutine i_H_j(key_i,key_j,Nint,hij)
|
||||
do k = 1, elec_alpha_num
|
||||
i = occ(k,1)
|
||||
if (.not.has_mipi(i)) then
|
||||
mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map)
|
||||
miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map)
|
||||
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
|
||||
miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map)
|
||||
has_mipi(i) = .True.
|
||||
endif
|
||||
enddo
|
||||
do k = 1, elec_beta_num
|
||||
i = occ(k,2)
|
||||
if (.not.has_mipi(i)) then
|
||||
mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map)
|
||||
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
|
||||
has_mipi(i) = .True.
|
||||
endif
|
||||
enddo
|
||||
@ -537,15 +537,15 @@ subroutine i_H_j(key_i,key_j,Nint,hij)
|
||||
do k = 1, elec_beta_num
|
||||
i = occ(k,2)
|
||||
if (.not.has_mipi(i)) then
|
||||
mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map)
|
||||
miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map)
|
||||
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
|
||||
miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map)
|
||||
has_mipi(i) = .True.
|
||||
endif
|
||||
enddo
|
||||
do k = 1, elec_alpha_num
|
||||
i = occ(k,1)
|
||||
if (.not.has_mipi(i)) then
|
||||
mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map)
|
||||
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
|
||||
has_mipi(i) = .True.
|
||||
endif
|
||||
enddo
|
||||
@ -579,7 +579,7 @@ subroutine i_H_j_phase_out(key_i,key_j,Nint,hij,phase,exc,degree)
|
||||
|
||||
integer,intent(out) :: exc(0:2,2,2)
|
||||
integer,intent(out) :: degree
|
||||
double precision :: get_mo_bielec_integral_schwartz
|
||||
double precision :: get_mo_bielec_integral
|
||||
integer :: m,n,p,q
|
||||
integer :: i,j,k
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
@ -604,31 +604,31 @@ subroutine i_H_j_phase_out(key_i,key_j,Nint,hij,phase,exc,degree)
|
||||
call get_double_excitation(key_i,key_j,exc,phase,Nint)
|
||||
if (exc(0,1,1) == 1) then
|
||||
! Mono alpha, mono beta
|
||||
hij = phase*get_mo_bielec_integral_schwartz( &
|
||||
hij = phase*get_mo_bielec_integral( &
|
||||
exc(1,1,1), &
|
||||
exc(1,1,2), &
|
||||
exc(1,2,1), &
|
||||
exc(1,2,2) ,mo_integrals_map)
|
||||
else if (exc(0,1,1) == 2) then
|
||||
! Double alpha
|
||||
hij = phase*(get_mo_bielec_integral_schwartz( &
|
||||
hij = phase*(get_mo_bielec_integral( &
|
||||
exc(1,1,1), &
|
||||
exc(2,1,1), &
|
||||
exc(1,2,1), &
|
||||
exc(2,2,1) ,mo_integrals_map) - &
|
||||
get_mo_bielec_integral_schwartz( &
|
||||
get_mo_bielec_integral( &
|
||||
exc(1,1,1), &
|
||||
exc(2,1,1), &
|
||||
exc(2,2,1), &
|
||||
exc(1,2,1) ,mo_integrals_map) )
|
||||
else if (exc(0,1,2) == 2) then
|
||||
! Double beta
|
||||
hij = phase*(get_mo_bielec_integral_schwartz( &
|
||||
hij = phase*(get_mo_bielec_integral( &
|
||||
exc(1,1,2), &
|
||||
exc(2,1,2), &
|
||||
exc(1,2,2), &
|
||||
exc(2,2,2) ,mo_integrals_map) - &
|
||||
get_mo_bielec_integral_schwartz( &
|
||||
get_mo_bielec_integral( &
|
||||
exc(1,1,2), &
|
||||
exc(2,1,2), &
|
||||
exc(2,2,2), &
|
||||
@ -646,15 +646,15 @@ subroutine i_H_j_phase_out(key_i,key_j,Nint,hij,phase,exc,degree)
|
||||
do k = 1, elec_alpha_num
|
||||
i = occ(k,1)
|
||||
if (.not.has_mipi(i)) then
|
||||
mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map)
|
||||
miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map)
|
||||
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
|
||||
miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map)
|
||||
has_mipi(i) = .True.
|
||||
endif
|
||||
enddo
|
||||
do k = 1, elec_beta_num
|
||||
i = occ(k,2)
|
||||
if (.not.has_mipi(i)) then
|
||||
mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map)
|
||||
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
|
||||
has_mipi(i) = .True.
|
||||
endif
|
||||
enddo
|
||||
@ -673,15 +673,15 @@ subroutine i_H_j_phase_out(key_i,key_j,Nint,hij,phase,exc,degree)
|
||||
do k = 1, elec_beta_num
|
||||
i = occ(k,2)
|
||||
if (.not.has_mipi(i)) then
|
||||
mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map)
|
||||
miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map)
|
||||
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
|
||||
miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map)
|
||||
has_mipi(i) = .True.
|
||||
endif
|
||||
enddo
|
||||
do k = 1, elec_alpha_num
|
||||
i = occ(k,1)
|
||||
if (.not.has_mipi(i)) then
|
||||
mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map)
|
||||
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
|
||||
has_mipi(i) = .True.
|
||||
endif
|
||||
enddo
|
||||
@ -715,7 +715,7 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble)
|
||||
|
||||
integer :: exc(0:2,2,2)
|
||||
integer :: degree
|
||||
double precision :: get_mo_bielec_integral_schwartz
|
||||
double precision :: get_mo_bielec_integral
|
||||
integer :: m,n,p,q
|
||||
integer :: i,j,k
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
@ -742,31 +742,31 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble)
|
||||
call get_double_excitation(key_i,key_j,exc,phase,Nint)
|
||||
if (exc(0,1,1) == 1) then
|
||||
! Mono alpha, mono beta
|
||||
hij = phase*get_mo_bielec_integral_schwartz( &
|
||||
hij = phase*get_mo_bielec_integral( &
|
||||
exc(1,1,1), &
|
||||
exc(1,1,2), &
|
||||
exc(1,2,1), &
|
||||
exc(1,2,2) ,mo_integrals_map)
|
||||
else if (exc(0,1,1) == 2) then
|
||||
! Double alpha
|
||||
hij = phase*(get_mo_bielec_integral_schwartz( &
|
||||
hij = phase*(get_mo_bielec_integral( &
|
||||
exc(1,1,1), &
|
||||
exc(2,1,1), &
|
||||
exc(1,2,1), &
|
||||
exc(2,2,1) ,mo_integrals_map) - &
|
||||
get_mo_bielec_integral_schwartz( &
|
||||
get_mo_bielec_integral( &
|
||||
exc(1,1,1), &
|
||||
exc(2,1,1), &
|
||||
exc(2,2,1), &
|
||||
exc(1,2,1) ,mo_integrals_map) )
|
||||
else if (exc(0,1,2) == 2) then
|
||||
! Double beta
|
||||
hij = phase*(get_mo_bielec_integral_schwartz( &
|
||||
hij = phase*(get_mo_bielec_integral( &
|
||||
exc(1,1,2), &
|
||||
exc(2,1,2), &
|
||||
exc(1,2,2), &
|
||||
exc(2,2,2) ,mo_integrals_map) - &
|
||||
get_mo_bielec_integral_schwartz( &
|
||||
get_mo_bielec_integral( &
|
||||
exc(1,1,2), &
|
||||
exc(2,1,2), &
|
||||
exc(2,2,2), &
|
||||
@ -784,15 +784,15 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble)
|
||||
do k = 1, elec_alpha_num
|
||||
i = occ(k,1)
|
||||
if (.not.has_mipi(i)) then
|
||||
mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map)
|
||||
miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map)
|
||||
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
|
||||
miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map)
|
||||
has_mipi(i) = .True.
|
||||
endif
|
||||
enddo
|
||||
do k = 1, elec_beta_num
|
||||
i = occ(k,2)
|
||||
if (.not.has_mipi(i)) then
|
||||
mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map)
|
||||
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
|
||||
has_mipi(i) = .True.
|
||||
endif
|
||||
enddo
|
||||
@ -811,15 +811,15 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble)
|
||||
do k = 1, elec_beta_num
|
||||
i = occ(k,2)
|
||||
if (.not.has_mipi(i)) then
|
||||
mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map)
|
||||
miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map)
|
||||
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
|
||||
miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map)
|
||||
has_mipi(i) = .True.
|
||||
endif
|
||||
enddo
|
||||
do k = 1, elec_alpha_num
|
||||
i = occ(k,1)
|
||||
if (.not.has_mipi(i)) then
|
||||
mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map)
|
||||
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
|
||||
has_mipi(i) = .True.
|
||||
endif
|
||||
enddo
|
||||
@ -845,25 +845,30 @@ subroutine create_minilist(key_mask, fullList, miniList, idx_miniList, N_fullLis
|
||||
use bitmasks
|
||||
implicit none
|
||||
|
||||
integer(bit_kind), intent(in) :: fullList(Nint, 2, N_fullList)
|
||||
integer, intent(in) :: N_fullList
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: fullList(Nint, 2, N_fullList)
|
||||
integer(bit_kind),intent(out) :: miniList(Nint, 2, N_fullList)
|
||||
integer,intent(out) :: idx_miniList(N_fullList), N_miniList
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind) :: key_mask(Nint, 2)
|
||||
integer :: ni, i, n_a, n_b, e_a, e_b
|
||||
integer :: ni, k, i, n_a, n_b, e_a, e_b
|
||||
|
||||
|
||||
n_a = 0
|
||||
n_b = 0
|
||||
do ni=1,nint
|
||||
n_a = popcnt(key_mask(1,1))
|
||||
n_b = popcnt(key_mask(1,2))
|
||||
do ni=2,nint
|
||||
n_a = n_a + popcnt(key_mask(ni,1))
|
||||
n_b = n_b + popcnt(key_mask(ni,2))
|
||||
end do
|
||||
|
||||
if(n_a == 0) then
|
||||
N_miniList = N_fullList
|
||||
miniList(:,:,:) = fullList(:,:,:)
|
||||
do k=1,N_fullList
|
||||
do ni=1,Nint
|
||||
miniList(ni,1,k) = fullList(ni,1,k)
|
||||
miniList(ni,2,k) = fullList(ni,2,k)
|
||||
enddo
|
||||
enddo
|
||||
do i=1,N_fullList
|
||||
idx_miniList(i) = i
|
||||
end do
|
||||
@ -873,16 +878,19 @@ subroutine create_minilist(key_mask, fullList, miniList, idx_miniList, N_fullLis
|
||||
N_miniList = 0
|
||||
|
||||
do i=1,N_fullList
|
||||
e_a = n_a
|
||||
e_b = n_b
|
||||
do ni=1,nint
|
||||
e_a = n_a - popcnt(iand(fullList(1, 1, i), key_mask(1, 1)))
|
||||
e_b = n_b - popcnt(iand(fullList(1, 2, i), key_mask(1, 2)))
|
||||
do ni=2,nint
|
||||
e_a -= popcnt(iand(fullList(ni, 1, i), key_mask(ni, 1)))
|
||||
e_b -= popcnt(iand(fullList(ni, 2, i), key_mask(ni, 2)))
|
||||
end do
|
||||
|
||||
if(e_a + e_b <= 2) then
|
||||
N_miniList = N_miniList + 1
|
||||
miniList(:,:,N_miniList) = fullList(:,:,i)
|
||||
do ni=1,Nint
|
||||
miniList(ni,1,N_miniList) = fullList(ni,1,i)
|
||||
miniList(ni,2,N_miniList) = fullList(ni,2,i)
|
||||
enddo
|
||||
idx_miniList(N_miniList) = i
|
||||
end if
|
||||
end do
|
||||
@ -892,29 +900,34 @@ subroutine create_minilist_find_previous(key_mask, fullList, miniList, N_fullLis
|
||||
use bitmasks
|
||||
implicit none
|
||||
|
||||
integer(bit_kind), intent(in) :: fullList(Nint, 2, N_fullList)
|
||||
integer, intent(in) :: N_fullList
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: fullList(Nint, 2, N_fullList)
|
||||
integer(bit_kind),intent(out) :: miniList(Nint, 2, N_fullList)
|
||||
integer(bit_kind) :: subList(Nint, 2, N_fullList)
|
||||
logical,intent(out) :: fullMatch
|
||||
integer,intent(out) :: N_miniList
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind) :: key_mask(Nint, 2)
|
||||
integer :: ni, i, k, l, N_subList
|
||||
|
||||
|
||||
fullMatch = .false.
|
||||
l = 0
|
||||
N_miniList = 0
|
||||
N_subList = 0
|
||||
|
||||
do ni = 1,Nint
|
||||
l += popcnt(key_mask(ni,1)) + popcnt(key_mask(ni,2))
|
||||
l = popcnt(key_mask(1,1)) + popcnt(key_mask(1,2))
|
||||
do ni = 2,Nint
|
||||
l = l + popcnt(key_mask(ni,1)) + popcnt(key_mask(ni,2))
|
||||
end do
|
||||
|
||||
if(l == 0) then
|
||||
N_miniList = N_fullList
|
||||
miniList(:,:,:N_miniList) = fullList(:,:,:N_minilist)
|
||||
do k=1,N_fullList
|
||||
do ni=1,Nint
|
||||
miniList(ni,1,k) = fullList(ni,1,k)
|
||||
miniList(ni,2,k) = fullList(ni,2,k)
|
||||
enddo
|
||||
enddo
|
||||
else
|
||||
do i=N_fullList,1,-1
|
||||
k = l
|
||||
@ -923,10 +936,16 @@ subroutine create_minilist_find_previous(key_mask, fullList, miniList, N_fullLis
|
||||
end do
|
||||
if(k == 2) then
|
||||
N_subList += 1
|
||||
subList(:,:,N_subList) = fullList(:,:,i)
|
||||
do ni=1,Nint
|
||||
subList(ni,1,N_subList) = fullList(ni,1,i)
|
||||
subList(ni,2,N_subList) = fullList(ni,2,i)
|
||||
enddo
|
||||
else if(k == 1) then
|
||||
N_minilist += 1
|
||||
miniList(:,:,N_minilist) = fullList(:,:,i)
|
||||
do ni=1,Nint
|
||||
miniList(ni,1,N_minilist) = fullList(ni,1,i)
|
||||
miniList(ni,2,N_minilist) = fullList(ni,2,i)
|
||||
enddo
|
||||
else if(k == 0) then
|
||||
fullMatch = .true.
|
||||
return
|
||||
@ -935,7 +954,12 @@ subroutine create_minilist_find_previous(key_mask, fullList, miniList, N_fullLis
|
||||
end if
|
||||
|
||||
if(N_subList > 0) then
|
||||
miniList(:,:,N_minilist+1:N_minilist+N_subList) = sublist(:,:,:N_subList)
|
||||
do k=1,N_subList
|
||||
do ni=1,Nint
|
||||
miniList(ni,1,N_minilist+k) = sublist(ni,1,k)
|
||||
miniList(ni,2,N_minilist+k) = sublist(ni,2,k)
|
||||
enddo
|
||||
enddo
|
||||
N_minilist = N_minilist + N_subList
|
||||
end if
|
||||
end subroutine
|
||||
@ -972,14 +996,28 @@ subroutine i_H_psi(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array)
|
||||
i_H_psi_array = 0.d0
|
||||
|
||||
call filter_connected_i_H_psi0(keys,key,Nint,Ndet,idx)
|
||||
do ii=1,idx(0)
|
||||
i = idx(ii)
|
||||
!DIR$ FORCEINLINE
|
||||
call i_H_j(keys(1,1,i),key,Nint,hij)
|
||||
do j = 1, Nstate
|
||||
i_H_psi_array(j) = i_H_psi_array(j) + coef(i,j)*hij
|
||||
if (Nstate == 1) then
|
||||
|
||||
do ii=1,idx(0)
|
||||
i = idx(ii)
|
||||
!DIR$ FORCEINLINE
|
||||
call i_H_j(keys(1,1,i),key,Nint,hij)
|
||||
i_H_psi_array(1) = i_H_psi_array(1) + coef(i,1)*hij
|
||||
enddo
|
||||
enddo
|
||||
|
||||
else
|
||||
|
||||
do ii=1,idx(0)
|
||||
i = idx(ii)
|
||||
!DIR$ FORCEINLINE
|
||||
call i_H_j(keys(1,1,i),key,Nint,hij)
|
||||
do j = 1, Nstate
|
||||
i_H_psi_array(j) = i_H_psi_array(j) + coef(i,j)*hij
|
||||
enddo
|
||||
enddo
|
||||
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
|
||||
@ -1012,15 +1050,30 @@ subroutine i_H_psi_minilist(key,keys,idx_key,N_minilist,coef,Nint,Ndet,Ndet_max,
|
||||
i_H_psi_array = 0.d0
|
||||
|
||||
call filter_connected_i_H_psi0(keys,key,Nint,N_minilist,idx)
|
||||
do ii=1,idx(0)
|
||||
i_in_key = idx(ii)
|
||||
i_in_coef = idx_key(idx(ii))
|
||||
!DIR$ FORCEINLINE
|
||||
call i_H_j(keys(1,1,i_in_key),key,Nint,hij)
|
||||
do j = 1, Nstate
|
||||
i_H_psi_array(j) = i_H_psi_array(j) + coef(i_in_coef,j)*hij
|
||||
if (Nstate == 1) then
|
||||
|
||||
do ii=1,idx(0)
|
||||
i_in_key = idx(ii)
|
||||
i_in_coef = idx_key(idx(ii))
|
||||
!DIR$ FORCEINLINE
|
||||
call i_H_j(keys(1,1,i_in_key),key,Nint,hij)
|
||||
i_H_psi_array(1) = i_H_psi_array(1) + coef(i_in_coef,1)*hij
|
||||
enddo
|
||||
enddo
|
||||
|
||||
else
|
||||
|
||||
do ii=1,idx(0)
|
||||
i_in_key = idx(ii)
|
||||
i_in_coef = idx_key(idx(ii))
|
||||
!DIR$ FORCEINLINE
|
||||
call i_H_j(keys(1,1,i_in_key),key,Nint,hij)
|
||||
do j = 1, Nstate
|
||||
i_H_psi_array(j) = i_H_psi_array(j) + coef(i_in_coef,j)*hij
|
||||
enddo
|
||||
enddo
|
||||
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
subroutine i_H_psi_sec_ord(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array,idx_interaction,interactions)
|
||||
@ -1497,8 +1550,8 @@ subroutine get_occ_from_key(key,occ,Nint)
|
||||
BEGIN_DOC
|
||||
! Returns a list of occupation numbers from a bitstring
|
||||
END_DOC
|
||||
integer(bit_kind), intent(in) :: key(Nint,2)
|
||||
integer , intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key(Nint,2)
|
||||
integer , intent(out) :: occ(Nint*bit_kind_size,2)
|
||||
integer :: tmp(2)
|
||||
|
||||
@ -1675,3 +1728,55 @@ subroutine H_u_0(v_0,u_0,H_jj,n,keys_tmp,Nint)
|
||||
deallocate (shortcut, sort_idx, sorted, version)
|
||||
end
|
||||
|
||||
|
||||
subroutine apply_excitation(det, exc, res, ok, Nint)
|
||||
use bitmasks
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: Nint
|
||||
integer, intent(in) :: exc(0:2,2,2)
|
||||
integer(bit_kind),intent(in) :: det(Nint, 2)
|
||||
integer(bit_kind),intent(out) :: res(Nint, 2)
|
||||
logical, intent(out) :: ok
|
||||
integer :: h1,p1,h2,p2,s1,s2,degree
|
||||
integer :: ii, pos
|
||||
|
||||
|
||||
ok = .false.
|
||||
degree = exc(0,1,1) + exc(0,1,2)
|
||||
|
||||
if(.not. (degree > 0 .and. degree <= 2)) then
|
||||
print *, degree
|
||||
print *, "apply ex"
|
||||
STOP
|
||||
endif
|
||||
|
||||
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
|
||||
res = det
|
||||
|
||||
ii = (h1-1)/bit_kind_size + 1
|
||||
pos = mod(h1-1, 64)!iand(h1-1,bit_kind_size-1) ! mod 64
|
||||
if(iand(det(ii, s1), ishft(1_bit_kind, pos)) == 0_8) return
|
||||
res(ii, s1) = ibclr(res(ii, s1), pos)
|
||||
|
||||
ii = (p1-1)/bit_kind_size + 1
|
||||
pos = mod(p1-1, 64)!iand(p1-1,bit_kind_size-1)
|
||||
if(iand(det(ii, s1), ishft(1_bit_kind, pos)) /= 0_8) return
|
||||
res(ii, s1) = ibset(res(ii, s1), pos)
|
||||
|
||||
if(degree == 2) then
|
||||
ii = (h2-1)/bit_kind_size + 1
|
||||
pos = mod(h2-1, 64)!iand(h2-1,bit_kind_size-1)
|
||||
if(iand(det(ii, s2), ishft(1_bit_kind, pos)) == 0_8) return
|
||||
res(ii, s2) = ibclr(res(ii, s2), pos)
|
||||
|
||||
ii = (p2-1)/bit_kind_size + 1
|
||||
pos = mod(p2-1, 64)!iand(p2-1,bit_kind_size-1)
|
||||
if(iand(det(ii, s2), ishft(1_bit_kind, pos)) /= 0_8) return
|
||||
res(ii, s2) = ibset(res(ii, s2), pos)
|
||||
endif
|
||||
|
||||
ok = .true.
|
||||
end subroutine
|
||||
|
||||
|
||||
|
@ -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
|
||||
|
||||
|
||||
|
@ -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)
|
||||
|
@ -1,20 +1,73 @@
|
||||
subroutine ao_bielec_integrals_in_map_slave_tcp
|
||||
subroutine ao_bielec_integrals_in_map_slave_tcp(i)
|
||||
implicit none
|
||||
integer, intent(in) :: i
|
||||
BEGIN_DOC
|
||||
! Computes a buffer of integrals
|
||||
! Computes a buffer of integrals. i is the ID of the current thread.
|
||||
END_DOC
|
||||
call ao_bielec_integrals_in_map_slave(0)
|
||||
call ao_bielec_integrals_in_map_slave(0,i)
|
||||
end
|
||||
|
||||
subroutine ao_bielec_integrals_in_map_slave_inproc
|
||||
|
||||
subroutine ao_bielec_integrals_in_map_slave_inproc(i)
|
||||
implicit none
|
||||
integer, intent(in) :: i
|
||||
BEGIN_DOC
|
||||
! Computes a buffer of integrals
|
||||
! Computes a buffer of integrals. i is the ID of the current thread.
|
||||
END_DOC
|
||||
call ao_bielec_integrals_in_map_slave(1)
|
||||
call ao_bielec_integrals_in_map_slave(1,i)
|
||||
end
|
||||
|
||||
subroutine ao_bielec_integrals_in_map_slave(thread)
|
||||
|
||||
subroutine push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, task_id)
|
||||
use f77_zmq
|
||||
use map_module
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Push integrals in the push socket
|
||||
END_DOC
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_socket_push
|
||||
integer, intent(in) :: n_integrals
|
||||
integer(key_kind), intent(in) :: buffer_i(*)
|
||||
real(integral_kind), intent(in) :: buffer_value(*)
|
||||
integer, intent(in) :: task_id
|
||||
integer :: rc
|
||||
|
||||
rc = f77_zmq_send( zmq_socket_push, n_integrals, 4, ZMQ_SNDMORE)
|
||||
if (rc /= 4) then
|
||||
print *, irp_here, 'f77_zmq_send( zmq_socket_push, n_integrals, 4, ZMQ_SNDMORE)'
|
||||
stop 'error'
|
||||
endif
|
||||
|
||||
rc = f77_zmq_send( zmq_socket_push, buffer_i, key_kind*n_integrals, ZMQ_SNDMORE)
|
||||
if (rc /= key_kind*n_integrals) then
|
||||
print *, irp_here, 'f77_zmq_send( zmq_socket_push, buffer_i, key_kind*n_integrals, ZMQ_SNDMORE)'
|
||||
stop 'error'
|
||||
endif
|
||||
|
||||
rc = f77_zmq_send( zmq_socket_push, buffer_value, integral_kind*n_integrals, ZMQ_SNDMORE)
|
||||
if (rc /= integral_kind*n_integrals) then
|
||||
print *, irp_here, 'f77_zmq_send( zmq_socket_push, buffer_value, integral_kind*n_integrals, 0)'
|
||||
stop 'error'
|
||||
endif
|
||||
|
||||
rc = f77_zmq_send( zmq_socket_push, task_id, 4, 0)
|
||||
if (rc /= 4) then
|
||||
print *, irp_here, 'f77_zmq_send( zmq_socket_push, task_id, 4, 0)'
|
||||
stop 'error'
|
||||
endif
|
||||
|
||||
! Activate is zmq_socket_push is a REQ
|
||||
! integer :: idummy
|
||||
! rc = f77_zmq_recv( zmq_socket_push, idummy, 4, 0)
|
||||
! if (rc /= 4) then
|
||||
! print *, irp_here, 'f77_zmq_send( zmq_socket_push, idummy, 4, 0)'
|
||||
! stop 'error'
|
||||
! endif
|
||||
end
|
||||
|
||||
|
||||
|
||||
subroutine ao_bielec_integrals_in_map_slave(thread,iproc)
|
||||
use map_module
|
||||
use f77_zmq
|
||||
implicit none
|
||||
@ -22,7 +75,7 @@ subroutine ao_bielec_integrals_in_map_slave(thread)
|
||||
! Computes a buffer of integrals
|
||||
END_DOC
|
||||
|
||||
integer, intent(in) :: thread
|
||||
integer, intent(in) :: thread, iproc
|
||||
|
||||
integer :: j,l,n_integrals
|
||||
integer :: rc
|
||||
@ -35,19 +88,11 @@ subroutine ao_bielec_integrals_in_map_slave(thread)
|
||||
integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
|
||||
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
|
||||
|
||||
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
|
||||
|
||||
integer(ZMQ_PTR), external :: new_zmq_push_socket
|
||||
integer(ZMQ_PTR) :: zmq_socket_push
|
||||
! zmq_socket_push = f77_zmq_socket(zmq_context, ZMQ_PUSH)
|
||||
zmq_socket_push = f77_zmq_socket(zmq_context, ZMQ_REQ )
|
||||
if (thread == 1) then
|
||||
rc = f77_zmq_connect(zmq_socket_push, trim(zmq_socket_pull_inproc_address))
|
||||
else
|
||||
rc = f77_zmq_connect(zmq_socket_push, trim(zmq_socket_push_tcp_address))
|
||||
endif
|
||||
if (rc /= 0) then
|
||||
stop 'Unable to connect zmq_socket_push_tcp'
|
||||
endif
|
||||
|
||||
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
|
||||
zmq_socket_push = new_zmq_push_socket(thread)
|
||||
|
||||
allocate ( buffer_i(ao_num*ao_num), buffer_value(ao_num*ao_num) )
|
||||
|
||||
@ -55,31 +100,78 @@ subroutine ao_bielec_integrals_in_map_slave(thread)
|
||||
|
||||
do
|
||||
call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task)
|
||||
if (task_id == 0) then
|
||||
exit
|
||||
endif
|
||||
read(task,*) j, l
|
||||
call compute_ao_integrals_jl(j,l,n_integrals,buffer_i,buffer_value)
|
||||
rc = f77_zmq_send( zmq_socket_push, n_integrals, 4, ZMQ_SNDMORE)
|
||||
rc = f77_zmq_send( zmq_socket_push, buffer_i, key_kind*n_integrals, ZMQ_SNDMORE)
|
||||
rc = f77_zmq_send( zmq_socket_push, buffer_value, integral_kind*n_integrals, 0)
|
||||
call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id)
|
||||
character*(2) :: ok
|
||||
rc = f77_zmq_recv( zmq_socket_push, ok, 2, 0)
|
||||
if (task_id == 0) exit
|
||||
read(task,*) l
|
||||
do j=1,l-1
|
||||
call compute_ao_integrals_jl(j,l,n_integrals,buffer_i,buffer_value)
|
||||
call push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, 0)
|
||||
enddo
|
||||
call compute_ao_integrals_jl(l,l,n_integrals,buffer_i,buffer_value)
|
||||
call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id,n_integrals)
|
||||
call push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, task_id)
|
||||
enddo
|
||||
|
||||
deallocate( buffer_i, buffer_value )
|
||||
|
||||
integer :: finished
|
||||
call disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id,finished)
|
||||
call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id)
|
||||
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
|
||||
call end_zmq_push_socket(zmq_socket_push,thread)
|
||||
|
||||
if (finished /= 0) then
|
||||
rc = f77_zmq_send( zmq_socket_push, -1, 4, 0)
|
||||
rc = f77_zmq_recv( zmq_socket_push, ok, 2, ZMQ_NOBLOCK)
|
||||
end
|
||||
|
||||
|
||||
subroutine pull_integrals(zmq_socket_pull, n_integrals, buffer_i, buffer_value, task_id)
|
||||
use f77_zmq
|
||||
use map_module
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! How the collector pulls the computed integrals
|
||||
END_DOC
|
||||
integer(ZMQ_PTR), intent(out) :: zmq_socket_pull
|
||||
integer, intent(out) :: n_integrals
|
||||
integer(key_kind), intent(out) :: buffer_i(*)
|
||||
real(integral_kind), intent(out) :: buffer_value(*)
|
||||
integer, intent(out) :: task_id
|
||||
integer :: rc
|
||||
|
||||
rc = f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0)
|
||||
if (rc == -1) then
|
||||
n_integrals = 0
|
||||
return
|
||||
endif
|
||||
if (rc /= 4) then
|
||||
print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0)'
|
||||
stop 'error'
|
||||
endif
|
||||
|
||||
rc = f77_zmq_disconnect(zmq_socket_push,trim(zmq_socket_push_tcp_address))
|
||||
rc = f77_zmq_close(zmq_socket_push)
|
||||
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
|
||||
|
||||
! Activate if zmq_socket_pull is a REP
|
||||
! rc = f77_zmq_send( zmq_socket_pull, 0, 4, 0)
|
||||
! if (rc /= 4) then
|
||||
! print *, irp_here, ' f77_zmq_send (zmq_socket_pull,...'
|
||||
! stop 'error'
|
||||
! endif
|
||||
|
||||
end
|
||||
|
||||
@ -94,27 +186,54 @@ subroutine ao_bielec_integrals_in_map_collector
|
||||
|
||||
integer :: j,l,n_integrals
|
||||
integer :: rc
|
||||
|
||||
real(integral_kind), allocatable :: buffer_value(:)
|
||||
integer(key_kind), allocatable :: buffer_i(:)
|
||||
|
||||
integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
|
||||
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
|
||||
|
||||
integer(ZMQ_PTR), external :: new_zmq_pull_socket
|
||||
integer(ZMQ_PTR) :: zmq_socket_pull
|
||||
|
||||
integer*8 :: control, accu
|
||||
integer :: task_id, more
|
||||
|
||||
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
|
||||
zmq_socket_pull = new_zmq_pull_socket()
|
||||
|
||||
allocate ( buffer_i(ao_num*ao_num), buffer_value(ao_num*ao_num) )
|
||||
|
||||
n_integrals = 0
|
||||
do while (n_integrals >= 0)
|
||||
accu = 0_8
|
||||
more = 1
|
||||
do while (more == 1)
|
||||
|
||||
rc = f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0)
|
||||
call pull_integrals(zmq_socket_pull, n_integrals, buffer_i, buffer_value, task_id)
|
||||
if (n_integrals >= 0) then
|
||||
rc = f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0)
|
||||
rc = f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0)
|
||||
rc = f77_zmq_send( zmq_socket_pull, 'ok', 2, 0)
|
||||
call insert_into_ao_integrals_map(n_integrals,buffer_i,buffer_value)
|
||||
else
|
||||
rc = f77_zmq_send( zmq_socket_pull, 'ok', 2, 0)
|
||||
accu += n_integrals
|
||||
if (task_id /= 0) then
|
||||
call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more)
|
||||
endif
|
||||
endif
|
||||
|
||||
enddo
|
||||
|
||||
deallocate( buffer_i, buffer_value )
|
||||
|
||||
integer (map_size_kind) :: get_ao_map_size
|
||||
control = get_ao_map_size(ao_integrals_map)
|
||||
|
||||
if (control /= accu) then
|
||||
print *, irp_here, 'Control : ', control
|
||||
print *, 'Accu : ', accu
|
||||
print *, 'Some integrals were lost during the parallel computation. (2)'
|
||||
print *, 'Try to reduce the number of threads.'
|
||||
stop
|
||||
endif
|
||||
|
||||
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
|
||||
call end_zmq_pull_socket(zmq_socket_pull)
|
||||
|
||||
end
|
||||
|
||||
|
@ -324,9 +324,9 @@ double precision function mo_bielec_integral(i,j,k,l)
|
||||
! Returns one integral <ij|kl> in the MO basis
|
||||
END_DOC
|
||||
integer, intent(in) :: i,j,k,l
|
||||
double precision :: get_mo_bielec_integral_schwartz
|
||||
double precision :: get_mo_bielec_integral
|
||||
PROVIDE mo_bielec_integrals_in_map
|
||||
mo_bielec_integral = get_mo_bielec_integral_schwartz(i,j,k,l,mo_integrals_map)
|
||||
mo_bielec_integral = get_mo_bielec_integral(i,j,k,l,mo_integrals_map)
|
||||
return
|
||||
end
|
||||
|
||||
|
@ -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
|
||||
|
||||
|
@ -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'
|
||||
|
@ -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
|
||||
|
@ -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) )
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -295,6 +295,18 @@ BEGIN_PROVIDER [ integer, nproc ]
|
||||
!$OMP END PARALLEL
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ integer, iproc_save, (nproc) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! iproc_save(i) = i-1. Used to start threads with pthreads.
|
||||
END_DOC
|
||||
integer :: i
|
||||
do i=1,nproc
|
||||
iproc_save(i) = i-1
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
double precision function u_dot_v(u,v,sze)
|
||||
implicit none
|
||||
@ -401,5 +413,21 @@ end
|
||||
|
||||
|
||||
|
||||
|
||||
subroutine lowercase(txt,n)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Transform to lower case
|
||||
END_DOC
|
||||
character*(*), intent(inout) :: txt
|
||||
integer, intent(in) :: n
|
||||
character( * ), PARAMETER :: LOWER_CASE = 'abcdefghijklmnopqrstuvwxyz'
|
||||
character( * ), PARAMETER :: UPPER_CASE = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
|
||||
integer :: i, ic
|
||||
do i=1,n
|
||||
ic = index( UPPER_CASE, txt(i:i) )
|
||||
if (ic /= 0) then
|
||||
txt(i:i) = LOWER_CASE(ic:ic)
|
||||
endif
|
||||
enddo
|
||||
end
|
||||
|
||||
|
759
src/ZMQ/utils.irp.f
Normal file
759
src/ZMQ/utils.irp.f
Normal file
@ -0,0 +1,759 @@
|
||||
use f77_zmq
|
||||
use omp_lib
|
||||
|
||||
integer, pointer :: thread_id
|
||||
integer(omp_lock_kind) :: zmq_lock
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ integer(ZMQ_PTR), zmq_context ]
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Context for the ZeroMQ library
|
||||
END_DOC
|
||||
call omp_init_lock(zmq_lock)
|
||||
zmq_context = 0_ZMQ_PTR
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ character*(128), qp_run_address ]
|
||||
&BEGIN_PROVIDER [ integer, zmq_port_start ]
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Address of the qp_run socket
|
||||
! Example : tcp://130.120.229.139:12345
|
||||
END_DOC
|
||||
character*(128) :: buffer
|
||||
call getenv('QP_RUN_ADDRESS',buffer)
|
||||
if (trim(buffer) == '') then
|
||||
print *, 'This run should be started with the qp_run command'
|
||||
stop -1
|
||||
endif
|
||||
|
||||
integer :: i
|
||||
do i=len(buffer),1,-1
|
||||
if ( buffer(i:i) == ':') then
|
||||
qp_run_address = trim(buffer(1:i-1))
|
||||
read(buffer(i+1:), *) zmq_port_start
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ character*(128), zmq_socket_pull_tcp_address ]
|
||||
&BEGIN_PROVIDER [ character*(128), zmq_socket_pair_inproc_address ]
|
||||
&BEGIN_PROVIDER [ character*(128), zmq_socket_push_tcp_address ]
|
||||
&BEGIN_PROVIDER [ character*(128), zmq_socket_pull_inproc_address ]
|
||||
&BEGIN_PROVIDER [ character*(128), zmq_socket_push_inproc_address ]
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Socket which pulls the results (2)
|
||||
END_DOC
|
||||
|
||||
character*(8), external :: zmq_port
|
||||
zmq_socket_pull_tcp_address = 'tcp://*:'//zmq_port(1)//' '
|
||||
zmq_socket_push_tcp_address = trim(qp_run_address)//':'//zmq_port(1)//' '
|
||||
zmq_socket_pull_inproc_address = 'inproc://'//zmq_port(1)//' '
|
||||
zmq_socket_push_inproc_address = zmq_socket_pull_inproc_address
|
||||
zmq_socket_pair_inproc_address = 'inproc://'//zmq_port(2)//' '
|
||||
END_PROVIDER
|
||||
|
||||
subroutine reset_zmq_addresses
|
||||
use f77_zmq
|
||||
implicit none
|
||||
character*(8), external :: zmq_port
|
||||
|
||||
zmq_socket_pull_tcp_address = 'tcp://*:'//zmq_port(1)//' '
|
||||
zmq_socket_push_tcp_address = trim(qp_run_address)//':'//zmq_port(1)//' '
|
||||
zmq_socket_pull_inproc_address = 'inproc://'//zmq_port(1)//' '
|
||||
zmq_socket_push_inproc_address = zmq_socket_pull_inproc_address
|
||||
zmq_socket_pair_inproc_address = 'inproc://'//zmq_port(2)//' '
|
||||
end
|
||||
|
||||
|
||||
subroutine switch_qp_run_to_master
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Address of the master qp_run socket
|
||||
! Example : tcp://130.120.229.139:12345
|
||||
END_DOC
|
||||
character*(128) :: buffer
|
||||
call getenv('QP_RUN_ADDRESS_MASTER',buffer)
|
||||
if (trim(buffer) == '') then
|
||||
print *, 'This run should be started with the qp_run command'
|
||||
stop -1
|
||||
endif
|
||||
qp_run_address = trim(buffer)
|
||||
|
||||
integer :: i
|
||||
do i=len(buffer),1,-1
|
||||
if ( buffer(i:i) == ':') then
|
||||
qp_run_address = trim(buffer(1:i-1))
|
||||
read(buffer(i+1:), *) zmq_port_start
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
|
||||
call reset_zmq_addresses
|
||||
|
||||
end
|
||||
|
||||
|
||||
function zmq_port(ishift)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Return the value of the ZMQ port from the corresponding integer
|
||||
END_DOC
|
||||
integer, intent(in) :: ishift
|
||||
character*(8) :: zmq_port
|
||||
write(zmq_port,'(I8)') zmq_port_start+ishift
|
||||
zmq_port = adjustl(trim(zmq_port))
|
||||
end
|
||||
|
||||
|
||||
function new_zmq_to_qp_run_socket()
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Socket on which the qp_run process replies
|
||||
END_DOC
|
||||
integer :: rc
|
||||
character*(8), external :: zmq_port
|
||||
integer(ZMQ_PTR) :: new_zmq_to_qp_run_socket
|
||||
|
||||
call omp_set_lock(zmq_lock)
|
||||
new_zmq_to_qp_run_socket = f77_zmq_socket(zmq_context, ZMQ_REQ)
|
||||
call omp_unset_lock(zmq_lock)
|
||||
if (new_zmq_to_qp_run_socket == 0_ZMQ_PTR) then
|
||||
stop 'Unable to create zmq req socket'
|
||||
endif
|
||||
|
||||
rc = f77_zmq_connect(new_zmq_to_qp_run_socket, trim(qp_run_address)//':'//trim(zmq_port(0)))
|
||||
if (rc /= 0) then
|
||||
stop 'Unable to connect new_zmq_to_qp_run_socket'
|
||||
endif
|
||||
|
||||
rc = f77_zmq_setsockopt(new_zmq_to_qp_run_socket, ZMQ_SNDTIMEO, 120000, 4)
|
||||
if (rc /= 0) then
|
||||
stop 'Unable to set send timout in new_zmq_to_qp_run_socket'
|
||||
endif
|
||||
|
||||
rc = f77_zmq_setsockopt(new_zmq_to_qp_run_socket, ZMQ_RCVTIMEO, 120000, 4)
|
||||
if (rc /= 0) then
|
||||
stop 'Unable to set recv timout in new_zmq_to_qp_run_socket'
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
|
||||
function new_zmq_pair_socket(bind)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Socket on which the collector and the main communicate
|
||||
END_DOC
|
||||
logical :: bind
|
||||
integer :: rc
|
||||
character*(8), external :: zmq_port
|
||||
integer(ZMQ_PTR) :: new_zmq_pair_socket
|
||||
|
||||
call omp_set_lock(zmq_lock)
|
||||
new_zmq_pair_socket = f77_zmq_socket(zmq_context, ZMQ_PAIR)
|
||||
call omp_unset_lock(zmq_lock)
|
||||
if (new_zmq_pair_socket == 0_ZMQ_PTR) then
|
||||
stop 'Unable to create zmq pair socket'
|
||||
endif
|
||||
|
||||
if (bind) then
|
||||
rc = f77_zmq_bind(new_zmq_pair_socket,zmq_socket_pair_inproc_address)
|
||||
if (rc /= 0) then
|
||||
print *, 'f77_zmq_bind(new_zmq_pair_socket, zmq_socket_pair_inproc_address)'
|
||||
stop 'error'
|
||||
endif
|
||||
else
|
||||
rc = f77_zmq_connect(new_zmq_pair_socket,zmq_socket_pair_inproc_address)
|
||||
if (rc /= 0) then
|
||||
stop 'Unable to connect new_zmq_pair_socket'
|
||||
endif
|
||||
endif
|
||||
|
||||
rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_SNDHWM, 0, 4)
|
||||
if (rc /= 0) then
|
||||
stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_SNDHWM, 0, 4)'
|
||||
endif
|
||||
|
||||
rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_RCVHWM, 0, 4)
|
||||
if (rc /= 0) then
|
||||
stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_RCVHWM, 0, 4)'
|
||||
endif
|
||||
|
||||
rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_IMMEDIATE, 1, 4)
|
||||
if (rc /= 0) then
|
||||
stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_IMMEDIATE, 1, 4)'
|
||||
endif
|
||||
|
||||
rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_LINGER, 600000, 4)
|
||||
if (rc /= 0) then
|
||||
stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_LINGER, 60000, 4)'
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
|
||||
|
||||
|
||||
function new_zmq_pull_socket()
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Socket on which the results are sent. If thread is 1, use inproc
|
||||
END_DOC
|
||||
integer :: rc
|
||||
character*(8), external :: zmq_port
|
||||
integer(ZMQ_PTR) :: new_zmq_pull_socket
|
||||
|
||||
call omp_set_lock(zmq_lock)
|
||||
new_zmq_pull_socket = f77_zmq_socket(zmq_context, ZMQ_PULL)
|
||||
! new_zmq_pull_socket = f77_zmq_socket(zmq_context, ZMQ_REP)
|
||||
call omp_unset_lock(zmq_lock)
|
||||
if (new_zmq_pull_socket == 0_ZMQ_PTR) then
|
||||
stop 'Unable to create zmq pull socket'
|
||||
endif
|
||||
|
||||
rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_LINGER,300000,4)
|
||||
if (rc /= 0) then
|
||||
stop 'Unable to set ZMQ_LINGER on pull socket'
|
||||
endif
|
||||
|
||||
rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_RCVHWM,100000,4)
|
||||
if (rc /= 0) then
|
||||
stop 'Unable to set ZMQ_RCVHWM on pull socket'
|
||||
endif
|
||||
|
||||
rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_IMMEDIATE,1,4)
|
||||
if (rc /= 0) then
|
||||
stop 'Unable to set ZMQ_IMMEDIATE on pull socket'
|
||||
endif
|
||||
|
||||
rc = f77_zmq_bind(new_zmq_pull_socket, zmq_socket_pull_tcp_address)
|
||||
if (rc /= 0) then
|
||||
print *, 'Unable to bind new_zmq_pull_socket (tcp)', zmq_socket_pull_tcp_address
|
||||
stop
|
||||
endif
|
||||
|
||||
rc = f77_zmq_bind(new_zmq_pull_socket, zmq_socket_pull_inproc_address)
|
||||
if (rc /= 0) then
|
||||
stop 'Unable to bind new_zmq_pull_socket (inproc)'
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
|
||||
|
||||
|
||||
function new_zmq_push_socket(thread)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Socket on which the results are sent. If thread is 1, use inproc
|
||||
END_DOC
|
||||
integer, intent(in) :: thread
|
||||
integer :: rc
|
||||
character*(8), external :: zmq_port
|
||||
integer(ZMQ_PTR) :: new_zmq_push_socket
|
||||
|
||||
call omp_set_lock(zmq_lock)
|
||||
new_zmq_push_socket = f77_zmq_socket(zmq_context, ZMQ_PUSH)
|
||||
! new_zmq_push_socket = f77_zmq_socket(zmq_context, ZMQ_REQ)
|
||||
call omp_unset_lock(zmq_lock)
|
||||
if (new_zmq_push_socket == 0_ZMQ_PTR) then
|
||||
stop 'Unable to create zmq push socket'
|
||||
endif
|
||||
|
||||
rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_LINGER,300000,4)
|
||||
if (rc /= 0) then
|
||||
stop 'Unable to set ZMQ_LINGER on push socket'
|
||||
endif
|
||||
|
||||
rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_SNDHWM,100,4)
|
||||
if (rc /= 0) then
|
||||
stop 'Unable to set ZMQ_SNDHWM on push socket'
|
||||
endif
|
||||
|
||||
rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_IMMEDIATE,1,4)
|
||||
if (rc /= 0) then
|
||||
stop 'Unable to set ZMQ_IMMEDIATE on push socket'
|
||||
endif
|
||||
|
||||
rc = f77_zmq_setsockopt(new_zmq_push_socket, ZMQ_SNDTIMEO, 100000, 4)
|
||||
if (rc /= 0) then
|
||||
stop 'Unable to set send timout in new_zmq_push_socket'
|
||||
endif
|
||||
|
||||
if (thread == 1) then
|
||||
rc = f77_zmq_connect(new_zmq_push_socket, zmq_socket_push_inproc_address)
|
||||
else
|
||||
rc = f77_zmq_connect(new_zmq_push_socket, zmq_socket_push_tcp_address)
|
||||
endif
|
||||
if (rc /= 0) then
|
||||
stop 'Unable to connect new_zmq_push_socket'
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
|
||||
|
||||
subroutine end_zmq_pair_socket(zmq_socket_pair)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Terminate socket on which the results are sent.
|
||||
END_DOC
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_socket_pair
|
||||
integer :: rc
|
||||
character*(8), external :: zmq_port
|
||||
|
||||
rc = f77_zmq_unbind(zmq_socket_pair,zmq_socket_pair_inproc_address)
|
||||
! if (rc /= 0) then
|
||||
! print *, rc
|
||||
! print *, irp_here, 'f77_zmq_unbind(zmq_socket_pair,zmq_socket_pair_inproc_address)'
|
||||
! stop 'error'
|
||||
! endif
|
||||
|
||||
rc = f77_zmq_setsockopt(zmq_socket_pair,ZMQ_LINGER,0,4)
|
||||
if (rc /= 0) then
|
||||
stop 'Unable to set ZMQ_LINGER on zmq_socket_pair'
|
||||
endif
|
||||
|
||||
rc = f77_zmq_close(zmq_socket_pair)
|
||||
if (rc /= 0) then
|
||||
print *, 'f77_zmq_close(zmq_socket_pair)'
|
||||
stop 'error'
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
subroutine end_zmq_pull_socket(zmq_socket_pull)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Terminate socket on which the results are sent.
|
||||
END_DOC
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
|
||||
integer :: rc
|
||||
character*(8), external :: zmq_port
|
||||
|
||||
rc = f77_zmq_unbind(zmq_socket_pull,zmq_socket_pull_inproc_address)
|
||||
! if (rc /= 0) then
|
||||
! print *, rc
|
||||
! print *, irp_here, 'f77_zmq_unbind(zmq_socket_pull,zmq_socket_pull_inproc_address)'
|
||||
! stop 'error'
|
||||
! endif
|
||||
|
||||
rc = f77_zmq_unbind(zmq_socket_pull,zmq_socket_pull_tcp_address)
|
||||
if (rc /= 0) then
|
||||
print *, rc
|
||||
print *, irp_here, 'f77_zmq_unbind(zmq_socket_pull,zmq_socket_pull_tcp_address)'
|
||||
stop 'error'
|
||||
endif
|
||||
|
||||
rc = f77_zmq_setsockopt(zmq_socket_pull,ZMQ_LINGER,0,4)
|
||||
if (rc /= 0) then
|
||||
stop 'Unable to set ZMQ_LINGER on zmq_socket_pull'
|
||||
endif
|
||||
|
||||
rc = f77_zmq_close(zmq_socket_pull)
|
||||
if (rc /= 0) then
|
||||
print *, 'f77_zmq_close(zmq_socket_pull)'
|
||||
stop 'error'
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
|
||||
subroutine end_zmq_push_socket(zmq_socket_push,thread)
|
||||
implicit none
|
||||
use f77_zmq
|
||||
BEGIN_DOC
|
||||
! Terminate socket on which the results are sent.
|
||||
END_DOC
|
||||
integer, intent(in) :: thread
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_socket_push
|
||||
integer :: rc
|
||||
character*(8), external :: zmq_port
|
||||
|
||||
if (thread == 1) then
|
||||
rc = f77_zmq_disconnect(zmq_socket_push,zmq_socket_push_inproc_address)
|
||||
! if (rc /= 0) then
|
||||
! print *, 'f77_zmq_disconnect(zmq_socket_push,zmq_socket_push_inproc_address)'
|
||||
! stop 'error'
|
||||
! endif
|
||||
else
|
||||
rc = f77_zmq_disconnect(zmq_socket_push,zmq_socket_push_tcp_address)
|
||||
if (rc /= 0) then
|
||||
print *, 'f77_zmq_disconnect(zmq_socket_push,zmq_socket_push_tcp_address)'
|
||||
stop 'error'
|
||||
endif
|
||||
endif
|
||||
|
||||
|
||||
rc = f77_zmq_setsockopt(zmq_socket_push,ZMQ_LINGER,0,4)
|
||||
if (rc /= 0) then
|
||||
stop 'Unable to set ZMQ_LINGER on push socket'
|
||||
endif
|
||||
|
||||
rc = f77_zmq_close(zmq_socket_push)
|
||||
if (rc /= 0) then
|
||||
print *, 'f77_zmq_close(zmq_socket_push)'
|
||||
stop 'error'
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ character*(128), zmq_state ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Threads executing work through the ZeroMQ interface
|
||||
END_DOC
|
||||
zmq_state = 'No_state'
|
||||
END_PROVIDER
|
||||
|
||||
subroutine new_parallel_job(zmq_to_qp_run_socket,name_in)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Start a new parallel job with name 'name'. The slave tasks execute subroutine 'slave'
|
||||
END_DOC
|
||||
character*(*), intent(in) :: name_in
|
||||
|
||||
character*(512) :: message, name
|
||||
integer :: rc, sze
|
||||
integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
|
||||
integer(ZMQ_PTR), intent(out) :: zmq_to_qp_run_socket
|
||||
|
||||
zmq_context = f77_zmq_ctx_new ()
|
||||
if (zmq_context == 0_ZMQ_PTR) then
|
||||
stop 'ZMQ_PTR is null'
|
||||
endif
|
||||
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
|
||||
name = name_in
|
||||
sze = len(trim(name))
|
||||
call lowercase(name,sze)
|
||||
message = 'new_job '//trim(name)//' '//zmq_socket_push_tcp_address//' '//zmq_socket_pull_inproc_address
|
||||
sze = len(trim(message))
|
||||
rc = f77_zmq_send(zmq_to_qp_run_socket,message,sze,0)
|
||||
if (rc /= sze) then
|
||||
print *, irp_here, ':f77_zmq_send(zmq_to_qp_run_socket,message,sze,0)'
|
||||
stop 'error'
|
||||
endif
|
||||
rc = f77_zmq_recv(zmq_to_qp_run_socket,message,510,0)
|
||||
message = trim(message(1:rc))
|
||||
if (message(1:2) /= 'ok') then
|
||||
print *, message
|
||||
print *, 'Unable to start parallel job : '//name
|
||||
stop 1
|
||||
endif
|
||||
|
||||
zmq_state = trim(name)
|
||||
|
||||
end
|
||||
|
||||
|
||||
subroutine end_parallel_job(zmq_to_qp_run_socket,name_in)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! End a new parallel job with name 'name'. The slave tasks execute subroutine 'slave'
|
||||
END_DOC
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
|
||||
character*(*), intent(in) :: name_in
|
||||
|
||||
character*(512) :: message, name
|
||||
integer :: i,rc, sze
|
||||
|
||||
name = name_in
|
||||
sze = len(trim(name))
|
||||
call lowercase(name,sze)
|
||||
if (name /= zmq_state) then
|
||||
stop 'Wrong end of job'
|
||||
endif
|
||||
|
||||
rc = f77_zmq_send(zmq_to_qp_run_socket, 'end_job '//trim(zmq_state),8+len(trim(zmq_state)),0)
|
||||
rc = f77_zmq_recv(zmq_to_qp_run_socket, zmq_state, 2, 0)
|
||||
if (rc /= 2) then
|
||||
print *, 'f77_zmq_recv(zmq_to_qp_run_socket, zmq_state, 2, 0)'
|
||||
stop 'error'
|
||||
endif
|
||||
zmq_state = 'No_state'
|
||||
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
|
||||
|
||||
rc = f77_zmq_ctx_term(zmq_context)
|
||||
if (rc /= 0) then
|
||||
print *, 'Unable to terminate ZMQ context'
|
||||
stop 'error'
|
||||
endif
|
||||
end
|
||||
|
||||
subroutine connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Connect to the task server and obtain the worker ID
|
||||
END_DOC
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
|
||||
integer, intent(out) :: worker_id
|
||||
integer, intent(in) :: thread
|
||||
|
||||
character*(512) :: message
|
||||
character*(128) :: reply, state, address
|
||||
integer :: rc
|
||||
|
||||
if (thread == 1) then
|
||||
rc = f77_zmq_send(zmq_to_qp_run_socket, "connect inproc", 14, 0)
|
||||
if (rc /= 14) then
|
||||
print *, 'f77_zmq_send(zmq_to_qp_run_socket, "connect inproc", 14, 0)'
|
||||
stop 'error'
|
||||
endif
|
||||
else
|
||||
rc = f77_zmq_send(zmq_to_qp_run_socket, "connect tcp", 11, 0)
|
||||
if (rc /= 11) then
|
||||
print *, 'f77_zmq_send(zmq_to_qp_run_socket, "connect tcp", 11, 0)'
|
||||
stop 'error'
|
||||
endif
|
||||
endif
|
||||
|
||||
rc = f77_zmq_recv(zmq_to_qp_run_socket, message, 510, 0)
|
||||
message = trim(message(1:rc))
|
||||
read(message,*) reply, state, worker_id, address
|
||||
if ( (trim(reply) /= 'connect_reply') .and. &
|
||||
(trim(state) /= trim(zmq_state)) ) then
|
||||
print *, 'Reply: ', trim(reply)
|
||||
print *, 'State: ', trim(state), '/', trim(zmq_state)
|
||||
print *, 'Address: ', trim(address)
|
||||
stop -1
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
subroutine disconnect_from_taskserver(zmq_to_qp_run_socket, &
|
||||
zmq_socket_push, worker_id)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Disconnect from the task server
|
||||
END_DOC
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_socket_push
|
||||
integer, intent(in) :: worker_id
|
||||
|
||||
integer :: rc, sze
|
||||
character*(64) :: message, reply, state
|
||||
write(message,*) 'disconnect '//trim(zmq_state), worker_id
|
||||
|
||||
sze = len(trim(message))
|
||||
rc = f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0)
|
||||
if (rc /= sze) then
|
||||
print *, rc, sze
|
||||
print *, irp_here, 'f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0)'
|
||||
stop 'error'
|
||||
endif
|
||||
|
||||
rc = f77_zmq_recv(zmq_to_qp_run_socket, message, 510, 0)
|
||||
message = trim(message(1:rc))
|
||||
|
||||
read(message,*) reply, state
|
||||
if ( (trim(reply) /= 'disconnect_reply').or. &
|
||||
(trim(state) /= zmq_state) ) then
|
||||
print *, 'Unable to disconnect : ', zmq_state
|
||||
print *, trim(message)
|
||||
stop -1
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
subroutine add_task_to_taskserver(zmq_to_qp_run_socket,task)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Get a task from the task server
|
||||
END_DOC
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
|
||||
character*(*), intent(in) :: task
|
||||
|
||||
integer :: rc, sze
|
||||
character*(512) :: message
|
||||
write(message,*) 'add_task '//trim(zmq_state)//' '//trim(task)
|
||||
|
||||
sze = len(trim(message))
|
||||
rc = f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0)
|
||||
if (rc /= sze) then
|
||||
print *, rc, sze
|
||||
print *, irp_here,': f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0)'
|
||||
stop 'error'
|
||||
endif
|
||||
|
||||
rc = f77_zmq_recv(zmq_to_qp_run_socket, message, 510, 0)
|
||||
message = trim(message(1:rc))
|
||||
if (trim(message) /= 'ok') then
|
||||
print *, trim(task)
|
||||
print *, 'Unable to add the next task'
|
||||
stop -1
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
subroutine task_done_to_taskserver(zmq_to_qp_run_socket,worker_id, task_id)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Get a task from the task server
|
||||
END_DOC
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
|
||||
integer, intent(in) :: worker_id, task_id
|
||||
|
||||
integer :: rc, sze
|
||||
character*(512) :: message
|
||||
write(message,*) 'task_done '//trim(zmq_state), worker_id, task_id
|
||||
|
||||
sze = len(trim(message))
|
||||
rc = f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0)
|
||||
if (rc /= sze) then
|
||||
print *, irp_here, 'f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0)'
|
||||
stop 'error'
|
||||
endif
|
||||
|
||||
rc = f77_zmq_recv(zmq_to_qp_run_socket, message, 510, 0)
|
||||
message = trim(message(1:rc))
|
||||
if (trim(message) /= 'ok') then
|
||||
print *, 'Unable to send task_done message'
|
||||
stop -1
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
subroutine get_task_from_taskserver(zmq_to_qp_run_socket,worker_id,task_id,task)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Get a task from the task server
|
||||
END_DOC
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
|
||||
integer, intent(in) :: worker_id
|
||||
integer, intent(out) :: task_id
|
||||
character*(512), intent(out) :: task
|
||||
|
||||
character*(512) :: message
|
||||
character*(64) :: reply
|
||||
integer :: rc, sze
|
||||
|
||||
write(message,*) 'get_task '//trim(zmq_state), worker_id
|
||||
|
||||
sze = len(trim(message))
|
||||
rc = f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0)
|
||||
if (rc /= sze) then
|
||||
print *, irp_here, ':f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0)'
|
||||
stop 'error'
|
||||
endif
|
||||
|
||||
rc = f77_zmq_recv(zmq_to_qp_run_socket, message, 510, 0)
|
||||
message = trim(message(1:rc))
|
||||
read(message,*) reply
|
||||
if (trim(reply) == 'get_task_reply') then
|
||||
read(message,*) reply, task_id
|
||||
rc = 15
|
||||
do while (message(rc:rc) == ' ')
|
||||
rc += 1
|
||||
enddo
|
||||
do while (message(rc:rc) /= ' ')
|
||||
rc += 1
|
||||
enddo
|
||||
rc += 1
|
||||
task = message(rc:)
|
||||
else if (trim(reply) == 'terminate') then
|
||||
task_id = 0
|
||||
task = 'terminate'
|
||||
else
|
||||
print *, 'Unable to get the next task'
|
||||
print *, trim(message)
|
||||
stop -1
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
|
||||
subroutine end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Terminate the socket from the application to qp_run
|
||||
END_DOC
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
|
||||
character*(8), external :: zmq_port
|
||||
integer :: rc
|
||||
|
||||
rc = f77_zmq_disconnect(zmq_to_qp_run_socket, trim(qp_run_address)//':'//trim(zmq_port(0)))
|
||||
! if (rc /= 0) then
|
||||
! print *, 'f77_zmq_disconnect(zmq_to_qp_run_socket, trim(qp_run_address)//'':''//trim(zmq_port(0)))'
|
||||
! stop 'error'
|
||||
! endif
|
||||
|
||||
rc = f77_zmq_setsockopt(zmq_to_qp_run_socket,ZMQ_LINGER,0,4)
|
||||
if (rc /= 0) then
|
||||
stop 'Unable to set ZMQ_LINGER on zmq_to_qp_run_socket'
|
||||
endif
|
||||
|
||||
rc = f77_zmq_close(zmq_to_qp_run_socket)
|
||||
if (rc /= 0) then
|
||||
print *, 'f77_zmq_close(zmq_to_qp_run_socket)'
|
||||
stop 'error'
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
subroutine zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! When a task is done, it has to be removed from the list of tasks on the qp_run
|
||||
! queue. This guarantees that the results have been received in the pull.
|
||||
END_DOC
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
|
||||
integer(ZMQ_PTR) :: zmq_socket_pull
|
||||
integer, intent(in) :: task_id
|
||||
integer, intent(out) :: more
|
||||
integer :: rc
|
||||
character*(512) :: msg
|
||||
|
||||
write(msg,*) 'del_task ', zmq_state, task_id
|
||||
rc = f77_zmq_send(zmq_to_qp_run_socket,msg,512,0)
|
||||
if (rc /= 512) then
|
||||
print *, 'f77_zmq_send(zmq_to_qp_run_socket,task_id,4,0)'
|
||||
stop 'error'
|
||||
endif
|
||||
|
||||
character*(64) :: reply
|
||||
reply = ''
|
||||
rc = f77_zmq_recv(zmq_to_qp_run_socket,reply,64,0)
|
||||
|
||||
if (reply(16:19) == 'more') then
|
||||
more = 1
|
||||
else if (reply(16:19) == 'done') then
|
||||
more = 0
|
||||
rc = f77_zmq_setsockopt(zmq_socket_pull, ZMQ_RCVTIMEO, 1000, 4)
|
||||
if (rc /= 0) then
|
||||
print *, 'f77_zmq_setsockopt(zmq_socket_pull, ZMQ_RCVTIMEO, 3000, 4)'
|
||||
stop 'error'
|
||||
endif
|
||||
else
|
||||
print *, reply
|
||||
print *, 'f77_zmq_recv(zmq_to_qp_run_socket,reply,64,0)'
|
||||
stop 'error'
|
||||
endif
|
||||
end
|
||||
|
@ -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,8 +24,6 @@ function eq() {
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
# ___
|
||||
# | ._ o _|_
|
||||
# _|_ | | | |_
|
||||
@ -65,7 +63,7 @@ function run_HF() {
|
||||
}
|
||||
|
||||
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
|
||||
@ -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" {
|
||||
@ -156,7 +155,7 @@ function run_all_1h_1p() {
|
||||
ezfio set determinants read_wf True
|
||||
qp_run mrcc_cassd $INPUT
|
||||
energy="$(ezfio get mrcc_cassd energy)"
|
||||
eq $energy -0.762303253805911E+02 1.E-3
|
||||
eq $energy -76.2289109271715 1.E-3
|
||||
|
||||
}
|
||||
|
||||
@ -171,7 +170,8 @@ function run_all_1h_1p() {
|
||||
}
|
||||
|
||||
@test "FCI H2O VDZ pseudo" {
|
||||
run_FCI h2o_pseudo.ezfio 2000 -0.171550015498807E+02 -0.171645044185009E+02
|
||||
qp_set_mo_class h2o_pseudo.ezfio -core "[1]" -act "[2-12]" -del "[13-23]"
|
||||
run_FCI h2o_pseudo.ezfio 2000 -0.170399597228904E+02 -0.170400168816800E+02
|
||||
}
|
||||
|
||||
#=== Convert
|
||||
|
27
tests/bats_to_sh.py
Executable file
27
tests/bats_to_sh.py
Executable 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")
|
||||
|
||||
|
||||
|
@ -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
|
||||
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user