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

Merge pull request #10 from scemama/master

Browse Source 
merge with scemama
This commit is contained in:
garniron 2016-03-30 09:23:19 +02:00
commit 0c6f650323
96 changed files with 4781 additions and 2914 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.travis.yml
View File

@ -27,4 +27,4 @@ script:
- source ./quantum_package.rc ; qp_module.py install Full_CI Hartree_Fock CAS_SD MRCC_CASSD All_singles - source ./quantum_package.rc ; qp_module.py install Full_CI Hartree_Fock CAS_SD MRCC_CASSD All_singles
- source ./quantum_package.rc ; ninja - source ./quantum_package.rc ; ninja
- source ./quantum_package.rc ; cd ocaml ; make ; cd - - source ./quantum_package.rc ; cd ocaml ; make ; cd -
- source ./quantum_package.rc ; cd tests ; bats bats/qp.bats - source ./quantum_package.rc ; cd tests ; ./run_tests.sh #-v

4
config/gfortran.cfg
View File

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

62
config/gfortran_avx.cfg Normal file
View File

@ -0,0 +1,62 @@
# Common flags
##############
#
# -ffree-line-length-none : Needed for IRPF90 which produces long lines
# -lblas -llapack : Link with libblas and liblapack libraries provided by the system
# -I . : Include the curent directory (Mandatory)
#
# --ninja : Allow the utilisation of ninja. (Mandatory)
# --align=32 : Align all provided arrays on a 32-byte boundary
#
#
[COMMON]
FC : gfortran -ffree-line-length-none -I . -mavx
LAPACK_LIB : -llapack -lblas
IRPF90 : irpf90
IRPF90_FLAGS : --ninja --align=32
# Global options
################
#
# 1 : Activate
# 0 : Deactivate
#
[OPTION]
MODE : OPT ; [ OPT | PROFILE | DEBUG ] : Chooses the section below
CACHE : 1 ; Enable cache_compile.py
OPENMP : 1 ; Append OpenMP flags
# Optimization flags
####################
#
# -Ofast : Disregard strict standards compliance. Enables all -O3 optimizations.
# It also enables optimizations that are not valid
# for all standard-compliant programs. It turns on
# -ffast-math and the Fortran-specific
# -fno-protect-parens and -fstack-arrays.
[OPT]
FCFLAGS : -Ofast
# Profiling flags
#################
#
[PROFILE]
FC : -p -g
FCFLAGS : -Ofast
# Debugging flags
#################
#
# -fcheck=all : Checks uninitialized variables, array subscripts, etc...
# -g : Extra debugging information
#
[DEBUG]
FCFLAGS : -fcheck=all -g
# OpenMP flags
#################
#
[OPENMP]
FC : -fopenmp
IRPF90_FLAGS : --openmp

62
config/gfortran_debug.cfg Normal file
View File

@ -0,0 +1,62 @@
# Common flags
##############
#
# -ffree-line-length-none : Needed for IRPF90 which produces long lines
# -lblas -llapack : Link with libblas and liblapack libraries provided by the system
# -I . : Include the curent directory (Mandatory)
#
# --ninja : Allow the utilisation of ninja. (Mandatory)
# --align=32 : Align all provided arrays on a 32-byte boundary
#
#
[COMMON]
FC : gfortran -g -ffree-line-length-none -I . -static-libgcc
LAPACK_LIB : -llapack -lblas
IRPF90 : irpf90
IRPF90_FLAGS : --ninja --assert --align=32
# Global options
################
#
# 1 : Activate
# 0 : Deactivate
#
[OPTION]
MODE : DEBUG ; [ OPT | PROFILE | DEBUG ] : Chooses the section below
CACHE : 0 ; Enable cache_compile.py
OPENMP : 1 ; Append OpenMP flags
# Optimization flags
####################
#
# -Ofast : Disregard strict standards compliance. Enables all -O3 optimizations.
# It also enables optimizations that are not valid
# for all standard-compliant programs. It turns on
# -ffast-math and the Fortran-specific
# -fno-protect-parens and -fstack-arrays.
[OPT]
FCFLAGS : -Ofast
# Profiling flags
#################
#
[PROFILE]
FC : -p -g
FCFLAGS : -Ofast
# Debugging flags
#################
#
# -fcheck=all : Checks uninitialized variables, array subscripts, etc...
# -g : Extra debugging information
#
[DEBUG]
FCFLAGS : -g -pedantic -msse4.2
# OpenMP flags
#################
#
[OPENMP]
FC : -fopenmp
IRPF90_FLAGS : --openmp

2
config/ifort.cfg
View File

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

9
configure vendored
View File

@ -144,8 +144,8 @@ zeromq = Info(
f77zmq = Info( f77zmq = Info(
url='{head}/zeromq/f77_zmq/{tail}'.format(**path_github), url='{head}/zeromq/f77_zmq/{tail}'.format(**path_github),
description=' F77-ZeroMQ', description=' F77-ZeroMQ',
default_path=join(QP_ROOT_LIB, "libf77zmq.a") + " " + \ default_path=join(QP_ROOT_LIB, "libf77zmq.a") )
join(QP_ROOT, "src", "ZMQ", "f77zmq.h") ) # join(QP_ROOT, "src", "ZMQ", "f77zmq.h") )
p_graphviz = Info( p_graphviz = Info(
url='https://github.com/xflr6/graphviz/archive/master.tar.gz', url='https://github.com/xflr6/graphviz/archive/master.tar.gz',
@ -328,7 +328,7 @@ def installation(l_install_descendant):
l_rules += [ l_rules += [
"rule install_verbose", "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", "" " description = Installing ${descr}", " pool = console", ""
] ]
@ -482,10 +482,11 @@ def create_ninja_and_rc(l_installed):
l_rc = [ l_rc = [
'export QP_ROOT={0}'.format(QP_ROOT), '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_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 IRPF90={0}'.format(path_irpf90.replace(QP_ROOT,"${QP_ROOT}")),
'export NINJA={0}'.format(path_ninja.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 PYTHONPATH="${QP_EZFIO}/Python":"${QP_PYTHON}":"${PYTHONPATH}"',
'export PATH="${QP_PYTHON}":"${QP_ROOT}"/bin:"${QP_ROOT}"/ocaml:"${PATH}"', 'export PATH="${QP_PYTHON}":"${QP_ROOT}"/bin:"${QP_ROOT}"/ocaml:"${PATH}"',
'export LD_LIBRARY_PATH="${QP_ROOT}"/lib:"${LD_LIBRARY_PATH}"', 'export LD_LIBRARY_PATH="${QP_ROOT}"/lib:"${LD_LIBRARY_PATH}"',

732
data/basis/cc-pcv6z
View File

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

118
data/list_element.txt Normal file
View File

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

61
ocaml/.gitignore vendored
View File

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

10
ocaml/Address.ml
View File

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

96
ocaml/Bitlist.ml
View File

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

11
ocaml/Bitlist.mli
View File

@ -6,16 +6,21 @@ val zero : Qptypes.N_int_number.t -> t
(** Convert to a string for printing *) (** Convert to a string for printing *)
val to_string : t -> string val to_string : t -> string
(** Convert to a string for printing *) (** Read from a string *)
val of_string : ?zero:char -> ?one:char -> string -> t 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 *) (** int64 conversion functions *)
val of_int64 : int64 -> t val of_int64 : int64 -> t
val to_int64 : t -> int64 val to_int64 : t -> int64
val of_int64_list : int64 list -> t val of_int64_list : int64 list -> t
val to_int64_list : t -> int64 list 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 *) (** 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 val n_int_of_mo_tot_num : int -> Qptypes.N_int_number.t

59
ocaml/Determinant.ml
View File

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

3
ocaml/Determinant.mli
View File

@ -24,7 +24,8 @@ val to_alpha_beta : t -> (int64 array)*(int64 array)
val to_bitlist_couple : t -> Bitlist.t * Bitlist.t val to_bitlist_couple : t -> Bitlist.t * Bitlist.t
(** Create from a bit list *) (** 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 -> beta:Qptypes.Elec_beta_number.t ->
Bitlist.t * Bitlist.t -> t Bitlist.t * Bitlist.t -> t

85
ocaml/Input_determinants_by_hand.ml
View File

@ -11,11 +11,13 @@ module Determinants_by_hand : sig
psi_coef : Det_coef.t array; psi_coef : Det_coef.t array;
psi_det : Determinant.t array; psi_det : Determinant.t array;
} with sexp } with sexp
val read : unit -> t option val read : unit -> t
val read_maybe : unit -> t option
val write : t -> unit val write : t -> unit
val to_string : t -> string val to_string : t -> string
val to_rst : t -> Rst_string.t val to_rst : t -> Rst_string.t
val of_rst : Rst_string.t -> t option val of_rst : Rst_string.t -> t option
val read_n_int : unit -> N_int_number.t
end = struct end = struct
type t = type t =
{ n_int : N_int_number.t; { n_int : N_int_number.t;
@ -29,6 +31,8 @@ end = struct
let get_default = Qpackage.get_ezfio_default "determinants";; let get_default = Qpackage.get_ezfio_default "determinants";;
let n_det_read_max = 10_000 ;;
let read_n_int () = let read_n_int () =
if not (Ezfio.has_determinants_n_int()) then if not (Ezfio.has_determinants_n_int()) then
Ezfio.get_mo_basis_mo_tot_num () Ezfio.get_mo_basis_mo_tot_num ()
@ -207,14 +211,24 @@ end = struct
let read () = let read () =
if (Ezfio.has_mo_basis_mo_tot_num ()) then if (Ezfio.has_mo_basis_mo_tot_num ()) then
Some { n_int = read_n_int () ;
{ n_int = read_n_int () ; bit_kind = read_bit_kind () ;
bit_kind = read_bit_kind () ; n_det = read_n_det () ;
n_det = read_n_det () ; expected_s2 = read_expected_s2 () ;
expected_s2 = read_expected_s2 () ; psi_coef = read_psi_coef () ;
psi_coef = read_psi_coef () ; psi_det = read_psi_det () ;
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 else
None None
;; ;;
@ -236,11 +250,16 @@ end = struct
let to_rst b = let to_rst b =
let mo_tot_num = Ezfio.get_mo_basis_mo_tot_num () in let max =
let mo_tot_num = MO_number.of_int mo_tot_num ~max:mo_tot_num in Ezfio.get_mo_basis_mo_tot_num ()
in
let mo_tot_num =
MO_number.of_int ~max max
in
let det_text = let det_text =
let nstates = let nstates =
read_n_states () |> States_number.to_int read_n_states ()
|> States_number.to_int
and ndet = and ndet =
Det_number.to_int b.n_det Det_number.to_int b.n_det
in in
@ -393,29 +412,47 @@ psi_det = %s
in in
let rec read_dets accu = function let rec read_dets accu = function
| [] -> List.rev accu | [] -> List.rev accu
| ""::c::alpha::beta::tail -> | ""::_::alpha::beta::tail ->
begin begin
let alpha = String.rev alpha |> Bitlist.of_string ~zero:'-' ~one:'+' let newdet =
and beta = String.rev beta |> Bitlist.of_string ~zero:'-' ~one:'+' (Bitlist.of_string ~zero:'-' ~one:'+' alpha ,
in Bitlist.of_string ~zero:'-' ~one:'+' beta)
let newdet = Determinant.of_bitlist_couple |> Determinant.of_bitlist_couple ~alpha:n_alpha ~beta:n_beta
~alpha:n_alpha ~beta:n_beta (alpha,beta) |> Determinant.sexp_of_t
|> Determinant.sexp_of_t |> Sexplib.Sexp.to_string |> Sexplib.Sexp.to_string
in in
read_dets (newdet::accu) tail read_dets (newdet::accu) tail
end end
| _::tail -> read_dets accu tail | _::tail -> read_dets accu tail
in in
let a = read_dets [] dets let dets =
|> String.concat List.map ~f:String.rev dets
in 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^"))" "(psi_det ("^a^"))"
in 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) |> Bit_kind.to_int)
and n_int = Printf.sprintf "(n_int %d)" (N_int_number.get_max ()) in and n_int =
let s = String.concat [ header ; bitkind ; n_int ; psi_coef ; psi_det] Printf.sprintf "(n_int %d)" (N_int_number.get_max ())
in
let s =
String.concat [ header ; bitkind ; n_int ; psi_coef ; psi_det]
in in
Generic_input_of_rst.evaluate_sexp t_of_sexp s Generic_input_of_rst.evaluate_sexp t_of_sexp s

401
ocaml/Message.ml
View File

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

108
ocaml/Progress_bar.ml Normal file
View File

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

19
ocaml/Queuing_system.ml
View File

@ -1,4 +1,5 @@
open Core.Std open Core.Std
open Qptypes
type t = type t =
@ -32,7 +33,7 @@ let add_task ~task q =
queued = task_id :: q.queued ; queued = task_id :: q.queued ;
tasks = Map.add q.tasks ~key:task_id ~data:task ; tasks = Map.add q.tasks ~key:task_id ~data:task ;
next_task_id = Id.Task.increment task_id ; next_task_id = Id.Task.increment task_id ;
}, task_id }
@ -81,13 +82,25 @@ let end_task ~task_id ~client_id q =
in in
{ q with { q with
running = Map.remove running task_id ; 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 = let number_of_queued q =
List.length q.queued Map.length q.tasks
let number_of_running q = let number_of_running q =
Map.length q.running Map.length q.running

810
ocaml/TaskServer.ml
View File

@ -1,47 +1,60 @@
open Core.Std open Core.Std
open Qptypes 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" type t =
-> "OK" {
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 let debug_env =
-> "%d %s" task_id task 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 = let bind_socket ~socket_type ~socket ~address =
try let rec loop = function
ZMQ.Socket.bind socket address | 0 -> failwith @@ Printf.sprintf
with "Unable to bind the %s socket : %s "
| Unix.Unix_error (_, message, f) -> socket_type address
failwith @@ Printf.sprintf | -1 -> ()
"\n%s\nUnable to bind the %s socket :\n %s\n%s" | i ->
f socket_type address message try
| other_exception -> raise other_exception 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 ( let hostname = lazy (
try try
Unix.gethostname () Unix.gethostname ()
with with
| _ -> "localhost" | _ -> "localhost"
) )
(** IP address *)
let ip_address = lazy ( let ip_address = lazy (
match Sys.getenv "QP_NIC" with match Sys.getenv "QP_NIC" with
| None -> | 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 stop ~port =
let zmq_context = debug "STOP";
ZMQ.Context.create () let req_socket =
in ZMQ.Socket.create zmq_context ZMQ.Socket.req
let req_socket = and address =
ZMQ.Socket.create zmq_context ZMQ.Socket.req Printf.sprintf "tcp://%s:%d" (Lazy.force ip_address) port
and address = in
Printf.sprintf "tcp://%s:%d" (Lazy.force ip_address) port ZMQ.Socket.set_linger_period req_socket 1_000_000;
in ZMQ.Socket.connect req_socket address;
ZMQ.Socket.connect req_socket address;
Message.Terminate (Message.Terminate_msg.create ()) Message.Terminate (Message.Terminate_msg.create ())
|> Message.to_string |> Message.to_string
|> ZMQ.Socket.send ~block:false req_socket ; |> ZMQ.Socket.send req_socket ;
let msg = let msg =
ZMQ.Socket.recv req_socket ZMQ.Socket.recv req_socket
|> Message.of_string |> Message.of_string
in in
let () = let () =
match msg with match msg with
| Message.Ok _ -> () | Message.Ok _ -> ()
| _ -> failwith "Problem in termination" | _ -> failwith "Problem in termination"
in in
ZMQ.Socket.set_linger_period req_socket 1000; ZMQ.Socket.set_linger_period req_socket 1_000;
ZMQ.Socket.close req_socket ZMQ.Socket.close req_socket
(** Run the task server *) let new_job msg program_state rep_socket =
let run ~port =
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 = let state =
get_state () msg.Message.Newjob_msg.state
and polling =
ZMQ.Poll.poll ~timeout:1000 pollitem
in in
let terminate () = let progress_bar =
running := false; Progress_bar.init
Message.to_string ok ~start_value:0.
|> ZMQ.Socket.send ~block:false rep_socket ~end_value:1.
~bar_length:20
~title:(Message.State.to_string state)
in
and newjob x = let result =
q := Queuing_system.create (); { program_state with
job := Some x; state = Some state ;
Message.to_string ok progress_bar = Some progress_bar ;
|> ZMQ.Socket.send ~block:false rep_socket 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 end_job msg program_state rep_socket =
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
and add_task state msg = let failure () =
let s, task = reply_wrong_state rep_socket;
msg.Message.AddTask_msg.state, program_state
msg.Message.AddTask_msg.task
in and success state =
assert (s = state); reply_ok rep_socket;
Message.to_string ok { program_state with
|> ZMQ.Socket.send ~block:false rep_socket state = None ;
; progress_bar = None ;
}
in
match program_state.state with
| None -> failure ()
| Some state ->
begin begin
match if (msg.Message.Endjob_msg.state = state) then
String.split ~on:' ' msg.Message.AddTask_msg.task success state
|> List.filter ~f:(fun x -> x <> "") else
with failure ()
| "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
end 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 connect msg program_state rep_socket =
let s, client_id, task_id =
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.state,
msg.Message.TaskDone_msg.client_id, msg.Message.TaskDone_msg.client_id,
msg.Message.TaskDone_msg.task_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 in
if (polling.(0) = Some ZMQ.Poll.In) then let increment_progress_bar = function
let raw_message = | Some bar -> Some (Progress_bar.increment_cur bar)
ZMQ.Socket.recv rep_socket | None -> None
in in
try
let message = let failure () =
Message.of_string raw_message 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 in
(* reply_ok rep_socket;
Printf.printf "%d %d : %s\n%!" result
(Queuing_system.number_of_queued !q) in
(Queuing_system.number_of_running !q)
(Message.to_string message);
Printf.printf "%s\n%!" (Queuing_system.to_string !q); *)
match (state, message) with
| _ , Message.Terminate _ -> terminate ()
| None , Message.Newjob x -> newjob x
| None , _ -> error "No job is running"
| _ , Message.Newjob _ -> error "A job is already running"
| Some s, Message.Connect x -> connect s x
| Some s, Message.Disconnect x -> disconnect s x
| Some s, Message.AddTask x -> add_task s x
| Some s, Message.GetTask x -> get_task s x
| Some s, Message.TaskDone x -> task_done s x
| _ , _ ->
error ("Invalid message : "^(Message.to_string message))
with
| Failure f -> error (f^" : "^raw_message)
| Assert_failure (f,i,j) -> error (Printf.sprintf "%s:%d:%d : %s" f i j raw_message)
done; match program_state.state with
ZMQ.Socket.set_linger_period rep_socket 1000; | None -> assert false
ZMQ.Socket.close rep_socket | 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
ocaml/_tags
View File

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

314
ocaml/qp_edit.ml
View File

@ -1,314 +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
| Hartree_fock
| Pseudo
| Integrals_bielec
| Perturbation
| Properties
| Foboci
| Determinants
;;
let keyword_to_string = function
| Ao_basis -> "AO basis"
| Determinants_by_hand -> "Determinants_by_hand"
| Electrons -> "Electrons"
| Mo_basis -> "MO basis"
| Nuclei -> "Molecule"
| Hartree_fock -> "Hartree_fock"
| Pseudo -> "Pseudo"
| Integrals_bielec -> "Integrals_bielec"
| Perturbation -> "Perturbation"
| Properties -> "Properties"
| Foboci -> "Foboci"
| Determinants -> "Determinants"
;;
(** 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)
| Hartree_fock ->
f Hartree_fock.(read, to_rst)
| Pseudo ->
f Pseudo.(read, to_rst)
| Integrals_bielec ->
f Integrals_bielec.(read, to_rst)
| Perturbation ->
f Perturbation.(read, to_rst)
| Properties ->
f Properties.(read, to_rst)
| Foboci ->
f Foboci.(read, to_rst)
| Determinants ->
f Determinants.(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
| Hartree_fock -> write Hartree_fock.(of_rst, write) s
| Pseudo -> write Pseudo.(of_rst, write) s
| Integrals_bielec -> write Integrals_bielec.(of_rst, write) s
| Perturbation -> write Perturbation.(of_rst, write) s
| Properties -> write Properties.(of_rst, write) s
| Foboci -> write Foboci.(of_rst, write) s
| Determinants -> write Determinants.(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 ;
Hartree_fock ;
Pseudo ;
Integrals_bielec ;
Perturbation ;
Properties ;
Foboci ;
Determinants ;
Mo_basis;
Determinants_by_hand ;
]
in
(* Create the temp file *)
let temp_filename = create_temp_file ezfio_filename tasks in
(* Open the temp file with external editor *)
let editor =
match Sys.getenv "EDITOR" with
| Some editor -> editor
| None -> "vi"
in
match check_only with
| true -> ()
| false ->
Printf.sprintf "%s %s" editor temp_filename
|> Sys.command_exn
;
(* Re-read the temp file *)
let temp_string =
In_channel.with_file temp_filename ~f:(fun in_channel ->
In_channel.input_all in_channel)
in
List.iter ~f:(fun x -> set temp_string x) tasks;
(* Remove temp_file *)
Sys.remove temp_filename;
;;
(** Create a backup file in case of an exception *)
let create_backup ezfio_filename =
Printf.sprintf "
rm -f %s/backup.tgz ;
tar -zcf .backup.tgz %s && mv .backup.tgz %s/backup.tgz
"
ezfio_filename ezfio_filename ezfio_filename
|> Sys.command_exn
;;
(** Restore the backup file when an exception occuprs *)
let restore_backup ezfio_filename =
Printf.sprintf "tar -zxf %s/backup.tgz"
ezfio_filename
|> Sys.command_exn
;;
let spec =
let open Command.Spec in
empty
+> flag "-c" no_arg
~doc:"Checks the input data"
(*
+> flag "o" (optional string)
~doc:"Prints output data"
*)
+> anon ("ezfio_file" %: string)
;;
let command =
Command.basic
~summary: "Quantum Package command"
~readme:(fun () ->
"
Edit input data
")
spec
(* (fun i o ezfio_file () -> *)
(*fun ezfio_file () ->
try
run ezfio_file
with
| _ msg -> print_string ("\n\nError\n\n"^msg^"\n\n")
*)
(fun c ezfio_file () ->
try
run c ezfio_file ;
(* create_backup ezfio_file; *)
with
| Failure exc
| Invalid_argument exc as e ->
begin
Printf.eprintf "=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n\n";
Printf.eprintf "%s\n\n" exc;
Printf.eprintf "=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n\n";
(* restore_backup ezfio_file; *)
raise e
end
| Assert_failure (file, line, ch) as e ->
begin
Printf.eprintf "=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n\n";
Printf.eprintf "Assert error in file $QP_ROOT/ocaml/%s, line %d, character %d\n\n" file line ch;
Printf.eprintf "=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n\n";
(* restore_backup ezfio_file; *)
raise e
end
)
;;
let () =
Command.run command;
exit 0
;;

19
ocaml/qp_print_basis.ml
View File

@ -35,7 +35,24 @@ let mo () =
|> print_endline |> 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 () = let () =
basis (); basis ();
mo () mo ();
psi_det ()

95
ocaml/qp_run.ml
View File

@ -1,21 +1,64 @@
open Core.Std;; open Core.Std
open Qputils;; open Qputils
(* Environment variables :
QP_PREFIX=gdb : to run gdb (or valgrind, or whatever)
QP_TASK_DEBUG=1 : debug task server
*)
let print_list () = let print_list () =
Lazy.force Qpackage.executables Lazy.force Qpackage.executables
|> List.iter ~f:(fun (x,_) -> Printf.printf " * %s\n" x) |> 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 if (not (Sys.file_exists_exn ezfio_file)) then
failwith ("EZFIO directory "^ezfio_file^" not found"); failwith ("EZFIO directory "^ezfio_file^" not found");
let executables = Lazy.force Qpackage.executables in let executables = Lazy.force Qpackage.executables in
if (not (List.exists ~f:(fun (x,_) -> x = exe) executables)) then 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 "%s\n" (Time.to_string time_start);
Printf.printf "===============\nQuantum Package\n===============\n\n"; Printf.printf "===============\nQuantum Package\n===============\n\n";
@ -26,16 +69,18 @@ let run exe ezfio_file =
(** Check input *) (** Check input *)
match (Sys.command ("qp_edit -c "^ezfio_file)) with begin
| 0 -> () match (Sys.command ("qp_edit -c "^ezfio_file)) with
| i -> failwith "Error: Input inconsistent\n"; | 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 *) (** Start task server *)
let port_number =
12345
in
let address = let address =
Printf.sprintf "tcp://%s:%d" (Lazy.force TaskServer.ip_address) port_number Printf.sprintf "tcp://%s:%d" (Lazy.force TaskServer.ip_address) port_number
in in
@ -49,12 +94,16 @@ let run exe ezfio_file =
Unix.putenv ~key:"QP_RUN_ADDRESS" ~data:address; Unix.putenv ~key:"QP_RUN_ADDRESS" ~data:address;
(** Run executable *) (** 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 match (List.find ~f:(fun (x,_) -> x = exe) executables) with
| Some (_,x) -> x^" "
| None -> assert false | None -> assert false
| Some (_,x) -> x
in in
match (Sys.command (exe^" "^ezfio_file)) with match (Sys.command (prefix^exe^ezfio_file)) with
| 0 -> () | 0 -> ()
| i -> Printf.printf "Program exited with code %d.\n%!" i; | 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 let duration = Time.diff (Time.now()) time_start
|> Core.Span.to_string in |> Core.Span.to_string in
Printf.printf "Wall time : %s\n\n" duration; Printf.printf "Wall time : %s\n\n" duration
;;
let spec = let spec =
let open Command.Spec in let open Command.Spec in
empty empty
+> flag "master" (optional string)
~doc:("address Address of the master process")
+> anon ("executable" %: string) +> anon ("executable" %: string)
+> anon ("ezfio_file" %: string) +> anon ("ezfio_file" %: string)
;; ;;
let () = let () =
Command.basic Command.basic
~summary: "Quantum Package command" ~summary: "Quantum Package command"
@ -85,10 +137,9 @@ Executes a Quantum Package binary file among these:\n\n"
) )
) )
spec spec
(fun exe ezfio_file () -> (fun master exe ezfio_file () ->
run exe ezfio_file run ~master exe ezfio_file
) )
|> Command.run ~version: Git.sha1 ~build_info: Git.message |> Command.run ~version: Git.sha1 ~build_info: Git.message
;;

3
ocaml/qptypes_generator.ml
View File

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

4
ocaml/test_message.ml
View File

@ -1,7 +1,7 @@
open Core.Std open Core.Std
let () = 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 |> Message.to_string
|> print_endline |> print_endline
; ;
@ -37,7 +37,7 @@ let () =
; ;
try 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 |> Message.to_string
|> print_endline |> print_endline
; ;

59
ocaml/test_task_server.py
View File

@ -3,7 +3,6 @@
import zmq import zmq
import sys, os import sys, os
def main(): def main():
context = zmq.Context() context = zmq.Context()
socket = context.socket(zmq.REQ) socket = context.socket(zmq.REQ)
@ -11,9 +10,11 @@ def main():
def send(msg,expected): def send(msg,expected):
print "Send : ", msg print "Send : ", msg
print " -> ", socket.send(msg) socket.send(msg)
reply = socket.recv() reply = socket.recv()
print "Reply : ", reply print "Reply : ", ':'+reply+':'
if (reply != expected):
print "Expected: ", ':'+expected+':'
print "" print ""
assert (reply == expected) assert (reply == expected)
@ -23,23 +24,59 @@ def main():
send("new_job ao_integrals tcp://130.120.229.139:12345 inproc://ao_integrals", send("new_job ao_integrals tcp://130.120.229.139:12345 inproc://ao_integrals",
"error A job is already running") "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 tcp","connect_reply ao_integrals 1 tcp://130.120.229.139:12345")
send("connect inproc","connect_reply ao_integrals 2 inproc://ao_integrals") 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 3","error Queuing_system.ml:68:2 : disconnect ao_integrals 3")
send("disconnect ao_integrals 2","disconnect_reply ao_integrals 1") send("disconnect ao_integrals 2","disconnect_reply ao_integrals")
send("connect inproc","connect_reply ao_integrals 3 inproc://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") 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 10 10 20")
send("get_task ao_integrals 3", "get_task_reply %d %d %d"%(i+1,i,i+10)) send("get_task ao_integrals 3", "get_task_reply 9 9 19")
send("task_done ao_integrals 3 %d"%(i+1), "ok") 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") send("terminate","ok")
if __name__ == '__main__': if __name__ == '__main__':

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -13,11 +13,11 @@ subroutine super_CI
character :: save_char character :: save_char
call write_time(output_hartree_fock) 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 ' ' 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 E = HF_energy + 1.d0
@ -39,7 +39,7 @@ subroutine super_CI
save_char = ' ' save_char = ' '
endif endif
E_min = min(E,E_min) 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 k, E, delta_E, save_char
if ( (delta_E < 0.d0).and.(dabs(delta_E) < thresh_scf) ) then if ( (delta_E < 0.d0).and.(dabs(delta_E) < thresh_scf) ) then
exit exit
@ -55,7 +55,7 @@ subroutine super_CI
TOUCH mo_coef TOUCH mo_coef
enddo 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) call write_time(output_hartree_fock)
end end

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

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

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

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

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

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

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

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

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

@ -4,39 +4,47 @@ from generate_h_apply import *
s = H_apply("FCI") s = H_apply("FCI")
s.set_selection_pt2("epstein_nesbet_2x2") s.set_selection_pt2("epstein_nesbet_2x2")
#s.unset_openmp()
print s print s
s = H_apply("FCI_PT2") s = H_apply_zmq("FCI_PT2")
s.set_perturbation("epstein_nesbet_2x2") s.set_perturbation("epstein_nesbet_2x2")
#s.unset_openmp()
print s print s
s = H_apply("FCI_no_skip") s = H_apply("FCI_no_skip")
s.set_selection_pt2("epstein_nesbet_2x2") s.set_selection_pt2("epstein_nesbet_2x2")
s.unset_skip() s.unset_skip()
#s.unset_openmp()
print s print s
s = H_apply("FCI_mono") s = H_apply("FCI_mono")
s.set_selection_pt2("epstein_nesbet_2x2") s.set_selection_pt2("epstein_nesbet_2x2")
s.unset_double_excitations() s.unset_double_excitations()
s.unset_openmp()
print s print s
s = H_apply("select_mono_delta_rho") s = H_apply("select_mono_delta_rho")
s.unset_double_excitations() s.unset_double_excitations()
s.set_selection_pt2("delta_rho_one_point") s.set_selection_pt2("delta_rho_one_point")
s.unset_openmp()
print s print s
s = H_apply("pt2_mono_delta_rho") s = H_apply("pt2_mono_delta_rho")
s.unset_double_excitations() s.unset_double_excitations()
s.set_perturbation("delta_rho_one_point") s.set_perturbation("delta_rho_one_point")
s.unset_openmp()
print s print s
s = H_apply("select_mono_di_delta_rho") s = H_apply("select_mono_di_delta_rho")
s.set_selection_pt2("delta_rho_one_point") s.set_selection_pt2("delta_rho_one_point")
s.unset_openmp()
print s print s
s = H_apply("pt2_mono_di_delta_rho") s = H_apply("pt2_mono_di_delta_rho")
s.set_perturbation("delta_rho_one_point") s.set_perturbation("delta_rho_one_point")
s.unset_openmp()
print s print s

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

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

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

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

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

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

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

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

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

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

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

@ -30,11 +30,11 @@ subroutine damping_SCF
call write_time(output_hartree_fock) 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' ' 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 E = HF_energy + 1.d0
@ -58,7 +58,7 @@ subroutine damping_SCF
save_char = ' ' save_char = ' '
endif 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 k, E, delta_E, delta_D, save_char
D_alpha = HF_density_matrix_ao_alpha D_alpha = HF_density_matrix_ao_alpha
@ -116,7 +116,7 @@ subroutine damping_SCF
enddo 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,*) 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) call mo_as_eigvectors_of_mo_matrix(Fock_matrix_mo,size(Fock_matrix_mo,1),size(Fock_matrix_mo,2),mo_label,1)

13
plugins/MRCC_CASSD/EZFIO.cfg
View File

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

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

@ -3,19 +3,19 @@ BEGIN_SHELL [ /usr/bin/env python ]
from generate_h_apply import * from generate_h_apply import *
s = H_apply("mrcc") 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"] += """ s.data["declarations"] += """
integer, intent(in) :: Ndet_ref,Ndet_non_ref integer, intent(in) :: Nstates, Ndet_ref, Ndet_non_ref
double precision, intent(in) :: delta_ij_(Ndet_ref,Ndet_non_ref,*) double precision, intent(in) :: delta_ij_(Nstates, Ndet_non_ref, Ndet_ref)
double precision, intent(in) :: delta_ii_(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["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_, Ndet_ref, Ndet_non_ref" s.data["params_post"] += ", delta_ij_, delta_ii_, Nstates, Ndet_non_ref, Ndet_ref"
s.data["params_main"] += "delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref" s.data["params_main"] += "delta_ij_, delta_ii_, Nstates, Ndet_non_ref, Ndet_ref"
s.data["decls_main"] += """ s.data["decls_main"] += """
integer, intent(in) :: Ndet_ref,Ndet_non_ref integer, intent(in) :: Ndet_ref, Ndet_non_ref, Nstates
double precision, intent(in) :: delta_ij_(Ndet_ref,Ndet_non_ref,*) double precision, intent(in) :: delta_ij_(Nstates,Ndet_non_ref,Ndet_ref)
double precision, intent(in) :: delta_ii_(Ndet_ref,*) double precision, intent(in) :: delta_ii_(Nstates,Ndet_ref)
""" """
s.data["finalization"] = "" s.data["finalization"] = ""
s.data["copy_buffer"] = "" s.data["copy_buffer"] = ""
@ -24,27 +24,5 @@ s.data["size_max"] = "3072"
print s 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 END_SHELL

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

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

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

@ -14,14 +14,14 @@ BEGIN_PROVIDER [ integer(omp_lock_kind), psi_ref_lock, (psi_det_size) ]
END_PROVIDER 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 use bitmasks
implicit none implicit none
integer, intent(in) :: i_generator,n_selected, Nint, iproc integer, intent(in) :: i_generator,n_selected, Nint, iproc
integer, intent(in) :: Ndet_ref, Ndet_non_ref integer, intent(in) :: Nstates, Ndet_ref, Ndet_non_ref
double precision, intent(inout) :: delta_ij_(Ndet_ref,Ndet_non_ref,*) double precision, intent(inout) :: delta_ij_(Nstates,Ndet_non_ref,Ndet_ref)
double precision, intent(inout) :: delta_ii_(Ndet_ref,*) double precision, intent(inout) :: delta_ii_(Nstates,Ndet_ref)
integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected)
integer :: i,j,k,l integer :: i,j,k,l
@ -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(bit_kind) :: tq(Nint,2,n_selected)
integer :: N_tq, c_ref ,degree 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, allocatable :: dIa_hla(:,:)
double precision :: haj, phase, phase2 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 :: exc(0:2,2,2)
integer :: h1,h2,p1,p2,s1,s2 integer :: h1,h2,p1,p2,s1,s2
integer(bit_kind) :: tmp_det(Nint,2) integer(bit_kind) :: tmp_det(Nint,2)
@ -46,10 +46,11 @@ 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(bit_kind),intent(in) :: key_mask(Nint, 2)
integer,allocatable :: idx_miniList(:) integer,allocatable :: idx_miniList(:)
integer :: N_miniList, ni, leng integer :: N_miniList, ni, leng
double precision, allocatable :: hij_cache(:)
leng = max(N_det_generators, N_det_non_ref) 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) !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) call create_minilist_find_previous(key_mask, psi_det_generators, miniList, i_generator-1, N_miniList, fullMatch, Nint)
@ -61,123 +62,156 @@ subroutine mrcc_dress(delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref,i_generator,n
call find_triples_and_quadruples(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist) call find_triples_and_quadruples(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist)
allocate (dIa_hla(N_states,Ndet_non_ref)) allocate (dIa_hla(Nstates,Ndet_non_ref))
! |I> ! |I>
! |alpha> ! |alpha>
if(N_tq > 0) then if(N_tq > 0) then
call create_minilist(key_mask, psi_non_ref, miniList, idx_miniList, N_det_non_ref, N_minilist, Nint) call create_minilist(key_mask, psi_non_ref, miniList, idx_miniList, N_det_non_ref, N_minilist, Nint)
end if end if
do i_alpha=1,N_tq 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(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) call get_excitation_degree_vector(miniList,tq(1,1,i_alpha),degree_alpha,Nint,N_minilist,idx_alpha)
do j=1,idx_alpha(0) do j=1,idx_alpha(0)
idx_alpha(j) = idx_miniList(idx_alpha(j)) idx_alpha(j) = idx_miniList(idx_alpha(j))
end do end do
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> ! |I>
do i_I=1,N_det_ref do i_I=1,N_det_ref
! Find triples and quadruple grand parents ! Find triples and quadruple grand parents
call get_excitation_degree(tq(1,1,i_alpha),psi_ref(1,1,i_I),degree,Nint) call get_excitation_degree(tq(1,1,i_alpha),psi_ref(1,1,i_I),degree,Nint)
if (degree > 4) then if (degree > 4) then
cycle cycle
endif endif
do i_state=1,N_states do i_state=1,Nstates
dIa(i_state) = 0.d0 dIa(i_state) = 0.d0
enddo enddo
! <I| <> |alpha> ! <I| <> |alpha>
do k_sd=1,idx_alpha(0) do k_sd=1,idx_alpha(0)
call get_excitation_degree(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),degree,Nint)
if (degree > 2) then
cycle
endif
! <I| /k\ |alpha>
! <I|H|k>
call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),Nint,hIk)
do i_state=1,N_states
dIk(i_state) = hIk * lambda_mrcc(i_state,idx_alpha(k_sd))
enddo
! |l> = Exc(k -> alpha) |I>
call get_excitation(psi_non_ref(1,1,idx_alpha(k_sd)),tq(1,1,i_alpha),exc,degree,phase,Nint)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
do k=1,N_int
tmp_det(k,1) = psi_ref(k,1,i_I)
tmp_det(k,2) = psi_ref(k,2,i_I)
enddo
! Hole (see list_to_bitstring)
iint = ishft(h1-1,-bit_kind_shift) + 1
ipos = h1-ishft((iint-1),bit_kind_shift)-1
tmp_det(iint,s1) = ibclr(tmp_det(iint,s1),ipos)
! Particle ! Loop if lambda == 0
iint = ishft(p1-1,-bit_kind_shift) + 1 logical :: loop
ipos = p1-ishft((iint-1),bit_kind_shift)-1 loop = .True.
tmp_det(iint,s1) = ibset(tmp_det(iint,s1),ipos) do i_state=1,Nstates
if (degree_alpha(k_sd) == 2) then if (lambda_mrcc(i_state,idx_alpha(k_sd)) /= 0.d0) then
! Hole (see list_to_bitstring) loop = .False.
iint = ishft(h2-1,-bit_kind_shift) + 1 exit
ipos = h2-ishft((iint-1),bit_kind_shift)-1 endif
tmp_det(iint,s2) = ibclr(tmp_det(iint,s2),ipos) enddo
if (loop) then
cycle
endif
! Particle call get_excitation_degree(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),degree,Nint)
iint = ishft(p2-1,-bit_kind_shift) + 1 if (degree > 2) then
ipos = p2-ishft((iint-1),bit_kind_shift)-1 cycle
tmp_det(iint,s2) = ibset(tmp_det(iint,s2),ipos) endif
endif
! <I| \l/ |alpha> ! <I| /k\ |alpha>
do i_state=1,N_states ! <I|H|k>
dka(i_state) = 0.d0 hIk = hij_mrcc(idx_alpha(k_sd),i_I)
enddo ! call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),Nint,hIk)
do l_sd=k_sd+1,idx_alpha(0) do i_state=1,Nstates
call get_excitation_degree(tmp_det,psi_non_ref(1,1,idx_alpha(l_sd)),degree,Nint) dIk(i_state) = hIk * lambda_mrcc(i_state,idx_alpha(k_sd))
if (degree == 0) then enddo
call get_excitation(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),exc,degree,phase2,Nint) ! |l> = Exc(k -> alpha) |I>
call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hIl) call get_excitation(psi_non_ref(1,1,idx_alpha(k_sd)),tq(1,1,i_alpha),exc,degree,phase,Nint)
do i_state=1,N_states call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
dka(i_state) = hIl * lambda_mrcc(i_state,idx_alpha(l_sd)) * phase * phase2 do k=1,N_int
enddo tmp_det(k,1) = psi_ref(k,1,i_I)
exit tmp_det(k,2) = psi_ref(k,2,i_I)
endif enddo
enddo ! Hole (see list_to_bitstring)
do i_state=1,N_states iint = ishft(h1-1,-bit_kind_shift) + 1
dIa(i_state) = dIa(i_state) + dIk(i_state) * dka(i_state) ipos = h1-ishft((iint-1),bit_kind_shift)-1
enddo tmp_det(iint,s1) = ibclr(tmp_det(iint,s1),ipos)
enddo
do i_state=1,N_states ! Particle
ci_inv(i_state) = 1.d0/psi_ref_coef(i_I,i_state) iint = ishft(p1-1,-bit_kind_shift) + 1
enddo ipos = p1-ishft((iint-1),bit_kind_shift)-1
do l_sd=1,idx_alpha(0) tmp_det(iint,s1) = ibset(tmp_det(iint,s1),ipos)
k_sd = idx_alpha(l_sd) if (degree_alpha(k_sd) == 2) then
call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hla) ! Hole (see list_to_bitstring)
do i_state=1,N_states iint = ishft(h2-1,-bit_kind_shift) + 1
dIa_hla(i_state,k_sd) = dIa(i_state) * hla ipos = h2-ishft((iint-1),bit_kind_shift)-1
enddo tmp_det(iint,s2) = ibclr(tmp_det(iint,s2),ipos)
enddo
call omp_set_lock( psi_ref_lock(i_I) ) ! Particle
do l_sd=1,idx_alpha(0) iint = ishft(p2-1,-bit_kind_shift) + 1
k_sd = idx_alpha(l_sd) ipos = p2-ishft((iint-1),bit_kind_shift)-1
do i_state=1,N_states tmp_det(iint,s2) = ibset(tmp_det(iint,s2),ipos)
delta_ij_(i_I,k_sd,i_state) += dIa_hla(i_state,k_sd) endif
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) ! <I| \l/ |alpha>
else do i_state=1,Nstates
delta_ii_(i_I,i_state) = 0.d0 dka(i_state) = 0.d0
endif enddo
enddo do l_sd=k_sd+1,idx_alpha(0)
enddo call get_excitation_degree(tmp_det,psi_non_ref(1,1,idx_alpha(l_sd)),degree,Nint)
call omp_unset_lock( psi_ref_lock(i_I) ) 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
enddo enddo
deallocate (dIa_hla) deallocate (dIa_hla,hij_cache)
deallocate(miniList, idx_miniList) deallocate(miniList, idx_miniList)
end end

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

@ -31,23 +31,7 @@ subroutine mrcc_iterations
E_past(j) = E_new E_past(j) = E_new
j +=1 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 call save_wavefunction
! if (i_oscillations > 5) then
! exit
! endif
if (iteration > 200) then if (iteration > 200) then
exit exit
endif endif

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

@ -1,99 +1,32 @@
BEGIN_PROVIDER [integer, pert_determinants, (N_states, psi_det_size) ] BEGIN_PROVIDER [ double precision, lambda_mrcc, (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) ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! cm/<Psi_0|H|D_m> or perturbative 1/Delta_E(m) ! cm/<Psi_0|H|D_m> or perturbative 1/Delta_E(m)
END_DOC END_DOC
integer :: i,k,j integer :: i,k
double precision :: ihpsi(N_states), hii,delta_e_eff,ihpsi_current(N_states),hij double precision :: ihpsi(N_states),ihpsi_current(N_states)
integer :: i_ok,i_pert,i_pert_count integer :: i_pert_count
i_ok = 0
double precision :: phase_restart(N_states),tmp
do k = 1, N_states
phase_restart(k) = dsign(1.d0,psi_ref_coef_restart(1,k)/psi_ref_coef(1,k))
enddo
i_pert_count = 0 i_pert_count = 0
lambda_mrcc = 0.d0
do i=1,N_det_non_ref 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,& 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)
size(psi_ref_coef_restart,1), n_states, ihpsi) do k=1,N_states
call i_H_j(psi_non_ref(1,1,i),psi_non_ref(1,1,i),N_int,hii) if (ihpsi_current(k) == 0.d0) then
! TODO --- Test perturbatif ------ ihpsi_current(k) = 1.d-32
do k=1,N_states endif
lambda_pert(k,i) = 1.d0 / (psi_ref_energy_diagonalized(k)-hii) if(dabs(ihpsi_current(k) * psi_non_ref_coef(i,k)) < 1d-5) then
! TODO : i_h_psi peut sortir de la boucle? i_pert_count +=1
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) else
if (ihpsi_current(k) == 0.d0) then lambda_mrcc(k,i) = psi_non_ref_coef(i,k)/ihpsi_current(k)
ihpsi_current(k) = 1.d-32 endif
endif enddo
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
if( i_pert == 1)then
pert_determinants(k,i) = i_pert
endif
if(pert_determinants(k,i) == 1)then
i_ok +=1
lambda_mrcc(k,i) = lambda_pert(k,i)
else
lambda_mrcc(k,i) = psi_non_ref_coef(i,k)/ihpsi_current(k)
endif
enddo
! TODO --- Fin test perturbatif ------
enddo enddo
!if(oscillations)then
! print*,'AVERAGING the lambda_mrcc with those of the previous iterations'
! do i = 1, N_det_non_ref
! do k = 1, N_states
! double precision :: tmp
! tmp = lambda_mrcc(k,i)
! lambda_mrcc(k,i) += lambda_mrcc_tmp(k,i)
! lambda_mrcc(k,i) = lambda_mrcc(k,i) * 0.5d0
! if(dabs(tmp - lambda_mrcc(k,i)).ge.1.d-9)then
! print*,''
! print*,'i = ',i
! print*,'psi_non_ref_coef(i,k) = ',psi_non_ref_coef(i,k)
! print*,'lambda_mrcc(k,i) = ',lambda_mrcc(k,i)
! print*,' tmp = ',tmp
! endif
! enddo
! enddo
!endif
print*,'N_det_non_ref = ',N_det_non_ref print*,'N_det_non_ref = ',N_det_non_ref
print*,'Number of Perturbatively treated determinants = ',i_ok print*,'Number of ignored determinants = ',i_pert_count
print*,'i_pert_count = ',i_pert_count
print*,'psi_coef_ref_ratio = ',psi_ref_coef(2,1)/psi_ref_coef(1,1) print*,'psi_coef_ref_ratio = ',psi_ref_coef(2,1)/psi_ref_coef(1,1)
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 END_PROVIDER
@ -108,8 +41,22 @@ END_PROVIDER
!call H_apply_mrcc_simple(delta_ij_non_ref,N_det_non_ref) !call H_apply_mrcc_simple(delta_ij_non_ref,N_det_non_ref)
!END_PROVIDER !END_PROVIDER
BEGIN_PROVIDER [ double precision, delta_ij, (N_det_ref,N_det_non_ref,N_states) ] BEGIN_PROVIDER [ double precision, hij_mrcc, (N_det_non_ref,N_det_ref) ]
&BEGIN_PROVIDER [ double precision, delta_ii, (N_det_ref,N_states) ] 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 implicit none
BEGIN_DOC BEGIN_DOC
! Dressing matrix in N_det basis ! Dressing matrix in N_det basis
@ -117,32 +64,7 @@ END_PROVIDER
integer :: i,j,m integer :: i,j,m
delta_ij = 0.d0 delta_ij = 0.d0
delta_ii = 0.d0 delta_ii = 0.d0
call H_apply_mrcc(delta_ij,delta_ii,N_det_ref,N_det_non_ref) call H_apply_mrcc(delta_ij,delta_ii,N_states,N_det_non_ref,N_det_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
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
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ double precision, h_matrix_dressed, (N_det,N_det,N_states) ] BEGIN_PROVIDER [ double precision, h_matrix_dressed, (N_det,N_det,N_states) ]
@ -159,11 +81,11 @@ BEGIN_PROVIDER [ double precision, h_matrix_dressed, (N_det,N_det,N_states) ]
enddo enddo
do ii = 1, N_det_ref do ii = 1, N_det_ref
i =idx_ref(ii) 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 do jj = 1, N_det_non_ref
j =idx_non_ref(jj) j =idx_non_ref(jj)
h_matrix_dressed(i,j,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(ii,jj,istate) h_matrix_dressed(j,i,istate) += delta_ij(istate,jj,ii)
enddo enddo
enddo enddo
enddo enddo
@ -267,3 +189,4 @@ subroutine diagonalize_CI_dressed
SOFT_TOUCH psi_coef SOFT_TOUCH psi_coef
end end

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

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

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

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

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

@ -3,7 +3,6 @@ import perturbation
END_SHELL 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) 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 implicit none
BEGIN_DOC 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) :: 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, 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) 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 integer, external :: connected_to_ref
logical, external :: is_in_wavefunction 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 ) deallocate( minilist, minilist_gen, idx_minilist )
return return
end if end if
call create_minilist(key_mask, psi_selectors, minilist, idx_miniList, N_det_selectors, N_minilist, Nint) call create_minilist(key_mask, psi_selectors, minilist, idx_miniList, N_det_selectors, N_minilist, Nint)
allocate( microlist(Nint,2,N_minilist*4), & allocate( microlist(Nint,2,N_minilist*4), &
idx_microlist(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 i=0,mo_tot_num*2
do k=ptr_microlist(i),ptr_microlist(i+1)-1 do k=ptr_microlist(i),ptr_microlist(i+1)-1
idx_microlist(k) = idx_minilist(idx_microlist(k)) idx_microlist(k) = idx_minilist(idx_microlist(k))
end do end do
end do end do
if(N_microlist(0) > 0) then if(N_microlist(0) > 0) then
microlist_zero(:,:,1:N_microlist(0)) = microlist(:,:,1:N_microlist(0)) ! TODO OLD
idx_microlist_zero(1:N_microlist(0)) = idx_microlist(1:N_microlist(0)) ! 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
end if end if
@ -100,7 +110,7 @@ subroutine perturb_buffer_$PERT(i_generator,buffer,buffer_size,e_2_pert_buffer,c
endif endif
if(key_mask(1,1) /= 0) then 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 if(N_microlist(mobiles(1)) < N_microlist(mobiles(2))) then
smallerlist = mobiles(1) smallerlist = mobiles(1)
else else
@ -108,24 +118,44 @@ subroutine perturb_buffer_$PERT(i_generator,buffer,buffer_size,e_2_pert_buffer,c
end if end if
if(N_microlist_gen(smallerlist) > 0) then 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 cycle
end if end if
end if end if
if(N_microlist_gen(0) > 0) then 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 cycle
end if end if
end if end if
if(N_microlist(smallerlist) > 0) then 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) ! TODO OLD
idx_microlist_zero(ptr_microlist(1):ptr_microlist(1)+N_microlist(smallerlist)-1) = idx_microlist(ptr_microlist(smallerlist):ptr_microlist(smallerlist+1)-1) ! microlist_zero(:,:,ptr_microlist(1):ptr_microlist(1)+N_microlist(smallerlist)-1) = 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)) ! 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 end if
call pt2_$PERT(psi_det_generators(1,1,i_generator),buffer(1,1,i), fock_diag_tmp, & 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)) 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 else
ASSERT (N_minilist_gen <= N_det_generators)
if(is_connected_to(buffer(1,1,i), miniList_gen, Nint, N_minilist_gen)) then if(is_connected_to(buffer(1,1,i), miniList_gen, Nint, N_minilist_gen)) then
cycle cycle
end if end if
@ -146,9 +176,9 @@ subroutine perturb_buffer_$PERT(i_generator,buffer,buffer_size,e_2_pert_buffer,c
enddo enddo
enddo enddo
deallocate( minilist, minilist_gen, idx_minilist ) deallocate( minilist, minilist_gen, idx_minilist, &
deallocate( microlist, idx_microlist, N_microlist,ptr_microlist ) microlist, idx_microlist, N_microlist,ptr_microlist, &
deallocate( microlist_gen, idx_microlist_gen,N_microlist_gen,ptr_microlist_gen ) microlist_gen, idx_microlist_gen,N_microlist_gen,ptr_microlist_gen )
end end

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

@ -14,6 +14,31 @@ use bitmasks
END_PROVIDER 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 [ 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) ] &BEGIN_PROVIDER [ double precision, psi_non_ref_coef, (psi_det_size,n_states) ]

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

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

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

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

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

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

63
plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py
View File

@ -9,6 +9,7 @@ print "#QP -> QMCPACK"
from ezfio import ezfio from ezfio import ezfio
import os
import sys import sys
ezfio_path = sys.argv[1] ezfio_path = sys.argv[1]
@ -17,7 +18,15 @@ ezfio.set_file(ezfio_path)
do_pseudo = ezfio.get_pseudo_do_pseudo() do_pseudo = ezfio.get_pseudo_do_pseudo()
if do_pseudo: if do_pseudo:
print "do_pseudo True" 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: else:
print "do_pseudo False" print "do_pseudo False"
@ -68,11 +77,10 @@ print "nucl_num", len(l_label)
print "Atomic coord in Bohr" print "Atomic coord in Bohr"
for i, t in enumerate(zip(l_label, l_charge, l_coord_str)): for i, t in enumerate(zip(l_label, l_charge, l_coord_str)):
try: t_1 = d_z[t[0]] if do_pseudo else t[1]
l = (t[0], t[1] + zcore[i], t[2])
except NameError: t_new = [t[0],t_1,t[2]]
l = t print list_to_string(t_new)
print list_to_string(l)
# #
# Call externet process to get the sysmetry # Call externet process to get the sysmetry
@ -83,7 +91,7 @@ process = subprocess.Popen(
stdout=subprocess.PIPE) stdout=subprocess.PIPE)
out, err = process.communicate() 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 _ (_ _ _|_ # |_) _. _ o _ (_ _ _|_
@ -306,7 +314,7 @@ if do_pseudo:
l_str.append(l_dump) l_str.append(l_dump)
str_ = "PARAMETERS FOR {0} ON ATOM {1} WITH ZCORE {2} AND LMAX {3} ARE" 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): for i, l in enumerate(l_str):
str_ = "FOR L= {0} COEFF N ZETA" str_ = "FOR L= {0} COEFF N ZETA"
@ -315,7 +323,7 @@ if do_pseudo:
print " ", ii + 1, ll print " ", ii + 1, ll
str_ = "THE ECP RUN REMOVES {0} CORE ELECTRONS, AND THE SAME NUMBER OF PROTONS." 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" print "END_PSEUDO"
# _ # _
@ -329,31 +337,26 @@ print "mo_num", mo_num
print "det_num", n_det print "det_num", n_det
print "" 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 = "" token = "Determinants ::"
for i,int_det in enumerate(l_det_bit_alpha): pos = det_raw.rfind(token) + len(token)
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))
print bin_det det_without_header = det_raw[pos+2::]
bin_det = "" d_rep={"+":"1","-":"0"}
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))
print bin_det det_without_header = det_raw[pos+2::]
print ""
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" print "END_DET"

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

@ -14,6 +14,12 @@ program qmcpack
enddo enddo
enddo enddo
call ezfio_set_ao_basis_ao_coef(ao_coef) 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('rm '//trim(ezfio_filename)//'/mo_basis/ao_md5')
call system('$QP_ROOT/src/qmcpack/qp_convert_qmcpack_to_ezfio.py '//trim(ezfio_filename)) call system('$QP_ROOT/src/qmcpack/qp_convert_qmcpack_to_ezfio.py '//trim(ezfio_filename))

2
scripts/ezfio_interface/ei_handler.py
View File

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

2
scripts/ezfio_interface/qp_edit_template
View File

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

147
scripts/generate_h_apply.py
View File

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

3
scripts/module/qp_module.py
View File

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

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

@ -50,9 +50,6 @@ END_PROVIDER
enddo enddo
enddo enddo
ao_coef_normalization_factor(i) = 1.d0/sqrt(norm) 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 enddo
END_PROVIDER END_PROVIDER

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

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

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

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

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

@ -1,13 +1,12 @@
subroutine $subroutine_diexc(key_in, key_prev, hole_1,particl_1, hole_2, particl_2, fock_diag_tmp, i_generator, iproc_in $parameters ) 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) :: 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), 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(bit_kind) :: p1_mask(N_int, 2), p2_mask(N_int, 2), tmp
integer,intent(in) :: i_generator,iproc_in integer,intent(in) :: i_generator,iproc_in
integer(bit_kind) :: status(N_int*bit_kind_size, 2) integer :: status(N_int*bit_kind_size, 2)
integer :: highest, p1,p2,sp,ni,i,mi,nt,ns integer :: highest, p1,p2,sp,ni,i,mi,nt,ns,k
double precision, intent(in) :: fock_diag_tmp(2,mo_tot_num+1) double precision, intent(in) :: fock_diag_tmp(2,mo_tot_num+1)
integer(bit_kind), intent(in) :: key_prev(N_int, 2, *) integer(bit_kind), intent(in) :: key_prev(N_int, 2, *)
PROVIDE N_int PROVIDE N_int
@ -17,16 +16,19 @@ subroutine $subroutine_diexc(key_in, key_prev, hole_1,particl_1, hole_2, particl
highest = 0 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 sp=1,2
do ni=1,N_int do ni=1,N_int
do i=1,bit_kind_size 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 cycle
end if end if
mi = (ni-1)*bit_kind_size+i mi = (ni-1)*bit_kind_size+i
status(mi, sp) = iand(1,ishft(hole_1(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*iand(1,ishft(hole_2(ni, sp), -(i-1))) 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 if(status(mi, sp) /= 0 .and. mi > highest) then
highest = mi highest = mi
end if 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(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,intent(in) :: fs1,fs2,i_generator,iproc_in, fh1,fh2
integer(bit_kind) :: miniList(N_int, 2, N_det) 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 $declarations
integer(bit_kind), parameter :: one = 1_bit_kind integer(bit_kind), parameter :: one = 1_bit_kind
p1_mask(:,:) = 0_bit_kind do k=1,N_int
p2_mask(:,:) = 0_bit_kind 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)) 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)) 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(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)) 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 accu = 0.d0
do ispin=1,2 do ispin=1,2
other_spin = iand(ispin,1)+1 other_spin = iand(ispin,1)+1
if (abort_here) then
exit
endif
$omp_do $omp_do
do ii=1,ia_ja_pairs(1,0,ispin) do ii=1,ia_ja_pairs(1,0,ispin)
if (abort_here) then
cycle
endif
i_a = ia_ja_pairs(1,ii,ispin) i_a = ia_ja_pairs(1,ii,ispin)
ASSERT (i_a > 0) ASSERT (i_a > 0)
ASSERT (i_a <= mo_tot_num) 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 $keys_work
key_idx = 0 key_idx = 0
endif endif
if (abort_here) then
exit
endif
enddo enddo
endif endif
@ -366,9 +366,6 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl
$keys_work $keys_work
key_idx = 0 key_idx = 0
endif endif
if (abort_here) then
exit
endif
enddo ! kk enddo ! kk
enddo ! ii 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_1p
logical :: is_a_2p 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 iproc = iproc_in
@ -533,168 +533,3 @@ subroutine $subroutine_monoexc(key_in, hole_1,particl_1,fock_diag_tmp,i_generato
end end
subroutine $subroutine($params_main)
implicit none
use omp_lib
use bitmasks
BEGIN_DOC
! Calls H_apply on the HF determinant and selects all connected single and double
! excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script.
END_DOC
$decls_main
integer :: i_generator, nmax
double precision :: wall_0, wall_1
integer(omp_lock_kind) :: lck
integer(bit_kind), allocatable :: mask(:,:,:)
integer :: ispin, k
integer :: iproc
double precision, allocatable :: fock_diag_tmp(:,:)
$initialization
PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators
nmax = mod( N_det_generators,nproc )
!$ call omp_init_lock(lck)
call start_progress(N_det_generators,'Selection (norm)',0.d0)
call wall_time(wall_0)
iproc = 0
allocate( mask(N_int,2,6), fock_diag_tmp(2,mo_tot_num+1) )
do i_generator=1,nmax
progress_bar(1) = i_generator
if (abort_here) then
exit
endif
$skip
! Compute diagonal of the Fock matrix
call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int)
! Create bit masks for holes and particles
do ispin=1,2
do k=1,N_int
mask(k,ispin,s_hole) = &
iand(generators_bitmask(k,ispin,s_hole,i_bitmask_gen), &
psi_det_generators(k,ispin,i_generator) )
mask(k,ispin,s_part) = &
iand(generators_bitmask(k,ispin,s_part,i_bitmask_gen), &
not(psi_det_generators(k,ispin,i_generator)) )
mask(k,ispin,d_hole1) = &
iand(generators_bitmask(k,ispin,d_hole1,i_bitmask_gen), &
psi_det_generators(k,ispin,i_generator) )
mask(k,ispin,d_part1) = &
iand(generators_bitmask(k,ispin,d_part1,i_bitmask_gen), &
not(psi_det_generators(k,ispin,i_generator)) )
mask(k,ispin,d_hole2) = &
iand(generators_bitmask(k,ispin,d_hole2,i_bitmask_gen), &
psi_det_generators(k,ispin,i_generator) )
mask(k,ispin,d_part2) = &
iand(generators_bitmask(k,ispin,d_part2,i_bitmask_gen), &
not(psi_det_generators(k,ispin,i_generator)) )
enddo
enddo
if($do_double_excitations)then
call $subroutine_diexc(psi_det_generators(1,1,i_generator), &
psi_det_generators(1,1,1), &
mask(1,1,d_hole1), mask(1,1,d_part1), &
mask(1,1,d_hole2), mask(1,1,d_part2), &
fock_diag_tmp, i_generator, iproc $params_post)
endif
if($do_mono_excitations)then
call $subroutine_monoexc(psi_det_generators(1,1,i_generator), &
mask(1,1,s_hole ), mask(1,1,s_part ), &
fock_diag_tmp, i_generator, iproc $params_post)
endif
call wall_time(wall_1)
$printout_always
if (wall_1 - wall_0 > 2.d0) then
$printout_now
wall_0 = wall_1
endif
enddo
deallocate( mask, fock_diag_tmp )
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(i_generator,wall_1,wall_0,ispin,k,mask,iproc,fock_diag_tmp)
call wall_time(wall_0)
!$ iproc = omp_get_thread_num()
allocate( mask(N_int,2,6), fock_diag_tmp(2,mo_tot_num+1) )
!$OMP DO SCHEDULE(dynamic,1)
do i_generator=nmax+1,N_det_generators
if (iproc == 0) then
progress_bar(1) = i_generator
endif
if (abort_here) then
cycle
endif
$skip
! Compute diagonal of the Fock matrix
call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int)
! Create bit masks for holes and particles
do ispin=1,2
do k=1,N_int
mask(k,ispin,s_hole) = &
iand(generators_bitmask(k,ispin,s_hole,i_bitmask_gen), &
psi_det_generators(k,ispin,i_generator) )
mask(k,ispin,s_part) = &
iand(generators_bitmask(k,ispin,s_part,i_bitmask_gen), &
not(psi_det_generators(k,ispin,i_generator)) )
mask(k,ispin,d_hole1) = &
iand(generators_bitmask(k,ispin,d_hole1,i_bitmask_gen), &
psi_det_generators(k,ispin,i_generator) )
mask(k,ispin,d_part1) = &
iand(generators_bitmask(k,ispin,d_part1,i_bitmask_gen), &
not(psi_det_generators(k,ispin,i_generator)) )
mask(k,ispin,d_hole2) = &
iand(generators_bitmask(k,ispin,d_hole2,i_bitmask_gen), &
psi_det_generators(k,ispin,i_generator) )
mask(k,ispin,d_part2) = &
iand(generators_bitmask(k,ispin,d_part2,i_bitmask_gen), &
not (psi_det_generators(k,ispin,i_generator)) )
enddo
enddo
if($do_double_excitations)then
call $subroutine_diexc(psi_det_generators(1,1,i_generator), &
psi_det_generators(1,1,1), &
mask(1,1,d_hole1), mask(1,1,d_part1), &
mask(1,1,d_hole2), mask(1,1,d_part2), &
fock_diag_tmp, i_generator, iproc $params_post)
endif
if($do_mono_excitations)then
call $subroutine_monoexc(psi_det_generators(1,1,i_generator), &
mask(1,1,s_hole ), mask(1,1,s_part ), &
fock_diag_tmp, i_generator, iproc $params_post)
endif
!$ call omp_set_lock(lck)
call wall_time(wall_1)
$printout_always
if (wall_1 - wall_0 > 2.d0) then
$printout_now
wall_0 = wall_1
endif
!$ call omp_unset_lock(lck)
enddo
!$OMP END DO
deallocate( mask, fock_diag_tmp )
!$OMP END PARALLEL
!$ call omp_destroy_lock(lck)
abort_here = abort_all
call stop_progress
$copy_buffer
$generate_psi_guess
end

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

@ -0,0 +1,150 @@
subroutine $subroutine($params_main)
implicit none
use omp_lib
use bitmasks
BEGIN_DOC
! Calls H_apply on the HF determinant and selects all connected single and double
! excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script.
END_DOC
$decls_main
integer :: i_generator, nmax
double precision :: wall_0, wall_1
integer(omp_lock_kind) :: lck
integer(bit_kind), allocatable :: mask(:,:,:)
integer :: ispin, k
integer :: iproc
double precision, allocatable :: fock_diag_tmp(:,:)
$initialization
PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators
nmax = mod( N_det_generators,nproc )
!$ call omp_init_lock(lck)
call wall_time(wall_0)
iproc = 0
allocate( mask(N_int,2,6), fock_diag_tmp(2,mo_tot_num+1) )
do i_generator=1,nmax
$skip
! Compute diagonal of the Fock matrix
call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int)
! Create bit masks for holes and particles
do ispin=1,2
do k=1,N_int
mask(k,ispin,s_hole) = &
iand(generators_bitmask(k,ispin,s_hole,i_bitmask_gen), &
psi_det_generators(k,ispin,i_generator) )
mask(k,ispin,s_part) = &
iand(generators_bitmask(k,ispin,s_part,i_bitmask_gen), &
not(psi_det_generators(k,ispin,i_generator)) )
mask(k,ispin,d_hole1) = &
iand(generators_bitmask(k,ispin,d_hole1,i_bitmask_gen), &
psi_det_generators(k,ispin,i_generator) )
mask(k,ispin,d_part1) = &
iand(generators_bitmask(k,ispin,d_part1,i_bitmask_gen), &
not(psi_det_generators(k,ispin,i_generator)) )
mask(k,ispin,d_hole2) = &
iand(generators_bitmask(k,ispin,d_hole2,i_bitmask_gen), &
psi_det_generators(k,ispin,i_generator) )
mask(k,ispin,d_part2) = &
iand(generators_bitmask(k,ispin,d_part2,i_bitmask_gen), &
not(psi_det_generators(k,ispin,i_generator)) )
enddo
enddo
if($do_double_excitations)then
call $subroutine_diexc(psi_det_generators(1,1,i_generator), &
psi_det_generators(1,1,1), &
mask(1,1,d_hole1), mask(1,1,d_part1), &
mask(1,1,d_hole2), mask(1,1,d_part2), &
fock_diag_tmp, i_generator, iproc $params_post)
endif
if($do_mono_excitations)then
call $subroutine_monoexc(psi_det_generators(1,1,i_generator), &
mask(1,1,s_hole ), mask(1,1,s_part ), &
fock_diag_tmp, i_generator, iproc $params_post)
endif
call wall_time(wall_1)
$printout_always
if (wall_1 - wall_0 > 2.d0) then
$printout_now
wall_0 = wall_1
endif
enddo
deallocate( mask, fock_diag_tmp )
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(i_generator,wall_1,wall_0,ispin,k,mask,iproc,fock_diag_tmp)
call wall_time(wall_0)
!$ iproc = omp_get_thread_num()
allocate( mask(N_int,2,6), fock_diag_tmp(2,mo_tot_num+1) )
!$OMP DO SCHEDULE(dynamic,1)
do i_generator=nmax+1,N_det_generators
$skip
! Compute diagonal of the Fock matrix
call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int)
! Create bit masks for holes and particles
do ispin=1,2
do k=1,N_int
mask(k,ispin,s_hole) = &
iand(generators_bitmask(k,ispin,s_hole,i_bitmask_gen), &
psi_det_generators(k,ispin,i_generator) )
mask(k,ispin,s_part) = &
iand(generators_bitmask(k,ispin,s_part,i_bitmask_gen), &
not(psi_det_generators(k,ispin,i_generator)) )
mask(k,ispin,d_hole1) = &
iand(generators_bitmask(k,ispin,d_hole1,i_bitmask_gen), &
psi_det_generators(k,ispin,i_generator) )
mask(k,ispin,d_part1) = &
iand(generators_bitmask(k,ispin,d_part1,i_bitmask_gen), &
not(psi_det_generators(k,ispin,i_generator)) )
mask(k,ispin,d_hole2) = &
iand(generators_bitmask(k,ispin,d_hole2,i_bitmask_gen), &
psi_det_generators(k,ispin,i_generator) )
mask(k,ispin,d_part2) = &
iand(generators_bitmask(k,ispin,d_part2,i_bitmask_gen), &
not (psi_det_generators(k,ispin,i_generator)) )
enddo
enddo
if($do_double_excitations)then
call $subroutine_diexc(psi_det_generators(1,1,i_generator), &
psi_det_generators(1,1,1), &
mask(1,1,d_hole1), mask(1,1,d_part1), &
mask(1,1,d_hole2), mask(1,1,d_part2), &
fock_diag_tmp, i_generator, iproc $params_post)
endif
if($do_mono_excitations)then
call $subroutine_monoexc(psi_det_generators(1,1,i_generator), &
mask(1,1,s_hole ), mask(1,1,s_part ), &
fock_diag_tmp, i_generator, iproc $params_post)
endif
!$ call omp_set_lock(lck)
call wall_time(wall_1)
$printout_always
if (wall_1 - wall_0 > 2.d0) then
$printout_now
wall_0 = wall_1
endif
!$ call omp_unset_lock(lck)
enddo
!$OMP END DO
deallocate( mask, fock_diag_tmp )
!$OMP END PARALLEL
!$ call omp_destroy_lock(lck)
$copy_buffer
$generate_psi_guess
end

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

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

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

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

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

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

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

@ -386,66 +386,6 @@ subroutine sort_dets_by_det_search_key(Ndet, det_in, coef_in, det_out, coef_out)
end 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_max, (N_states) ]
&BEGIN_PROVIDER [ double precision, psi_coef_min, (N_states) ] &BEGIN_PROVIDER [ double precision, psi_coef_min, (N_states) ]
@ -465,130 +405,6 @@ end
END_PROVIDER 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 subroutine save_ref_determinant
implicit none implicit none
use bitmasks 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 end

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

@ -112,16 +112,16 @@ subroutine getMobiles(key,key_mask, mobiles,Nint)
mobileMask(j,2) = xor(key(j,2), key_mask(j,2)) mobileMask(j,2) = xor(key(j,2), key_mask(j,2))
end do 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 if(nel == 2) then
mobiles(1) = list(1) mobiles(1) = list(1)
mobiles(2) = list(2) mobiles(2) = list(2)
else if(nel == 1) then else if(nel == 1) then
mobiles(1) = list(1) 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 mobiles(2) = list(1) + mo_tot_num
else 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(1) = list(1) + mo_tot_num
mobiles(2) = list(2) + mo_tot_num mobiles(2) = list(2) + mo_tot_num
end if 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 :: i,j,k,nt,n_element(2)
integer :: list(Nint*bit_kind_size,2), cur_microlist(0:mo_tot_num*2+1) 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(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 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)) key_mask_neg(i,2) = not(key_mask(i,2))
end do end do
N_microlist(:) = 0 do i=0,mo_tot_num_2
N_microlist(i) = 0
enddo
do i=1, N_minilist do i=1, N_minilist
do j=1,Nint 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)) mobileMask(j,2) = iand(key_mask_neg(j,2), minilist(j,2,i))
end do end do
call bitstring_to_list(mobileMask(:,1), list(:,1), n_element(1), Nint) call bitstring_to_list(mobileMask(1,1), list(1,1), n_element(1), Nint)
call bitstring_to_list(mobileMask(:,2), list(:,2), n_element(2), Nint) call bitstring_to_list(mobileMask(1,2), list(1,2), n_element(2), Nint)
if(n_element(1) + n_element(2) /= 4) then if(n_element(1) + n_element(2) /= 4) then
N_microlist(0) = N_microlist(0) + 1 N_microlist(0) = N_microlist(0) + 1
@ -173,11 +177,14 @@ subroutine create_microlist(minilist, N_minilist, key_mask, microlist, idx_micro
end do end do
ptr_microlist(0) = 1 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) ptr_microlist(i) = ptr_microlist(i-1) + N_microlist(i-1)
end do 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 i=1, N_minilist
do j=1,Nint 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)) mobileMask(j,2) = iand(key_mask_neg(j,2), minilist(j,2,i))
end do end do
call bitstring_to_list(mobileMask(:,1), list(:,1), n_element(1), Nint) call bitstring_to_list(mobileMask(1,1), list(1,1), n_element(1), Nint)
call bitstring_to_list(mobileMask(:,2), list(:,2), n_element(2), Nint) call bitstring_to_list(mobileMask(1,2), list(1,2), n_element(2), Nint)
if(n_element(1) + n_element(2) /= 4) then if(n_element(1) + n_element(2) /= 4) then
idx_microlist(cur_microlist(0)) = i 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 cur_microlist(0) = cur_microlist(0) + 1
else else
do j=1,n_element(1) do j=1,n_element(1)
nt = list(j,1) nt = list(j,1)
idx_microlist(cur_microlist(nt)) = i 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 cur_microlist(nt) = cur_microlist(nt) + 1
end do end do
do j=1,n_element(2) do j=1,n_element(2)
nt = list(j,2) + mo_tot_num nt = list(j,2) + mo_tot_num
idx_microlist(cur_microlist(nt)) = i 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 cur_microlist(nt) = cur_microlist(nt) + 1
end do end do
end if end if
@ -212,16 +228,6 @@ subroutine create_microlist(minilist, N_minilist, key_mask, microlist, idx_micro
end subroutine 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) subroutine filter_connected_i_H_psi0(key1,key2,Nint,sze,idx)
use bitmasks use bitmasks
BEGIN_DOC BEGIN_DOC

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

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

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

@ -443,7 +443,7 @@ subroutine i_H_j(key_i,key_j,Nint,hij)
integer :: exc(0:2,2,2) integer :: exc(0:2,2,2)
integer :: degree integer :: degree
double precision :: get_mo_bielec_integral_schwartz double precision :: get_mo_bielec_integral
integer :: m,n,p,q integer :: m,n,p,q
integer :: i,j,k integer :: i,j,k
integer :: occ(Nint*bit_kind_size,2) 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) call get_double_excitation(key_i,key_j,exc,phase,Nint)
if (exc(0,1,1) == 1) then if (exc(0,1,1) == 1) then
! Mono alpha, mono beta ! Mono alpha, mono beta
hij = phase*get_mo_bielec_integral_schwartz( & hij = phase*get_mo_bielec_integral( &
exc(1,1,1), & exc(1,1,1), &
exc(1,1,2), & exc(1,1,2), &
exc(1,2,1), & exc(1,2,1), &
exc(1,2,2) ,mo_integrals_map) exc(1,2,2) ,mo_integrals_map)
else if (exc(0,1,1) == 2) then else if (exc(0,1,1) == 2) then
! Double alpha ! Double alpha
hij = phase*(get_mo_bielec_integral_schwartz( & hij = phase*(get_mo_bielec_integral( &
exc(1,1,1), & exc(1,1,1), &
exc(2,1,1), & exc(2,1,1), &
exc(1,2,1), & exc(1,2,1), &
exc(2,2,1) ,mo_integrals_map) - & exc(2,2,1) ,mo_integrals_map) - &
get_mo_bielec_integral_schwartz( & get_mo_bielec_integral( &
exc(1,1,1), & exc(1,1,1), &
exc(2,1,1), & exc(2,1,1), &
exc(2,2,1), & exc(2,2,1), &
exc(1,2,1) ,mo_integrals_map) ) exc(1,2,1) ,mo_integrals_map) )
else if (exc(0,1,2) == 2) then else if (exc(0,1,2) == 2) then
! Double beta ! Double beta
hij = phase*(get_mo_bielec_integral_schwartz( & hij = phase*(get_mo_bielec_integral( &
exc(1,1,2), & exc(1,1,2), &
exc(2,1,2), & exc(2,1,2), &
exc(1,2,2), & exc(1,2,2), &
exc(2,2,2) ,mo_integrals_map) - & exc(2,2,2) ,mo_integrals_map) - &
get_mo_bielec_integral_schwartz( & get_mo_bielec_integral( &
exc(1,1,2), & exc(1,1,2), &
exc(2,1,2), & exc(2,1,2), &
exc(2,2,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 do k = 1, elec_alpha_num
i = occ(k,1) i = occ(k,1)
if (.not.has_mipi(i)) then 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)
miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map) miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map)
has_mipi(i) = .True. has_mipi(i) = .True.
endif endif
enddo enddo
do k = 1, elec_beta_num do k = 1, elec_beta_num
i = occ(k,2) i = occ(k,2)
if (.not.has_mipi(i)) then 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. has_mipi(i) = .True.
endif endif
enddo enddo
@ -537,15 +537,15 @@ subroutine i_H_j(key_i,key_j,Nint,hij)
do k = 1, elec_beta_num do k = 1, elec_beta_num
i = occ(k,2) i = occ(k,2)
if (.not.has_mipi(i)) then 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)
miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map) miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map)
has_mipi(i) = .True. has_mipi(i) = .True.
endif endif
enddo enddo
do k = 1, elec_alpha_num do k = 1, elec_alpha_num
i = occ(k,1) i = occ(k,1)
if (.not.has_mipi(i)) then 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. has_mipi(i) = .True.
endif endif
enddo 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) :: exc(0:2,2,2)
integer,intent(out) :: degree integer,intent(out) :: degree
double precision :: get_mo_bielec_integral_schwartz double precision :: get_mo_bielec_integral
integer :: m,n,p,q integer :: m,n,p,q
integer :: i,j,k integer :: i,j,k
integer :: occ(Nint*bit_kind_size,2) 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) call get_double_excitation(key_i,key_j,exc,phase,Nint)
if (exc(0,1,1) == 1) then if (exc(0,1,1) == 1) then
! Mono alpha, mono beta ! Mono alpha, mono beta
hij = phase*get_mo_bielec_integral_schwartz( & hij = phase*get_mo_bielec_integral( &
exc(1,1,1), & exc(1,1,1), &
exc(1,1,2), & exc(1,1,2), &
exc(1,2,1), & exc(1,2,1), &
exc(1,2,2) ,mo_integrals_map) exc(1,2,2) ,mo_integrals_map)
else if (exc(0,1,1) == 2) then else if (exc(0,1,1) == 2) then
! Double alpha ! Double alpha
hij = phase*(get_mo_bielec_integral_schwartz( & hij = phase*(get_mo_bielec_integral( &
exc(1,1,1), & exc(1,1,1), &
exc(2,1,1), & exc(2,1,1), &
exc(1,2,1), & exc(1,2,1), &
exc(2,2,1) ,mo_integrals_map) - & exc(2,2,1) ,mo_integrals_map) - &
get_mo_bielec_integral_schwartz( & get_mo_bielec_integral( &
exc(1,1,1), & exc(1,1,1), &
exc(2,1,1), & exc(2,1,1), &
exc(2,2,1), & exc(2,2,1), &
exc(1,2,1) ,mo_integrals_map) ) exc(1,2,1) ,mo_integrals_map) )
else if (exc(0,1,2) == 2) then else if (exc(0,1,2) == 2) then
! Double beta ! Double beta
hij = phase*(get_mo_bielec_integral_schwartz( & hij = phase*(get_mo_bielec_integral( &
exc(1,1,2), & exc(1,1,2), &
exc(2,1,2), & exc(2,1,2), &
exc(1,2,2), & exc(1,2,2), &
exc(2,2,2) ,mo_integrals_map) - & exc(2,2,2) ,mo_integrals_map) - &
get_mo_bielec_integral_schwartz( & get_mo_bielec_integral( &
exc(1,1,2), & exc(1,1,2), &
exc(2,1,2), & exc(2,1,2), &
exc(2,2,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 do k = 1, elec_alpha_num
i = occ(k,1) i = occ(k,1)
if (.not.has_mipi(i)) then 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)
miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map) miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map)
has_mipi(i) = .True. has_mipi(i) = .True.
endif endif
enddo enddo
do k = 1, elec_beta_num do k = 1, elec_beta_num
i = occ(k,2) i = occ(k,2)
if (.not.has_mipi(i)) then 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. has_mipi(i) = .True.
endif endif
enddo 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 do k = 1, elec_beta_num
i = occ(k,2) i = occ(k,2)
if (.not.has_mipi(i)) then 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)
miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map) miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map)
has_mipi(i) = .True. has_mipi(i) = .True.
endif endif
enddo enddo
do k = 1, elec_alpha_num do k = 1, elec_alpha_num
i = occ(k,1) i = occ(k,1)
if (.not.has_mipi(i)) then 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. has_mipi(i) = .True.
endif endif
enddo 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 :: exc(0:2,2,2)
integer :: degree integer :: degree
double precision :: get_mo_bielec_integral_schwartz double precision :: get_mo_bielec_integral
integer :: m,n,p,q integer :: m,n,p,q
integer :: i,j,k integer :: i,j,k
integer :: occ(Nint*bit_kind_size,2) 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) call get_double_excitation(key_i,key_j,exc,phase,Nint)
if (exc(0,1,1) == 1) then if (exc(0,1,1) == 1) then
! Mono alpha, mono beta ! Mono alpha, mono beta
hij = phase*get_mo_bielec_integral_schwartz( & hij = phase*get_mo_bielec_integral( &
exc(1,1,1), & exc(1,1,1), &
exc(1,1,2), & exc(1,1,2), &
exc(1,2,1), & exc(1,2,1), &
exc(1,2,2) ,mo_integrals_map) exc(1,2,2) ,mo_integrals_map)
else if (exc(0,1,1) == 2) then else if (exc(0,1,1) == 2) then
! Double alpha ! Double alpha
hij = phase*(get_mo_bielec_integral_schwartz( & hij = phase*(get_mo_bielec_integral( &
exc(1,1,1), & exc(1,1,1), &
exc(2,1,1), & exc(2,1,1), &
exc(1,2,1), & exc(1,2,1), &
exc(2,2,1) ,mo_integrals_map) - & exc(2,2,1) ,mo_integrals_map) - &
get_mo_bielec_integral_schwartz( & get_mo_bielec_integral( &
exc(1,1,1), & exc(1,1,1), &
exc(2,1,1), & exc(2,1,1), &
exc(2,2,1), & exc(2,2,1), &
exc(1,2,1) ,mo_integrals_map) ) exc(1,2,1) ,mo_integrals_map) )
else if (exc(0,1,2) == 2) then else if (exc(0,1,2) == 2) then
! Double beta ! Double beta
hij = phase*(get_mo_bielec_integral_schwartz( & hij = phase*(get_mo_bielec_integral( &
exc(1,1,2), & exc(1,1,2), &
exc(2,1,2), & exc(2,1,2), &
exc(1,2,2), & exc(1,2,2), &
exc(2,2,2) ,mo_integrals_map) - & exc(2,2,2) ,mo_integrals_map) - &
get_mo_bielec_integral_schwartz( & get_mo_bielec_integral( &
exc(1,1,2), & exc(1,1,2), &
exc(2,1,2), & exc(2,1,2), &
exc(2,2,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 do k = 1, elec_alpha_num
i = occ(k,1) i = occ(k,1)
if (.not.has_mipi(i)) then 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)
miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map) miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map)
has_mipi(i) = .True. has_mipi(i) = .True.
endif endif
enddo enddo
do k = 1, elec_beta_num do k = 1, elec_beta_num
i = occ(k,2) i = occ(k,2)
if (.not.has_mipi(i)) then 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. has_mipi(i) = .True.
endif endif
enddo enddo
@ -811,15 +811,15 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble)
do k = 1, elec_beta_num do k = 1, elec_beta_num
i = occ(k,2) i = occ(k,2)
if (.not.has_mipi(i)) then 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)
miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map) miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map)
has_mipi(i) = .True. has_mipi(i) = .True.
endif endif
enddo enddo
do k = 1, elec_alpha_num do k = 1, elec_alpha_num
i = occ(k,1) i = occ(k,1)
if (.not.has_mipi(i)) then 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. has_mipi(i) = .True.
endif endif
enddo enddo
@ -845,25 +845,30 @@ subroutine create_minilist(key_mask, fullList, miniList, idx_miniList, N_fullLis
use bitmasks use bitmasks
implicit none implicit none
integer(bit_kind), intent(in) :: fullList(Nint, 2, N_fullList)
integer, intent(in) :: 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),intent(out) :: miniList(Nint, 2, N_fullList)
integer,intent(out) :: idx_miniList(N_fullList), N_miniList integer,intent(out) :: idx_miniList(N_fullList), N_miniList
integer, intent(in) :: Nint
integer(bit_kind) :: key_mask(Nint, 2) 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_a = popcnt(key_mask(1,1))
n_b = 0 n_b = popcnt(key_mask(1,2))
do ni=1,nint do ni=2,nint
n_a = n_a + popcnt(key_mask(ni,1)) n_a = n_a + popcnt(key_mask(ni,1))
n_b = n_b + popcnt(key_mask(ni,2)) n_b = n_b + popcnt(key_mask(ni,2))
end do end do
if(n_a == 0) then if(n_a == 0) then
N_miniList = N_fullList 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 do i=1,N_fullList
idx_miniList(i) = i idx_miniList(i) = i
end do end do
@ -873,16 +878,19 @@ subroutine create_minilist(key_mask, fullList, miniList, idx_miniList, N_fullLis
N_miniList = 0 N_miniList = 0
do i=1,N_fullList do i=1,N_fullList
e_a = n_a e_a = n_a - popcnt(iand(fullList(1, 1, i), key_mask(1, 1)))
e_b = n_b e_b = n_b - popcnt(iand(fullList(1, 2, i), key_mask(1, 2)))
do ni=1,nint do ni=2,nint
e_a -= popcnt(iand(fullList(ni, 1, i), key_mask(ni, 1))) e_a -= popcnt(iand(fullList(ni, 1, i), key_mask(ni, 1)))
e_b -= popcnt(iand(fullList(ni, 2, i), key_mask(ni, 2))) e_b -= popcnt(iand(fullList(ni, 2, i), key_mask(ni, 2)))
end do end do
if(e_a + e_b <= 2) then if(e_a + e_b <= 2) then
N_miniList = N_miniList + 1 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 idx_miniList(N_miniList) = i
end if end if
end do end do
@ -892,29 +900,34 @@ subroutine create_minilist_find_previous(key_mask, fullList, miniList, N_fullLis
use bitmasks use bitmasks
implicit none implicit none
integer(bit_kind), intent(in) :: fullList(Nint, 2, N_fullList)
integer, intent(in) :: 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),intent(out) :: miniList(Nint, 2, N_fullList)
integer(bit_kind) :: subList(Nint, 2, N_fullList) integer(bit_kind) :: subList(Nint, 2, N_fullList)
logical,intent(out) :: fullMatch logical,intent(out) :: fullMatch
integer,intent(out) :: N_miniList integer,intent(out) :: N_miniList
integer, intent(in) :: Nint
integer(bit_kind) :: key_mask(Nint, 2) integer(bit_kind) :: key_mask(Nint, 2)
integer :: ni, i, k, l, N_subList integer :: ni, i, k, l, N_subList
fullMatch = .false. fullMatch = .false.
l = 0
N_miniList = 0 N_miniList = 0
N_subList = 0 N_subList = 0
do ni = 1,Nint l = popcnt(key_mask(1,1)) + popcnt(key_mask(1,2))
l += popcnt(key_mask(ni,1)) + popcnt(key_mask(ni,2)) do ni = 2,Nint
l = l + popcnt(key_mask(ni,1)) + popcnt(key_mask(ni,2))
end do end do
if(l == 0) then if(l == 0) then
N_miniList = N_fullList 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 else
do i=N_fullList,1,-1 do i=N_fullList,1,-1
k = l k = l
@ -923,10 +936,16 @@ subroutine create_minilist_find_previous(key_mask, fullList, miniList, N_fullLis
end do end do
if(k == 2) then if(k == 2) then
N_subList += 1 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 else if(k == 1) then
N_minilist += 1 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 else if(k == 0) then
fullMatch = .true. fullMatch = .true.
return return
@ -935,7 +954,12 @@ subroutine create_minilist_find_previous(key_mask, fullList, miniList, N_fullLis
end if end if
if(N_subList > 0) then 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 N_minilist = N_minilist + N_subList
end if end if
end subroutine 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 i_H_psi_array = 0.d0
call filter_connected_i_H_psi0(keys,key,Nint,Ndet,idx) call filter_connected_i_H_psi0(keys,key,Nint,Ndet,idx)
do ii=1,idx(0) if (Nstate == 1) then
i = idx(ii)
!DIR$ FORCEINLINE do ii=1,idx(0)
call i_H_j(keys(1,1,i),key,Nint,hij) i = idx(ii)
do j = 1, Nstate !DIR$ FORCEINLINE
i_H_psi_array(j) = i_H_psi_array(j) + coef(i,j)*hij 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
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 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 i_H_psi_array = 0.d0
call filter_connected_i_H_psi0(keys,key,Nint,N_minilist,idx) call filter_connected_i_H_psi0(keys,key,Nint,N_minilist,idx)
do ii=1,idx(0) if (Nstate == 1) then
i_in_key = idx(ii)
i_in_coef = idx_key(idx(ii)) do ii=1,idx(0)
!DIR$ FORCEINLINE i_in_key = idx(ii)
call i_H_j(keys(1,1,i_in_key),key,Nint,hij) i_in_coef = idx_key(idx(ii))
do j = 1, Nstate !DIR$ FORCEINLINE
i_H_psi_array(j) = i_H_psi_array(j) + coef(i_in_coef,j)*hij 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
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 end
subroutine i_H_psi_sec_ord(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array,idx_interaction,interactions) 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 BEGIN_DOC
! Returns a list of occupation numbers from a bitstring ! Returns a list of occupation numbers from a bitstring
END_DOC END_DOC
integer(bit_kind), intent(in) :: key(Nint,2)
integer , intent(in) :: Nint integer , intent(in) :: Nint
integer(bit_kind), intent(in) :: key(Nint,2)
integer , intent(out) :: occ(Nint*bit_kind_size,2) integer , intent(out) :: occ(Nint*bit_kind_size,2)
integer :: tmp(2) integer :: tmp(2)

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

@ -14,13 +14,13 @@ integer*8 function spin_det_search_key(det,Nint)
END_DOC END_DOC
integer, intent(in) :: Nint integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: det(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 integer :: i
spin_det_search_key = det(1) spin_det_search_key = det(1)
do i=2,Nint do i=2,Nint
spin_det_search_key = ieor(spin_det_search_key,det(i)) spin_det_search_key = ieor(spin_det_search_key,det(i))
enddo 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 end

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

@ -365,20 +365,31 @@ BEGIN_PROVIDER [ logical, ao_bielec_integrals_in_map ]
call cpu_time(cpu_1) call cpu_time(cpu_1)
integer(ZMQ_PTR) :: zmq_to_qp_run_socket integer(ZMQ_PTR) :: zmq_to_qp_run_socket
call new_parallel_job(zmq_to_qp_run_socket,'ao_integrals')
character*(32) :: task character*(32) :: task
call new_parallel_job(zmq_to_qp_run_socket,'ao_integrals')
do l=1,ao_num do l=1,ao_num
write(task,*) 'triangle', l write(task,*) l
call add_task_to_taskserver(zmq_to_qp_run_socket,task) call add_task_to_taskserver(zmq_to_qp_run_socket,task)
enddo enddo
external :: ao_bielec_integrals_in_map_slave_inproc, ao_bielec_integrals_in_map_collector integer(ZMQ_PTR) :: collector_thread
call new_parallel_threads(ao_bielec_integrals_in_map_slave_inproc, ao_bielec_integrals_in_map_collector) 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' print*, 'Sorting the map'
call map_sort(ao_integrals_map) call map_sort(ao_integrals_map)

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

@ -1,20 +1,73 @@
subroutine ao_bielec_integrals_in_map_slave_tcp subroutine ao_bielec_integrals_in_map_slave_tcp(i)
implicit none implicit none
integer, intent(in) :: i
BEGIN_DOC BEGIN_DOC
! Computes a buffer of integrals ! Computes a buffer of integrals. i is the ID of the current thread.
END_DOC END_DOC
call ao_bielec_integrals_in_map_slave(0) call ao_bielec_integrals_in_map_slave(0,i)
end end
subroutine ao_bielec_integrals_in_map_slave_inproc
subroutine ao_bielec_integrals_in_map_slave_inproc(i)
implicit none implicit none
integer, intent(in) :: i
BEGIN_DOC BEGIN_DOC
! Computes a buffer of integrals ! Computes a buffer of integrals. i is the ID of the current thread.
END_DOC END_DOC
call ao_bielec_integrals_in_map_slave(1) call ao_bielec_integrals_in_map_slave(1,i)
end 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 map_module
use f77_zmq use f77_zmq
implicit none implicit none
@ -22,7 +75,7 @@ subroutine ao_bielec_integrals_in_map_slave(thread)
! Computes a buffer of integrals ! Computes a buffer of integrals
END_DOC END_DOC
integer, intent(in) :: thread integer, intent(in) :: thread, iproc
integer :: j,l,n_integrals integer :: j,l,n_integrals
integer :: rc 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),external :: new_zmq_to_qp_run_socket
integer(ZMQ_PTR) :: 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 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 ) zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
if (thread == 1) then zmq_socket_push = new_zmq_push_socket(thread)
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
allocate ( buffer_i(ao_num*ao_num), buffer_value(ao_num*ao_num) ) 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 do
call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task) call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task)
if (task_id == 0) then if (task_id == 0) exit
exit read(task,*) l
endif do j=1,l-1
read(task,*) j, l call compute_ao_integrals_jl(j,l,n_integrals,buffer_i,buffer_value)
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)
rc = f77_zmq_send( zmq_socket_push, n_integrals, 4, ZMQ_SNDMORE) enddo
rc = f77_zmq_send( zmq_socket_push, buffer_i, key_kind*n_integrals, ZMQ_SNDMORE) call compute_ao_integrals_jl(l,l,n_integrals,buffer_i,buffer_value)
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,n_integrals)
call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) call push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, task_id)
character*(2) :: ok
rc = f77_zmq_recv( zmq_socket_push, ok, 2, 0)
enddo enddo
deallocate( buffer_i, buffer_value ) deallocate( buffer_i, buffer_value )
integer :: finished call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id)
call disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id,finished) 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 end
rc = f77_zmq_send( zmq_socket_push, -1, 4, 0)
rc = f77_zmq_recv( zmq_socket_push, ok, 2, ZMQ_NOBLOCK)
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 endif
rc = f77_zmq_disconnect(zmq_socket_push,trim(zmq_socket_push_tcp_address)) if (n_integrals >= 0) then
rc = f77_zmq_close(zmq_socket_push)
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 end
@ -94,27 +186,54 @@ subroutine ao_bielec_integrals_in_map_collector
integer :: j,l,n_integrals integer :: j,l,n_integrals
integer :: rc integer :: rc
real(integral_kind), allocatable :: buffer_value(:) real(integral_kind), allocatable :: buffer_value(:)
integer(key_kind), allocatable :: buffer_i(:) 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) ) allocate ( buffer_i(ao_num*ao_num), buffer_value(ao_num*ao_num) )
n_integrals = 0 accu = 0_8
do while (n_integrals >= 0) 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 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) call insert_into_ao_integrals_map(n_integrals,buffer_i,buffer_value)
else accu += n_integrals
rc = f77_zmq_send( zmq_socket_pull, 'ok', 2, 0) if (task_id /= 0) then
call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more)
endif
endif endif
enddo enddo
deallocate( buffer_i, buffer_value ) 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 end

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

@ -324,9 +324,9 @@ double precision function mo_bielec_integral(i,j,k,l)
! Returns one integral <ij|kl> in the MO basis ! Returns one integral <ij|kl> in the MO basis
END_DOC END_DOC
integer, intent(in) :: i,j,k,l 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 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 return
end end

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

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

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

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

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

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

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

@ -146,9 +146,9 @@ subroutine ao_to_mo(A_ao,LDA_ao,A_mo,LDA_mo)
BEGIN_DOC BEGIN_DOC
! Transform A from the AO basis to the MO basis ! Transform A from the AO basis to the MO basis
END_DOC END_DOC
integer, intent(in) :: LDA_ao,LDA_mo
double precision, intent(in) :: A_ao(LDA_ao) double precision, intent(in) :: A_ao(LDA_ao)
double precision, intent(out) :: A_mo(LDA_mo) double precision, intent(out) :: A_mo(LDA_mo)
integer, intent(in) :: LDA_ao,LDA_mo
double precision, allocatable :: T(:,:) double precision, allocatable :: T(:,:)
allocate ( T(ao_num_align,mo_tot_num) ) 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 BEGIN_DOC
! Transform A from the MO basis to the AO basis ! Transform A from the MO basis to the AO basis
END_DOC END_DOC
integer, intent(in) :: LDA_ao,LDA_mo
double precision, intent(in) :: A_mo(LDA_mo) double precision, intent(in) :: A_mo(LDA_mo)
double precision, intent(out) :: A_ao(LDA_ao) double precision, intent(out) :: A_ao(LDA_ao)
integer, intent(in) :: LDA_ao,LDA_mo
double precision, allocatable :: T(:,:), SC(:,:) double precision, allocatable :: T(:,:), SC(:,:)
allocate ( SC(ao_num_align,mo_tot_num) ) 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 BEGIN_DOC
! Transform A from the MO basis to the S^-1 AO basis ! Transform A from the MO basis to the S^-1 AO basis
END_DOC END_DOC
integer, intent(in) :: LDA_ao,LDA_mo
double precision, intent(in) :: A_mo(LDA_mo) double precision, intent(in) :: A_mo(LDA_mo)
double precision, intent(out) :: A_ao(LDA_ao) double precision, intent(out) :: A_ao(LDA_ao)
integer, intent(in) :: LDA_ao,LDA_mo
double precision, allocatable :: T(:,:) double precision, allocatable :: T(:,:)
allocate ( T(mo_tot_num_align,ao_num) ) allocate ( T(mo_tot_num_align,ao_num) )

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

@ -76,22 +76,22 @@ subroutine mo_as_eigvectors_of_mo_matrix(matrix,n,m,label,sign)
mo_coef_new = mo_coef mo_coef_new = mo_coef
call lapack_diag(eigvalues,R,A,n,m) call lapack_diag(eigvalues,R,A,n,m)
write (output_mo_basis,'(A)'), 'MOs are now **'//trim(label)//'**' write (output_mo_basis,'(A)') 'MOs are now **'//trim(label)//'**'
write (output_mo_basis,'(A)'), '' write (output_mo_basis,'(A)') ''
write (output_mo_basis,'(A)'), 'Eigenvalues' 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)') ''
write (output_mo_basis,'(A)'), '======== ================' write (output_mo_basis,'(A)') '======== ================'
if (sign == -1) then if (sign == -1) then
do i=1,m do i=1,m
eigvalues(i) = -eigvalues(i) eigvalues(i) = -eigvalues(i)
enddo enddo
endif endif
do i=1,m 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 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)) 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) 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) 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)') 'MOs are now **'//trim(label)//'**'
write (output_mo_basis,'(A)'), '' write (output_mo_basis,'(A)') ''
write (output_mo_basis,'(A)'), 'Eigenvalues' 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)') ''
write (output_mo_basis,'(A)'), '======== ================' write (output_mo_basis,'(A)') '======== ================'
do i=1,m 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 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)) 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) 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*,'' print*,''
enddo enddo
write (output_mo_basis,'(A)'), 'MOs are now **'//trim(label)//'**' write (output_mo_basis,'(A)') 'MOs are now **'//trim(label)//'**'
write (output_mo_basis,'(A)'), '' write (output_mo_basis,'(A)') ''
write (output_mo_basis,'(A)'), 'Eigenvalues' 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)') ''
write (output_mo_basis,'(A)'), '======== ================' write (output_mo_basis,'(A)') '======== ================'
do i = 1, m 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 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)) 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) deallocate(mo_coef_new,R,eigvalues)
@ -256,8 +256,8 @@ subroutine mo_sort_by_observable(observable,label)
enddo enddo
enddo enddo
write (output_mo_basis,'(A)'), 'MOs are now **'//trim(label)//'**' write (output_mo_basis,'(A)') 'MOs are now **'//trim(label)//'**'
write (output_mo_basis,'(A)'), '' write (output_mo_basis,'(A)') ''
deallocate(mo_coef_new,value) deallocate(mo_coef_new,value)

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

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

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

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

1
src/Utils/map_module.f90
View File

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

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

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

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

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

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

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

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

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

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

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

12
tests/bats/qp.bats
View File

@ -24,8 +24,6 @@ function eq() {
} }
# ___ # ___
# | ._ o _|_ # | ._ o _|_
# _|_ | | | |_ # _|_ | | | |_
@ -65,7 +63,7 @@ function run_HF() {
} }
function run_FCI() { function run_FCI() {
thresh=1.e-5 thresh=5.e-5
test_exe full_ci || skip test_exe full_ci || skip
ezfio set_file $1 ezfio set_file $1
ezfio set perturbation do_pt2_end True ezfio set perturbation do_pt2_end True
@ -132,7 +130,8 @@ function run_all_1h_1p() {
} }
@test "FCI H2O cc-pVDZ" { @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" { @test "CAS_SD H2O cc-pVDZ" {
@ -156,7 +155,7 @@ function run_all_1h_1p() {
ezfio set determinants read_wf True ezfio set determinants read_wf True
qp_run mrcc_cassd $INPUT qp_run mrcc_cassd $INPUT
energy="$(ezfio get mrcc_cassd energy)" 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" { @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 #=== Convert

27
tests/bats_to_sh.py Executable file
View File

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

16
tests/run_tests.sh
View File

@ -1,6 +1,18 @@
#!/bin/bash #!/bin/bash
rm -rf work export QP_PREFIX="timeout -s 9 300"
exec bats bats/qp.bats 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