From 20a857c446d95b0b077c5160cfed256c9190d2bf Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 19 Feb 2016 00:20:28 +0100 Subject: [PATCH 01/23] Distributed PT2 --- .travis.yml | 2 +- config/gfortran.cfg | 4 +- config/gfortran_avx.cfg | 62 ++ config/gfortran_debug.cfg | 62 ++ configure | 9 +- data/basis/cc-pcv6z | 732 ++++++++++++++++ ocaml/.gitignore | 61 -- ocaml/Address.ml | 10 + ocaml/Bitlist.ml | 47 +- ocaml/Determinant.ml | 13 +- ocaml/Input_determinants_by_hand.ml | 55 +- ocaml/Message.ml | 401 ++++++++- ocaml/Progress_bar.ml | 108 +++ ocaml/Queuing_system.ml | 19 +- ocaml/TaskServer.ml | 795 ++++++++++++------ ocaml/qp_run.ml | 89 +- ocaml/qptypes_generator.ml | 3 + ocaml/test_task_server.py | 59 +- plugins/CASSCF/casscf.irp.f | 3 - plugins/CAS_SD/cas_s.irp.f | 3 - plugins/CAS_SD/cas_s_selected.irp.f | 3 - plugins/CAS_SD/cas_sd.irp.f | 3 - plugins/CAS_SD/cas_sd_selected.irp.f | 3 - .../CID_SC2_selected/cid_sc2_selection.irp.f | 9 +- ...cid_selection.irp.f => cid_selected.irp.f} | 3 - plugins/CIS/super_ci.irp.f | 10 +- .../cisd_sc2_selection.irp.f | 9 +- plugins/CISD_selected/cisd_selected.irp.f | 3 - plugins/DDCI_selected/ddci.irp.f | 3 - plugins/FOBOCI/H_apply_dressed_autonom.irp.f | 35 - plugins/Full_CI/H_apply.irp.f | 14 +- plugins/Full_CI/full_ci.irp.f | 3 - plugins/Full_CI/full_ci_no_skip.irp.f | 3 - plugins/Full_CI/micro_pt2.irp.f | 42 + plugins/Full_CI/target_pt2.irp.f | 3 - plugins/Full_CI/var_pt2_ratio.irp.f | 3 - plugins/Hartree_Fock/damping_SCF.irp.f | 10 +- plugins/MRCC_Utils/davidson.irp.f | 1 - plugins/Perturbation/perturbation.template.f | 66 +- plugins/Selectors_full/zmq.irp.f | 105 +++ scripts/ezfio_interface/ei_handler.py | 2 + scripts/generate_h_apply.py | 147 ++-- src/Bitmask/bitmasks.irp.f | 98 +-- src/Determinants/H_apply.irp.f | 114 +++ src/Determinants/H_apply.template.f | 215 +---- src/Determinants/H_apply_nozmq.template.f | 150 ++++ src/Determinants/H_apply_zmq.template.f | 248 ++++++ src/Determinants/SC2.irp.f | 7 +- src/Determinants/davidson.irp.f | 8 +- src/Determinants/determinants.irp.f | 6 +- src/Determinants/filter_connected.irp.f | 52 +- src/Determinants/s2.irp.f | 4 +- src/Determinants/slater_rules.irp.f | 125 ++- src/Determinants/spindeterminants.irp.f | 4 +- src/Integrals_Bielec/ao_bi_integrals.irp.f | 25 +- .../ao_bielec_integrals_in_map_slave.irp.f | 210 ++++- src/Integrals_Bielec/mo_bi_integrals.irp.f | 48 +- src/Integrals_Bielec/qp_ao_ints.irp.f | 10 +- src/Integrals_Monoelec/pot_ao_ints.irp.f | 5 +- src/MO_Basis/mos.irp.f | 6 +- src/MO_Basis/utils.irp.f | 58 +- src/Utils/LinearAlgebra.irp.f | 2 +- src/Utils/abort.irp.f | 47 -- src/Utils/map_module.f90 | 1 - src/Utils/progress.irp.f | 4 +- src/Utils/sort.irp.f | 16 +- src/Utils/util.irp.f | 30 +- src/ZMQ/utils.irp.f | 730 ++++++++++++++++ src/ZMQ/zmq.irp.f | 344 -------- tests/bats/qp.bats | 24 +- tests/bats_to_sh.py | 27 + tests/run_tests.sh | 16 +- 72 files changed, 4190 insertions(+), 1461 deletions(-) create mode 100644 config/gfortran_avx.cfg create mode 100644 config/gfortran_debug.cfg delete mode 100644 ocaml/.gitignore create mode 100644 ocaml/Progress_bar.ml rename plugins/CID_selected/{cid_selection.irp.f => cid_selected.irp.f} (95%) create mode 100644 plugins/Full_CI/micro_pt2.irp.f create mode 100644 plugins/Selectors_full/zmq.irp.f create mode 100644 src/Determinants/H_apply_nozmq.template.f create mode 100644 src/Determinants/H_apply_zmq.template.f delete mode 100644 src/Utils/abort.irp.f create mode 100644 src/ZMQ/utils.irp.f delete mode 100644 src/ZMQ/zmq.irp.f create mode 100755 tests/bats_to_sh.py diff --git a/.travis.yml b/.travis.yml index b5cf3053..18a13949 100644 --- a/.travis.yml +++ b/.travis.yml @@ -27,4 +27,4 @@ script: - source ./quantum_package.rc ; qp_module.py install Full_CI Hartree_Fock CAS_SD MRCC_CASSD All_singles - source ./quantum_package.rc ; ninja - source ./quantum_package.rc ; cd ocaml ; make ; cd - - - source ./quantum_package.rc ; cd tests ; bats bats/qp.bats + - source ./quantum_package.rc ; cd tests ; ./run_tests.sh #-v diff --git a/config/gfortran.cfg b/config/gfortran.cfg index c0bc19f5..694ef0df 100644 --- a/config/gfortran.cfg +++ b/config/gfortran.cfg @@ -10,7 +10,7 @@ # # [COMMON] -FC : gfortran -g -ffree-line-length-none -I . -static-libgcc +FC : gfortran -ffree-line-length-none -I . LAPACK_LIB : -llapack -lblas IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=32 @@ -35,7 +35,7 @@ OPENMP : 1 ; Append OpenMP flags # -ffast-math and the Fortran-specific # -fno-protect-parens and -fstack-arrays. [OPT] -FCFLAGS : -Ofast -march=native +FCFLAGS : -Ofast # Profiling flags ################# diff --git a/config/gfortran_avx.cfg b/config/gfortran_avx.cfg new file mode 100644 index 00000000..6672bca1 --- /dev/null +++ b/config/gfortran_avx.cfg @@ -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 + diff --git a/config/gfortran_debug.cfg b/config/gfortran_debug.cfg new file mode 100644 index 00000000..72084241 --- /dev/null +++ b/config/gfortran_debug.cfg @@ -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 + diff --git a/configure b/configure index b5c46269..b217cbea 100755 --- a/configure +++ b/configure @@ -144,8 +144,8 @@ zeromq = Info( f77zmq = Info( url='{head}/zeromq/f77_zmq/{tail}'.format(**path_github), description=' F77-ZeroMQ', - default_path=join(QP_ROOT_LIB, "libf77zmq.a") + " " + \ - join(QP_ROOT, "src", "ZMQ", "f77zmq.h") ) + default_path=join(QP_ROOT_LIB, "libf77zmq.a") ) +# join(QP_ROOT, "src", "ZMQ", "f77zmq.h") ) p_graphviz = Info( url='https://github.com/xflr6/graphviz/archive/master.tar.gz', @@ -328,7 +328,7 @@ def installation(l_install_descendant): l_rules += [ "rule install_verbose", - " command = ./scripts/install_${target}.sh | tee _build/${target}.log 2>&1", + ' command = bash -o pipefail -c "./scripts/install_${target}.sh | tee _build/${target}.log 2>&1" ', " description = Installing ${descr}", " pool = console", "" ] @@ -482,10 +482,11 @@ def create_ninja_and_rc(l_installed): l_rc = [ 'export QP_ROOT={0}'.format(QP_ROOT), + '#export QP_NIC=ib0 # Choose the correct network inuterface', 'export QP_EZFIO={0}'.format(path_ezfio.replace(QP_ROOT,"${QP_ROOT}")), + 'export QP_PYTHON={0}'.format(":".join(l_python)), "", 'export IRPF90={0}'.format(path_irpf90.replace(QP_ROOT,"${QP_ROOT}")), 'export NINJA={0}'.format(path_ninja.replace(QP_ROOT,"${QP_ROOT}")), - 'export QP_PYTHON={0}'.format(":".join(l_python)), "", 'export PYTHONPATH="${QP_EZFIO}/Python":"${QP_PYTHON}":"${PYTHONPATH}"', 'export PATH="${QP_PYTHON}":"${QP_ROOT}"/bin:"${QP_ROOT}"/ocaml:"${PATH}"', 'export LD_LIBRARY_PATH="${QP_ROOT}"/lib:"${LD_LIBRARY_PATH}"', diff --git a/data/basis/cc-pcv6z b/data/basis/cc-pcv6z index b20fd6fd..24be7b59 100644 --- a/data/basis/cc-pcv6z +++ b/data/basis/cc-pcv6z @@ -1,3 +1,735 @@ +BORON +S 11 + 1 210400.0000000 0.00000583 + 2 31500.0000000 0.00004532 + 3 7169.0000000 0.00023838 + 4 2030.0000000 0.00100570 + 5 662.5000000 0.00364496 + 6 239.2000000 0.01173628 + 7 93.2600000 0.03380702 + 8 38.6400000 0.08556593 + 9 16.7800000 0.18260322 + 10 7.5410000 0.30583760 + 11 3.4820000 0.34080347 +S 11 + 1 210400.0000000 -0.00000118 + 2 31500.0000000 -0.00000915 + 3 7169.0000000 -0.00004819 + 4 2030.0000000 -0.00020306 + 5 662.5000000 -0.00073917 + 6 239.2000000 -0.00238603 + 7 93.2600000 -0.00698654 + 8 38.6400000 -0.01811594 + 9 16.7800000 -0.04123129 + 10 7.5410000 -0.07781353 + 11 3.4820000 -0.12123181 +S 1 + 1 1.6180000 1.0000000 +S 1 + 1 0.6270000 1.0000000 +S 1 + 1 0.2934000 1.0000000 +S 1 + 1 0.1310000 1.0000000 +S 1 + 1 0.0581500 1.0000000 +S 1 + 1 127.6200000 1.0000000 +S 1 + 1 63.6510000 1.0000000 +S 1 + 1 31.7460000 1.0000000 +S 1 + 1 15.8330000 1.0000000 +S 1 + 1 7.8970000 1.0000000 +P 5 + 1 192.5000000 0.00013490 + 2 45.6400000 0.00114741 + 3 14.7500000 0.00584793 + 4 5.5030000 0.02117091 + 5 2.2220000 0.06266872 +P 1 + 1 0.9590000 1.0000000 +P 1 + 1 0.4314000 1.0000000 +P 1 + 1 0.1969000 1.0000000 +P 1 + 1 0.0903300 1.0000000 +P 1 + 1 0.0406600 1.0000000 +P 1 + 1 144.2110000 1.0000000 +P 1 + 1 63.6980000 1.0000000 +P 1 + 1 28.1350000 1.0000000 +P 1 + 1 12.4270000 1.0000000 +P 1 + 1 5.4890000 1.0000000 +D 1 + 1 2.8860000 1.0000000 +D 1 + 1 1.2670000 1.0000000 +D 1 + 1 0.5560000 1.0000000 +D 1 + 1 0.2440000 1.0000000 +D 1 + 1 0.1070000 1.0000000 +D 1 + 1 100.3980000 1.0000000 +D 1 + 1 43.1630000 1.0000000 +D 1 + 1 18.5570000 1.0000000 +D 1 + 1 7.9780000 1.0000000 +F 1 + 1 1.6510000 1.0000000 +F 1 + 1 0.8002000 1.0000000 +F 1 + 1 0.3878000 1.0000000 +F 1 + 1 0.1880000 1.0000000 +F 1 + 1 56.0930000 1.0000000 +F 1 + 1 20.3090000 1.0000000 +F 1 + 1 7.3530000 1.0000000 +G 1 + 1 1.6469000 1.0000000 +G 1 + 1 0.7889000 1.0000000 +G 1 + 1 0.3779000 1.0000000 +G 1 + 1 43.0160000 1.0000000 +G 1 + 1 14.4690000 1.0000000 +H 1 + 1 1.3120000 1.0000000 +H 1 + 1 0.5806000 1.0000000 +H 1 + 1 29.5550000 1.0000000 +I 1 + 1 0.9847000 1.0000000 + +CARBON +S 11 + 1 312100.0000000 0.00000567 + 2 46740.0000000 0.00004410 + 3 10640.0000000 0.00023190 + 4 3013.0000000 0.00097897 + 5 982.8000000 0.00355163 + 6 354.8000000 0.01144061 + 7 138.4000000 0.03299855 + 8 57.3500000 0.08405347 + 9 24.9200000 0.18067613 + 10 11.2300000 0.30491140 + 11 5.2010000 0.34141570 +S 11 + 1 312100.0000000 -0.00000121 + 2 46740.0000000 -0.00000939 + 3 10640.0000000 -0.00004947 + 4 3013.0000000 -0.00020857 + 5 982.8000000 -0.00076015 + 6 354.8000000 -0.00245469 + 7 138.4000000 -0.00720153 + 8 57.3500000 -0.01880742 + 9 24.9200000 -0.04325001 + 10 11.2300000 -0.08259733 + 11 5.2010000 -0.12857592 +S 1 + 1 2.4260000 1.0000000 +S 1 + 1 0.9673000 1.0000000 +S 1 + 1 0.4456000 1.0000000 +S 1 + 1 0.1971000 1.0000000 +S 1 + 1 0.0863500 1.0000000 +S 1 + 1 183.0760000 1.0000000 +S 1 + 1 91.9980000 1.0000000 +S 1 + 1 46.2300000 1.0000000 +S 1 + 1 23.2310000 1.0000000 +S 1 + 1 11.6740000 1.0000000 +P 5 + 1 295.2000000 0.00014249 + 2 69.9800000 0.00122010 + 3 22.6400000 0.00633696 + 4 8.4850000 0.02351875 + 5 3.4590000 0.06990447 +P 1 + 1 1.5040000 1.0000000 +P 1 + 1 0.6783000 1.0000000 +P 1 + 1 0.3087000 1.0000000 +P 1 + 1 0.1400000 1.0000000 +P 1 + 1 0.0617800 1.0000000 +P 1 + 1 206.5670000 1.0000000 +P 1 + 1 92.5890000 1.0000000 +P 1 + 1 41.5010000 1.0000000 +P 1 + 1 18.6020000 1.0000000 +P 1 + 1 8.3380000 1.0000000 +D 1 + 1 4.5420000 1.0000000 +D 1 + 1 1.9790000 1.0000000 +D 1 + 1 0.8621000 1.0000000 +D 1 + 1 0.3756000 1.0000000 +D 1 + 1 0.1636000 1.0000000 +D 1 + 1 145.5240000 1.0000000 +D 1 + 1 62.9160000 1.0000000 +D 1 + 1 27.2010000 1.0000000 +D 1 + 1 11.7600000 1.0000000 +F 1 + 1 2.6310000 1.0000000 +F 1 + 1 1.2550000 1.0000000 +F 1 + 1 0.5988000 1.0000000 +F 1 + 1 0.2857000 1.0000000 +F 1 + 1 78.5650000 1.0000000 +F 1 + 1 28.0590000 1.0000000 +F 1 + 1 10.0210000 1.0000000 +G 1 + 1 2.6520000 1.0000000 +G 1 + 1 1.2040000 1.0000000 +G 1 + 1 0.5470000 1.0000000 +G 1 + 1 55.1450000 1.0000000 +G 1 + 1 17.6070000 1.0000000 +H 1 + 1 2.0300000 1.0000000 +H 1 + 1 0.8511000 1.0000000 +H 1 + 1 40.7100000 1.0000000 +I 1 + 1 1.4910000 1.0000000 + +NITROGEN +S 11 + 1 432300.0000000 0.00000559 + 2 64700.0000000 0.00004351 + 3 14720.0000000 0.00022893 + 4 4170.0000000 0.00096502 + 5 1361.0000000 0.00350219 + 6 491.2000000 0.01129212 + 7 191.6000000 0.03261283 + 8 79.4100000 0.08329727 + 9 34.5300000 0.17998566 + 10 15.5800000 0.30500351 + 11 7.2320000 0.34115932 +S 11 + 1 432300.0000000 -0.00000123 + 2 64700.0000000 -0.00000958 + 3 14720.0000000 -0.00005051 + 4 4170.0000000 -0.00021264 + 5 1361.0000000 -0.00077534 + 6 491.2000000 -0.00250624 + 7 191.6000000 -0.00736529 + 8 79.4100000 -0.01930167 + 9 34.5300000 -0.04471738 + 10 15.5800000 -0.08606647 + 11 7.2320000 -0.13329627 +S 1 + 1 3.3820000 1.0000000 +S 1 + 1 1.3690000 1.0000000 +S 1 + 1 0.6248000 1.0000000 +S 1 + 1 0.2747000 1.0000000 +S 1 + 1 0.1192000 1.0000000 +S 1 + 1 246.2620000 1.0000000 +S 1 + 1 124.1870000 1.0000000 +S 1 + 1 62.6260000 1.0000000 +S 1 + 1 31.5810000 1.0000000 +S 1 + 1 15.9260000 1.0000000 +P 5 + 1 415.9000000 0.00014841 + 2 98.6100000 0.00127634 + 3 31.9200000 0.00670242 + 4 12.0000000 0.02526170 + 5 4.9190000 0.07518943 +P 1 + 1 2.1480000 1.0000000 +P 1 + 1 0.9696000 1.0000000 +P 1 + 1 0.4399000 1.0000000 +P 1 + 1 0.1978000 1.0000000 +P 1 + 1 0.0860300 1.0000000 +P 1 + 1 270.1420000 1.0000000 +P 1 + 1 123.4650000 1.0000000 +P 1 + 1 56.4280000 1.0000000 +P 1 + 1 25.7900000 1.0000000 +P 1 + 1 11.7870000 1.0000000 +D 1 + 1 6.7170000 1.0000000 +D 1 + 1 2.8960000 1.0000000 +D 1 + 1 1.2490000 1.0000000 +D 1 + 1 0.5380000 1.0000000 +D 1 + 1 0.2320000 1.0000000 +D 1 + 1 199.9200000 1.0000000 +D 1 + 1 87.1110000 1.0000000 +D 1 + 1 37.9570000 1.0000000 +D 1 + 1 16.5390000 1.0000000 +F 1 + 1 3.8290000 1.0000000 +F 1 + 1 1.7950000 1.0000000 +F 1 + 1 0.8410000 1.0000000 +F 1 + 1 0.3940000 1.0000000 +F 1 + 1 105.3460000 1.0000000 +F 1 + 1 37.5300000 1.0000000 +F 1 + 1 13.3700000 1.0000000 +G 1 + 1 3.8560000 1.0000000 +G 1 + 1 1.7020000 1.0000000 +G 1 + 1 0.7510000 1.0000000 +G 1 + 1 67.1880000 1.0000000 +G 1 + 1 20.3600000 1.0000000 +H 1 + 1 2.8750000 1.0000000 +H 1 + 1 1.1700000 1.0000000 +H 1 + 1 52.0500000 1.0000000 +I 1 + 1 2.0990000 1.0000000 + +OXYGEN +S 11 + 1 570800.0000000 0.00000555 + 2 85480.0000000 0.00004311 + 3 19460.0000000 0.00022667 + 4 5512.0000000 0.00095637 + 5 1798.0000000 0.00347320 + 6 648.9000000 0.01119778 + 7 253.1000000 0.03238766 + 8 104.9000000 0.08285977 + 9 45.6500000 0.17958381 + 10 20.6200000 0.30522110 + 11 9.5870000 0.34089349 +S 11 + 1 570800.0000000 -0.00000126 + 2 85480.0000000 -0.00000977 + 3 19460.0000000 -0.00005148 + 4 5512.0000000 -0.00021696 + 5 1798.0000000 -0.00079162 + 6 648.9000000 -0.00255900 + 7 253.1000000 -0.00753313 + 8 104.9000000 -0.01978897 + 9 45.6500000 -0.04606288 + 10 20.6200000 -0.08919560 + 11 9.5870000 -0.13754216 +S 1 + 1 4.4930000 1.0000000 +S 1 + 1 1.8370000 1.0000000 +S 1 + 1 0.8349000 1.0000000 +S 1 + 1 0.3658000 1.0000000 +S 1 + 1 0.1570000 1.0000000 +S 1 + 1 317.0960000 1.0000000 +S 1 + 1 160.3930000 1.0000000 +S 1 + 1 81.1290000 1.0000000 +S 1 + 1 41.0370000 1.0000000 +S 1 + 1 20.7570000 1.0000000 +P 5 + 1 525.6000000 0.00016664 + 2 124.6000000 0.00143336 + 3 40.3400000 0.00754762 + 4 15.1800000 0.02859456 + 5 6.2450000 0.08438858 +P 1 + 1 2.7320000 1.0000000 +P 1 + 1 1.2270000 1.0000000 +P 1 + 1 0.5492000 1.0000000 +P 1 + 1 0.2418000 1.0000000 +P 1 + 1 0.1025000 1.0000000 +P 1 + 1 358.9110000 1.0000000 +P 1 + 1 161.8180000 1.0000000 +P 1 + 1 72.9570000 1.0000000 +P 1 + 1 32.8930000 1.0000000 +P 1 + 1 14.8300000 1.0000000 +D 1 + 1 8.2530000 1.0000000 +D 1 + 1 3.5970000 1.0000000 +D 1 + 1 1.5680000 1.0000000 +D 1 + 1 0.6840000 1.0000000 +D 1 + 1 0.2980000 1.0000000 +D 1 + 1 250.8300000 1.0000000 +D 1 + 1 108.1630000 1.0000000 +D 1 + 1 46.6420000 1.0000000 +D 1 + 1 20.1130000 1.0000000 +F 1 + 1 5.4300000 1.0000000 +F 1 + 1 2.4160000 1.0000000 +F 1 + 1 1.0750000 1.0000000 +F 1 + 1 0.4780000 1.0000000 +F 1 + 1 136.1110000 1.0000000 +F 1 + 1 48.8550000 1.0000000 +F 1 + 1 17.5360000 1.0000000 +G 1 + 1 5.2110000 1.0000000 +G 1 + 1 2.1900000 1.0000000 +G 1 + 1 0.9200000 1.0000000 +G 1 + 1 81.6280000 1.0000000 +G 1 + 1 24.0650000 1.0000000 +H 1 + 1 3.8720000 1.0000000 +H 1 + 1 1.5050000 1.0000000 +H 1 + 1 62.8500000 1.0000000 +I 1 + 1 2.7730000 1.0000000 + +FLUORINE +S 11 + 1 723500.0000000 0.00000556 + 2 108400.0000000 0.00004318 + 3 24680.0000000 0.00022700 + 4 6990.0000000 0.00095803 + 5 2282.0000000 0.00347015 + 6 824.6000000 0.01118526 + 7 321.8000000 0.03232880 + 8 133.5000000 0.08279545 + 9 58.1100000 0.17988024 + 10 26.2800000 0.30557831 + 11 12.2400000 0.34026839 +S 11 + 1 723500.0000000 -0.00000129 + 2 108400.0000000 -0.00000999 + 3 24680.0000000 -0.00005260 + 4 6990.0000000 -0.00022172 + 5 2282.0000000 -0.00080692 + 6 824.6000000 -0.00260817 + 7 321.8000000 -0.00767402 + 8 133.5000000 -0.02019353 + 9 58.1100000 -0.04718752 + 10 26.2800000 -0.09158009 + 11 12.2400000 -0.14048558 +S 1 + 1 5.7470000 1.0000000 +S 1 + 1 2.3650000 1.0000000 +S 1 + 1 1.0710000 1.0000000 +S 1 + 1 0.4681000 1.0000000 +S 1 + 1 0.1994000 1.0000000 +S 1 + 1 397.5440000 1.0000000 +S 1 + 1 201.5940000 1.0000000 +S 1 + 1 102.2280000 1.0000000 +S 1 + 1 51.8400000 1.0000000 +S 1 + 1 26.2880000 1.0000000 +P 5 + 1 660.0000000 0.00017721 + 2 156.4000000 0.00152691 + 3 50.6400000 0.00807207 + 4 19.0800000 0.03074021 + 5 7.8720000 0.09011914 +P 1 + 1 3.4490000 1.0000000 +P 1 + 1 1.5450000 1.0000000 +P 1 + 1 0.6864000 1.0000000 +P 1 + 1 0.2986000 1.0000000 +P 1 + 1 0.1245000 1.0000000 +P 1 + 1 446.5700000 1.0000000 +P 1 + 1 201.3390000 1.0000000 +P 1 + 1 90.7750000 1.0000000 +P 1 + 1 40.9270000 1.0000000 +P 1 + 1 18.4520000 1.0000000 +D 1 + 1 10.5730000 1.0000000 +D 1 + 1 4.6130000 1.0000000 +D 1 + 1 2.0130000 1.0000000 +D 1 + 1 0.8780000 1.0000000 +D 1 + 1 0.3830000 1.0000000 +D 1 + 1 313.7310000 1.0000000 +D 1 + 1 135.4040000 1.0000000 +D 1 + 1 58.4390000 1.0000000 +D 1 + 1 25.2220000 1.0000000 +F 1 + 1 7.5630000 1.0000000 +F 1 + 1 3.3300000 1.0000000 +F 1 + 1 1.4660000 1.0000000 +F 1 + 1 0.6450000 1.0000000 +F 1 + 1 177.2200000 1.0000000 +F 1 + 1 64.3500000 1.0000000 +F 1 + 1 23.3660000 1.0000000 +G 1 + 1 6.7350000 1.0000000 +G 1 + 1 2.7830000 1.0000000 +G 1 + 1 1.1500000 1.0000000 +G 1 + 1 99.3840000 1.0000000 +G 1 + 1 29.5170000 1.0000000 +H 1 + 1 5.0880000 1.0000000 +H 1 + 1 1.9370000 1.0000000 +H 1 + 1 67.8200000 1.0000000 +I 1 + 1 3.5810000 1.0000000 + +NEON +S 11 + 1 902400.0000000 0.00000551 + 2 135100.0000000 0.00004282 + 3 30750.0000000 0.00022514 + 4 8710.0000000 0.00095016 + 5 2842.0000000 0.00344719 + 6 1026.0000000 0.01112545 + 7 400.1000000 0.03220568 + 8 165.9000000 0.08259891 + 9 72.2100000 0.17990564 + 10 32.6600000 0.30605208 + 11 15.2200000 0.34012559 +S 11 + 1 902400.0000000 -0.00000129 + 2 135100.0000000 -0.00001005 + 3 30750.0000000 -0.00005293 + 4 8710.0000000 -0.00022312 + 5 2842.0000000 -0.00081338 + 6 1026.0000000 -0.00263230 + 7 400.1000000 -0.00775910 + 8 165.9000000 -0.02045277 + 9 72.2100000 -0.04797505 + 10 32.6600000 -0.09340086 + 11 15.2200000 -0.14277215 +S 1 + 1 7.1490000 1.0000000 +S 1 + 1 2.9570000 1.0000000 +S 1 + 1 1.3350000 1.0000000 +S 1 + 1 0.5816000 1.0000000 +S 1 + 1 0.2463000 1.0000000 +S 1 + 1 526.1367000 1.0000000 +S 1 + 1 264.9976000 1.0000000 +S 1 + 1 133.4704000 1.0000000 +S 1 + 1 67.2246200 1.0000000 +S 1 + 1 33.8588000 1.0000000 +P 5 + 1 815.6000000 0.00018376 + 2 193.3000000 0.00158509 + 3 62.6000000 0.00841464 + 4 23.6100000 0.03220033 + 5 9.7620000 0.09396390 +P 1 + 1 4.2810000 1.0000000 +P 1 + 1 1.9150000 1.0000000 +P 1 + 1 0.8476000 1.0000000 +P 1 + 1 0.3660000 1.0000000 +P 1 + 1 0.1510000 1.0000000 +P 1 + 1 558.8741000 1.0000000 +P 1 + 1 250.2470000 1.0000000 +P 1 + 1 112.0531000 1.0000000 +P 1 + 1 50.1739900 1.0000000 +P 1 + 1 22.4664000 1.0000000 +D 1 + 1 13.3170000 1.0000000 +D 1 + 1 5.8030000 1.0000000 +D 1 + 1 2.5290000 1.0000000 +D 1 + 1 1.1020000 1.0000000 +D 1 + 1 0.4800000 1.0000000 +D 1 + 1 392.7164000 1.0000000 +D 1 + 1 169.5564000 1.0000000 +D 1 + 1 73.2064700 1.0000000 +D 1 + 1 31.6071000 1.0000000 +F 1 + 1 10.3560000 1.0000000 +F 1 + 1 4.5380000 1.0000000 +F 1 + 1 1.9890000 1.0000000 +F 1 + 1 0.8710000 1.0000000 +F 1 + 1 224.9657000 1.0000000 +F 1 + 1 82.4518500 1.0000000 +F 1 + 1 30.2193000 1.0000000 +G 1 + 1 8.3450000 1.0000000 +G 1 + 1 3.4170000 1.0000000 +G 1 + 1 1.3990000 1.0000000 +G 1 + 1 119.8449000 1.0000000 +G 1 + 1 33.5255000 1.0000000 +H 1 + 1 6.5190000 1.0000000 +H 1 + 1 2.4470000 1.0000000 +H 1 + 1 50.9084700 1.0000000 +I 1 + 1 4.4890000 1.0000000 + ALUMINUM S 11 1 3652000.0000000 0.0000019 diff --git a/ocaml/.gitignore b/ocaml/.gitignore deleted file mode 100644 index 45d71ee3..00000000 --- a/ocaml/.gitignore +++ /dev/null @@ -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 diff --git a/ocaml/Address.ml b/ocaml/Address.ml index 5f3bb748..e107cf0c 100644 --- a/ocaml/Address.ml +++ b/ocaml/Address.ml @@ -4,11 +4,15 @@ module Tcp : sig type t val of_string : string -> t val to_string : t -> string + val create : host:string -> port:int -> t end = struct type t = string let of_string x = assert (String.is_prefix ~prefix:"tcp://" x); x + let create ~host ~port = + assert (port > 0); + Printf.sprintf "tcp://%s:%d" host port let to_string x = x end @@ -16,11 +20,14 @@ module Ipc : sig type t val of_string : string -> t val to_string : t -> string + val create : string -> t end = struct type t = string let of_string x = assert (String.is_prefix ~prefix:"ipc://" x); x + let create name = + Printf.sprintf "ipc://%s" name let to_string x = x end @@ -28,11 +35,14 @@ module Inproc : sig type t val of_string : string -> t val to_string : t -> string + val create : string -> t end = struct type t = string let of_string x = assert (String.is_prefix ~prefix:"inproc://" x); x + let create name = + Printf.sprintf "ipc://%s" name let to_string x = x end diff --git a/ocaml/Bitlist.ml b/ocaml/Bitlist.ml index 80efd2b2..4648ef6b 100644 --- a/ocaml/Bitlist.ml +++ b/ocaml/Bitlist.ml @@ -1,5 +1,5 @@ -open Qptypes;; -open Core.Std;; +open Qptypes +open Core.Std (* Type for bits strings @@ -19,15 +19,16 @@ let to_string b = in do_work new_accu tail in do_work "" b -;; + let of_string ?(zero='0') ?(one='1') s = String.to_list s |> List.rev_map ~f:( fun c -> if (c = zero) then Bit.Zero else if (c = one) then Bit.One - else (failwith ("Error in string "^s) ) ) -;; + else (failwith ("Error in bitstring ") ) ) + + (* Create a bit list from an int64 *) let of_int64 i = @@ -43,15 +44,15 @@ let of_int64 i = in let adjust_length result = let rec do_work accu = function - | 64 -> accu + | 64 -> List.rev accu | i when i>64 -> raise (Failure "Error in of_int64 > 64") | i when i<0 -> raise (Failure "Error in of_int64 < 0") - | i -> do_work (accu@[Bit.Zero]) (i+1) + | i -> do_work (Bit.Zero :: accu) (i+1) in - do_work result (List.length result) + do_work (List.rev result) (List.length result) in adjust_length (do_work i) -;; + (* Create an int64 from a bit list *) let to_int64 l = @@ -61,26 +62,26 @@ let to_int64 l = | Bit.Zero::tail -> do_work Int64.(shift_left accu 1) tail | Bit.One::tail -> do_work Int64.(bit_or one (shift_left accu 1)) tail in do_work Int64.zero (List.rev l) -;; + (* Create a bit list from a list of int64 *) let of_int64_list l = List.map ~f:of_int64 l |> List.concat -;; + (* Compute n_int *) let n_int_of_mo_tot_num mo_tot_num = let bit_kind_size = Bit_kind_size.to_int (Lazy.force Qpackage.bit_kind_size) in N_int_number.of_int ( (mo_tot_num-1)/bit_kind_size + 1 ) -;; + (* Create a zero bit list *) let zero n_int = let n_int = N_int_number.to_int n_int in let a = Array.init n_int (fun i-> 0L) in of_int64_list ( Array.to_list a ) -;; + (* Create an int64 list from a bit list *) let to_int64_list l = @@ -100,7 +101,7 @@ let to_int64_list l = let l = do_work [] [] 1 l in List.rev_map ~f:to_int64 l -;; + (* Create a bit list from a list of MO indices *) let of_mo_number_list n_int l = @@ -109,7 +110,7 @@ let of_mo_number_list n_int l = let a = Array.create length (Bit.Zero) in List.iter ~f:(fun i-> a.((MO_number.to_int i)-1) <- Bit.One) l; Array.to_list a -;; + let to_mo_number_list l = let a = Array.of_list l in @@ -127,7 +128,7 @@ let to_mo_number_list l = end in do_work [] (List.length l) -;; + @@ -142,7 +143,7 @@ let logical_operator2 op a b = in do_work_binary (newbit::result) ta tb in List.rev (do_work_binary [] a b) -;; + let logical_operator1 op b = let rec do_work_unary result b = @@ -153,12 +154,12 @@ let logical_operator1 op b = in do_work_unary (newbit::result) tb in List.rev (do_work_unary [] b) -;; -let and_operator a b = logical_operator2 Bit.and_operator a b;; -let xor_operator a b = logical_operator2 Bit.xor_operator a b;; -let or_operator a b = logical_operator2 Bit.or_operator a b;; -let not_operator b = logical_operator1 Bit.not_operator b ;; + +let and_operator a b = logical_operator2 Bit.and_operator a b +let xor_operator a b = logical_operator2 Bit.xor_operator a b +let or_operator a b = logical_operator2 Bit.or_operator a b +let not_operator b = logical_operator1 Bit.not_operator b let popcnt b = @@ -167,6 +168,6 @@ let popcnt b = | Bit.One::rest -> popcnt (accu+1) rest | Bit.Zero::rest -> popcnt (accu) rest in popcnt 0 b -;; + diff --git a/ocaml/Determinant.ml b/ocaml/Determinant.ml index 96291904..63dab9b9 100644 --- a/ocaml/Determinant.ml +++ b/ocaml/Determinant.ml @@ -4,14 +4,14 @@ open Qptypes;; type t = int64 array with sexp let to_int64_array (x:t) = (x:int64 array) -;; + let to_alpha_beta x = let x = to_int64_array x in let n_int = (Array.length x)/2 in ( Array.init n_int ~f:(fun i -> x.(i)) , Array.init n_int ~f:(fun i -> x.(i+n_int)) ) -;; + let to_bitlist_couple x = let (xa,xb) = to_alpha_beta x in @@ -22,7 +22,7 @@ let to_bitlist_couple x = |> Array.to_list |> Bitlist.of_int64_list in (xa,xb) -;; + let bitlist_to_string ~mo_tot_num x = List.map x ~f:(fun i -> match i with @@ -30,7 +30,7 @@ let bitlist_to_string ~mo_tot_num x = | Bit.One -> "+" ) |> String.concat |> String.sub ~pos:0 ~len:(MO_number.to_int mo_tot_num) -;; + let of_int64_array ~n_int ~alpha ~beta x = @@ -54,20 +54,19 @@ let of_int64_array ~n_int ~alpha ~beta x = %s" beta (bitlist_to_string ~mo_tot_num:mo_tot_num b) ) end; x -;; + let of_bitlist_couple ~alpha ~beta (xa,xb) = let ba = Bitlist.to_int64_list xa in let bb = Bitlist.to_int64_list xb in let n_int = Bitlist.n_int_of_mo_tot_num (List.length xa) in of_int64_array ~n_int:n_int ~alpha:alpha ~beta:beta (Array.of_list (ba@bb)) -;; + let to_string ~mo_tot_num x = let (xa,xb) = to_bitlist_couple x in [ bitlist_to_string ~mo_tot_num:mo_tot_num xa ; bitlist_to_string ~mo_tot_num:mo_tot_num xb ] |> String.concat ~sep:"\n" -;; diff --git a/ocaml/Input_determinants_by_hand.ml b/ocaml/Input_determinants_by_hand.ml index d78233ca..ff9eb520 100644 --- a/ocaml/Input_determinants_by_hand.ml +++ b/ocaml/Input_determinants_by_hand.ml @@ -29,6 +29,8 @@ end = struct let get_default = Qpackage.get_ezfio_default "determinants";; + let n_det_read_max = 50_000_000 ;; + let read_n_int () = if not (Ezfio.has_determinants_n_int()) then Ezfio.get_mo_basis_mo_tot_num () @@ -207,14 +209,20 @@ end = struct let read () = if (Ezfio.has_mo_basis_mo_tot_num ()) then - Some - { n_int = read_n_int () ; - bit_kind = read_bit_kind () ; - n_det = read_n_det () ; - expected_s2 = read_expected_s2 () ; - psi_coef = read_psi_coef () ; - psi_det = read_psi_det () ; - } + let n_det = + read_n_det () + in + if ( (Det_number.to_int n_det) > n_det_read_max ) then + None + else + Some + { n_int = read_n_int () ; + bit_kind = read_bit_kind () ; + n_det = read_n_det () ; + expected_s2 = read_expected_s2 () ; + psi_coef = read_psi_coef () ; + psi_det = read_psi_det () ; + } else None ;; @@ -393,22 +401,35 @@ psi_det = %s in let rec read_dets accu = function | [] -> List.rev accu - | ""::c::alpha::beta::tail -> + | ""::_::alpha::beta::tail -> begin - let alpha = String.rev alpha |> Bitlist.of_string ~zero:'-' ~one:'+' - and beta = String.rev beta |> Bitlist.of_string ~zero:'-' ~one:'+' - in - let newdet = Determinant.of_bitlist_couple - ~alpha:n_alpha ~beta:n_beta (alpha,beta) - |> Determinant.sexp_of_t |> Sexplib.Sexp.to_string + let newdet = + (Bitlist.of_string ~zero:'-' ~one:'+' alpha , + Bitlist.of_string ~zero:'-' ~one:'+' beta) + |> Determinant.of_bitlist_couple ~alpha:n_alpha ~beta:n_beta + |> Determinant.sexp_of_t + |> Sexplib.Sexp.to_string in read_dets (newdet::accu) tail end | _::tail -> read_dets accu tail in - let a = read_dets [] dets - |> String.concat + let dets = + List.map ~f:String.rev dets in + let sze = + List.fold ~init:0 ~f:(fun accu x -> accu + (String.length x)) dets + in + let control = + Gc.get () + in + Gc.tune ~minor_heap_size:(sze) ~space_overhead:(sze/10) + ~max_overhead:100000 ~major_heap_increment:(sze/10) (); + let a = + read_dets [] dets + |> String.concat + in + Gc.set control; "(psi_det ("^a^"))" in diff --git a/ocaml/Message.ml b/ocaml/Message.ml index ee5ff80c..505f9789 100644 --- a/ocaml/Message.ml +++ b/ocaml/Message.ml @@ -1,4 +1,5 @@ open Core.Std +open Qptypes (** New job : Request to create a new multi-tasked job *) @@ -32,12 +33,30 @@ end = struct address_inproc = Address.Inproc.of_string address_inproc ; } let to_string t = - Printf.sprintf "newjob %s %s %s" + Printf.sprintf "new_job %s %s %s" ( State.to_string t.state ) ( Address.Tcp.to_string t.address_tcp ) ( Address.Inproc.to_string t.address_inproc ) end +module Endjob_msg : sig + type t = + { state: State.t; + } + val create : state:string -> t + val to_string : t -> string +end = struct + type t = + { state: State.t; + } + let create ~state = + { state = State.of_string state; + } + let to_string t = + Printf.sprintf "end_job %s" + ( State.to_string t.state ) +end + (** Connect : connect a new client to the task server *) @@ -108,22 +127,21 @@ end module DisconnectReply_msg : sig type t = - { finished: bool ; + { state: State.t ; } - val create : state:State.t -> finished:bool -> t + val create : state:State.t -> t val to_string : t -> string end = struct type t = - { finished: bool; + { state: State.t ; } - let create ~state ~finished = - { state ; finished } + let create ~state = + { state } let to_string x = - Printf.sprintf "disconnect_reply %s %d" + Printf.sprintf "disconnect_reply %s" (State.to_string x.state) - (if x.finished then 1 else 0) end @@ -160,6 +178,52 @@ end = struct end +(** DelTask : Remove a task from the queue *) +module DelTask_msg : sig + type t = + { state: State.t; + task_id: Id.Task.t + } + val create : state:string -> task_id:string -> t + val to_string : t -> string +end = struct + type t = + { state: State.t; + task_id: Id.Task.t + } + let create ~state ~task_id = + { state = State.of_string state ; + task_id = Id.Task.of_string task_id + } + let to_string x = + Printf.sprintf "del_task %s %d" + (State.to_string x.state) + (Id.Task.to_int x.task_id) +end + + +(** DelTaskReply : Reply to the DelTask message *) +module DelTaskReply_msg : sig + type t + val create : task_id:Id.Task.t -> more:bool -> t + val to_string : t -> string +end = struct + type t = { + task_id : Id.Task.t ; + more : bool; + } + let create ~task_id ~more = { task_id ; more } + let to_string x = + let more = + if x.more then "more" + else "done" + in + Printf.sprintf "del_task_reply %s %d" + more (Id.Task.to_int x.task_id) +end + + + (** GetTask : get a new task to do *) module GetTask_msg : sig type t = @@ -196,14 +260,240 @@ end = struct Printf.sprintf "get_task_reply %d %s" (Id.Task.to_int x.task_id) x.task end +(** GetPsi : get the current variational wave function *) +module GetPsi_msg : sig + type t = + { client_id: Id.Client.t ; + } + val create : client_id:string -> t + val to_string : t -> string +end = struct + type t = + { client_id: Id.Client.t ; + } + let create ~client_id = + { client_id = Id.Client.of_string client_id } + let to_string x = + Printf.sprintf "get_psi %d" + (Id.Client.to_int x.client_id) +end + +module Psi : sig + type t = + { + n_state : Strictly_positive_int.t ; + n_det : Strictly_positive_int.t ; + psi_det_size : Strictly_positive_int.t ; + n_det_generators : Strictly_positive_int.t option; + n_det_selectors : Strictly_positive_int.t option; + psi_det : string ; + psi_coef : string ; + } + val create : n_state:Strictly_positive_int.t + -> n_det:Strictly_positive_int.t + -> psi_det_size:Strictly_positive_int.t + -> n_det_generators:Strictly_positive_int.t option + -> n_det_selectors:Strictly_positive_int.t option + -> psi_det:string -> psi_coef:string -> t +end = struct + type t = + { + n_state : Strictly_positive_int.t ; + n_det : Strictly_positive_int.t ; + psi_det_size : Strictly_positive_int.t ; + n_det_generators : Strictly_positive_int.t option; + n_det_selectors : Strictly_positive_int.t option; + psi_det : string ; + psi_coef : string ; + } + let create ~n_state ~n_det ~psi_det_size + ~n_det_generators ~n_det_selectors ~psi_det ~psi_coef = + assert (Strictly_positive_int.to_int n_det <= + Strictly_positive_int.to_int psi_det_size ); + { n_state; n_det ; psi_det_size ; + n_det_generators ; n_det_selectors ; + psi_det ; psi_coef } +end + +(** GetPsiReply_msg : Reply to the GetPsi message *) +module GetPsiReply_msg : sig + type t = + { client_id : Id.Client.t ; + psi : Psi.t } + val create : client_id:Id.Client.t -> psi:Psi.t -> t + val to_string_list : t -> string list + val to_string : t -> string +end = struct + type t = + { client_id : Id.Client.t ; + psi : Psi.t } + let create ~client_id ~psi = + { client_id ; psi } + let to_string_list x = + let g, s = + match x.psi.Psi.n_det_generators, x.psi.Psi.n_det_selectors with + | Some g, Some s -> Strictly_positive_int.to_int g, Strictly_positive_int.to_int s + | _ -> -1, -1 + in + [ Printf.sprintf "get_psi_reply %d %d %d %d %d %d" + (Id.Client.to_int x.client_id) + (Strictly_positive_int.to_int x.psi.Psi.n_state) + (Strictly_positive_int.to_int x.psi.Psi.n_det) + (Strictly_positive_int.to_int x.psi.Psi.psi_det_size) + g s ; + x.psi.Psi.psi_det ; x.psi.Psi.psi_coef ] + let to_string x = + let g, s = + match x.psi.Psi.n_det_generators, x.psi.Psi.n_det_selectors with + | Some g, Some s -> Strictly_positive_int.to_int g, Strictly_positive_int.to_int s + | _ -> -1, -1 + in + Printf.sprintf "get_psi_reply %d %d %d %d %d %d" + (Id.Client.to_int x.client_id) + (Strictly_positive_int.to_int x.psi.Psi.n_state) + (Strictly_positive_int.to_int x.psi.Psi.n_det) + (Strictly_positive_int.to_int x.psi.Psi.psi_det_size) + g s +end + + +(** PutPsi : put the current variational wave function *) +module PutPsi_msg : sig + type t = + { client_id : Id.Client.t ; + n_state : Strictly_positive_int.t ; + n_det : Strictly_positive_int.t ; + psi_det_size : Strictly_positive_int.t ; + n_det_generators : Strictly_positive_int.t option; + n_det_selectors : Strictly_positive_int.t option; + psi : Psi.t option } + val create : + client_id:string -> + n_state:string -> + n_det:string -> + psi_det_size:string -> + psi_det:string option -> + psi_coef:string option -> + n_det_generators: string option -> + n_det_selectors:string option -> t + val to_string_list : t -> string list + val to_string : t -> string +end = struct + type t = + { client_id : Id.Client.t ; + n_state : Strictly_positive_int.t ; + n_det : Strictly_positive_int.t ; + psi_det_size : Strictly_positive_int.t ; + n_det_generators : Strictly_positive_int.t option; + n_det_selectors : Strictly_positive_int.t option; + psi : Psi.t option } + let create ~client_id ~n_state ~n_det ~psi_det_size ~psi_det ~psi_coef + ~n_det_generators ~n_det_selectors = + let n_state, n_det, psi_det_size = + Int.of_string n_state + |> Strictly_positive_int.of_int , + Int.of_string n_det + |> Strictly_positive_int.of_int , + Int.of_string psi_det_size + |> Strictly_positive_int.of_int + in + assert (Strictly_positive_int.to_int psi_det_size >= + Strictly_positive_int.to_int n_det); + let n_det_generators, n_det_selectors = + match n_det_generators, n_det_selectors with + | Some x, Some y -> + Some (Strictly_positive_int.of_int @@ Int.of_string x), + Some (Strictly_positive_int.of_int @@ Int.of_string y) + | _ -> None, None + in + let psi = + match (psi_det, psi_coef) with + | (Some psi_det, Some psi_coef) -> + Some (Psi.create ~n_state ~n_det ~psi_det_size ~psi_det + ~psi_coef ~n_det_generators ~n_det_selectors) + | _ -> None + in + { client_id = Id.Client.of_string client_id ; + n_state ; n_det ; psi_det_size ; n_det_generators ; + n_det_selectors ; psi } + let to_string_list x = + match x.n_det_generators, x.n_det_selectors, x.psi with + | Some g, Some s, Some psi -> + [ Printf.sprintf "put_psi %d %d %d %d %d %d" + (Id.Client.to_int x.client_id) + (Strictly_positive_int.to_int x.n_state) + (Strictly_positive_int.to_int x.n_det) + (Strictly_positive_int.to_int x.psi_det_size) + (Strictly_positive_int.to_int g) + (Strictly_positive_int.to_int s) ; + psi.Psi.psi_det ; psi.Psi.psi_coef ] + | Some g, Some s, None -> + [ Printf.sprintf "put_psi %d %d %d %d %d %d" + (Id.Client.to_int x.client_id) + (Strictly_positive_int.to_int x.n_state) + (Strictly_positive_int.to_int x.n_det) + (Strictly_positive_int.to_int x.psi_det_size) + (Strictly_positive_int.to_int g) + (Strictly_positive_int.to_int s) ; + "None" ; "None" ] + | _ -> + [ Printf.sprintf "put_psi %d %d %d %d -1 -1" + (Id.Client.to_int x.client_id) + (Strictly_positive_int.to_int x.n_state) + (Strictly_positive_int.to_int x.n_det) + (Strictly_positive_int.to_int x.psi_det_size) ; + "None" ; "None" ] + let to_string x = + match x.n_det_generators, x.n_det_selectors, x.psi with + | Some g, Some s, Some psi -> + Printf.sprintf "put_psi %d %d %d %d %d %d" + (Id.Client.to_int x.client_id) + (Strictly_positive_int.to_int x.n_state) + (Strictly_positive_int.to_int x.n_det) + (Strictly_positive_int.to_int x.psi_det_size) + (Strictly_positive_int.to_int g) + (Strictly_positive_int.to_int s) + | Some g, Some s, None -> + Printf.sprintf "put_psi %d %d %d %d %d %d" + (Id.Client.to_int x.client_id) + (Strictly_positive_int.to_int x.n_state) + (Strictly_positive_int.to_int x.n_det) + (Strictly_positive_int.to_int x.psi_det_size) + (Strictly_positive_int.to_int g) + (Strictly_positive_int.to_int s) + | _, _, _ -> + Printf.sprintf "put_psi %d %d %d %d %d %d" + (Id.Client.to_int x.client_id) + (Strictly_positive_int.to_int x.n_state) + (Strictly_positive_int.to_int x.n_det) + (Strictly_positive_int.to_int x.psi_det_size) + (-1) (-1) +end + +(** PutPsiReply_msg : Reply to the PutPsi message *) +module PutPsiReply_msg : sig + type t + val create : client_id:Id.Client.t -> t + val to_string : t -> string +end = struct + type t = + { client_id : Id.Client.t ; + } + let create ~client_id = + { client_id; } + let to_string x = + Printf.sprintf "put_psi_reply %d" + (Id.Client.to_int x.client_id) +end + (** TaskDone : Inform the server that a task is finished *) module TaskDone_msg : sig type t = - { client_id: Id.Client.t ; - state: State.t ; - task_id: Id.Task.t; - } + { client_id: Id.Client.t ; + state: State.t ; + task_id: Id.Task.t ; + } val create : state:string -> client_id:string -> task_id:string -> t val to_string : t -> string end = struct @@ -215,7 +505,9 @@ end = struct let create ~state ~client_id ~task_id = { client_id = Id.Client.of_string client_id ; state = State.of_string state ; - task_id = Id.Task.of_string task_id } + task_id = Id.Task.of_string task_id; + } + let to_string x = Printf.sprintf "task_done %s %d %d" (State.to_string x.state) @@ -262,19 +554,26 @@ end (** Message *) type t = -| Newjob of Newjob_msg.t -| Connect of Connect_msg.t -| ConnectReply of ConnectReply_msg.t -| Disconnect of Disconnect_msg.t -| DisconnectReply of DisconnectReply_msg.t -| GetTask of GetTask_msg.t -| GetTaskReply of GetTaskReply_msg.t -| AddTask of AddTask_msg.t -| AddTaskReply of AddTaskReply_msg.t -| TaskDone of TaskDone_msg.t -| Terminate of Terminate_msg.t -| Ok of Ok_msg.t -| Error of Error_msg.t +| GetPsi of GetPsi_msg.t +| PutPsi of PutPsi_msg.t +| GetPsiReply of GetPsiReply_msg.t +| PutPsiReply of PutPsiReply_msg.t +| Newjob of Newjob_msg.t +| Endjob of Endjob_msg.t +| Connect of Connect_msg.t +| ConnectReply of ConnectReply_msg.t +| Disconnect of Disconnect_msg.t +| DisconnectReply of DisconnectReply_msg.t +| GetTask of GetTask_msg.t +| GetTaskReply of GetTaskReply_msg.t +| DelTask of DelTask_msg.t +| DelTaskReply of DelTaskReply_msg.t +| AddTask of AddTask_msg.t +| AddTaskReply of AddTaskReply_msg.t +| TaskDone of TaskDone_msg.t +| Terminate of Terminate_msg.t +| Ok of Ok_msg.t +| Error of Error_msg.t let of_string s = @@ -286,6 +585,8 @@ let of_string s = match l with | "add_task" :: state :: task -> AddTask (AddTask_msg.create ~state ~task:(String.concat ~sep:" " task) ) + | "del_task" :: state :: task_id :: [] -> + DelTask (DelTask_msg.create ~state ~task_id) | "get_task" :: state :: client_id :: [] -> GetTask (GetTask_msg.create ~state ~client_id) | "task_done" :: state :: client_id :: task_id :: [] -> @@ -296,8 +597,19 @@ let of_string s = Connect (Connect_msg.create t) | "new_job" :: state :: push_address_tcp :: push_address_inproc :: [] -> Newjob (Newjob_msg.create push_address_tcp push_address_inproc state) + | "end_job" :: state :: [] -> + Endjob (Endjob_msg.create state) | "terminate" :: [] -> Terminate (Terminate_msg.create () ) + | "get_psi" :: client_id :: [] -> + GetPsi (GetPsi_msg.create ~client_id) + | "put_psi" :: client_id :: n_state :: n_det :: psi_det_size :: n_det_generators :: n_det_selectors :: [] -> + PutPsi (PutPsi_msg.create ~client_id ~n_state ~n_det ~psi_det_size + ~n_det_generators:(Some n_det_generators) ~n_det_selectors:(Some n_det_selectors) + ~psi_det:None ~psi_coef:None ) + | "put_psi" :: client_id :: n_state :: n_det :: psi_det_size :: [] -> + PutPsi (PutPsi_msg.create ~client_id ~n_state ~n_det ~psi_det_size ~n_det_generators:None + ~n_det_selectors:None ~psi_det:None ~psi_coef:None ) | "ok" :: [] -> Ok (Ok_msg.create ()) | "error" :: rest -> @@ -306,18 +618,29 @@ let of_string s = let to_string = function -| Newjob x -> Newjob_msg.to_string x -| Connect x -> Connect_msg.to_string x -| ConnectReply x -> ConnectReply_msg.to_string x -| Disconnect x -> Disconnect_msg.to_string x -| DisconnectReply x -> DisconnectReply_msg.to_string x -| GetTask x -> GetTask_msg.to_string x -| GetTaskReply x -> GetTaskReply_msg.to_string x -| AddTask x -> AddTask_msg.to_string x -| AddTaskReply x -> AddTaskReply_msg.to_string x -| TaskDone x -> TaskDone_msg.to_string x -| Terminate x -> Terminate_msg.to_string x -| Ok x -> Ok_msg.to_string x -| Error x -> Error_msg.to_string x +| GetPsi x -> GetPsi_msg.to_string x +| PutPsiReply x -> PutPsiReply_msg.to_string x +| Newjob x -> Newjob_msg.to_string x +| Endjob x -> Endjob_msg.to_string x +| Connect x -> Connect_msg.to_string x +| ConnectReply x -> ConnectReply_msg.to_string x +| Disconnect x -> Disconnect_msg.to_string x +| DisconnectReply x -> DisconnectReply_msg.to_string x +| GetTask x -> GetTask_msg.to_string x +| GetTaskReply x -> GetTaskReply_msg.to_string x +| DelTask x -> DelTask_msg.to_string x +| DelTaskReply x -> DelTaskReply_msg.to_string x +| AddTask x -> AddTask_msg.to_string x +| AddTaskReply x -> AddTaskReply_msg.to_string x +| TaskDone x -> TaskDone_msg.to_string x +| Terminate x -> Terminate_msg.to_string x +| Ok x -> Ok_msg.to_string x +| Error x -> Error_msg.to_string x +| PutPsi x -> PutPsi_msg.to_string x +| GetPsiReply x -> GetPsiReply_msg.to_string x +let to_string_list = function +| PutPsi x -> PutPsi_msg.to_string_list x +| GetPsiReply x -> GetPsiReply_msg.to_string_list x +| _ -> assert false diff --git a/ocaml/Progress_bar.ml b/ocaml/Progress_bar.ml new file mode 100644 index 00000000..2ca8bd00 --- /dev/null +++ b/ocaml/Progress_bar.ml @@ -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 + + + diff --git a/ocaml/Queuing_system.ml b/ocaml/Queuing_system.ml index 7407d78d..acdfd439 100644 --- a/ocaml/Queuing_system.ml +++ b/ocaml/Queuing_system.ml @@ -1,4 +1,5 @@ open Core.Std +open Qptypes type t = @@ -32,7 +33,7 @@ let add_task ~task q = queued = task_id :: q.queued ; tasks = Map.add q.tasks ~key:task_id ~data:task ; next_task_id = Id.Task.increment task_id ; - }, task_id + } @@ -81,13 +82,25 @@ let end_task ~task_id ~client_id q = in { q with running = Map.remove running task_id ; - tasks = Map.remove tasks task_id ; } +let del_task ~task_id q = + let { tasks ; _ } = + q + in + + if (Map.mem tasks task_id) then + { q with + tasks = Map.remove tasks task_id ; + } + else + Printf.sprintf "Task %d is already deleted" (Id.Task.to_int task_id) + |> failwith + let number_of_queued q = - List.length q.queued + Map.length q.tasks let number_of_running q = Map.length q.running diff --git a/ocaml/TaskServer.ml b/ocaml/TaskServer.ml index 61eec19f..8f6e6ddf 100644 --- a/ocaml/TaskServer.ml +++ b/ocaml/TaskServer.ml @@ -1,25 +1,35 @@ open Core.Std open Qptypes -(** -The tasks server listens on a REQ socket and accepts the following commands: -* "new_job %s %s %s" state push_address_tcp push_address_inproc -> "OK" - -> "OK" +type t = +{ + queue : Queuing_system.t ; + state : Message.State.t option ; + address_tcp : Address.Tcp.t option ; + address_inproc : Address.Inproc.t option ; + psi : Message.Psi.t option; + progress_bar : Progress_bar.t option ; + running : bool; +} -* "connect %s" ["tcp"|"inproc"] - -> "%d %s %s" id state push_address -* "disconnect %d" id - -> "OK" -* "get_task %d %s" id state - -> "%d %s" task_id task +let debug_env = + match Sys.getenv "QP_TASK_DEBUG" with + | Some x -> x <> "" + | None -> false -* "task_done %d task_id %s" id state - -> "%d %s" task_id task -*) +let debug str = + if debug_env then + Printf.printf "TASK : %s%!" str + + + +let zmq_context = + ZMQ.Context.create () + let bind_socket ~socket_type ~socket ~address = try @@ -32,16 +42,14 @@ let bind_socket ~socket_type ~socket ~address = | other_exception -> raise other_exception -(** Name of the host on which the server runs *) let hostname = lazy ( try Unix.gethostname () with | _ -> "localhost" - ) +) -(** IP address *) let ip_address = lazy ( match Sys.getenv "QP_NIC" with | None -> @@ -67,271 +75,540 @@ let ip_address = lazy ( ) +let reply_ok rep_socket = + Message.Ok_msg.create () + |> Message.Ok_msg.to_string + |> ZMQ.Socket.send rep_socket + +let reply_wrong_state rep_socket = + Printf.printf "WRONG STATE\n%!"; + Message.Error_msg.create "Wrong state" + |> Message.Error_msg.to_string + |> ZMQ.Socket.send rep_socket + + + let stop ~port = - let zmq_context = - ZMQ.Context.create () - in - let req_socket = - ZMQ.Socket.create zmq_context ZMQ.Socket.req - and address = - Printf.sprintf "tcp://%s:%d" (Lazy.force ip_address) port - in - ZMQ.Socket.connect req_socket address; + debug "STOP"; + let req_socket = + ZMQ.Socket.create zmq_context ZMQ.Socket.req + and address = + Printf.sprintf "tcp://%s:%d" (Lazy.force ip_address) port + in + ZMQ.Socket.set_linger_period req_socket 1_000_000; + ZMQ.Socket.connect req_socket address; - Message.Terminate (Message.Terminate_msg.create ()) - |> Message.to_string - |> ZMQ.Socket.send ~block:false req_socket ; + Message.Terminate (Message.Terminate_msg.create ()) + |> Message.to_string + |> ZMQ.Socket.send req_socket ; - let msg = - ZMQ.Socket.recv req_socket - |> Message.of_string - in - let () = - match msg with - | Message.Ok _ -> () - | _ -> failwith "Problem in termination" - in - ZMQ.Socket.set_linger_period req_socket 1000; - ZMQ.Socket.close req_socket - + let msg = + ZMQ.Socket.recv req_socket + |> Message.of_string + in + let () = + match msg with + | Message.Ok _ -> () + | _ -> failwith "Problem in termination" + in + ZMQ.Socket.set_linger_period req_socket 1_000; + ZMQ.Socket.close req_socket -(** Run the task server *) -let run ~port = - let zmq_context = - ZMQ.Context.create () - in +let new_job msg program_state rep_socket = - let rep_socket = - ZMQ.Socket.create zmq_context ZMQ.Socket.rep - and address = - Printf.sprintf "tcp://%s:%d" (Lazy.force ip_address) port - in - bind_socket "REP" rep_socket address; - - let pollitem = - ZMQ.Poll.mask_of - [| (rep_socket, ZMQ.Poll.In) |] - in - - Printf.printf "Task server running : %s\n%!" address; - - (** State variables *) - let q = ref - (Queuing_system.create ()) - and running = - ref true - and job = - ref None - in - - let get_state () = - match !job with - | None -> None - | Some j -> Some j.Message.Newjob_msg.state - in - - let get_tcp_address () = - match !job with - | Some j -> Address.Tcp j.Message.Newjob_msg.address_tcp - | None -> assert false - in - - let get_inproc_address () = - match !job with - | Some j -> Address.Inproc j.Message.Newjob_msg.address_inproc - | None -> assert false - in - - let ok = - Message.Ok (Message.Ok_msg.create ()) - in - - while ( !running ) - do - let state = - get_state () - and polling = - ZMQ.Poll.poll ~timeout:1000 pollitem + let state = + msg.Message.Newjob_msg.state in - let terminate () = - running := false; - Message.to_string ok - |> ZMQ.Socket.send ~block:false rep_socket + let progress_bar = + Progress_bar.init + ~start_value:0. + ~end_value:1. + ~bar_length:20 + ~title:(Message.State.to_string state) + in - and newjob x = - q := Queuing_system.create (); - job := Some x; - Message.to_string ok - |> ZMQ.Socket.send ~block:false rep_socket + let result = + { program_state with + state = Some state ; + progress_bar = Some progress_bar ; + address_tcp = Some msg.Message.Newjob_msg.address_tcp; + address_inproc = Some msg.Message.Newjob_msg.address_inproc; + } + in + reply_ok rep_socket; + result - and connect state msg = - let push_address = - match msg with - | Message.Connect_msg.Tcp -> get_tcp_address () - | Message.Connect_msg.Inproc -> get_inproc_address () - | Message.Connect_msg.Ipc -> assert false - in - let new_q, client_id = - Queuing_system.add_client !q - in - q := new_q; - Message.ConnectReply (Message.ConnectReply_msg.create - ~state ~client_id ~push_address) - |> Message.to_string - |> ZMQ.Socket.send ~block:false rep_socket - and disconnect state msg = - let s, c = - msg.Message.Disconnect_msg.state , - msg.Message.Disconnect_msg.client_id - in - assert (s = state); - let new_q = - Queuing_system.del_client ~client_id:c !q - in - q := new_q; - let finished = - Queuing_system.number_of_queued !q + - Queuing_system.number_of_running !q = 0 - in - Message.DisconnectReply (Message.DisconnectReply_msg.create - ~state ~finished) - |> Message.to_string - |> ZMQ.Socket.send ~block:false rep_socket +let end_job msg program_state rep_socket = - and add_task state msg = - let s, task = - msg.Message.AddTask_msg.state, - msg.Message.AddTask_msg.task - in - assert (s = state); - Message.to_string ok - |> ZMQ.Socket.send ~block:false rep_socket - ; + let failure () = + reply_wrong_state rep_socket; + program_state + + and success state = + reply_ok rep_socket; + { program_state with + state = None ; + progress_bar = None ; + } + + in + match program_state.state with + | None -> failure () + | Some state -> begin - match - String.split ~on:' ' msg.Message.AddTask_msg.task - |> List.filter ~f:(fun x -> x <> "") - with - | "triangle" :: str_l :: [] -> - begin - let l = - Int.of_string str_l - in - for j=1 to l - do - let task = - Printf.sprintf "%d %s" j str_l - in - let new_q, _ = - Queuing_system.add_task ~task !q - in - q := new_q - done - end - | "range" :: str_i :: str_j :: [] -> - begin - let i, j = - Int.of_string str_i, - Int.of_string str_j - in - for k=i to (j+1) - do - let task = - Int.to_string k - in - let new_q, task_id = - Queuing_system.add_task ~task !q - in - q := new_q - done - end - | _ -> - let new_q, task_id = - Queuing_system.add_task ~task !q - in - q := new_q + if (msg.Message.Endjob_msg.state = state) then + success state + else + failure () end - - and get_task state msg = - let s, client_id = - msg.Message.GetTask_msg.state, - msg.Message.GetTask_msg.client_id - in - assert (s = state); - let new_q, task_id, task = - Queuing_system.pop_task ~client_id !q - in - q := new_q; - let reply = + + +let connect msg program_state rep_socket = + + let state = + match program_state.state with + | Some state -> state + | None -> assert false + in + + let push_address = + match msg with + | Message.Connect_msg.Tcp -> + begin + match program_state.address_tcp with + | Some address -> Address.Tcp address + | None -> failwith "Error: No TCP address" + end + | Message.Connect_msg.Inproc -> + begin + match program_state.address_inproc with + | Some address -> Address.Inproc address + | None -> failwith "Error: No inproc address" + end + | Message.Connect_msg.Ipc -> assert false + in + + let new_queue, client_id = + Queuing_system.add_client program_state.queue + in + Message.ConnectReply (Message.ConnectReply_msg.create + ~state:state ~client_id ~push_address) + |> Message.to_string + |> ZMQ.Socket.send rep_socket ; + { program_state with + queue = new_queue + } + + +let disconnect msg program_state rep_socket = + + let state, client_id = + msg.Message.Disconnect_msg.state, + msg.Message.Disconnect_msg.client_id + in + + let failure () = + reply_wrong_state rep_socket; + program_state + + and success () = + + let new_program_state = + { program_state with + queue = Queuing_system.del_client ~client_id program_state.queue + } + in + Message.DisconnectReply (Message.DisconnectReply_msg.create ~state) + |> Message.to_string + |> ZMQ.Socket.send rep_socket ; + new_program_state + + in + + match program_state.state with + | None -> assert false + | Some state' -> + begin + if (state = state') then + success () + else + failure () + end + +let del_task msg program_state rep_socket = + + let state, task_id = + msg.Message.DelTask_msg.state, + msg.Message.DelTask_msg.task_id + in + + let failure () = + reply_wrong_state rep_socket; + program_state + + and success () = + + let new_program_state = + { program_state with + queue = Queuing_system.del_task ~task_id program_state.queue + } + in + let more = + (Queuing_system.number_of_queued new_program_state.queue + + Queuing_system.number_of_running new_program_state.queue) > 0 + in + Message.DelTaskReply (Message.DelTaskReply_msg.create ~task_id ~more) + |> Message.to_string + |> ZMQ.Socket.send ~block:true rep_socket ; (** /!\ Has to be blocking *) + new_program_state + + in + + match program_state.state with + | None -> assert false + | Some state' -> + begin + if (state = state') then + success () + else + failure () + end + + + +let add_task msg program_state rep_socket = + + let state, task = + msg.Message.AddTask_msg.state, + msg.Message.AddTask_msg.task + in + + let increment_progress_bar = function + | Some bar -> Some (Progress_bar.increment_end bar) + | None -> None + in + + let rec add_task_triangle program_state imax = function + | 0 -> program_state + | i -> + let task = + Printf.sprintf "%d %d" i imax + in + let new_program_state = + { program_state with + queue = Queuing_system.add_task ~task program_state.queue ; + progress_bar = increment_progress_bar program_state.progress_bar ; + } + in + add_task_triangle new_program_state imax (i-1) + in + + let rec add_task_range program_state i = function + | j when (j < i) -> program_state + | j -> + let task = + Printf.sprintf "%d" j + in + let new_program_state = + { program_state with + queue = Queuing_system.add_task ~task program_state.queue ; + progress_bar = increment_progress_bar program_state.progress_bar ; + } + in + add_task_range new_program_state i (j-1) + in + + let new_program_state = function + | "triangle" :: i_str :: [] -> + let imax = + Int.of_string i_str + in + add_task_triangle program_state imax imax + | "range" :: i_str :: j_str :: [] -> + let i, j = + Int.of_string i_str, + Int.of_string j_str + in + add_task_range program_state i j + | _ -> + { program_state with + queue = Queuing_system.add_task ~task program_state.queue ; + progress_bar = increment_progress_bar program_state.progress_bar ; + } + in + + let result = + String.split ~on:' ' task + |> List.filter ~f:(fun x -> x <> "") + |> new_program_state + in + reply_ok rep_socket; + result + + + +let get_task msg program_state rep_socket = + + let state, client_id = + msg.Message.GetTask_msg.state, + msg.Message.GetTask_msg.client_id + in + + let failure () = + reply_wrong_state rep_socket; + program_state + + and success () = + + let new_queue, task_id, task = + Queuing_system.pop_task ~client_id program_state.queue + in + + let new_program_state = + { program_state with + queue = new_queue + } + in + match (task, task_id) with - | Some task, Some task_id -> - Message.GetTaskReply (Message.GetTaskReply_msg.create ~task ~task_id) - | _ -> Message.Terminate (Message.Terminate_msg.create ()) - in - Message.to_string reply - |> ZMQ.Socket.send ~block:false rep_socket - - and task_done state msg = - let s, client_id, task_id = + | Some task, Some task_id -> + begin + Message.GetTaskReply (Message.GetTaskReply_msg.create ~task ~task_id) + |> Message.to_string + |> ZMQ.Socket.send rep_socket ; + new_program_state + end + | _ -> + begin + Message.Terminate (Message.Terminate_msg.create ()) + |> Message.to_string + |> ZMQ.Socket.send rep_socket ; + program_state + end + + in + + match program_state.state with + | None -> assert false + | Some state' -> + begin + if (state = state') then + success () + else + failure () + end + + + +let task_done msg program_state rep_socket = + + let state, client_id, task_id = msg.Message.TaskDone_msg.state, msg.Message.TaskDone_msg.client_id, msg.Message.TaskDone_msg.task_id - in - assert (s = state); - let new_q = - Queuing_system.end_task ~task_id ~client_id !q - in - q := new_q; - Message.to_string ok - |> ZMQ.Socket.send ~block:false rep_socket - - and error msg = - Message.Error (Message.Error_msg.create msg) - |> Message.to_string - |> ZMQ.Socket.send ~block:false rep_socket in - if (polling.(0) = Some ZMQ.Poll.In) then - let raw_message = - ZMQ.Socket.recv rep_socket - in - try - let message = - Message.of_string raw_message + let increment_progress_bar = function + | Some bar -> Some (Progress_bar.increment_cur bar) + | None -> None + in + + let failure () = + reply_wrong_state rep_socket; + program_state + + and success () = + let result = + { program_state with + queue = Queuing_system.end_task ~task_id ~client_id program_state.queue ; + progress_bar = increment_progress_bar program_state.progress_bar ; + } in -(* - Printf.printf "%d %d : %s\n%!" - (Queuing_system.number_of_queued !q) - (Queuing_system.number_of_running !q) - (Message.to_string message); - Printf.printf "%s\n%!" (Queuing_system.to_string !q); *) - match (state, message) with - | _ , Message.Terminate _ -> terminate () - | None , Message.Newjob x -> newjob x - | None , _ -> error "No job is running" - | _ , Message.Newjob _ -> error "A job is already running" - | Some s, Message.Connect x -> connect s x - | Some s, Message.Disconnect x -> disconnect s x - | Some s, Message.AddTask x -> add_task s x - | Some s, Message.GetTask x -> get_task s x - | Some s, Message.TaskDone x -> task_done s x - | _ , _ -> - error ("Invalid message : "^(Message.to_string message)) - with - | Failure f -> error (f^" : "^raw_message) - | Assert_failure (f,i,j) -> error (Printf.sprintf "%s:%d:%d : %s" f i j raw_message) - - done; - ZMQ.Socket.set_linger_period rep_socket 1000; - ZMQ.Socket.close rep_socket + reply_ok rep_socket; + result + in + + match program_state.state with + | None -> assert false + | Some state' -> + begin + if (state = state') then + success () + else + failure () + end -(* -let () = - Printf.printf "export QP_RUN_ADDRESS=tcp://%s:%d\n%!" (Lazy.force ip_address) (Lazy.force port) -*) +let put_psi msg rest_of_msg program_state rep_socket = + + let psi_local = + match msg.Message.PutPsi_msg.psi with + | Some x -> x + | None -> + begin + let psi_det, psi_coef = + match rest_of_msg with + | [ x ; y ] -> x, y + | _ -> failwith "Badly formed put_psi message" + in + Message.Psi.create + ~n_state:msg.Message.PutPsi_msg.n_state + ~n_det:msg.Message.PutPsi_msg.n_det + ~psi_det_size:msg.Message.PutPsi_msg.psi_det_size + ~n_det_generators:msg.Message.PutPsi_msg.n_det_generators + ~n_det_selectors:msg.Message.PutPsi_msg.n_det_selectors + ~psi_det + ~psi_coef + end + in + let new_program_state = + { program_state with + psi = Some psi_local + } + and client_id = + msg.Message.PutPsi_msg.client_id + in + Message.PutPsiReply (Message.PutPsiReply_msg.create ~client_id) + |> Message.to_string + |> ZMQ.Socket.send rep_socket; + + new_program_state +let get_psi msg program_state rep_socket = + + let client_id = + msg.Message.GetPsi_msg.client_id + in + match program_state.psi with + | None -> failwith "No wave function saved in TaskServer" + | Some psi -> + Message.GetPsiReply (Message.GetPsiReply_msg.create ~client_id ~psi) + |> Message.to_string_list + |> ZMQ.Socket.send_all rep_socket; + program_state + + + +let terminate program_state rep_socket = + reply_ok rep_socket; + { program_state with + running = false + } + + +let error msg program_state rep_socket = + Printf.printf "%s\n%!" msg; + Message.Error (Message.Error_msg.create msg) + |> Message.to_string + |> ZMQ.Socket.send rep_socket ; + program_state + + + +let run ~port = + + (** Bind REP socket *) + let rep_socket = + ZMQ.Socket.create zmq_context ZMQ.Socket.rep + and address = + Printf.sprintf "tcp://%s:%d" (Lazy.force ip_address) port + in + bind_socket "REP" rep_socket address; + ZMQ.Socket.set_linger_period rep_socket 1_000_000; + + let initial_program_state = + { queue = Queuing_system.create () ; + running = true ; + psi = None; + state = None; + address_tcp = None; + address_inproc = None; + progress_bar = None ; + } + in + + (** ZMR polling item *) + let pollitem = + ZMQ.Poll.mask_of + [| (rep_socket, ZMQ.Poll.In) |] + in + + Printf.printf "Task server running : %s\n%!" address; + + + (** Main loop *) + let rec main_loop program_state = function + | false -> () + | true -> + let polling = + ZMQ.Poll.poll ~timeout:1000 pollitem + in + if (polling.(0) <> Some ZMQ.Poll.In) then + main_loop program_state true + else + begin + let program_state = + match program_state.progress_bar with + | None -> program_state + | Some bar -> + if bar.Progress_bar.dirty then + { program_state with + progress_bar = Some (Progress_bar.display bar) + } + else + program_state + in + + (** Extract message *) + let raw_message, rest = + match ZMQ.Socket.recv_all rep_socket with + | x :: rest -> x, rest + | [] -> failwith "Badly formed message" + in + let message = + Message.of_string raw_message + in + + (** Debug input *) + Printf.sprintf "%d %d : %s\n%!" + (Queuing_system.number_of_queued program_state.queue) + (Queuing_system.number_of_running program_state.queue) + (Message.to_string message) + |> debug; + + let new_program_state = + try + match program_state.state, message with + | _ , Message.Terminate _ -> terminate program_state rep_socket + | _ , Message.PutPsi x -> put_psi x rest program_state rep_socket + | _ , Message.GetPsi x -> get_psi x program_state rep_socket + | None , Message.Newjob x -> new_job x program_state rep_socket + | _ , Message.Newjob _ -> error "A job is already running" program_state rep_socket + | Some _, Message.Endjob x -> end_job x program_state rep_socket + | None , _ -> error "No job is running" program_state rep_socket + | Some _, Message.Connect x -> connect x program_state rep_socket + | Some _, Message.Disconnect x -> disconnect x program_state rep_socket + | Some _, Message.AddTask x -> add_task x program_state rep_socket + | Some _, Message.DelTask x -> del_task x program_state rep_socket + | Some _, Message.GetTask x -> get_task x program_state rep_socket + | Some _, Message.TaskDone x -> task_done x program_state rep_socket + | _ , _ -> + error ("Invalid message : "^(Message.to_string message)) program_state rep_socket + with + | Failure f -> + error (f^" : "^raw_message) program_state rep_socket + | Assert_failure (f,i,j) -> + error (Printf.sprintf "%s:%d:%d : %s" f i j raw_message) program_state rep_socket + + in + main_loop new_program_state new_program_state.running + end + in main_loop initial_program_state true; + + + + diff --git a/ocaml/qp_run.ml b/ocaml/qp_run.ml index 600c6f24..a20df362 100644 --- a/ocaml/qp_run.ml +++ b/ocaml/qp_run.ml @@ -1,14 +1,53 @@ -open Core.Std;; -open Qputils;; +open Core.Std +open Qputils + +(* Environment variables : + + QP_PREFIX=gdb : to run gdb (or valgrind, or whatever) + QP_TASK_DEBUG=1 : debug task server + +*) let print_list () = Lazy.force Qpackage.executables |> List.iter ~f:(fun (x,_) -> Printf.printf " * %s\n" x) -;; -let run exe ezfio_file = +let () = + Random.self_init () - let time_start = Time.now() in +let run ~master exe ezfio_file = + + + (** Check availability of the ports *) + let port_number = + let zmq_context = + ZMQ.Context.create () + in + let dummy_socket = + ZMQ.Socket.create zmq_context ZMQ.Socket.rep + in + let rec try_new_port port_number = + try + List.iter [ 0;1;2;3;4 ] ~f:(fun i -> + let address = + Printf.sprintf "tcp://%s:%d" (Lazy.force TaskServer.ip_address) (port_number+i) + in + TaskServer.bind_socket "REP" dummy_socket address ; + ZMQ.Socket.unbind dummy_socket address; + ); + port_number + with + | Failure _ -> try_new_port (port_number+100) + in + let result = + try_new_port 41279 + in + ZMQ.Socket.close dummy_socket; + result + in + let time_start = + Time.now () + in if (not (Sys.file_exists_exn ezfio_file)) then failwith ("EZFIO directory "^ezfio_file^" not found"); @@ -26,16 +65,18 @@ let run exe ezfio_file = (** Check input *) - match (Sys.command ("qp_edit -c "^ezfio_file)) with - | 0 -> () - | i -> failwith "Error: Input inconsistent\n"; - ; - + begin + match (Sys.command ("qp_edit -c "^ezfio_file)) with + | 0 -> () + | i -> failwith "Error: Input inconsistent\n" + end; + begin + match master with + | Some address -> Unix.putenv ~key:"QP_RUN_ADDRESS_MASTER" ~data:address + | None -> () + end; (** Start task server *) - let port_number = - 12345 - in let address = Printf.sprintf "tcp://%s:%d" (Lazy.force TaskServer.ip_address) port_number in @@ -49,12 +90,16 @@ let run exe ezfio_file = Unix.putenv ~key:"QP_RUN_ADDRESS" ~data:address; (** Run executable *) - let exe = + let prefix = + match Sys.getenv "QP_PREFIX" with + | Some x -> x^" " + | None -> "" + and exe = match (List.find ~f:(fun (x,_) -> x = exe) executables) with | None -> assert false - | Some (_,x) -> x + | Some (_,x) -> x^" " in - match (Sys.command (exe^" "^ezfio_file)) with + match (Sys.command (prefix^exe^ezfio_file)) with | 0 -> () | i -> Printf.printf "Program exited with code %d.\n%!" i; ; @@ -64,16 +109,19 @@ let run exe ezfio_file = let duration = Time.diff (Time.now()) time_start |> Core.Span.to_string in - Printf.printf "Wall time : %s\n\n" duration; -;; + Printf.printf "Wall time : %s\n\n" duration let spec = let open Command.Spec in empty + +> flag "master" (optional string) + ~doc:("address Address of the master process") +> anon ("executable" %: string) +> anon ("ezfio_file" %: string) ;; + + let () = Command.basic ~summary: "Quantum Package command" @@ -85,10 +133,9 @@ Executes a Quantum Package binary file among these:\n\n" ) ) spec - (fun exe ezfio_file () -> - run exe ezfio_file + (fun master exe ezfio_file () -> + run ~master exe ezfio_file ) |> Command.run ~version: Git.sha1 ~build_info: Git.message -;; diff --git a/ocaml/qptypes_generator.ml b/ocaml/qptypes_generator.ml index f3a5513e..d04d6629 100644 --- a/ocaml/qptypes_generator.ml +++ b/ocaml/qptypes_generator.ml @@ -13,6 +13,9 @@ let input_data = " * Strictly_negative_float : float assert (x < 0.) ; +* Positive_int64 : int64 + assert (x >= 0L) ; + * Positive_int : int assert (x >= 0) ; diff --git a/ocaml/test_task_server.py b/ocaml/test_task_server.py index cb7da8ee..dac14083 100755 --- a/ocaml/test_task_server.py +++ b/ocaml/test_task_server.py @@ -3,7 +3,6 @@ import zmq import sys, os - def main(): context = zmq.Context() socket = context.socket(zmq.REQ) @@ -11,9 +10,11 @@ def main(): def send(msg,expected): print "Send : ", msg - print " -> ", socket.send(msg) + socket.send(msg) reply = socket.recv() - print "Reply : ", reply + print "Reply : ", ':'+reply+':' + if (reply != expected): + print "Expected: ", ':'+expected+':' print "" assert (reply == expected) @@ -23,23 +24,59 @@ def main(): send("new_job ao_integrals tcp://130.120.229.139:12345 inproc://ao_integrals", "error A job is already running") - send("connect","error Message not understood : connect") +# send("connect","error Message not understood : connect") send("connect tcp","connect_reply ao_integrals 1 tcp://130.120.229.139:12345") send("connect inproc","connect_reply ao_integrals 2 inproc://ao_integrals") - send("disconnect ao_integrals 3","error Queuing_system.ml:65:2 : disconnect ao_integrals 3") - send("disconnect ao_integrals 2","disconnect_reply ao_integrals 1") + send("disconnect ao_integrals 3","error Queuing_system.ml:68:2 : disconnect ao_integrals 3") + send("disconnect ao_integrals 2","disconnect_reply ao_integrals") send("connect inproc","connect_reply ao_integrals 3 inproc://ao_integrals") - for i in range(10): + send("add_task ao_integrals triangle 3", "ok") + send("add_task ao_integrals range 4 7", "ok") + + for i in range(8,11): send("add_task ao_integrals %d %d"%(i,i+10), "ok") - for i in range(10): - send("get_task ao_integrals 3", "get_task_reply %d %d %d"%(i+1,i,i+10)) - send("task_done ao_integrals 3 %d"%(i+1), "ok") + send("get_task ao_integrals 3", "get_task_reply 10 10 20") + send("get_task ao_integrals 3", "get_task_reply 9 9 19") + send("get_task ao_integrals 3", "get_task_reply 8 8 18") - send("get_task ao_integrals 3", "terminate") + send("task_done ao_integrals 3 10", "ok") + send("task_done ao_integrals 3 9", "ok") + send("task_done ao_integrals 3 8", "ok") + send("del_task ao_integrals 10", "del_task_reply more 10") + send("del_task ao_integrals 9", "del_task_reply more 9") + send("del_task ao_integrals 8", "del_task_reply more 8") + send("del_task ao_integrals 10", "error Task 10 is already deleted : del_task ao_integrals 10") + send("get_task ao_integrals 1", "get_task_reply 7 4") + send("get_task ao_integrals 3", "get_task_reply 6 5") + send("get_task ao_integrals 1", "get_task_reply 5 6") + send("get_task ao_integrals 3", "get_task_reply 4 7") + send("get_task ao_integrals 3", "get_task_reply 3 1 3") + send("get_task ao_integrals 1", "get_task_reply 2 2 3") + send("get_task ao_integrals 1", "get_task_reply 1 3 3") + + send("task_done ao_integrals 1 1", "ok") + send("task_done ao_integrals 1 2", "ok") + send("task_done ao_integrals 3 3", "ok") + send("task_done ao_integrals 3 4", "ok") + send("task_done ao_integrals 1 5", "ok") + send("task_done ao_integrals 1 6", "error Queuing_system.ml:81:30 : task_done ao_integrals 1 6") + send("task_done ao_integrals 3 6", "ok") + send("task_done ao_integrals 1 7", "ok") + + send("del_task ao_integrals 1", "del_task_reply more 1") + send("del_task ao_integrals 2", "del_task_reply more 2") + send("del_task ao_integrals 3", "del_task_reply more 3") + send("del_task ao_integrals 4", "del_task_reply more 4") + send("del_task ao_integrals 5", "del_task_reply more 5") + send("del_task ao_integrals 6", "del_task_reply more 6") + send("del_task ao_integrals 7", "del_task_reply done 7") + + send("end_job ao_integrals","ok") + send("end_job ao_integrals","error No job is running") send("terminate","ok") if __name__ == '__main__': diff --git a/plugins/CASSCF/casscf.irp.f b/plugins/CASSCF/casscf.irp.f index 4e7450dc..864b1855 100644 --- a/plugins/CASSCF/casscf.irp.f +++ b/plugins/CASSCF/casscf.irp.f @@ -119,9 +119,6 @@ program casscf E_CI = sum(CI_energy(1:N_states)+pt2(1:N_states))/dble(N_states) call ezfio_set_casscf_energy(CI_energy(1)) - if (abort_all) then - exit - endif if (N_det == N_det_old) then exit endif diff --git a/plugins/CAS_SD/cas_s.irp.f b/plugins/CAS_SD/cas_s.irp.f index e0c4a663..c64bdcbc 100644 --- a/plugins/CAS_SD/cas_s.irp.f +++ b/plugins/CAS_SD/cas_s.irp.f @@ -54,9 +54,6 @@ program full_ci print *, 'E+PT2 = ', CI_energy+pt2 print *, '-----' call ezfio_set_cas_sd_energy(CI_energy(1)) - if (abort_all) then - exit - endif if (N_det == N_det_old) then exit endif diff --git a/plugins/CAS_SD/cas_s_selected.irp.f b/plugins/CAS_SD/cas_s_selected.irp.f index b1fd542a..802de171 100644 --- a/plugins/CAS_SD/cas_s_selected.irp.f +++ b/plugins/CAS_SD/cas_s_selected.irp.f @@ -51,9 +51,6 @@ program full_ci print *, 'E+PT2 = ', CI_energy+pt2 print *, '-----' call ezfio_set_cas_sd_energy(CI_energy(1)) - if (abort_all) then - exit - endif enddo call diagonalize_CI diff --git a/plugins/CAS_SD/cas_sd.irp.f b/plugins/CAS_SD/cas_sd.irp.f index e82adc36..a5fc39b2 100644 --- a/plugins/CAS_SD/cas_sd.irp.f +++ b/plugins/CAS_SD/cas_sd.irp.f @@ -54,9 +54,6 @@ program full_ci print *, 'E+PT2 = ', CI_energy+pt2 print *, '-----' call ezfio_set_cas_sd_energy(CI_energy(1)) - if (abort_all) then - exit - endif if (N_det == N_det_old) then exit endif diff --git a/plugins/CAS_SD/cas_sd_selected.irp.f b/plugins/CAS_SD/cas_sd_selected.irp.f index 08cfcf41..caed690c 100644 --- a/plugins/CAS_SD/cas_sd_selected.irp.f +++ b/plugins/CAS_SD/cas_sd_selected.irp.f @@ -51,9 +51,6 @@ program full_ci print *, 'E+PT2 = ', CI_energy+pt2 print *, '-----' call ezfio_set_cas_sd_energy(CI_energy(1)) - if (abort_all) then - exit - endif enddo call diagonalize_CI diff --git a/plugins/CID_SC2_selected/cid_sc2_selection.irp.f b/plugins/CID_SC2_selected/cid_sc2_selection.irp.f index d2390229..afdf2bd6 100644 --- a/plugins/CID_SC2_selected/cid_sc2_selection.irp.f +++ b/plugins/CID_SC2_selected/cid_sc2_selection.irp.f @@ -13,7 +13,7 @@ program cisd_sc2_selected pt2 = 1.d0 perturbation = "epstein_nesbet_sc2_projected" E_old(1) = HF_energy - davidson_threshold = 1.d-6 + threshold_davidson = 1.d-6 do while (maxval(abs(pt2(1:N_st))) > 1.d-4) print*,'----' @@ -33,14 +33,11 @@ program cisd_sc2_selected E_old(i) = CI_SC2_energy(i) enddo ! print *, 'E corr = ', (E_old(1)) - HF_energy - if (abort_all) then - exit - endif enddo pt2 = 0.d0 call H_apply_PT2(pt2, norm_pert, H_pert_diag, N_st) - davidson_threshold = 1.d-10 - touch davidson_threshold davidson_criterion + threshold_davidson = 1.d-10 + touch threshold_davidson davidson_criterion do i = 1, N_st max = 0.d0 diff --git a/plugins/CID_selected/cid_selection.irp.f b/plugins/CID_selected/cid_selected.irp.f similarity index 95% rename from plugins/CID_selected/cid_selection.irp.f rename to plugins/CID_selected/cid_selected.irp.f index f63a2d84..894ce71e 100644 --- a/plugins/CID_selected/cid_selection.irp.f +++ b/plugins/CID_selected/cid_selected.irp.f @@ -26,9 +26,6 @@ program cisd ! print *, 'E+PT2_new= ', (E_old(1)+1.d0*pt2(1)+H_pert_diag(1))/(1.d0 +norm_pert(1)) enddo E_old = CI_energy - if (abort_all) then - exit - endif enddo deallocate(pt2,norm_pert,H_pert_diag) end diff --git a/plugins/CIS/super_ci.irp.f b/plugins/CIS/super_ci.irp.f index a19a0368..630b9599 100644 --- a/plugins/CIS/super_ci.irp.f +++ b/plugins/CIS/super_ci.irp.f @@ -13,11 +13,11 @@ subroutine super_CI character :: save_char call write_time(output_hartree_fock) - write(output_hartree_fock,'(A4,X,A16, X, A16, X, A16 )'), & + write(output_hartree_fock,'(A4,X,A16, X, A16, X, A16 )') & '====','================','================','================' - write(output_hartree_fock,'(A4,X,A16, X, A16, X, A16 )'), & + write(output_hartree_fock,'(A4,X,A16, X, A16, X, A16 )') & ' N ', 'Energy ', 'Energy diff ', 'Save ' - write(output_hartree_fock,'(A4,X,A16, X, A16, X, A16 )'), & + write(output_hartree_fock,'(A4,X,A16, X, A16, X, A16 )') & '====','================','================','================' E = HF_energy + 1.d0 @@ -39,7 +39,7 @@ subroutine super_CI save_char = ' ' endif E_min = min(E,E_min) - write(output_hartree_fock,'(I4,X,F16.10, X, F16.10, X, A8 )'),& + write(output_hartree_fock,'(I4,X,F16.10, X, F16.10, X, A8 )') & k, E, delta_E, save_char if ( (delta_E < 0.d0).and.(dabs(delta_E) < thresh_scf) ) then exit @@ -55,7 +55,7 @@ subroutine super_CI TOUCH mo_coef enddo - write(output_hartree_fock,'(A4,X,A16, X, A16, X, A16 )'), & + write(output_hartree_fock,'(A4,X,A16, X, A16, X, A16 )') & '====','================','================','================' call write_time(output_hartree_fock) end diff --git a/plugins/CISD_SC2_selected/cisd_sc2_selection.irp.f b/plugins/CISD_SC2_selected/cisd_sc2_selection.irp.f index 3da36f80..1232835a 100644 --- a/plugins/CISD_SC2_selected/cisd_sc2_selection.irp.f +++ b/plugins/CISD_SC2_selected/cisd_sc2_selection.irp.f @@ -14,7 +14,7 @@ program cisd_sc2_selected perturbation = "epstein_nesbet_sc2_projected" E_old(1) = HF_energy - davidson_threshold = 1.d-10 + threshold_davidson = 1.d-10 if (N_det > N_det_max) then call diagonalize_CI_SC2 call save_wavefunction @@ -59,9 +59,6 @@ program cisd_sc2_selected else i_count = 0 endif - if (abort_all) then - exit - endif ! =~=~=~=~=~=~=~=~=~=~=~=~=~! ! W r i t e _ o n _ d i s k ! @@ -71,8 +68,8 @@ program cisd_sc2_selected enddo N_det = min(N_det_max,N_det) - davidson_threshold = 1.d-10 - touch N_det psi_det psi_coef davidson_threshold davidson_criterion + threshold_davidson = 1.d-10 + touch N_det psi_det psi_coef threshold_davidson davidson_criterion call diagonalize_CI_SC2 pt2 = 0.d0 diff --git a/plugins/CISD_selected/cisd_selected.irp.f b/plugins/CISD_selected/cisd_selected.irp.f index c016d28b..11f77d09 100644 --- a/plugins/CISD_selected/cisd_selected.irp.f +++ b/plugins/CISD_selected/cisd_selected.irp.f @@ -34,9 +34,6 @@ program cisd enddo E_old = CI_energy call save_wavefunction - if (abort_all) then - exit - endif enddo N_det = min(N_det,N_det_max) touch N_det psi_det psi_coef diff --git a/plugins/DDCI_selected/ddci.irp.f b/plugins/DDCI_selected/ddci.irp.f index 3fcb443b..248671b1 100644 --- a/plugins/DDCI_selected/ddci.irp.f +++ b/plugins/DDCI_selected/ddci.irp.f @@ -50,9 +50,6 @@ program ddci print *, 'E+PT2 = ', CI_energy+pt2 print *, '-----' call ezfio_set_ddci_selected_energy(CI_energy) - if (abort_all) then - exit - endif enddo if(do_pt2_end)then call H_apply_DDCI_pt2(pt2, norm_pert, H_pert_diag, N_st) diff --git a/plugins/FOBOCI/H_apply_dressed_autonom.irp.f b/plugins/FOBOCI/H_apply_dressed_autonom.irp.f index c5b0aa5c..657ea22e 100644 --- a/plugins/FOBOCI/H_apply_dressed_autonom.irp.f +++ b/plugins/FOBOCI/H_apply_dressed_autonom.irp.f @@ -117,14 +117,8 @@ subroutine H_apply_dressed_pert_diexc(key_in, hole_1,particl_1, hole_2, particl_ accu = 0.d0 do ispin=1,2 other_spin = iand(ispin,1)+1 - if (abort_here) then - exit - endif ! !$OMP DO SCHEDULE (static) do ii=1,ia_ja_pairs(1,0,ispin) - if (abort_here) then - cycle - endif i_a = ia_ja_pairs(1,ii,ispin) ASSERT (i_a > 0) ASSERT (i_a <= mo_tot_num) @@ -202,9 +196,6 @@ subroutine H_apply_dressed_pert_diexc(key_in, hole_1,particl_1, hole_2, particl_ call standard_dress(delta_ij_generators_,size_max,Ndet_generators,i_generator,key_idx,keys_out,N_int,iproc,psi_det_generators_input,E_ref) key_idx = 0 endif - if (abort_here) then - exit - endif enddo endif @@ -253,9 +244,6 @@ subroutine H_apply_dressed_pert_diexc(key_in, hole_1,particl_1, hole_2, particl_ call standard_dress(delta_ij_generators_,size_max,Ndet_generators,i_generator,key_idx,keys_out,N_int,iproc,psi_det_generators_input,E_ref) key_idx = 0 endif - if (abort_here) then - exit - endif enddo ! kk enddo ! ii @@ -467,22 +455,12 @@ subroutine H_apply_dressed_pert(delta_ij_generators_, Ndet_generators,psi_det_g ! !$ call omp_init_lock(lck) - call start_progress(Ndet_generators,'Selection (norm)',0.d0) - call wall_time(wall_0) iproc = 0 allocate( mask(N_int,2,6) ) do i_generator=1,nmax - progress_bar(1) = i_generator - - if (abort_here) then - exit - endif - - - ! ! Create bit masks for holes and particles do ispin=1,2 do k=1,N_int @@ -535,14 +513,6 @@ subroutine H_apply_dressed_pert(delta_ij_generators_, Ndet_generators,psi_det_g allocate( mask(N_int,2,6) ) ! !$OMP DO SCHEDULE(dynamic,1) do i_generator=nmax+1,Ndet_generators - if (iproc == 0) then - progress_bar(1) = i_generator - endif - if (abort_here) then - cycle - endif - - ! Create bit masks for holes and particles do ispin=1,2 @@ -594,11 +564,6 @@ subroutine H_apply_dressed_pert(delta_ij_generators_, Ndet_generators,psi_det_g ! !$OMP END PARALLEL ! !$ call omp_destroy_lock(lck) - abort_here = abort_all - call stop_progress - - - end diff --git a/plugins/Full_CI/H_apply.irp.f b/plugins/Full_CI/H_apply.irp.f index a755ad4a..1eb2d45a 100644 --- a/plugins/Full_CI/H_apply.irp.f +++ b/plugins/Full_CI/H_apply.irp.f @@ -2,41 +2,49 @@ use bitmasks BEGIN_SHELL [ /usr/bin/env python ] from generate_h_apply import * -s = H_apply("FCI") +s = H_apply_zmq("FCI") s.set_selection_pt2("epstein_nesbet_2x2") +s.unset_openmp() print s -s = H_apply("FCI_PT2") +s = H_apply_zmq("FCI_PT2") s.set_perturbation("epstein_nesbet_2x2") +s.unset_openmp() print s -s = H_apply("FCI_no_skip") +s = H_apply_zmq("FCI_no_skip") s.set_selection_pt2("epstein_nesbet_2x2") s.unset_skip() +s.unset_openmp() print s s = H_apply("FCI_mono") s.set_selection_pt2("epstein_nesbet_2x2") s.unset_double_excitations() +s.unset_openmp() print s s = H_apply("select_mono_delta_rho") s.unset_double_excitations() s.set_selection_pt2("delta_rho_one_point") +s.unset_openmp() print s s = H_apply("pt2_mono_delta_rho") s.unset_double_excitations() s.set_perturbation("delta_rho_one_point") +s.unset_openmp() print s s = H_apply("select_mono_di_delta_rho") s.set_selection_pt2("delta_rho_one_point") +s.unset_openmp() print s s = H_apply("pt2_mono_di_delta_rho") s.set_perturbation("delta_rho_one_point") +s.unset_openmp() print s diff --git a/plugins/Full_CI/full_ci.irp.f b/plugins/Full_CI/full_ci.irp.f index 33966743..e6d0f7f2 100644 --- a/plugins/Full_CI/full_ci.irp.f +++ b/plugins/Full_CI/full_ci.irp.f @@ -84,9 +84,6 @@ program full_ci endif E_CI_before = CI_energy call ezfio_set_full_ci_energy(CI_energy) - if (abort_all) then - exit - endif enddo N_det = min(N_det_max,N_det) touch N_det psi_det psi_coef diff --git a/plugins/Full_CI/full_ci_no_skip.irp.f b/plugins/Full_CI/full_ci_no_skip.irp.f index c9b8d1a0..82cc9b79 100644 --- a/plugins/Full_CI/full_ci_no_skip.irp.f +++ b/plugins/Full_CI/full_ci_no_skip.irp.f @@ -67,9 +67,6 @@ program full_ci print *, '-----' E_CI_before = CI_energy call ezfio_set_full_ci_energy(CI_energy) - if (abort_all) then - exit - endif enddo N_det = min(N_det_max,N_det) touch N_det psi_det psi_coef diff --git a/plugins/Full_CI/micro_pt2.irp.f b/plugins/Full_CI/micro_pt2.irp.f new file mode 100644 index 00000000..d78a942d --- /dev/null +++ b/plugins/Full_CI/micro_pt2.irp.f @@ -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 diff --git a/plugins/Full_CI/target_pt2.irp.f b/plugins/Full_CI/target_pt2.irp.f index 7e7c8fcf..538afcb9 100644 --- a/plugins/Full_CI/target_pt2.irp.f +++ b/plugins/Full_CI/target_pt2.irp.f @@ -73,9 +73,6 @@ program var_pt2_ratio_run print *, 'N_det = ', N_det print *, 'E = ', CI_energy(1) call ezfio_set_full_ci_energy(CI_energy) - if (abort_all) then - exit - endif enddo deallocate(pt2,norm_pert) end diff --git a/plugins/Full_CI/var_pt2_ratio.irp.f b/plugins/Full_CI/var_pt2_ratio.irp.f index 20395fa9..3d942a30 100644 --- a/plugins/Full_CI/var_pt2_ratio.irp.f +++ b/plugins/Full_CI/var_pt2_ratio.irp.f @@ -63,9 +63,6 @@ program var_pt2_ratio_run print *, 'N_det = ', N_det print *, 'E = ', CI_energy(1) call ezfio_set_full_ci_energy(CI_energy) - if (abort_all) then - exit - endif enddo deallocate(pt2,norm_pert) end diff --git a/plugins/Hartree_Fock/damping_SCF.irp.f b/plugins/Hartree_Fock/damping_SCF.irp.f index d77c91c5..6a532b25 100644 --- a/plugins/Hartree_Fock/damping_SCF.irp.f +++ b/plugins/Hartree_Fock/damping_SCF.irp.f @@ -30,11 +30,11 @@ subroutine damping_SCF call write_time(output_hartree_fock) - write(output_hartree_fock,'(A4,X,A16, X, A16, X, A16, X, A4 )'), & + write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') & '====','================','================','================', '====' - write(output_hartree_fock,'(A4,X,A16, X, A16, X, A16, X, A4 )'), & + write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') & ' N ', 'Energy ', 'Energy diff ', 'Density diff ', 'Save' - write(output_hartree_fock,'(A4,X,A16, X, A16, X, A16, X, A4 )'), & + write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') & '====','================','================','================', '====' E = HF_energy + 1.d0 @@ -58,7 +58,7 @@ subroutine damping_SCF save_char = ' ' endif - write(output_hartree_fock,'(I4,X,F16.10, X, F16.10, X, F16.10, 3X, A )'), & + write(output_hartree_fock,'(I4,1X,F16.10, 1X, F16.10, 1X, F16.10, 3X, A )') & k, E, delta_E, delta_D, save_char D_alpha = HF_density_matrix_ao_alpha @@ -116,7 +116,7 @@ subroutine damping_SCF enddo - write(output_hartree_fock,'(A4,X,A16, X, A16, X, A16, X, A4 )'), '====','================','================','================', '====' + write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') '====','================','================','================', '====' write(output_hartree_fock,*) call mo_as_eigvectors_of_mo_matrix(Fock_matrix_mo,size(Fock_matrix_mo,1),size(Fock_matrix_mo,2),mo_label,1) diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index 6752afcb..d278ba13 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -359,7 +359,6 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nin y, & lambda & ) - abort_here = abort_all end diff --git a/plugins/Perturbation/perturbation.template.f b/plugins/Perturbation/perturbation.template.f index d4e46396..94b6b8b0 100644 --- a/plugins/Perturbation/perturbation.template.f +++ b/plugins/Perturbation/perturbation.template.f @@ -3,7 +3,6 @@ import perturbation END_SHELL - subroutine perturb_buffer_$PERT(i_generator,buffer,buffer_size,e_2_pert_buffer,coef_pert_buffer,sum_e_2_pert,sum_norm_pert,sum_H_pert_diag,N_st,Nint,key_mask,fock_diag_tmp) implicit none BEGIN_DOC @@ -18,7 +17,7 @@ subroutine perturb_buffer_$PERT(i_generator,buffer,buffer_size,e_2_pert_buffer,c double precision, intent(inout) :: sum_norm_pert(N_st),sum_e_2_pert(N_st) double precision, intent(inout) :: coef_pert_buffer(N_st,buffer_size),e_2_pert_buffer(N_st,buffer_size),sum_H_pert_diag(N_st) double precision :: c_pert(N_st), e_2_pert(N_st), H_pert_diag(N_st) - integer :: i,k, c_ref, ni, ex + integer :: i,k,l, c_ref, ni, ex integer, external :: connected_to_ref logical, external :: is_in_wavefunction @@ -59,6 +58,7 @@ subroutine perturb_buffer_$PERT(i_generator,buffer,buffer_size,e_2_pert_buffer,c deallocate( minilist, minilist_gen, idx_minilist ) return end if + call create_minilist(key_mask, psi_selectors, minilist, idx_miniList, N_det_selectors, N_minilist, Nint) allocate( microlist(Nint,2,N_minilist*4), & idx_microlist(N_minilist*4), & @@ -80,15 +80,25 @@ subroutine perturb_buffer_$PERT(i_generator,buffer,buffer_size,e_2_pert_buffer,c do i=0,mo_tot_num*2 - do k=ptr_microlist(i),ptr_microlist(i+1)-1 - idx_microlist(k) = idx_minilist(idx_microlist(k)) - end do + do k=ptr_microlist(i),ptr_microlist(i+1)-1 + idx_microlist(k) = idx_minilist(idx_microlist(k)) + end do end do if(N_microlist(0) > 0) then - microlist_zero(:,:,1:N_microlist(0)) = microlist(:,:,1:N_microlist(0)) - idx_microlist_zero(1:N_microlist(0)) = idx_microlist(1:N_microlist(0)) +! TODO OLD +! microlist_zero(:,:,1:N_microlist(0)) = microlist(:,:,1:N_microlist(0)) +! idx_microlist_zero(1:N_microlist(0)) = idx_microlist(1:N_microlist(0)) +! TODO OLD + ASSERT (N_microlist(0) <= N_minilist) + do l=1,N_microlist(0) + do k=1,Nint + microlist_zero(k,1,l) = microlist(k,1,l) + microlist_zero(k,2,l) = microlist(k,2,l) + enddo + idx_microlist_zero(l) = idx_microlist(l) + enddo end if end if @@ -100,7 +110,7 @@ subroutine perturb_buffer_$PERT(i_generator,buffer,buffer_size,e_2_pert_buffer,c endif if(key_mask(1,1) /= 0) then - call getMobiles(buffer(:,:,i), key_mask, mobiles, Nint) + call getMobiles(buffer(1,1,i), key_mask, mobiles, Nint) if(N_microlist(mobiles(1)) < N_microlist(mobiles(2))) then smallerlist = mobiles(1) else @@ -108,24 +118,44 @@ subroutine perturb_buffer_$PERT(i_generator,buffer,buffer_size,e_2_pert_buffer,c end if if(N_microlist_gen(smallerlist) > 0) then - if(is_connected_to(buffer(1,1,i), microlist_gen(:,:,ptr_microlist_gen(smallerlist):ptr_microlist_gen(smallerlist+1)-1), Nint, N_microlist_gen(smallerlist))) then +! TODO OLD +! if(is_connected_to(buffer(1,1,i), microlist_gen(:,:,ptr_microlist_gen(smallerlist):ptr_microlist_gen(smallerlist+1)-1), Nint, N_microlist_gen(smallerlist))) then +! TODO OLD + ASSERT (ptr_microlist_gen(smallerlist) <= N_minilist_gen*4) + if(is_connected_to(buffer(1,1,i), microlist_gen(1,1,ptr_microlist_gen(smallerlist)), Nint, N_microlist_gen(smallerlist))) then cycle end if end if if(N_microlist_gen(0) > 0) then - if(is_connected_to(buffer(1,1,i), microlist_gen(:,:,1:ptr_microlist_gen(1)-1), Nint, N_microlist_gen(0))) then +! TODO OLD +! if(is_connected_to(buffer(1,1,i), microlist_gen(:,:,1:ptr_microlist_gen(1)-1), Nint, N_microlist_gen(0))) then +! TODO OLD + ASSERT ( N_microlist_gen(0) <= buffer_size) + if(is_connected_to(buffer(1,1,i), microlist_gen(1,1,1), Nint, N_microlist_gen(0))) then cycle end if end if if(N_microlist(smallerlist) > 0) then - microlist_zero(:,:,ptr_microlist(1):ptr_microlist(1)+N_microlist(smallerlist)-1) = microlist(:,:,ptr_microlist(smallerlist):ptr_microlist(smallerlist+1)-1) - idx_microlist_zero(ptr_microlist(1):ptr_microlist(1)+N_microlist(smallerlist)-1) = idx_microlist(ptr_microlist(smallerlist):ptr_microlist(smallerlist+1)-1) -! call merdge(microlist(:,:,:,smallerlist), idx_microlist(:,smallerlist), N_microlist(smallerlist), microlist(:,:,:,0), idx_microlist(:,0), N_microlist(0)) +! TODO OLD +! microlist_zero(:,:,ptr_microlist(1):ptr_microlist(1)+N_microlist(smallerlist)-1) = microlist(:,:,ptr_microlist(smallerlist):ptr_microlist(smallerlist+1)-1) +! idx_microlist_zero(ptr_microlist(1):ptr_microlist(1)+N_microlist(smallerlist)-1) = idx_microlist(ptr_microlist(smallerlist):ptr_microlist(smallerlist+1)-1) +! TODO OLD + ASSERT ( ptr_microlist(1)+N_microlist(smallerlist)-1 <= N_minilist ) + ASSERT ( ptr_microlist(smallerlist)+N_microlist(smallerlist)-1 <= N_minilist*4 ) + do l=0, N_microlist(smallerlist)-1 + do k=1,Nint + microlist_zero(k,1,ptr_microlist(1)+l) = microlist(k,1,ptr_microlist(smallerlist)+l) + microlist_zero(k,2,ptr_microlist(1)+l) = microlist(k,2,ptr_microlist(smallerlist)+l) + enddo + idx_microlist_zero(ptr_microlist(1)+l) = idx_microlist(ptr_microlist(smallerlist)+l) + enddo end if - call pt2_$PERT(psi_det_generators(1,1,i_generator),buffer(1,1,i), fock_diag_tmp, & - c_pert,e_2_pert,H_pert_diag,Nint,N_microlist(smallerlist)+N_microlist(0),n_st,microlist_zero(:,:,:),idx_microlist_zero(:),N_microlist(smallerlist)+N_microlist(0)) + call pt2_$PERT(psi_det_generators(1,1,i_generator),buffer(1,1,i), fock_diag_tmp, & + c_pert,e_2_pert,H_pert_diag,Nint,N_microlist(smallerlist)+N_microlist(0), & + n_st,microlist_zero,idx_microlist_zero,N_microlist(smallerlist)+N_microlist(0)) else + ASSERT (N_minilist_gen <= N_det_generators) if(is_connected_to(buffer(1,1,i), miniList_gen, Nint, N_minilist_gen)) then cycle end if @@ -146,9 +176,9 @@ subroutine perturb_buffer_$PERT(i_generator,buffer,buffer_size,e_2_pert_buffer,c enddo enddo - deallocate( minilist, minilist_gen, idx_minilist ) - deallocate( microlist, idx_microlist, N_microlist,ptr_microlist ) - deallocate( microlist_gen, idx_microlist_gen,N_microlist_gen,ptr_microlist_gen ) + deallocate( minilist, minilist_gen, idx_minilist, & + microlist, idx_microlist, N_microlist,ptr_microlist, & + microlist_gen, idx_microlist_gen,N_microlist_gen,ptr_microlist_gen ) end diff --git a/plugins/Selectors_full/zmq.irp.f b/plugins/Selectors_full/zmq.irp.f new file mode 100644 index 00000000..952e5c06 --- /dev/null +++ b/plugins/Selectors_full/zmq.irp.f @@ -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 + + diff --git a/scripts/ezfio_interface/ei_handler.py b/scripts/ezfio_interface/ei_handler.py index 2a250268..a3f3600b 100755 --- a/scripts/ezfio_interface/ei_handler.py +++ b/scripts/ezfio_interface/ei_handler.py @@ -126,6 +126,7 @@ def get_type_dict(): fancy_type['integer*8'] = Type(None, "int", "integer*8") fancy_type['int'] = Type(None, "int", "integer") + fancy_type['int64'] = Type(None, "int64", "integer*8") fancy_type['float'] = Type(None, "float", "double precision") fancy_type['double precision'] = Type(None, "float", "double precision") @@ -143,6 +144,7 @@ def get_type_dict(): # Dict to change ocaml LowLevel type into FortranLowLevel type ocaml_to_fortran = {"int": "integer", + "int64": "integer*8", "float": "double precision", "logical": "logical", "string": "character*32"} diff --git a/scripts/generate_h_apply.py b/scripts/generate_h_apply.py index ca2be5d6..c6466569 100755 --- a/scripts/generate_h_apply.py +++ b/scripts/generate_h_apply.py @@ -1,46 +1,59 @@ #!/usr/bin/env python import os -file = open(os.environ["QP_ROOT"]+'/src/Determinants/H_apply.template.f','r') -template = file.read() -file.close() keywords = """ -subroutine -parameters -params_main -initialization +check_double_excitation +copy_buffer declarations decls_main -keys_work -copy_buffer -finalization -generate_psi_guess -init_thread -printout_now -printout_always deinit_thread -skip -init_main -filter_integrals -filter2p -filter2h2p +do_double_excitations filter1h filter1p -only_2p_single -only_2p_double -filter_only_1h1p_single -filter_only_1h1p_double +filter2h2p +filter2p filterhole +filter_integrals +filter_only_1h1p_double +filter_only_1h1p_single filterparticle -do_double_excitations -check_double_excitation filter_vvvv_excitation +finalization +generate_psi_guess +initialization +init_main +init_thread +keys_work +omp_barrier +omp_do +omp_enddo +omp_end_master +omp_end_parallel +omp_master +omp_parallel +only_2p_double +only_2p_single +parameters +params_main +printout_always +printout_now +skip +subroutine """.split() class H_apply(object): + def read_template(self): + file = open(os.environ["QP_ROOT"]+'/src/Determinants/H_apply.template.f','r') + self.template = file.read() + file.close() + file = open(os.environ["QP_ROOT"]+'/src/Determinants/H_apply_nozmq.template.f','r') + self.template += file.read() + file.close() + def __init__(self,sub,SingleRef=False,do_mono_exc=True, do_double_exc=True): + self.read_template() s = {} for k in keywords: s[k] = "" @@ -124,7 +137,7 @@ class H_apply(object): return self.data[key] def __repr__(self): - buffer = template + buffer = self.template for key,value in self.data.items(): buffer = buffer.replace('$'+key, value) return buffer @@ -176,11 +189,11 @@ class H_apply(object): def filter_only_2p(self): self["only_2p_single"] = """ ! ! DIR$ FORCEINLINE - if (is_a_2p(hole).eq..False.) cycle + if (.not. is_a_2p(hole)) cycle """ self["only_2p_double"] = """ ! ! DIR$ FORCEINLINE - if (is_a_2p(key).eq..False.) cycle + if (.not. is_a_2p(key)) cycle """ @@ -248,20 +261,16 @@ class H_apply(object): PROVIDE psi_selectors_coef psi_selectors E_corr_per_selectors psi_det_sorted_bit """ if self.do_double_exc == True: - self.data["keys_work"] = """ -! if(check_double_excitation)then - call perturb_buffer_%s(i_generator,keys_out,key_idx,e_2_pert_buffer,coef_pert_buffer,sum_e_2_pert, & - sum_norm_pert,sum_H_pert_diag,N_st,N_int,key_mask,fock_diag_tmp) -! else -! call perturb_buffer_by_mono_%s(i_generator,keys_out,key_idx,e_2_pert_buffer,coef_pert_buffer,sum_e_2_pert, & -! sum_norm_pert,sum_H_pert_diag,N_st,N_int,key_mask,fock_diag_tmp) -! endif - """%(pert,pert) + self.data["keys_work"] = """ +! if(check_double_excitation)then + call perturb_buffer_%s(i_generator,keys_out,key_idx,e_2_pert_buffer,coef_pert_buffer,sum_e_2_pert, & + sum_norm_pert,sum_H_pert_diag,N_st,N_int,key_mask,fock_diag_tmp) + """%(pert) else: - self.data["keys_work"] = """ - call perturb_buffer_by_mono_%s(i_generator,keys_out,key_idx,e_2_pert_buffer,coef_pert_buffer,sum_e_2_pert, & - sum_norm_pert,sum_H_pert_diag,N_st,N_int,key_mask,fock_diag_tmp) - """%(pert) + self.data["keys_work"] = """ + call perturb_buffer_by_mono_%s(i_generator,keys_out,key_idx,e_2_pert_buffer,coef_pert_buffer,sum_e_2_pert, & + sum_norm_pert,sum_H_pert_diag,N_st,N_int,key_mask,fock_diag_tmp) + """%(pert) self.data["finalization"] = """ @@ -285,9 +294,9 @@ class H_apply(object): delta_pt2(k) = 0.d0 pt2_old(k) = 0.d0 enddo - write(output_determinants,'(A12, X, A8, 3(2X, A9), 2X, A8, 2X, A8, 2X, A8)') & + write(output_determinants,'(A12, 1X, A8, 3(2X, A9), 2X, A8, 2X, A8, 2X, A8)') & 'N_generators', 'Norm', 'Delta PT2', 'PT2', 'Est. PT2', 'secs' - write(output_determinants,'(A12, X, A8, 3(2X, A9), 2X, A8, 2X, A8, 2X, A8)') & + write(output_determinants,'(A12, 1X, A8, 3(2X, A9), 2X, A8, 2X, A8, 2X, A8)') & '============', '========', '=========', '=========', '=========', & '=========' """ @@ -306,7 +315,6 @@ class H_apply(object): wall_1-wall_0 pt2_old(k) = pt2(k) enddo - progress_value = norm_psi(1) """ self.data["omp_parallel"] += """& !$OMP SHARED(N_st) PRIVATE(e_2_pert_buffer,coef_pert_buffer) & @@ -350,9 +358,7 @@ class H_apply(object): !$ call omp_set_lock(lck) do k=1,N_st norm_psi(k) = norm_psi(k) + psi_coef_generators(i_generator,k)*psi_coef_generators(i_generator,k) -! delta_pt2(k) = 0.d0 - pt2_old(k) = 0.d0 -! pt2(k) = select_max(i_generator) + pt2_old(k) = 0.d0 enddo !$ call omp_unset_lock(lck) cycle @@ -362,3 +368,50 @@ class H_apply(object): """ + def unset_openmp(self): + for k in keywords: + if k.startswith("omp_"): + self[k] = "" + + +class H_apply_zmq(H_apply): + + def read_template(self): + file = open(os.environ["QP_ROOT"]+'/src/Determinants/H_apply.template.f','r') + self.template = file.read() + file.close() + file = open(os.environ["QP_ROOT"]+'/src/Determinants/H_apply_zmq.template.f','r') + self.template += file.read() + file.close() + + def set_perturbation(self,pert): + H_apply.set_perturbation(self,pert) + self.data["printout_now"] = "" + self.data["printout_always"] = "" + self.data["decls_main"] = """ integer, intent(in) :: N_st + double precision, intent(inout):: pt2(N_st) + double precision, intent(inout):: norm_pert(N_st) + double precision, intent(inout):: H_pert_diag(N_st) + double precision :: delta_pt2(N_st), norm_psi(N_st), pt2_old(N_st) + PROVIDE N_det_generators + do k=1,N_st + pt2(k) = 0.d0 + norm_pert(k) = 0.d0 + H_pert_diag(k) = 0.d0 + norm_psi(k) = 0.d0 + enddo + """ + + def set_selection_pt2(self,pert): + H_apply.set_selection_pt2(self,pert) + self.data["skip"] = """ + if (i_generator < size_select_max) then + if (select_max(i_generator) < selection_criterion_min*selection_criterion_factor) then + do k=1,N_st + pt2(k) = select_max(i_generator) + enddo + cycle + endif + select_max(i_generator) = 0.d0 + endif + """ diff --git a/src/Bitmask/bitmasks.irp.f b/src/Bitmask/bitmasks.irp.f index d6d8fcb0..6fe36c57 100644 --- a/src/Bitmask/bitmasks.irp.f +++ b/src/Bitmask/bitmasks.irp.f @@ -9,7 +9,7 @@ BEGIN_PROVIDER [ integer, N_int ] END_PROVIDER -BEGIN_PROVIDER [ integer(bit_kind), full_ijkl_bitmask, (N_int,4) ] +BEGIN_PROVIDER [ integer(bit_kind), full_ijkl_bitmask, (N_int) ] implicit none BEGIN_DOC ! Bitmask to include all possible MOs @@ -18,29 +18,26 @@ BEGIN_PROVIDER [ integer(bit_kind), full_ijkl_bitmask, (N_int,4) ] integer :: i,j,n n = mod(mo_tot_num-1,bit_kind_size)+1 full_ijkl_bitmask = 0_bit_kind - do j=1,4 - do i=1,N_int-1 - full_ijkl_bitmask(i,j) = not(0_bit_kind) - enddo - do i=1,n - full_ijkl_bitmask(N_int,j) = ibset(full_ijkl_bitmask(N_int,j),i-1) - enddo + do i=1,N_int-1 + full_ijkl_bitmask(i) = not(0_bit_kind) + enddo + do i=1,n + full_ijkl_bitmask(N_int) = ibset(full_ijkl_bitmask(N_int),i-1) + enddo +END_PROVIDER + +BEGIN_PROVIDER [ integer(bit_kind), full_ijkl_bitmask_4, (N_int,4) ] + implicit none + integer :: i + do i=1,N_int + full_ijkl_bitmask_4(i,1) = full_ijkl_bitmask(i) + full_ijkl_bitmask_4(i,2) = full_ijkl_bitmask(i) + full_ijkl_bitmask_4(i,3) = full_ijkl_bitmask(i) + full_ijkl_bitmask_4(i,4) = full_ijkl_bitmask(i) enddo END_PROVIDER -BEGIN_PROVIDER [ integer(bit_kind), cis_ijkl_bitmask, (N_int,4) ] - implicit none - BEGIN_DOC - ! Bitmask to include all possible single excitations from Hartree-Fock - END_DOC - - integer :: i,j,n - cis_ijkl_bitmask = full_ijkl_bitmask - cis_ijkl_bitmask(:,1) = HF_bitmask(:,1) -END_PROVIDER - - BEGIN_PROVIDER [ integer(bit_kind), HF_bitmask, (N_int,2)] implicit none BEGIN_DOC @@ -131,12 +128,14 @@ BEGIN_PROVIDER [ integer(bit_kind), generators_bitmask_restart, (N_int,2,6,N_gen integer :: k, ispin do k=1,N_generators_bitmask do ispin=1,2 - generators_bitmask_restart(:,ispin,s_hole ,k) = full_ijkl_bitmask(:,d_hole1) - generators_bitmask_restart(:,ispin,s_part ,k) = full_ijkl_bitmask(:,d_part1) - generators_bitmask_restart(:,ispin,d_hole1,k) = full_ijkl_bitmask(:,d_hole1) - generators_bitmask_restart(:,ispin,d_part1,k) = full_ijkl_bitmask(:,d_part1) - generators_bitmask_restart(:,ispin,d_hole2,k) = full_ijkl_bitmask(:,d_hole2) - generators_bitmask_restart(:,ispin,d_part2,k) = full_ijkl_bitmask(:,d_part2) + do i=1,N_int + generators_bitmask_restart(i,ispin,s_hole ,k) = full_ijkl_bitmask(i) + generators_bitmask_restart(i,ispin,s_part ,k) = full_ijkl_bitmask(i) + generators_bitmask_restart(i,ispin,d_hole1,k) = full_ijkl_bitmask(i) + generators_bitmask_restart(i,ispin,d_part1,k) = full_ijkl_bitmask(i) + generators_bitmask_restart(i,ispin,d_hole2,k) = full_ijkl_bitmask(i) + generators_bitmask_restart(i,ispin,d_part2,k) = full_ijkl_bitmask(i) + enddo enddo enddo endif @@ -145,12 +144,12 @@ BEGIN_PROVIDER [ integer(bit_kind), generators_bitmask_restart, (N_int,2,6,N_gen do k=1,N_generators_bitmask do ispin=1,2 do i=1,N_int - generators_bitmask_restart(i,ispin,s_hole ,k) = iand(full_ijkl_bitmask(i,d_hole1),generators_bitmask_restart(i,ispin,s_hole,k) ) - generators_bitmask_restart(i,ispin,s_part ,k) = iand(full_ijkl_bitmask(i,d_part1),generators_bitmask_restart(i,ispin,s_part,k) ) - generators_bitmask_restart(i,ispin,d_hole1,k) = iand(full_ijkl_bitmask(i,d_hole1),generators_bitmask_restart(i,ispin,d_hole1,k) ) - generators_bitmask_restart(i,ispin,d_part1,k) = iand(full_ijkl_bitmask(i,d_part1),generators_bitmask_restart(i,ispin,d_part1,k) ) - generators_bitmask_restart(i,ispin,d_hole2,k) = iand(full_ijkl_bitmask(i,d_hole2),generators_bitmask_restart(i,ispin,d_hole2,k) ) - generators_bitmask_restart(i,ispin,d_part2,k) = iand(full_ijkl_bitmask(i,d_part2),generators_bitmask_restart(i,ispin,d_part2,k) ) + generators_bitmask_restart(i,ispin,s_hole ,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,s_hole,k) ) + generators_bitmask_restart(i,ispin,s_part ,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,s_part,k) ) + generators_bitmask_restart(i,ispin,d_hole1,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,d_hole1,k) ) + generators_bitmask_restart(i,ispin,d_part1,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,d_part1,k) ) + generators_bitmask_restart(i,ispin,d_hole2,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,d_hole2,k) ) + generators_bitmask_restart(i,ispin,d_part2,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,d_part2,k) ) enddo enddo enddo @@ -188,12 +187,14 @@ BEGIN_PROVIDER [ integer(bit_kind), generators_bitmask, (N_int,2,6,N_generators_ integer :: k, ispin, i do k=1,N_generators_bitmask do ispin=1,2 - generators_bitmask(:,ispin,s_hole ,k) = full_ijkl_bitmask(:,d_hole1) - generators_bitmask(:,ispin,s_part ,k) = full_ijkl_bitmask(:,d_part1) - generators_bitmask(:,ispin,d_hole1,k) = full_ijkl_bitmask(:,d_hole1) - generators_bitmask(:,ispin,d_part1,k) = full_ijkl_bitmask(:,d_part1) - generators_bitmask(:,ispin,d_hole2,k) = full_ijkl_bitmask(:,d_hole2) - generators_bitmask(:,ispin,d_part2,k) = full_ijkl_bitmask(:,d_part2) + do i=1,N_int + generators_bitmask(i,ispin,s_hole ,k) = full_ijkl_bitmask(i) + generators_bitmask(i,ispin,s_part ,k) = full_ijkl_bitmask(i) + generators_bitmask(i,ispin,d_hole1,k) = full_ijkl_bitmask(i) + generators_bitmask(i,ispin,d_part1,k) = full_ijkl_bitmask(i) + generators_bitmask(i,ispin,d_hole2,k) = full_ijkl_bitmask(i) + generators_bitmask(i,ispin,d_part2,k) = full_ijkl_bitmask(i) + enddo enddo enddo endif @@ -201,12 +202,12 @@ BEGIN_PROVIDER [ integer(bit_kind), generators_bitmask, (N_int,2,6,N_generators_ do k=1,N_generators_bitmask do ispin=1,2 do i=1,N_int - generators_bitmask(i,ispin,s_hole ,k) = iand(full_ijkl_bitmask(i,d_hole1),generators_bitmask(i,ispin,s_hole,k) ) - generators_bitmask(i,ispin,s_part ,k) = iand(full_ijkl_bitmask(i,d_part1),generators_bitmask(i,ispin,s_part,k) ) - generators_bitmask(i,ispin,d_hole1,k) = iand(full_ijkl_bitmask(i,d_hole1),generators_bitmask(i,ispin,d_hole1,k) ) - generators_bitmask(i,ispin,d_part1,k) = iand(full_ijkl_bitmask(i,d_part1),generators_bitmask(i,ispin,d_part1,k) ) - generators_bitmask(i,ispin,d_hole2,k) = iand(full_ijkl_bitmask(i,d_hole2),generators_bitmask(i,ispin,d_hole2,k) ) - generators_bitmask(i,ispin,d_part2,k) = iand(full_ijkl_bitmask(i,d_part2),generators_bitmask(i,ispin,d_part2,k) ) + generators_bitmask(i,ispin,s_hole ,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,s_hole,k) ) + generators_bitmask(i,ispin,s_part ,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,s_part,k) ) + generators_bitmask(i,ispin,d_hole1,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,d_hole1,k) ) + generators_bitmask(i,ispin,d_part1,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,d_part1,k) ) + generators_bitmask(i,ispin,d_hole2,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,d_hole2,k) ) + generators_bitmask(i,ispin,d_part2,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,d_part2,k) ) enddo enddo enddo @@ -259,8 +260,11 @@ BEGIN_PROVIDER [ integer(bit_kind), cas_bitmask, (N_int,2,N_cas_bitmask) ] print*,'---------------------' else if(N_generators_bitmask == 1)then - do i=1,N_cas_bitmask - cas_bitmask(:,:,i) = iand(not(HF_bitmask(:,:)),full_ijkl_bitmask(:,:)) + do j=1, N_cas_bitmask + do i=1, N_int + cas_bitmask(i,1,j) = iand(not(HF_bitmask(i,1)),full_ijkl_bitmask(i)) + cas_bitmask(i,2,j) = iand(not(HF_bitmask(i,2)),full_ijkl_bitmask(i)) + enddo enddo else i_part = 2 @@ -276,7 +280,7 @@ BEGIN_PROVIDER [ integer(bit_kind), cas_bitmask, (N_int,2,N_cas_bitmask) ] do i=1,N_cas_bitmask do j = 1, N_cas_bitmask do k=1,N_int - cas_bitmask(k,j,i) = iand(cas_bitmask(k,j,i),full_ijkl_bitmask(k,j)) + cas_bitmask(k,j,i) = iand(cas_bitmask(k,j,i),full_ijkl_bitmask(k)) enddo enddo enddo diff --git a/src/Determinants/H_apply.irp.f b/src/Determinants/H_apply.irp.f index 7e9861fe..28513597 100644 --- a/src/Determinants/H_apply.irp.f +++ b/src/Determinants/H_apply.irp.f @@ -263,6 +263,7 @@ subroutine remove_duplicates_in_psi_det(found_duplicates) deallocate (duplicate,bit_tmp) end + subroutine fill_H_apply_buffer_no_selection(n_selected,det_buffer,Nint,iproc) use bitmasks implicit none @@ -306,3 +307,116 @@ subroutine fill_H_apply_buffer_no_selection(n_selected,det_buffer,Nint,iproc) end +subroutine push_pt2(zmq_socket_push,pt2,norm_pert,H_pert_diag,N_st,task_id) + use f77_zmq + implicit none + BEGIN_DOC +! Push PT2 calculation to the collector + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_socket_push + integer, intent(in) :: N_st + double precision, intent(in) :: pt2(N_st), norm_pert(N_st), H_pert_diag(N_st) + integer, intent(in) :: task_id + integer :: rc + + rc = f77_zmq_send( zmq_socket_push, 1, 4, ZMQ_SNDMORE) + if (rc /= 4) then + print *, irp_here, 'f77_zmq_send( zmq_socket_push, 1, 4, ZMQ_SNDMORE)' + stop 'error' + endif + + rc = f77_zmq_send( zmq_socket_push, pt2, 8*N_st, ZMQ_SNDMORE) + if (rc /= 8*N_st) then + print *, irp_here, 'f77_zmq_send( zmq_socket_push, pt2, 8*N_st, ZMQ_SNDMORE)' + stop 'error' + endif + + rc = f77_zmq_send( zmq_socket_push, norm_pert, 8*N_st, ZMQ_SNDMORE) + if (rc /= 8*N_st) then + print *, irp_here, 'f77_zmq_send( zmq_socket_push, norm_pert, 8*N_st, ZMQ_SNDMORE)' + stop 'error' + endif + + rc = f77_zmq_send( zmq_socket_push, H_pert_diag, 8*N_st, ZMQ_SNDMORE) + if (rc /= 8*N_st) then + print *, irp_here, 'f77_zmq_send( zmq_socket_push, H_pert_diag, 8*N_st, ZMQ_SNDMORE)' + stop 'error' + endif + + rc = f77_zmq_send( zmq_socket_push, task_id, 4, 0) + if (rc /= 4) then + print *, irp_here, 'f77_zmq_send( zmq_socket_push, task_id, 4, 0)' + stop 'error' + endif + +! Activate if zmq_socket_push is a REQ +! integer :: idummy +! rc = f77_zmq_recv( zmq_socket_push, idummy, 4, 0) +! if (rc /= 4) then +! print *, irp_here, 'f77_zmq_send( zmq_socket_push, idummy, 4, 0)' +! stop 'error' +! endif +end + +subroutine pull_pt2(zmq_socket_pull,pt2,norm_pert,H_pert_diag,N_st,n,task_id) + use f77_zmq + implicit none + BEGIN_DOC +! Pull PT2 calculation in the collector + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_socket_pull + integer, intent(in) :: N_st + double precision, intent(out) :: pt2(N_st), norm_pert(N_st), H_pert_diag(N_st) + integer, intent(out) :: task_id + integer, intent(out) :: n + integer :: rc + + n=0 + rc = f77_zmq_recv( zmq_socket_pull, n, 4, 0) + if (rc == -1) then + n=9 + return + endif + if (rc /= 4) then + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, n, 4, 0)' + stop 'error' + endif + + if (n > 0) then + + rc = f77_zmq_recv( zmq_socket_pull, pt2(1), 8*N_st, 0) + if (rc /= 8*N_st) then + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, pt2(1,1) , 8*N_st, 0)' + stop 'error' + endif + + rc = f77_zmq_recv( zmq_socket_pull, norm_pert(1), 8*N_st, 0) + if (rc /= 8*N_st) then + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, norm_pert(1,1), 8*N_st)' + stop 'error' + endif + + rc = f77_zmq_recv( zmq_socket_pull, H_pert_diag(1), 8*N_st, 0) + if (rc /= 8*N_st) then + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, H_pert_diag(1,1), 8*N_st)' + stop 'error' + endif + + rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0) + if (rc /= 4) then + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, task_id, 4, 0)' + stop 'error' + endif + + endif + +! Activate if zmq_socket_pull is a REP +! rc = f77_zmq_send( zmq_socket_pull, 0, 4, 0) +! if (rc /= 4) then +! print *, irp_here, 'f77_zmq_send( zmq_socket_pull, 0, 4, 0)' +! stop 'error' +! endif + +end + + diff --git a/src/Determinants/H_apply.template.f b/src/Determinants/H_apply.template.f index 86780430..4e419af5 100644 --- a/src/Determinants/H_apply.template.f +++ b/src/Determinants/H_apply.template.f @@ -1,13 +1,12 @@ - subroutine $subroutine_diexc(key_in, key_prev, hole_1,particl_1, hole_2, particl_2, fock_diag_tmp, i_generator, iproc_in $parameters ) - + implicit none integer(bit_kind), intent(in) :: key_in(N_int, 2), hole_1(N_int, 2), hole_2(N_int, 2) integer(bit_kind), intent(in) :: particl_1(N_int, 2), particl_2(N_int, 2) integer(bit_kind) :: p1_mask(N_int, 2), p2_mask(N_int, 2), tmp integer,intent(in) :: i_generator,iproc_in - integer(bit_kind) :: status(N_int*bit_kind_size, 2) - integer :: highest, p1,p2,sp,ni,i,mi,nt,ns + integer :: status(N_int*bit_kind_size, 2) + integer :: highest, p1,p2,sp,ni,i,mi,nt,ns,k double precision, intent(in) :: fock_diag_tmp(2,mo_tot_num+1) integer(bit_kind), intent(in) :: key_prev(N_int, 2, *) PROVIDE N_int @@ -17,16 +16,19 @@ subroutine $subroutine_diexc(key_in, key_prev, hole_1,particl_1, hole_2, particl highest = 0 - status(:,:) = 0 + do k=1,N_int*bit_kind_size + status(k,1) = 0 + status(k,2) = 0 + enddo do sp=1,2 do ni=1,N_int do i=1,bit_kind_size - if(iand(1,ishft(key_in(ni, sp), -(i-1))) == 0) then + if(iand(1_bit_kind,ishft(key_in(ni, sp), -(i-1))) == 0) then cycle end if mi = (ni-1)*bit_kind_size+i - status(mi, sp) = iand(1,ishft(hole_1(ni, sp), -(i-1))) - status(mi, sp) = status(mi, sp) + 2*iand(1,ishft(hole_2(ni, sp), -(i-1))) + status(mi, sp) = int(iand(1_bit_kind,ishft(hole_1(ni, sp), -(i-1))),4) + status(mi, sp) = status(mi, sp) + 2*int(iand(1_bit_kind,ishft(hole_2(ni, sp), -(i-1))),4) if(status(mi, sp) /= 0 .and. mi > highest) then highest = mi end if @@ -103,16 +105,23 @@ subroutine $subroutine_diexcP(key_in, fs1, fh1, particl_1, fs2, fh2, particl_2, integer(bit_kind) :: p1_mask(N_int, 2), p2_mask(N_int, 2), key_mask(N_int, 2) integer,intent(in) :: fs1,fs2,i_generator,iproc_in, fh1,fh2 integer(bit_kind) :: miniList(N_int, 2, N_det) - integer :: n_minilist, n_alpha, n_beta, deg(2), i, ni + integer :: n_minilist, n_alpha, n_beta, deg(2), i, ni, k $declarations integer(bit_kind), parameter :: one = 1_bit_kind - p1_mask(:,:) = 0_bit_kind - p2_mask(:,:) = 0_bit_kind + do k=1,N_int + p1_mask(k,1) = 0_bit_kind + p1_mask(k,2) = 0_bit_kind + p2_mask(k,1) = 0_bit_kind + p2_mask(k,2) = 0_bit_kind + enddo p1_mask(ishft(fh1-1,-bit_kind_shift) + 1, fs1) = ishft(one,iand(fh1-1,bit_kind_size-1)) p2_mask(ishft(fh2-1,-bit_kind_shift) + 1, fs2) = ishft(one,iand(fh2-1,bit_kind_size-1)) - key_mask(:,:) = key_in(:,:) + do k=1,N_int + key_mask(k,1) = key_in(k,1) + key_mask(k,2) = key_in(k,2) + enddo key_mask(ishft(fh1-1,-bit_kind_shift) + 1, fs1) -= ishft(one,iand(fh1-1,bit_kind_size-1)) key_mask(ishft(fh2-1,-bit_kind_shift) + 1, fs2) -= ishft(one,iand(fh2-1,bit_kind_size-1)) @@ -229,14 +238,8 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl accu = 0.d0 do ispin=1,2 other_spin = iand(ispin,1)+1 - if (abort_here) then - exit - endif $omp_do do ii=1,ia_ja_pairs(1,0,ispin) - if (abort_here) then - cycle - endif i_a = ia_ja_pairs(1,ii,ispin) ASSERT (i_a > 0) ASSERT (i_a <= mo_tot_num) @@ -314,9 +317,6 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl $keys_work key_idx = 0 endif - if (abort_here) then - exit - endif enddo endif @@ -366,9 +366,6 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl $keys_work key_idx = 0 endif - if (abort_here) then - exit - endif enddo ! kk enddo ! ii @@ -431,7 +428,10 @@ subroutine $subroutine_monoexc(key_in, hole_1,particl_1,fock_diag_tmp,i_generato logical :: is_a_1p logical :: is_a_2p - key_mask(:,:) = 0_bit_kind + do k=1,N_int + key_mask(k,1) = 0_bit_kind + key_mask(k,2) = 0_bit_kind + enddo iproc = iproc_in @@ -533,168 +533,3 @@ subroutine $subroutine_monoexc(key_in, hole_1,particl_1,fock_diag_tmp,i_generato end -subroutine $subroutine($params_main) - implicit none - use omp_lib - use bitmasks - BEGIN_DOC - ! Calls H_apply on the HF determinant and selects all connected single and double - ! excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. - END_DOC - - $decls_main - - integer :: i_generator, nmax - double precision :: wall_0, wall_1 - integer(omp_lock_kind) :: lck - integer(bit_kind), allocatable :: mask(:,:,:) - integer :: ispin, k - integer :: iproc - double precision, allocatable :: fock_diag_tmp(:,:) - - $initialization - PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators - - - nmax = mod( N_det_generators,nproc ) - - !$ call omp_init_lock(lck) - call start_progress(N_det_generators,'Selection (norm)',0.d0) - - call wall_time(wall_0) - - iproc = 0 - allocate( mask(N_int,2,6), fock_diag_tmp(2,mo_tot_num+1) ) - do i_generator=1,nmax - - progress_bar(1) = i_generator - - if (abort_here) then - exit - endif - $skip - - ! Compute diagonal of the Fock matrix - call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int) - - ! Create bit masks for holes and particles - do ispin=1,2 - do k=1,N_int - mask(k,ispin,s_hole) = & - iand(generators_bitmask(k,ispin,s_hole,i_bitmask_gen), & - psi_det_generators(k,ispin,i_generator) ) - mask(k,ispin,s_part) = & - iand(generators_bitmask(k,ispin,s_part,i_bitmask_gen), & - not(psi_det_generators(k,ispin,i_generator)) ) - mask(k,ispin,d_hole1) = & - iand(generators_bitmask(k,ispin,d_hole1,i_bitmask_gen), & - psi_det_generators(k,ispin,i_generator) ) - mask(k,ispin,d_part1) = & - iand(generators_bitmask(k,ispin,d_part1,i_bitmask_gen), & - not(psi_det_generators(k,ispin,i_generator)) ) - mask(k,ispin,d_hole2) = & - iand(generators_bitmask(k,ispin,d_hole2,i_bitmask_gen), & - psi_det_generators(k,ispin,i_generator) ) - mask(k,ispin,d_part2) = & - iand(generators_bitmask(k,ispin,d_part2,i_bitmask_gen), & - not(psi_det_generators(k,ispin,i_generator)) ) - enddo - enddo - if($do_double_excitations)then - call $subroutine_diexc(psi_det_generators(1,1,i_generator), & - psi_det_generators(1,1,1), & - mask(1,1,d_hole1), mask(1,1,d_part1), & - mask(1,1,d_hole2), mask(1,1,d_part2), & - fock_diag_tmp, i_generator, iproc $params_post) - endif - if($do_mono_excitations)then - call $subroutine_monoexc(psi_det_generators(1,1,i_generator), & - mask(1,1,s_hole ), mask(1,1,s_part ), & - fock_diag_tmp, i_generator, iproc $params_post) - endif - call wall_time(wall_1) - $printout_always - if (wall_1 - wall_0 > 2.d0) then - $printout_now - wall_0 = wall_1 - endif - enddo - - deallocate( mask, fock_diag_tmp ) - - !$OMP PARALLEL DEFAULT(SHARED) & - !$OMP PRIVATE(i_generator,wall_1,wall_0,ispin,k,mask,iproc,fock_diag_tmp) - call wall_time(wall_0) - !$ iproc = omp_get_thread_num() - allocate( mask(N_int,2,6), fock_diag_tmp(2,mo_tot_num+1) ) - !$OMP DO SCHEDULE(dynamic,1) - do i_generator=nmax+1,N_det_generators - if (iproc == 0) then - progress_bar(1) = i_generator - endif - if (abort_here) then - cycle - endif - $skip - - ! Compute diagonal of the Fock matrix - call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int) - - ! Create bit masks for holes and particles - do ispin=1,2 - do k=1,N_int - mask(k,ispin,s_hole) = & - iand(generators_bitmask(k,ispin,s_hole,i_bitmask_gen), & - psi_det_generators(k,ispin,i_generator) ) - mask(k,ispin,s_part) = & - iand(generators_bitmask(k,ispin,s_part,i_bitmask_gen), & - not(psi_det_generators(k,ispin,i_generator)) ) - mask(k,ispin,d_hole1) = & - iand(generators_bitmask(k,ispin,d_hole1,i_bitmask_gen), & - psi_det_generators(k,ispin,i_generator) ) - mask(k,ispin,d_part1) = & - iand(generators_bitmask(k,ispin,d_part1,i_bitmask_gen), & - not(psi_det_generators(k,ispin,i_generator)) ) - mask(k,ispin,d_hole2) = & - iand(generators_bitmask(k,ispin,d_hole2,i_bitmask_gen), & - psi_det_generators(k,ispin,i_generator) ) - mask(k,ispin,d_part2) = & - iand(generators_bitmask(k,ispin,d_part2,i_bitmask_gen), & - not (psi_det_generators(k,ispin,i_generator)) ) - enddo - enddo - - if($do_double_excitations)then - call $subroutine_diexc(psi_det_generators(1,1,i_generator), & - psi_det_generators(1,1,1), & - mask(1,1,d_hole1), mask(1,1,d_part1), & - mask(1,1,d_hole2), mask(1,1,d_part2), & - fock_diag_tmp, i_generator, iproc $params_post) - endif - if($do_mono_excitations)then - call $subroutine_monoexc(psi_det_generators(1,1,i_generator), & - mask(1,1,s_hole ), mask(1,1,s_part ), & - fock_diag_tmp, i_generator, iproc $params_post) - endif - !$ call omp_set_lock(lck) - call wall_time(wall_1) - $printout_always - if (wall_1 - wall_0 > 2.d0) then - $printout_now - wall_0 = wall_1 - endif - !$ call omp_unset_lock(lck) - enddo - !$OMP END DO - deallocate( mask, fock_diag_tmp ) - !$OMP END PARALLEL - !$ call omp_destroy_lock(lck) - - abort_here = abort_all - call stop_progress - - $copy_buffer - $generate_psi_guess - -end - diff --git a/src/Determinants/H_apply_nozmq.template.f b/src/Determinants/H_apply_nozmq.template.f new file mode 100644 index 00000000..e5220d49 --- /dev/null +++ b/src/Determinants/H_apply_nozmq.template.f @@ -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 + diff --git a/src/Determinants/H_apply_zmq.template.f b/src/Determinants/H_apply_zmq.template.f new file mode 100644 index 00000000..363c2fe3 --- /dev/null +++ b/src/Determinants/H_apply_zmq.template.f @@ -0,0 +1,248 @@ +subroutine $subroutine($params_main) + implicit none + use omp_lib + use bitmasks + use f77_zmq + BEGIN_DOC + ! Calls H_apply on the HF determinant and selects all connected single and double + ! excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. + END_DOC + + $decls_main + + integer :: i_generator + double precision :: wall_0, wall_1 + integer(omp_lock_kind) :: lck + integer(bit_kind), allocatable :: mask(:,:,:) + integer :: ispin, k + integer :: rc + character*(512) :: task + double precision, allocatable :: fock_diag_tmp(:,:) + + $initialization + PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators + + integer(ZMQ_PTR), external :: new_zmq_pair_socket + integer(ZMQ_PTR) :: zmq_socket_pair + zmq_socket_pair = new_zmq_pair_socket(.True.) + + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + call new_parallel_job(zmq_to_qp_run_socket,'$subroutine') + + call zmq_put_psi(zmq_to_qp_run_socket,1) + + do i_generator=N_det_generators,1,-1 + $skip + write(task,*) i_generator + call add_task_to_taskserver(zmq_to_qp_run_socket,task) + enddo + + integer(ZMQ_PTR) :: collector_thread + external :: $subroutine_collector + rc = pthread_create(collector_thread, $subroutine_collector) + + !$OMP PARALLEL DEFAULT(private) + !$OMP TASK PRIVATE(rc) + rc = omp_get_thread_num() + call $subroutine_slave_inproc(rc) + !$OMP END TASK + !$OMP TASKWAIT + !$OMP END PARALLEL + + + integer :: n, task_id + call pull_pt2(zmq_socket_pair, pt2, norm_pert, H_pert_diag, N_st, n, task_id) + + rc = pthread_join(collector_thread) + + call end_parallel_job(zmq_to_qp_run_socket,'$subroutine') + + rc = f77_zmq_close(zmq_socket_pair) + if (rc /= 0) then + print *, 'f77_zmq_close(zmq_socket_pair)' + stop 'error' + endif + + $copy_buffer + $generate_psi_guess + +end + +subroutine $subroutine_slave_tcp(iproc) + implicit none + integer, intent(in) :: iproc + BEGIN_DOC +! Computes a buffer over the network + END_DOC + call $subroutine_slave(0,iproc) +end + +subroutine $subroutine_slave_inproc(iproc) + implicit none + integer, intent(in) :: iproc + BEGIN_DOC +! Computes a buffer using threads + END_DOC + call $subroutine_slave(1,iproc) +end + + +subroutine $subroutine_slave(thread, iproc) + implicit none + use omp_lib + use bitmasks + use f77_zmq + integer, intent(in) :: thread + BEGIN_DOC + ! Calls H_apply on the HF determinant and selects all connected single and double + ! excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. + END_DOC + + integer, intent(in) :: iproc + integer :: i_generator + double precision :: wall_0, wall_1 + integer(bit_kind), allocatable :: mask(:,:,:) + integer :: ispin, k + double precision, allocatable :: fock_diag_tmp(:,:) + double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:) + + integer :: worker_id, task_id, rc, N_st + character*(512) :: task + integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + integer(ZMQ_PTR),external :: new_zmq_push_socket + integer(ZMQ_PTR) :: zmq_socket_push + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + zmq_socket_push = new_zmq_push_socket(thread) + + + N_st = N_states + allocate( pt2(N_st), norm_pert(N_st), H_pert_diag(N_st), & + mask(N_int,2,6), fock_diag_tmp(2,mo_tot_num+1) ) + + call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) + + do + call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task) + if (task_id == 0) exit + read(task,*) i_generator + + ! Compute diagonal of the Fock matrix + call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int) + + pt2 = 0.d0 + norm_pert = 0.d0 + H_pert_diag = 0.d0 + + ! Create bit masks for holes and particles + do ispin=1,2 + do k=1,N_int + mask(k,ispin,s_hole) = & + iand(generators_bitmask(k,ispin,s_hole,i_bitmask_gen), & + psi_det_generators(k,ispin,i_generator) ) + mask(k,ispin,s_part) = & + iand(generators_bitmask(k,ispin,s_part,i_bitmask_gen), & + not(psi_det_generators(k,ispin,i_generator)) ) + mask(k,ispin,d_hole1) = & + iand(generators_bitmask(k,ispin,d_hole1,i_bitmask_gen), & + psi_det_generators(k,ispin,i_generator) ) + mask(k,ispin,d_part1) = & + iand(generators_bitmask(k,ispin,d_part1,i_bitmask_gen), & + not(psi_det_generators(k,ispin,i_generator)) ) + mask(k,ispin,d_hole2) = & + iand(generators_bitmask(k,ispin,d_hole2,i_bitmask_gen), & + psi_det_generators(k,ispin,i_generator) ) + mask(k,ispin,d_part2) = & + iand(generators_bitmask(k,ispin,d_part2,i_bitmask_gen), & + not (psi_det_generators(k,ispin,i_generator)) ) + enddo + enddo + + if($do_double_excitations)then + call $subroutine_diexc(psi_det_generators(1,1,i_generator), & + psi_det_generators(1,1,1), & + mask(1,1,d_hole1), mask(1,1,d_part1), & + mask(1,1,d_hole2), mask(1,1,d_part2), & + fock_diag_tmp, i_generator, iproc $params_post) + endif + if($do_mono_excitations)then + call $subroutine_monoexc(psi_det_generators(1,1,i_generator), & + mask(1,1,s_hole ), mask(1,1,s_part ), & + fock_diag_tmp, i_generator, iproc $params_post) + endif + + call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id,1) + call push_pt2(zmq_socket_push,pt2,norm_pert,H_pert_diag,N_st,task_id) + + enddo + + call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) + + deallocate( mask, fock_diag_tmp, pt2, norm_pert, H_pert_diag ) + + call end_zmq_push_socket(zmq_socket_push,thread) + +end + +subroutine $subroutine_collector + use f77_zmq + implicit none + BEGIN_DOC +! Collects results from the selection + END_DOC + + integer :: k, rc + + integer(ZMQ_PTR), external :: new_zmq_pull_socket + integer(ZMQ_PTR) :: zmq_socket_pull + integer*8 :: control, accu + integer :: n, more, task_id + + integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + zmq_socket_pull = new_zmq_pull_socket() + + double precision, allocatable :: pt2(:,:), norm_pert(:,:), H_pert_diag(:,:) + allocate ( pt2(N_states,2), norm_pert(N_states,2), H_pert_diag(N_states,2)) + + pt2 = 0.d0 + norm_pert = 0.d0 + H_pert_diag = 0.d0 + accu = 0_8 + more = 1 + do while (more == 1) + + call pull_pt2(zmq_socket_pull, pt2, norm_pert, H_pert_diag, N_states, n, task_id) + if (n > 0) then + do k=1,N_states + pt2(k,2) = pt2(k,1) + pt2(k,2) + norm_pert(k,2) = norm_pert(k,1) + norm_pert(k,2) + H_pert_diag(k,2) = H_pert_diag(k,1) + H_pert_diag(k,2) + enddo + accu = accu + 1_8 + call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more) + endif + + enddo + + call end_zmq_pull_socket(zmq_socket_pull) + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + + + integer(ZMQ_PTR), external :: new_zmq_pair_socket + integer(ZMQ_PTR) :: socket_result + + socket_result = new_zmq_pair_socket(.False.) + + call push_pt2(socket_result, pt2(1,2), norm_pert(1,2), H_pert_diag(1,2), N_states,0) + + deallocate ( pt2, norm_pert, H_pert_diag) + + call end_zmq_pair_socket(socket_result) + +end + + diff --git a/src/Determinants/SC2.irp.f b/src/Determinants/SC2.irp.f index 440b2870..ea942307 100644 --- a/src/Determinants/SC2.irp.f +++ b/src/Determinants/SC2.irp.f @@ -91,9 +91,6 @@ subroutine CISD_SC2(dets_in,u_in,energies,dim_in,sze,N_st,Nint,convergence) e_corr_double_before = e_corr_double iter = 0 do while (.not.converged) - if (abort_here) then - exit - endif iter +=1 !$OMP PARALLEL DEFAULT(NONE) & !$OMP PRIVATE(i,j,degree,accu) & @@ -191,14 +188,14 @@ subroutine CISD_SC2(dets_in,u_in,energies,dim_in,sze,N_st,Nint,convergence) write(output_determinants,'(A)') 'State Energy ' write(output_determinants,'(A)') '===== ================' do i=1,N_st - write(output_determinants,'(I5,X,F16.10)') i, energies(i)+nuclear_repulsion + write(output_determinants,'(I5,1X,F16.10)') i, energies(i)+nuclear_repulsion enddo write(output_determinants,'(A)') '===== ================' write(output_determinants,'(A)') '' call write_double(output_determinants,(e_corr_double - e_corr_double_before),& 'Delta(E_corr)') converged = dabs(e_corr_double - e_corr_double_before) < convergence - converged = converged .or. abort_here + converged = converged if (converged) then exit endif diff --git a/src/Determinants/davidson.irp.f b/src/Determinants/davidson.irp.f index 3432ab2e..deba43c5 100644 --- a/src/Determinants/davidson.irp.f +++ b/src/Determinants/davidson.irp.f @@ -69,8 +69,8 @@ end logical function det_inf(key1, key2, Nint) use bitmasks implicit none - integer(bit_kind),intent(in) :: key1(Nint, 2), key2(Nint, 2) integer,intent(in) :: Nint + integer(bit_kind),intent(in) :: key1(Nint, 2), key2(Nint, 2) integer :: i,j det_inf = .false. @@ -239,10 +239,10 @@ subroutine sort_dets_ab(key, idx, shortcut, N_key, Nint) BEGIN_DOC ! Uncodumented : TODO END_DOC + integer, intent(in) :: Nint, N_key integer(bit_kind),intent(inout) :: key(Nint,2,N_key) integer,intent(out) :: idx(N_key) integer,intent(out) :: shortcut(0:N_key+1) - integer, intent(in) :: Nint, N_key integer(bit_kind) :: tmp(Nint, 2) integer :: tmpidx,i,ni @@ -498,7 +498,7 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nint,iun to_print(2,k) = residual_norm(k) enddo - write(iunit,'(X,I3,X,100(X,F16.10,X,E16.6))'), iter, to_print(:,1:N_st) + write(iunit,'(X,I3,X,100(X,F16.10,X,E16.6))') iter, to_print(:,1:N_st) call davidson_converged(lambda,residual_norm,wall,iter,cpu,N_st,converged) if (converged) then exit @@ -590,7 +590,6 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nint,iun y, & lambda & ) - abort_here = abort_all end BEGIN_PROVIDER [ character(64), davidson_criterion ] @@ -636,5 +635,4 @@ subroutine davidson_converged(energy,residual,wall,iterations,cpu,N_st,converged else if (davidson_criterion == 'iterations') then converged = iterations >= int(threshold_davidson) endif - converged = converged.or.abort_here end diff --git a/src/Determinants/determinants.irp.f b/src/Determinants/determinants.irp.f index 63ed7a92..32fd43a9 100644 --- a/src/Determinants/determinants.irp.f +++ b/src/Determinants/determinants.irp.f @@ -412,7 +412,7 @@ subroutine int_of_3_highest_electrons( det_in, res, Nint ) do while (ix /= 0_bit_kind) i = bit_kind_size-1-leadz(ix) ix = ibclr(ix,i) - res = ior(ishft(res, 21), i+ishft(k-1,bit_kind_shift)) + res = ior(ishft(res, 21_8), i+ishft(k-1,bit_kind_shift)) icount -= 1 if (icount == 0) then return @@ -645,7 +645,9 @@ end subroutine save_ref_determinant implicit none use bitmasks - call save_wavefunction_general(1,1,ref_bitmask,1,1.d0) + double precision :: buffer(1,1) + buffer(1,1) = 1.d0 + call save_wavefunction_general(1,1,ref_bitmask,1,buffer) end diff --git a/src/Determinants/filter_connected.irp.f b/src/Determinants/filter_connected.irp.f index 8635d921..46280b31 100644 --- a/src/Determinants/filter_connected.irp.f +++ b/src/Determinants/filter_connected.irp.f @@ -112,16 +112,16 @@ subroutine getMobiles(key,key_mask, mobiles,Nint) mobileMask(j,2) = xor(key(j,2), key_mask(j,2)) end do - call bitstring_to_list(mobileMask(:,1), list(:), nel, Nint) + call bitstring_to_list(mobileMask(1,1), list, nel, Nint) if(nel == 2) then mobiles(1) = list(1) mobiles(2) = list(2) else if(nel == 1) then mobiles(1) = list(1) - call bitstring_to_list(mobileMask(:,2), list(:), nel, Nint) + call bitstring_to_list(mobileMask(1,2), list, nel, Nint) mobiles(2) = list(1) + mo_tot_num else - call bitstring_to_list(mobileMask(:,2), list(:), nel, Nint) + call bitstring_to_list(mobileMask(1,2), list, nel, Nint) mobiles(1) = list(1) + mo_tot_num mobiles(2) = list(2) + mo_tot_num end if @@ -139,6 +139,8 @@ subroutine create_microlist(minilist, N_minilist, key_mask, microlist, idx_micro integer :: i,j,k,nt,n_element(2) integer :: list(Nint*bit_kind_size,2), cur_microlist(0:mo_tot_num*2+1) integer(bit_kind) :: key_mask_neg(Nint,2), mobileMask(Nint,2) + integer :: mo_tot_num_2 + mo_tot_num_2 = mo_tot_num+mo_tot_num do i=1,Nint @@ -146,7 +148,9 @@ subroutine create_microlist(minilist, N_minilist, key_mask, microlist, idx_micro key_mask_neg(i,2) = not(key_mask(i,2)) end do - N_microlist(:) = 0 + do i=0,mo_tot_num_2 + N_microlist(i) = 0 + enddo do i=1, N_minilist do j=1,Nint @@ -154,8 +158,8 @@ subroutine create_microlist(minilist, N_minilist, key_mask, microlist, idx_micro mobileMask(j,2) = iand(key_mask_neg(j,2), minilist(j,2,i)) end do - call bitstring_to_list(mobileMask(:,1), list(:,1), n_element(1), Nint) - call bitstring_to_list(mobileMask(:,2), list(:,2), n_element(2), Nint) + call bitstring_to_list(mobileMask(1,1), list(1,1), n_element(1), Nint) + call bitstring_to_list(mobileMask(1,2), list(1,2), n_element(2), Nint) if(n_element(1) + n_element(2) /= 4) then N_microlist(0) = N_microlist(0) + 1 @@ -173,11 +177,14 @@ subroutine create_microlist(minilist, N_minilist, key_mask, microlist, idx_micro end do ptr_microlist(0) = 1 - do i=1,mo_tot_num*2+1 + do i=1,mo_tot_num_2+1 ptr_microlist(i) = ptr_microlist(i-1) + N_microlist(i-1) end do + + do i=0,mo_tot_num_2+1 + cur_microlist(i) = ptr_microlist(i) + end do - cur_microlist(:) = ptr_microlist(:) do i=1, N_minilist do j=1,Nint @@ -185,26 +192,35 @@ subroutine create_microlist(minilist, N_minilist, key_mask, microlist, idx_micro mobileMask(j,2) = iand(key_mask_neg(j,2), minilist(j,2,i)) end do - call bitstring_to_list(mobileMask(:,1), list(:,1), n_element(1), Nint) - call bitstring_to_list(mobileMask(:,2), list(:,2), n_element(2), Nint) + call bitstring_to_list(mobileMask(1,1), list(1,1), n_element(1), Nint) + call bitstring_to_list(mobileMask(1,2), list(1,2), n_element(2), Nint) if(n_element(1) + n_element(2) /= 4) then idx_microlist(cur_microlist(0)) = i - microlist(:,:,cur_microlist(0)) = minilist(:,:,i) + do k=1,Nint + microlist(k,1,cur_microlist(0)) = minilist(k,1,i) + microlist(k,2,cur_microlist(0)) = minilist(k,2,i) + enddo cur_microlist(0) = cur_microlist(0) + 1 else do j=1,n_element(1) nt = list(j,1) idx_microlist(cur_microlist(nt)) = i - microlist(:,:,cur_microlist(nt)) = minilist(:,:,i) + do k=1,Nint + microlist(k,1,cur_microlist(nt)) = minilist(k,1,i) + microlist(k,2,cur_microlist(nt)) = minilist(k,2,i) + enddo cur_microlist(nt) = cur_microlist(nt) + 1 end do do j=1,n_element(2) nt = list(j,2) + mo_tot_num idx_microlist(cur_microlist(nt)) = i - microlist(:,:,cur_microlist(nt)) = minilist(:,:,i) + do k=1,Nint + microlist(k,1,cur_microlist(nt)) = minilist(k,1,i) + microlist(k,2,cur_microlist(nt)) = minilist(k,2,i) + enddo cur_microlist(nt) = cur_microlist(nt) + 1 end do end if @@ -212,16 +228,6 @@ subroutine create_microlist(minilist, N_minilist, key_mask, microlist, idx_micro end subroutine -subroutine merdge(mic, idx_mic, N_mic, mic0, idx_mic0, N_mic0, Nint) - use bitmasks - integer(bit_kind) :: mic(Nint,2,N_mic), mic0(Nint,2,*) - integer :: idx_mic(N_mic), idx_mic0(N_mic0), N_mic, N_mic0 - - mic0(:,:,N_mic0+1:N_mic0+N_mic) = mic(:,:,:) - idx_mic0(N_mic0+1:N_mic0+N_mic) = idx_mic(:) -end subroutine - - subroutine filter_connected_i_H_psi0(key1,key2,Nint,sze,idx) use bitmasks BEGIN_DOC diff --git a/src/Determinants/s2.irp.f b/src/Determinants/s2.irp.f index d84e4578..9810b219 100644 --- a/src/Determinants/s2.irp.f +++ b/src/Determinants/s2.irp.f @@ -82,8 +82,8 @@ END_PROVIDER subroutine get_s2_u0_old(psi_keys_tmp,psi_coefs_tmp,n,nmax,s2) implicit none use bitmasks - integer(bit_kind), intent(in) :: psi_keys_tmp(N_int,2,nmax) integer, intent(in) :: n,nmax + integer(bit_kind), intent(in) :: psi_keys_tmp(N_int,2,nmax) double precision, intent(in) :: psi_coefs_tmp(nmax) double precision, intent(out) :: s2 integer :: i,j,l @@ -109,8 +109,8 @@ end subroutine get_s2_u0(psi_keys_tmp,psi_coefs_tmp,n,nmax,s2) implicit none use bitmasks - integer(bit_kind), intent(in) :: psi_keys_tmp(N_int,2,nmax) integer, intent(in) :: n,nmax + integer(bit_kind), intent(in) :: psi_keys_tmp(N_int,2,nmax) double precision, intent(in) :: psi_coefs_tmp(nmax) double precision, intent(out) :: s2 double precision :: s2_tmp diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index e983ec34..ec786941 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -845,25 +845,30 @@ subroutine create_minilist(key_mask, fullList, miniList, idx_miniList, N_fullLis use bitmasks implicit none - integer(bit_kind), intent(in) :: fullList(Nint, 2, N_fullList) integer, intent(in) :: N_fullList + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: fullList(Nint, 2, N_fullList) integer(bit_kind),intent(out) :: miniList(Nint, 2, N_fullList) integer,intent(out) :: idx_miniList(N_fullList), N_miniList - integer, intent(in) :: Nint integer(bit_kind) :: key_mask(Nint, 2) - integer :: ni, i, n_a, n_b, e_a, e_b + integer :: ni, k, i, n_a, n_b, e_a, e_b - n_a = 0 - n_b = 0 - do ni=1,nint + n_a = popcnt(key_mask(1,1)) + n_b = popcnt(key_mask(1,2)) + do ni=2,nint n_a = n_a + popcnt(key_mask(ni,1)) n_b = n_b + popcnt(key_mask(ni,2)) end do if(n_a == 0) then N_miniList = N_fullList - miniList(:,:,:) = fullList(:,:,:) + do k=1,N_fullList + do ni=1,Nint + miniList(ni,1,k) = fullList(ni,1,k) + miniList(ni,2,k) = fullList(ni,2,k) + enddo + enddo do i=1,N_fullList idx_miniList(i) = i end do @@ -873,16 +878,19 @@ subroutine create_minilist(key_mask, fullList, miniList, idx_miniList, N_fullLis N_miniList = 0 do i=1,N_fullList - e_a = n_a - e_b = n_b - do ni=1,nint + e_a = n_a - popcnt(iand(fullList(1, 1, i), key_mask(1, 1))) + e_b = n_b - popcnt(iand(fullList(1, 2, i), key_mask(1, 2))) + do ni=2,nint e_a -= popcnt(iand(fullList(ni, 1, i), key_mask(ni, 1))) e_b -= popcnt(iand(fullList(ni, 2, i), key_mask(ni, 2))) end do if(e_a + e_b <= 2) then N_miniList = N_miniList + 1 - miniList(:,:,N_miniList) = fullList(:,:,i) + do ni=1,Nint + miniList(ni,1,N_miniList) = fullList(ni,1,i) + miniList(ni,2,N_miniList) = fullList(ni,2,i) + enddo idx_miniList(N_miniList) = i end if end do @@ -892,29 +900,34 @@ subroutine create_minilist_find_previous(key_mask, fullList, miniList, N_fullLis use bitmasks implicit none - integer(bit_kind), intent(in) :: fullList(Nint, 2, N_fullList) integer, intent(in) :: N_fullList + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: fullList(Nint, 2, N_fullList) integer(bit_kind),intent(out) :: miniList(Nint, 2, N_fullList) integer(bit_kind) :: subList(Nint, 2, N_fullList) logical,intent(out) :: fullMatch integer,intent(out) :: N_miniList - integer, intent(in) :: Nint integer(bit_kind) :: key_mask(Nint, 2) integer :: ni, i, k, l, N_subList fullMatch = .false. - l = 0 N_miniList = 0 N_subList = 0 - do ni = 1,Nint - l += popcnt(key_mask(ni,1)) + popcnt(key_mask(ni,2)) + l = popcnt(key_mask(1,1)) + popcnt(key_mask(1,2)) + do ni = 2,Nint + l = l + popcnt(key_mask(ni,1)) + popcnt(key_mask(ni,2)) end do if(l == 0) then N_miniList = N_fullList - miniList(:,:,:N_miniList) = fullList(:,:,:N_minilist) + do k=1,N_fullList + do ni=1,Nint + miniList(ni,1,k) = fullList(ni,1,k) + miniList(ni,2,k) = fullList(ni,2,k) + enddo + enddo else do i=N_fullList,1,-1 k = l @@ -923,10 +936,16 @@ subroutine create_minilist_find_previous(key_mask, fullList, miniList, N_fullLis end do if(k == 2) then N_subList += 1 - subList(:,:,N_subList) = fullList(:,:,i) + do ni=1,Nint + subList(ni,1,N_subList) = fullList(ni,1,i) + subList(ni,2,N_subList) = fullList(ni,2,i) + enddo else if(k == 1) then N_minilist += 1 - miniList(:,:,N_minilist) = fullList(:,:,i) + do ni=1,Nint + miniList(ni,1,N_minilist) = fullList(ni,1,i) + miniList(ni,2,N_minilist) = fullList(ni,2,i) + enddo else if(k == 0) then fullMatch = .true. return @@ -935,7 +954,12 @@ subroutine create_minilist_find_previous(key_mask, fullList, miniList, N_fullLis end if if(N_subList > 0) then - miniList(:,:,N_minilist+1:N_minilist+N_subList) = sublist(:,:,:N_subList) + do k=1,N_subList + do ni=1,Nint + miniList(ni,1,N_minilist+k) = sublist(ni,1,k) + miniList(ni,2,N_minilist+k) = sublist(ni,2,k) + enddo + enddo N_minilist = N_minilist + N_subList end if end subroutine @@ -972,14 +996,28 @@ subroutine i_H_psi(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array) i_H_psi_array = 0.d0 call filter_connected_i_H_psi0(keys,key,Nint,Ndet,idx) - do ii=1,idx(0) - i = idx(ii) - !DIR$ FORCEINLINE - call i_H_j(keys(1,1,i),key,Nint,hij) - do j = 1, Nstate - i_H_psi_array(j) = i_H_psi_array(j) + coef(i,j)*hij + if (Nstate == 1) then + + do ii=1,idx(0) + i = idx(ii) + !DIR$ FORCEINLINE + call i_H_j(keys(1,1,i),key,Nint,hij) + i_H_psi_array(1) = i_H_psi_array(1) + coef(i,1)*hij enddo - enddo + + else + + do ii=1,idx(0) + i = idx(ii) + !DIR$ FORCEINLINE + call i_H_j(keys(1,1,i),key,Nint,hij) + do j = 1, Nstate + i_H_psi_array(j) = i_H_psi_array(j) + coef(i,j)*hij + enddo + enddo + + endif + end @@ -1012,15 +1050,30 @@ subroutine i_H_psi_minilist(key,keys,idx_key,N_minilist,coef,Nint,Ndet,Ndet_max, i_H_psi_array = 0.d0 call filter_connected_i_H_psi0(keys,key,Nint,N_minilist,idx) - do ii=1,idx(0) - i_in_key = idx(ii) - i_in_coef = idx_key(idx(ii)) - !DIR$ FORCEINLINE - call i_H_j(keys(1,1,i_in_key),key,Nint,hij) - do j = 1, Nstate - i_H_psi_array(j) = i_H_psi_array(j) + coef(i_in_coef,j)*hij + if (Nstate == 1) then + + do ii=1,idx(0) + i_in_key = idx(ii) + i_in_coef = idx_key(idx(ii)) + !DIR$ FORCEINLINE + call i_H_j(keys(1,1,i_in_key),key,Nint,hij) + i_H_psi_array(1) = i_H_psi_array(1) + coef(i_in_coef,1)*hij enddo - enddo + + else + + do ii=1,idx(0) + i_in_key = idx(ii) + i_in_coef = idx_key(idx(ii)) + !DIR$ FORCEINLINE + call i_H_j(keys(1,1,i_in_key),key,Nint,hij) + do j = 1, Nstate + i_H_psi_array(j) = i_H_psi_array(j) + coef(i_in_coef,j)*hij + enddo + enddo + + endif + end subroutine i_H_psi_sec_ord(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array,idx_interaction,interactions) @@ -1497,8 +1550,8 @@ subroutine get_occ_from_key(key,occ,Nint) BEGIN_DOC ! Returns a list of occupation numbers from a bitstring END_DOC - integer(bit_kind), intent(in) :: key(Nint,2) integer , intent(in) :: Nint + integer(bit_kind), intent(in) :: key(Nint,2) integer , intent(out) :: occ(Nint*bit_kind_size,2) integer :: tmp(2) diff --git a/src/Determinants/spindeterminants.irp.f b/src/Determinants/spindeterminants.irp.f index 0ca6301a..8d5726f5 100644 --- a/src/Determinants/spindeterminants.irp.f +++ b/src/Determinants/spindeterminants.irp.f @@ -14,13 +14,13 @@ integer*8 function spin_det_search_key(det,Nint) END_DOC integer, intent(in) :: Nint integer(bit_kind), intent(in) :: det(Nint) - integer(bit_kind), parameter :: unsigned_shift = not(huge(1_bit_kind)) ! 100...00 + integer(bit_kind), parameter :: unsigned_shift = -huge(1_bit_kind) ! 100...00 integer :: i spin_det_search_key = det(1) do i=2,Nint spin_det_search_key = ieor(spin_det_search_key,det(i)) enddo - spin_det_search_key = spin_det_search_key-unsigned_shift + spin_det_search_key = spin_det_search_key+1_bit_kind-unsigned_shift end diff --git a/src/Integrals_Bielec/ao_bi_integrals.irp.f b/src/Integrals_Bielec/ao_bi_integrals.irp.f index 07416e61..eb443701 100644 --- a/src/Integrals_Bielec/ao_bi_integrals.irp.f +++ b/src/Integrals_Bielec/ao_bi_integrals.irp.f @@ -365,20 +365,31 @@ BEGIN_PROVIDER [ logical, ao_bielec_integrals_in_map ] call cpu_time(cpu_1) integer(ZMQ_PTR) :: zmq_to_qp_run_socket - call new_parallel_job(zmq_to_qp_run_socket,'ao_integrals') - - character*(32) :: task + call new_parallel_job(zmq_to_qp_run_socket,'ao_integrals') + do l=1,ao_num - write(task,*) 'triangle', l + write(task,*) l call add_task_to_taskserver(zmq_to_qp_run_socket,task) enddo - external :: ao_bielec_integrals_in_map_slave_inproc, ao_bielec_integrals_in_map_collector - call new_parallel_threads(ao_bielec_integrals_in_map_slave_inproc, ao_bielec_integrals_in_map_collector) + integer(ZMQ_PTR) :: collector_thread + external :: ao_bielec_integrals_in_map_collector + rc = pthread_create(collector_thread, ao_bielec_integrals_in_map_collector) + + !$OMP PARALLEL DEFAULT(private) + !$OMP TASK PRIVATE(i) + i = omp_get_thread_num() + call ao_bielec_integrals_in_map_slave_inproc(i) + !$OMP END TASK + !$OMP TASKWAIT + !$OMP END PARALLEL + + rc = pthread_join(collector_thread) + + call end_parallel_job(zmq_to_qp_run_socket, 'ao_integrals') - call end_parallel_job(zmq_to_qp_run_socket,'ao_integrals') print*, 'Sorting the map' call map_sort(ao_integrals_map) diff --git a/src/Integrals_Bielec/ao_bielec_integrals_in_map_slave.irp.f b/src/Integrals_Bielec/ao_bielec_integrals_in_map_slave.irp.f index 818247ff..8b165e72 100644 --- a/src/Integrals_Bielec/ao_bielec_integrals_in_map_slave.irp.f +++ b/src/Integrals_Bielec/ao_bielec_integrals_in_map_slave.irp.f @@ -1,20 +1,73 @@ -subroutine ao_bielec_integrals_in_map_slave_tcp +subroutine ao_bielec_integrals_in_map_slave_tcp(i) implicit none + integer, intent(in) :: i BEGIN_DOC -! Computes a buffer of integrals +! Computes a buffer of integrals. i is the ID of the current thread. END_DOC - call ao_bielec_integrals_in_map_slave(0) + call ao_bielec_integrals_in_map_slave(0,i) end -subroutine ao_bielec_integrals_in_map_slave_inproc + +subroutine ao_bielec_integrals_in_map_slave_inproc(i) implicit none + integer, intent(in) :: i BEGIN_DOC -! Computes a buffer of integrals +! Computes a buffer of integrals. i is the ID of the current thread. END_DOC - call ao_bielec_integrals_in_map_slave(1) + call ao_bielec_integrals_in_map_slave(1,i) end -subroutine ao_bielec_integrals_in_map_slave(thread) + +subroutine push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, task_id) + use f77_zmq + use map_module + implicit none + BEGIN_DOC +! Push integrals in the push socket + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_socket_push + integer, intent(in) :: n_integrals + integer(key_kind), intent(in) :: buffer_i(*) + real(integral_kind), intent(in) :: buffer_value(*) + integer, intent(in) :: task_id + integer :: rc + + rc = f77_zmq_send( zmq_socket_push, n_integrals, 4, ZMQ_SNDMORE) + if (rc /= 4) then + print *, irp_here, 'f77_zmq_send( zmq_socket_push, n_integrals, 4, ZMQ_SNDMORE)' + stop 'error' + endif + + rc = f77_zmq_send( zmq_socket_push, buffer_i, key_kind*n_integrals, ZMQ_SNDMORE) + if (rc /= key_kind*n_integrals) then + print *, irp_here, 'f77_zmq_send( zmq_socket_push, buffer_i, key_kind*n_integrals, ZMQ_SNDMORE)' + stop 'error' + endif + + rc = f77_zmq_send( zmq_socket_push, buffer_value, integral_kind*n_integrals, ZMQ_SNDMORE) + if (rc /= integral_kind*n_integrals) then + print *, irp_here, 'f77_zmq_send( zmq_socket_push, buffer_value, integral_kind*n_integrals, 0)' + stop 'error' + endif + + rc = f77_zmq_send( zmq_socket_push, task_id, 4, 0) + if (rc /= 4) then + print *, irp_here, 'f77_zmq_send( zmq_socket_push, task_id, 4, 0)' + stop 'error' + endif + +! Activate is zmq_socket_push is a REQ +! integer :: idummy +! rc = f77_zmq_recv( zmq_socket_push, idummy, 4, 0) +! if (rc /= 4) then +! print *, irp_here, 'f77_zmq_send( zmq_socket_push, idummy, 4, 0)' +! stop 'error' +! endif +end + + + +subroutine ao_bielec_integrals_in_map_slave(thread,iproc) use map_module use f77_zmq implicit none @@ -22,7 +75,7 @@ subroutine ao_bielec_integrals_in_map_slave(thread) ! Computes a buffer of integrals END_DOC - integer, intent(in) :: thread + integer, intent(in) :: thread, iproc integer :: j,l,n_integrals integer :: rc @@ -35,19 +88,11 @@ subroutine ao_bielec_integrals_in_map_slave(thread) integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket integer(ZMQ_PTR) :: zmq_to_qp_run_socket - zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() - + integer(ZMQ_PTR), external :: new_zmq_push_socket integer(ZMQ_PTR) :: zmq_socket_push -! zmq_socket_push = f77_zmq_socket(zmq_context, ZMQ_PUSH) - zmq_socket_push = f77_zmq_socket(zmq_context, ZMQ_REQ ) - if (thread == 1) then - rc = f77_zmq_connect(zmq_socket_push, trim(zmq_socket_pull_inproc_address)) - else - rc = f77_zmq_connect(zmq_socket_push, trim(zmq_socket_push_tcp_address)) - endif - if (rc /= 0) then - stop 'Unable to connect zmq_socket_push_tcp' - endif + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + zmq_socket_push = new_zmq_push_socket(thread) allocate ( buffer_i(ao_num*ao_num), buffer_value(ao_num*ao_num) ) @@ -55,31 +100,77 @@ subroutine ao_bielec_integrals_in_map_slave(thread) do call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task) - if (task_id == 0) then - exit - endif - read(task,*) j, l - call compute_ao_integrals_jl(j,l,n_integrals,buffer_i,buffer_value) - rc = f77_zmq_send( zmq_socket_push, n_integrals, 4, ZMQ_SNDMORE) - rc = f77_zmq_send( zmq_socket_push, buffer_i, key_kind*n_integrals, ZMQ_SNDMORE) - rc = f77_zmq_send( zmq_socket_push, buffer_value, integral_kind*n_integrals, 0) - call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) - character*(2) :: ok - rc = f77_zmq_recv( zmq_socket_push, ok, 2, 0) + if (task_id == 0) exit + read(task,*) l + do j=1,l-1 + call compute_ao_integrals_jl(j,l,n_integrals,buffer_i,buffer_value) + call push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, 0) + enddo + call compute_ao_integrals_jl(l,l,n_integrals,buffer_i,buffer_value) + call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id,n_integrals) + call push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, task_id) enddo deallocate( buffer_i, buffer_value ) - integer :: finished - call disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id,finished) + call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) + call end_zmq_push_socket(zmq_socket_push,thread) - if (finished /= 0) then - rc = f77_zmq_send( zmq_socket_push, -1, 4, 0) - rc = f77_zmq_recv( zmq_socket_push, ok, 2, ZMQ_NOBLOCK) +end + + +subroutine pull_integrals(zmq_socket_pull, n_integrals, buffer_i, buffer_value, task_id) + use f77_zmq + use map_module + implicit none + BEGIN_DOC + ! How the collector pulls the computed integrals + END_DOC + integer(ZMQ_PTR), intent(out) :: zmq_socket_pull + integer, intent(out) :: n_integrals + integer(key_kind), intent(out) :: buffer_i(*) + real(integral_kind), intent(out) :: buffer_value(*) + integer, intent(out) :: task_id + integer :: rc + + rc = f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0) + if (rc == -1) then + n_integrals = 0 + return + endif + if (rc /= 4) then + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0)' + stop 'error' + endif + + if (n_integrals >= 0) then + + rc = f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0) + if (rc /= key_kind*n_integrals) then + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0)' + stop 'error' + endif + + rc = f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0) + if (rc /= integral_kind*n_integrals) then + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0)' + stop 'error' + endif + + rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0) + if (rc /= 4) then + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, task_id, 4, 0)' + stop 'error' + endif + endif - rc = f77_zmq_disconnect(zmq_socket_push,trim(zmq_socket_push_tcp_address)) - rc = f77_zmq_close(zmq_socket_push) +! Activate if zmq_socket_pull is a REP +! rc = f77_zmq_send( zmq_socket_pull, 0, 4, 0) +! if (rc /= 4) then +! print *, irp_here, ' f77_zmq_send (zmq_socket_pull,...' +! stop 'error' +! endif end @@ -94,27 +185,54 @@ subroutine ao_bielec_integrals_in_map_collector integer :: j,l,n_integrals integer :: rc + real(integral_kind), allocatable :: buffer_value(:) integer(key_kind), allocatable :: buffer_i(:) + + integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + + integer(ZMQ_PTR), external :: new_zmq_pull_socket + integer(ZMQ_PTR) :: zmq_socket_pull + + integer*8 :: control, accu + integer :: task_id, more + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + zmq_socket_pull = new_zmq_pull_socket() allocate ( buffer_i(ao_num*ao_num), buffer_value(ao_num*ao_num) ) - n_integrals = 0 - do while (n_integrals >= 0) + accu = 0_8 + more = 1 + do while (more == 1) - rc = f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0) + call pull_integrals(zmq_socket_pull, n_integrals, buffer_i, buffer_value, task_id) if (n_integrals >= 0) then - rc = f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0) - rc = f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0) - rc = f77_zmq_send( zmq_socket_pull, 'ok', 2, 0) call insert_into_ao_integrals_map(n_integrals,buffer_i,buffer_value) - else - rc = f77_zmq_send( zmq_socket_pull, 'ok', 2, 0) + accu += n_integrals + if (task_id /= 0) then + call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more) + endif endif enddo deallocate( buffer_i, buffer_value ) + integer (map_size_kind) :: get_ao_map_size + control = get_ao_map_size(ao_integrals_map) + + if (control /= accu) then + print *, irp_here, 'Control : ', control + print *, 'Accu : ', accu + print *, 'Some integrals were lost during the parallel computation. (2)' + print *, 'Try to reduce the number of threads.' + stop + endif + + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + call end_zmq_pull_socket(zmq_socket_pull) + end diff --git a/src/Integrals_Bielec/mo_bi_integrals.irp.f b/src/Integrals_Bielec/mo_bi_integrals.irp.f index 0ff14168..4d471545 100644 --- a/src/Integrals_Bielec/mo_bi_integrals.irp.f +++ b/src/Integrals_Bielec/mo_bi_integrals.irp.f @@ -36,7 +36,7 @@ BEGIN_PROVIDER [ logical, mo_bielec_integrals_in_map ] endif endif - call add_integrals_to_map(full_ijkl_bitmask) + call add_integrals_to_map(full_ijkl_bitmask_4) END_PROVIDER subroutine add_integrals_to_map(mask_ijkl) @@ -90,8 +90,6 @@ subroutine add_integrals_to_map(mask_ijkl) call wall_time(wall_1) call cpu_time(cpu_1) - PROVIDE progress_bar - call start_progress(ao_num,'MO integrals (MB)',0.d0) !$OMP PARALLEL PRIVATE(l1,k1,j1,i1,i2,i3,i4,i,j,k,l,c, ii1,kmax, & !$OMP bielec_tmp_0_idx, bielec_tmp_0, bielec_tmp_1,bielec_tmp_2,bielec_tmp_3,& @@ -101,9 +99,10 @@ subroutine add_integrals_to_map(mask_ijkl) !$OMP SHARED(size_buffer,ao_num,mo_tot_num,n_i,n_j,n_k,n_l,mo_tot_num_align,& !$OMP mo_coef_transp, & !$OMP mo_coef_transp_is_built, list_ijkl, & - !$OMP mo_coef_is_built, wall_1, abort_here, & - !$OMP mo_coef,mo_integrals_threshold,mo_integrals_map,progress_bar,progress_value) + !$OMP mo_coef_is_built, wall_1, & + !$OMP mo_coef,mo_integrals_threshold,mo_integrals_map) n_integrals = 0 + wall_0 = wall_1 allocate(bielec_tmp_3(mo_tot_num_align, n_j, n_k), & bielec_tmp_1(mo_tot_num_align), & bielec_tmp_0(ao_num,ao_num), & @@ -112,20 +111,15 @@ subroutine add_integrals_to_map(mask_ijkl) buffer_i(size_buffer), & buffer_value(size_buffer) ) + thread_num = 0 !$ thread_num = omp_get_thread_num() !$OMP DO SCHEDULE(guided) do l1 = 1,ao_num - if (thread_num == 0) then - progress_bar(1) = l1 - endif -IRP_IF COARRAY - if (mod(l1-this_image(),num_images()) /= 0 ) then - cycle - endif -IRP_ENDIF - if (abort_here) then - cycle - endif +!IRP_IF COARRAY +! if (mod(l1-this_image(),num_images()) /= 0 ) then +! cycle +! endif +!IRP_ENDIF !DEC$ VECTOR ALIGNED bielec_tmp_3 = 0.d0 do k1 = 1,ao_num @@ -274,8 +268,6 @@ IRP_ENDIF wall_0 = wall_2 print*, 100.*float(l1)/float(ao_num), '% in ', & wall_2-wall_1, 's', map_mb(mo_integrals_map) ,'MB' - progress_value = dble(map_mb(mo_integrals_map)) - endif endif enddo @@ -286,14 +278,10 @@ IRP_ENDIF real(mo_integrals_threshold,integral_kind)) deallocate(buffer_i, buffer_value) !$OMP END PARALLEL - call stop_progress - if (abort_here) then - stop 'Aborting in MO integrals calculation' - endif -IRP_IF COARRAY - print*, 'Communicating the map' - call communicate_mo_integrals() -IRP_ENDIF +!IRP_IF COARRAY +! print*, 'Communicating the map' +! call communicate_mo_integrals() +!IRP_ENDIF call map_unique(mo_integrals_map) call wall_time(wall_2) @@ -354,7 +342,7 @@ end !$OMP PRIVATE (i,j,p,q,r,s,integral,c,n,pp,int_value,int_idx, & !$OMP iqrs, iqsr,iqri,iqis) & !$OMP SHARED(mo_tot_num,mo_coef_transp,mo_tot_num_align,ao_num,& - !$OMP ao_integrals_threshold,do_direct_integrals,abort_here) & + !$OMP ao_integrals_threshold,do_direct_integrals) & !$OMP REDUCTION(+:mo_bielec_integral_jj_from_ao,mo_bielec_integral_jj_exchange_from_ao) allocate( int_value(ao_num), int_idx(ao_num), & @@ -363,9 +351,6 @@ end !$OMP DO SCHEDULE (guided) do s=1,ao_num - if (abort_here) then - cycle - endif do q=1,ao_num do j=1,ao_num @@ -451,9 +436,6 @@ end !$OMP END DO NOWAIT deallocate(iqrs,iqsr,int_value,int_idx) !$OMP END PARALLEL - if (abort_here) then - stop 'Aborting in MO integrals calculation' - endif mo_bielec_integral_jj_anti_from_ao = mo_bielec_integral_jj_from_ao - mo_bielec_integral_jj_exchange_from_ao diff --git a/src/Integrals_Bielec/qp_ao_ints.irp.f b/src/Integrals_Bielec/qp_ao_ints.irp.f index dbeee9d7..f932df0f 100644 --- a/src/Integrals_Bielec/qp_ao_ints.irp.f +++ b/src/Integrals_Bielec/qp_ao_ints.irp.f @@ -1,9 +1,14 @@ program qp_ao_ints + use omp_lib implicit none BEGIN_DOC ! Increments a running calculation to compute AO integrals END_DOC + integer :: i + call switch_qp_run_to_master + + PROVIDE zmq_context ! Set the state of the ZMQ zmq_state = 'ao_integrals' @@ -11,8 +16,9 @@ program qp_ao_ints double precision :: integral, ao_bielec_integral integral = ao_bielec_integral(1,1,1,1) - !$OMP PARALLEL DEFAULT(PRIVATE) - call ao_bielec_integrals_in_map_slave_tcp + !$OMP PARALLEL DEFAULT(PRIVATE) PRIVATE(i) + i = omp_get_thread_num() + call ao_bielec_integrals_in_map_slave_tcp(i) !$OMP END PARALLEL print *, 'Done' diff --git a/src/Integrals_Monoelec/pot_ao_ints.irp.f b/src/Integrals_Monoelec/pot_ao_ints.irp.f index 3c23b458..9e64d5e2 100644 --- a/src/Integrals_Monoelec/pot_ao_ints.irp.f +++ b/src/Integrals_Monoelec/pot_ao_ints.irp.f @@ -139,6 +139,7 @@ double precision function NAI_pol_mult(A_center,B_center,power_A,power_B,alpha,b ! int{dr} of (x-A_x)^ax (x-B_X)^bx exp(-alpha (x-A_x)^2 - beta (x-B_x)^2 ) 1/(r-R_c) implicit none +integer, intent(in) :: n_pt_in double precision,intent(in) :: C_center(3),A_center(3),B_center(3),alpha,beta integer :: power_A(3),power_B(3) integer :: i,j,k,l,n_pt @@ -146,6 +147,8 @@ double precision :: P_center(3) double precision :: d(0:n_pt_in),pouet,coeff,rho,dist,const,pouet_2,p,p_inv,factor double precision :: I_n_special_exact,integrate_bourrin,I_n_bibi double precision :: V_e_n,const_factor,dist_integral,tmp +double precision :: accu,epsilo,rint +integer :: n_pt_out,lmax include 'Utils/constants.include.F' if ( (A_center(1)/=B_center(1)).or. & (A_center(2)/=B_center(2)).or. & @@ -198,8 +201,6 @@ include 'Utils/constants.include.F' NAI_pol_mult = 0.d0 return endif - double precision :: accu,epsilo,rint - integer :: n_pt_in,n_pt_out,lmax accu = 0.d0 ! 1/r1 standard attraction integral diff --git a/src/MO_Basis/mos.irp.f b/src/MO_Basis/mos.irp.f index 5756b7de..69abf7b3 100644 --- a/src/MO_Basis/mos.irp.f +++ b/src/MO_Basis/mos.irp.f @@ -146,9 +146,9 @@ subroutine ao_to_mo(A_ao,LDA_ao,A_mo,LDA_mo) BEGIN_DOC ! Transform A from the AO basis to the MO basis END_DOC + integer, intent(in) :: LDA_ao,LDA_mo double precision, intent(in) :: A_ao(LDA_ao) double precision, intent(out) :: A_mo(LDA_mo) - integer, intent(in) :: LDA_ao,LDA_mo double precision, allocatable :: T(:,:) allocate ( T(ao_num_align,mo_tot_num) ) @@ -172,9 +172,9 @@ subroutine mo_to_ao(A_mo,LDA_mo,A_ao,LDA_ao) BEGIN_DOC ! Transform A from the MO basis to the AO basis END_DOC + integer, intent(in) :: LDA_ao,LDA_mo double precision, intent(in) :: A_mo(LDA_mo) double precision, intent(out) :: A_ao(LDA_ao) - integer, intent(in) :: LDA_ao,LDA_mo double precision, allocatable :: T(:,:), SC(:,:) allocate ( SC(ao_num_align,mo_tot_num) ) @@ -204,9 +204,9 @@ subroutine mo_to_ao_no_overlap(A_mo,LDA_mo,A_ao,LDA_ao) BEGIN_DOC ! Transform A from the MO basis to the S^-1 AO basis END_DOC + integer, intent(in) :: LDA_ao,LDA_mo double precision, intent(in) :: A_mo(LDA_mo) double precision, intent(out) :: A_ao(LDA_ao) - integer, intent(in) :: LDA_ao,LDA_mo double precision, allocatable :: T(:,:) allocate ( T(mo_tot_num_align,ao_num) ) diff --git a/src/MO_Basis/utils.irp.f b/src/MO_Basis/utils.irp.f index 462addc0..aa2feead 100644 --- a/src/MO_Basis/utils.irp.f +++ b/src/MO_Basis/utils.irp.f @@ -76,22 +76,22 @@ subroutine mo_as_eigvectors_of_mo_matrix(matrix,n,m,label,sign) mo_coef_new = mo_coef call lapack_diag(eigvalues,R,A,n,m) - write (output_mo_basis,'(A)'), 'MOs are now **'//trim(label)//'**' - write (output_mo_basis,'(A)'), '' - write (output_mo_basis,'(A)'), 'Eigenvalues' - write (output_mo_basis,'(A)'), '-----------' - write (output_mo_basis,'(A)'), '' - write (output_mo_basis,'(A)'), '======== ================' + write (output_mo_basis,'(A)') 'MOs are now **'//trim(label)//'**' + write (output_mo_basis,'(A)') '' + write (output_mo_basis,'(A)') 'Eigenvalues' + write (output_mo_basis,'(A)') '-----------' + write (output_mo_basis,'(A)') '' + write (output_mo_basis,'(A)') '======== ================' if (sign == -1) then do i=1,m eigvalues(i) = -eigvalues(i) enddo endif do i=1,m - write (output_mo_basis,'(I8,X,F16.10)'), i,eigvalues(i) + write (output_mo_basis,'(I8,X,F16.10)') i,eigvalues(i) enddo - write (output_mo_basis,'(A)'), '======== ================' - write (output_mo_basis,'(A)'), '' + write (output_mo_basis,'(A)') '======== ================' + write (output_mo_basis,'(A)') '' call dgemm('N','N',ao_num,m,m,1.d0,mo_coef_new,size(mo_coef_new,1),R,size(R,1),0.d0,mo_coef,size(mo_coef,1)) deallocate(A,mo_coef_new,R,eigvalues) @@ -127,18 +127,18 @@ subroutine mo_as_svd_vectors_of_mo_matrix(matrix,lda,m,n,label) call svd(A,lda,U,lda,D,Vt,lda,m,n) - write (output_mo_basis,'(A)'), 'MOs are now **'//trim(label)//'**' - write (output_mo_basis,'(A)'), '' - write (output_mo_basis,'(A)'), 'Eigenvalues' - write (output_mo_basis,'(A)'), '-----------' - write (output_mo_basis,'(A)'), '' - write (output_mo_basis,'(A)'), '======== ================' + write (output_mo_basis,'(A)') 'MOs are now **'//trim(label)//'**' + write (output_mo_basis,'(A)') '' + write (output_mo_basis,'(A)') 'Eigenvalues' + write (output_mo_basis,'(A)') '-----------' + write (output_mo_basis,'(A)') '' + write (output_mo_basis,'(A)') '======== ================' do i=1,m - write (output_mo_basis,'(I8,X,F16.10)'), i,D(i) + write (output_mo_basis,'(I8,X,F16.10)') i,D(i) enddo - write (output_mo_basis,'(A)'), '======== ================' - write (output_mo_basis,'(A)'), '' + write (output_mo_basis,'(A)') '======== ================' + write (output_mo_basis,'(A)') '' call dgemm('N','N',ao_num,m,m,1.d0,mo_coef_new,size(mo_coef_new,1),U,size(U,1),0.d0,mo_coef,size(mo_coef,1)) deallocate(A,mo_coef_new,U,Vt,D) @@ -208,17 +208,17 @@ subroutine mo_as_eigvectors_of_mo_matrix_sort_by_observable(matrix,observable,n, print*,'' enddo - write (output_mo_basis,'(A)'), 'MOs are now **'//trim(label)//'**' - write (output_mo_basis,'(A)'), '' - write (output_mo_basis,'(A)'), 'Eigenvalues' - write (output_mo_basis,'(A)'), '-----------' - write (output_mo_basis,'(A)'), '' - write (output_mo_basis,'(A)'), '======== ================' + write (output_mo_basis,'(A)') 'MOs are now **'//trim(label)//'**' + write (output_mo_basis,'(A)') '' + write (output_mo_basis,'(A)') 'Eigenvalues' + write (output_mo_basis,'(A)') '-----------' + write (output_mo_basis,'(A)') '' + write (output_mo_basis,'(A)') '======== ================' do i = 1, m - write (output_mo_basis,'(I8,X,F16.10)'), i,eigvalues(i) + write (output_mo_basis,'(I8,X,F16.10)') i,eigvalues(i) enddo - write (output_mo_basis,'(A)'), '======== ================' - write (output_mo_basis,'(A)'), '' + write (output_mo_basis,'(A)') '======== ================' + write (output_mo_basis,'(A)') '' call dgemm('N','N',ao_num,m,m,1.d0,mo_coef_new,size(mo_coef_new,1),R,size(R,1),0.d0,mo_coef,size(mo_coef,1)) deallocate(mo_coef_new,R,eigvalues) @@ -256,8 +256,8 @@ subroutine mo_sort_by_observable(observable,label) enddo enddo - write (output_mo_basis,'(A)'), 'MOs are now **'//trim(label)//'**' - write (output_mo_basis,'(A)'), '' + write (output_mo_basis,'(A)') 'MOs are now **'//trim(label)//'**' + write (output_mo_basis,'(A)') '' deallocate(mo_coef_new,value) diff --git a/src/Utils/LinearAlgebra.irp.f b/src/Utils/LinearAlgebra.irp.f index dfa5d982..13138499 100644 --- a/src/Utils/LinearAlgebra.irp.f +++ b/src/Utils/LinearAlgebra.irp.f @@ -277,10 +277,10 @@ subroutine apply_rotation(A,LDA,R,LDR,B,LDB,m,n) BEGIN_DOC ! Apply the rotation found by find_rotation END_DOC + integer, intent(in) :: m,n, LDA, LDB, LDR double precision, intent(in) :: R(LDR,n) double precision, intent(in) :: A(LDA,n) double precision, intent(out) :: B(LDB,n) - integer, intent(in) :: m,n, LDA, LDB, LDR call dgemm('N','N',m,n,n,1.d0,A,LDA,R,LDR,0.d0,B,LDB) end diff --git a/src/Utils/abort.irp.f b/src/Utils/abort.irp.f deleted file mode 100644 index ec33fdb2..00000000 --- a/src/Utils/abort.irp.f +++ /dev/null @@ -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 - diff --git a/src/Utils/map_module.f90 b/src/Utils/map_module.f90 index 5c883c9b..47adc83e 100644 --- a/src/Utils/map_module.f90 +++ b/src/Utils/map_module.f90 @@ -76,7 +76,6 @@ subroutine cache_map_init(map,sze) NULLIFY(map%value, map%key) call cache_map_reallocate(map,sze) call omp_unset_lock(map%lock) - end subroutine map_init(map,keymax) diff --git a/src/Utils/progress.irp.f b/src/Utils/progress.irp.f index 129748f2..2320253f 100644 --- a/src/Utils/progress.irp.f +++ b/src/Utils/progress.irp.f @@ -59,8 +59,8 @@ recursive subroutine run_progress write(unit=0,fmt="(a1,a1,a70)") '+',char(13), bar else prog = int( progress_bar(1)*100./progress_bar(2) ) - write(bar(1:25),'(A)'),progress_title - write(bar(29:47),'(G17.10)'),progress_value + write(bar(1:25),'(A)') progress_title + write(bar(29:47),'(G17.10)') progress_value write(bar(72:74),'(i3)') prog integer :: k,j diff --git a/src/Utils/sort.irp.f b/src/Utils/sort.irp.f index 572cc353..b0decc33 100644 --- a/src/Utils/sort.irp.f +++ b/src/Utils/sort.irp.f @@ -6,9 +6,9 @@ BEGIN_TEMPLATE ! iorder in input should be (1,2,3,...,isize), and in output ! contains the new order of the elements. END_DOC + integer,intent(in) :: isize $type,intent(inout) :: x(isize) integer,intent(inout) :: iorder(isize) - integer,intent(in) :: isize $type :: xtmp integer :: i, i0, j, jmax @@ -36,9 +36,9 @@ BEGIN_TEMPLATE ! iorder in input should be (1,2,3,...,isize), and in output ! contains the new order of the elements. END_DOC + integer,intent(in) :: isize $type,intent(inout) :: x(isize) integer,intent(inout) :: iorder(isize) - integer,intent(in) :: isize integer :: i, k, j, l, i0 $type :: xtemp @@ -101,9 +101,9 @@ BEGIN_TEMPLATE ! This is a version for very large arrays where the indices need ! to be in integer*8 format END_DOC + integer*8,intent(in) :: isize $type,intent(inout) :: x(isize) integer*8,intent(inout) :: iorder(isize) - integer*8,intent(in) :: isize integer*8 :: i, k, j, l, i0 $type :: xtemp @@ -165,9 +165,9 @@ BEGIN_TEMPLATE ! iorder in input should be (1,2,3,...,isize), and in output ! contains the new order of the elements. END_DOC + integer,intent(in) :: isize $type,intent(inout) :: x(isize) integer,intent(inout) :: iorder(isize) - integer,intent(in) :: isize if (isize < 32) then call insertion_$Xsort(x,iorder,isize) else @@ -226,9 +226,9 @@ BEGIN_TEMPLATE ! This is a version for very large arrays where the indices need ! to be in integer*8 format END_DOC + integer*8,intent(in) :: isize $type,intent(inout) :: x(isize) integer*8,intent(inout) :: iorder(isize) - integer*8,intent(in) :: isize $type :: xtmp integer*8 :: i, i0, j, jmax @@ -298,6 +298,7 @@ BEGIN_TEMPLATE integer, intent(in) :: iradix integer :: iradix_new $type, allocatable :: x2(:), x1(:) + $type :: i4 $int_type, allocatable :: iorder1(:),iorder2(:) $int_type :: i0, i1, i2, i3, i integer, parameter :: integer_size=$octets @@ -311,11 +312,12 @@ BEGIN_TEMPLATE ! Find most significant bit i0 = 0_8 - i3 = -1_8 + i4 = -1_8 do i=1,isize - i3 = max(i3,x(i)) + i4 = max(i4,x(i)) enddo + i3 = i4 ! Type conversion iradix_new = integer_size-1-leadz(i3) mask = ibset(zero,iradix_new) diff --git a/src/Utils/util.irp.f b/src/Utils/util.irp.f index 02cd87f9..a5904183 100644 --- a/src/Utils/util.irp.f +++ b/src/Utils/util.irp.f @@ -295,6 +295,18 @@ BEGIN_PROVIDER [ integer, nproc ] !$OMP END PARALLEL END_PROVIDER +BEGIN_PROVIDER [ integer, iproc_save, (nproc) ] + implicit none + BEGIN_DOC + ! iproc_save(i) = i-1. Used to start threads with pthreads. + END_DOC + integer :: i + do i=1,nproc + iproc_save(i) = i-1 + enddo + +END_PROVIDER + double precision function u_dot_v(u,v,sze) implicit none @@ -401,5 +413,21 @@ end - +subroutine lowercase(txt,n) + implicit none + BEGIN_DOC +! Transform to lower case + END_DOC + character*(*), intent(inout) :: txt + integer, intent(in) :: n + character( * ), PARAMETER :: LOWER_CASE = 'abcdefghijklmnopqrstuvwxyz' + character( * ), PARAMETER :: UPPER_CASE = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' + integer :: i, ic + do i=1,n + ic = index( UPPER_CASE, txt(i:i) ) + if (ic /= 0) then + txt(i:i) = LOWER_CASE(ic:ic) + endif + enddo +end diff --git a/src/ZMQ/utils.irp.f b/src/ZMQ/utils.irp.f new file mode 100644 index 00000000..b1bc2795 --- /dev/null +++ b/src/ZMQ/utils.irp.f @@ -0,0 +1,730 @@ +use f77_zmq +use omp_lib + +integer, pointer :: thread_id +integer(omp_lock_kind) :: zmq_lock + + +BEGIN_PROVIDER [ integer(ZMQ_PTR), zmq_context ] + use f77_zmq + implicit none + BEGIN_DOC + ! Context for the ZeroMQ library + END_DOC + call omp_init_lock(zmq_lock) + zmq_context = f77_zmq_ctx_new () +END_PROVIDER + + + BEGIN_PROVIDER [ character*(128), qp_run_address ] +&BEGIN_PROVIDER [ integer, zmq_port_start ] + use f77_zmq + implicit none + BEGIN_DOC + ! Address of the qp_run socket + ! Example : tcp://130.120.229.139:12345 + END_DOC + character*(128) :: buffer + call getenv('QP_RUN_ADDRESS',buffer) + if (trim(buffer) == '') then + print *, 'This run should be started with the qp_run command' + stop -1 + endif + + integer :: i + do i=len(buffer),1,-1 + if ( buffer(i:i) == ':') then + qp_run_address = trim(buffer(1:i-1)) + read(buffer(i+1:), *) zmq_port_start + exit + endif + enddo +END_PROVIDER + + BEGIN_PROVIDER [ character*(128), zmq_socket_pull_tcp_address ] +&BEGIN_PROVIDER [ character*(128), zmq_socket_pair_inproc_address ] +&BEGIN_PROVIDER [ character*(128), zmq_socket_push_tcp_address ] +&BEGIN_PROVIDER [ character*(128), zmq_socket_pull_inproc_address ] +&BEGIN_PROVIDER [ character*(128), zmq_socket_push_inproc_address ] + use f77_zmq + implicit none + BEGIN_DOC + ! Socket which pulls the results (2) + END_DOC + + character*(8), external :: zmq_port + zmq_socket_pull_tcp_address = 'tcp://*:'//zmq_port(1)//' ' + zmq_socket_push_tcp_address = trim(qp_run_address)//':'//zmq_port(1)//' ' + zmq_socket_pull_inproc_address = 'inproc://'//zmq_port(1)//' ' + zmq_socket_push_inproc_address = zmq_socket_pull_inproc_address + zmq_socket_pair_inproc_address = 'inproc://'//zmq_port(2)//' ' +END_PROVIDER + +subroutine reset_zmq_addresses + use f77_zmq + implicit none + character*(8), external :: zmq_port + + zmq_socket_pull_tcp_address = 'tcp://*:'//zmq_port(1)//' ' + zmq_socket_push_tcp_address = trim(qp_run_address)//':'//zmq_port(1)//' ' + zmq_socket_pull_inproc_address = 'inproc://'//zmq_port(1)//' ' + zmq_socket_push_inproc_address = zmq_socket_pull_inproc_address + zmq_socket_pair_inproc_address = 'inproc://'//zmq_port(2)//' ' +end + + +subroutine switch_qp_run_to_master + use f77_zmq + implicit none + BEGIN_DOC + ! Address of the master qp_run socket + ! Example : tcp://130.120.229.139:12345 + END_DOC + character*(128) :: buffer + call getenv('QP_RUN_ADDRESS_MASTER',buffer) + if (trim(buffer) == '') then + print *, 'This run should be started with the qp_run command' + stop -1 + endif + qp_run_address = trim(buffer) + + integer :: i + do i=len(buffer),1,-1 + if ( buffer(i:i) == ':') then + qp_run_address = trim(buffer(1:i-1)) + read(buffer(i+1:), *) zmq_port_start + exit + endif + enddo + + call reset_zmq_addresses + +end + + +function zmq_port(ishift) + use f77_zmq + implicit none + BEGIN_DOC + ! Return the value of the ZMQ port from the corresponding integer + END_DOC + integer, intent(in) :: ishift + character*(8) :: zmq_port + write(zmq_port,'(I8)') zmq_port_start+ishift + zmq_port = adjustl(trim(zmq_port)) +end + + +function new_zmq_to_qp_run_socket() + use f77_zmq + implicit none + BEGIN_DOC + ! Socket on which the qp_run process replies + END_DOC + integer :: rc + character*(8), external :: zmq_port + integer(ZMQ_PTR) :: new_zmq_to_qp_run_socket + + call omp_set_lock(zmq_lock) + new_zmq_to_qp_run_socket = f77_zmq_socket(zmq_context, ZMQ_REQ) + call omp_unset_lock(zmq_lock) + if (new_zmq_to_qp_run_socket == 0_ZMQ_PTR) then + stop 'Unable to create zmq req socket' + endif + + rc = f77_zmq_connect(new_zmq_to_qp_run_socket, trim(qp_run_address)//':'//trim(zmq_port(0))) + if (rc /= 0) then + stop 'Unable to connect new_zmq_to_qp_run_socket' + endif + + rc = f77_zmq_setsockopt(new_zmq_to_qp_run_socket, ZMQ_SNDTIMEO, 120000, 4) + if (rc /= 0) then + stop 'Unable to set send timout in new_zmq_to_qp_run_socket' + endif + + rc = f77_zmq_setsockopt(new_zmq_to_qp_run_socket, ZMQ_RCVTIMEO, 120000, 4) + if (rc /= 0) then + stop 'Unable to set recv timout in new_zmq_to_qp_run_socket' + endif + +end + + +function new_zmq_pair_socket(bind) + use f77_zmq + implicit none + BEGIN_DOC + ! Socket on which the collector and the main communicate + END_DOC + logical :: bind + integer :: rc + character*(8), external :: zmq_port + integer(ZMQ_PTR) :: new_zmq_pair_socket + + call omp_set_lock(zmq_lock) + new_zmq_pair_socket = f77_zmq_socket(zmq_context, ZMQ_PAIR) + call omp_unset_lock(zmq_lock) + if (new_zmq_pair_socket == 0_ZMQ_PTR) then + stop 'Unable to create zmq pair socket' + endif + + if (bind) then + rc = f77_zmq_bind(new_zmq_pair_socket,zmq_socket_pair_inproc_address) + if (rc /= 0) then + print *, 'f77_zmq_bind(new_zmq_pair_socket, zmq_socket_pair_inproc_address)' + stop 'error' + endif + else + rc = f77_zmq_connect(new_zmq_pair_socket,zmq_socket_pair_inproc_address) + if (rc /= 0) then + stop 'Unable to connect new_zmq_pair_socket' + endif + endif + + rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_SNDHWM, 0, 4) + if (rc /= 0) then + stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_SNDHWM, 0, 4)' + endif + + rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_RCVHWM, 0, 4) + if (rc /= 0) then + stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_RCVHWM, 0, 4)' + endif + + rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_IMMEDIATE, 1, 4) + if (rc /= 0) then + stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_IMMEDIATE, 1, 4)' + endif + + rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_LINGER, 600000, 4) + if (rc /= 0) then + stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_LINGER, 60000, 4)' + endif + +end + + + + +function new_zmq_pull_socket() + use f77_zmq + implicit none + BEGIN_DOC + ! Socket on which the results are sent. If thread is 1, use inproc + END_DOC + integer :: rc + character*(8), external :: zmq_port + integer(ZMQ_PTR) :: new_zmq_pull_socket + + call omp_set_lock(zmq_lock) + new_zmq_pull_socket = f77_zmq_socket(zmq_context, ZMQ_PULL) +! new_zmq_pull_socket = f77_zmq_socket(zmq_context, ZMQ_REP) + call omp_unset_lock(zmq_lock) + if (new_zmq_pull_socket == 0_ZMQ_PTR) then + stop 'Unable to create zmq pull socket' + endif + + rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_LINGER,300000,4) + if (rc /= 0) then + stop 'Unable to set ZMQ_LINGER on pull socket' + endif + + rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_RCVHWM,100000,4) + if (rc /= 0) then + stop 'Unable to set ZMQ_RCVHWM on pull socket' + endif + + rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_IMMEDIATE,1,4) + if (rc /= 0) then + stop 'Unable to set ZMQ_IMMEDIATE on pull socket' + endif + + rc = f77_zmq_bind(new_zmq_pull_socket, zmq_socket_pull_tcp_address) + if (rc /= 0) then + print *, 'Unable to bind new_zmq_pull_socket (tcp)', zmq_socket_pull_tcp_address + stop + endif + + rc = f77_zmq_bind(new_zmq_pull_socket, zmq_socket_pull_inproc_address) + if (rc /= 0) then + stop 'Unable to bind new_zmq_pull_socket (inproc)' + endif + +end + + + + +function new_zmq_push_socket(thread) + use f77_zmq + implicit none + BEGIN_DOC + ! Socket on which the results are sent. If thread is 1, use inproc + END_DOC + integer, intent(in) :: thread + integer :: rc + character*(8), external :: zmq_port + integer(ZMQ_PTR) :: new_zmq_push_socket + + call omp_set_lock(zmq_lock) + new_zmq_push_socket = f77_zmq_socket(zmq_context, ZMQ_PUSH) +! new_zmq_push_socket = f77_zmq_socket(zmq_context, ZMQ_REQ) + call omp_unset_lock(zmq_lock) + if (new_zmq_push_socket == 0_ZMQ_PTR) then + stop 'Unable to create zmq push socket' + endif + + rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_LINGER,300000,4) + if (rc /= 0) then + stop 'Unable to set ZMQ_LINGER on push socket' + endif + + rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_SNDHWM,100,4) + if (rc /= 0) then + stop 'Unable to set ZMQ_SNDHWM on push socket' + endif + + rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_IMMEDIATE,1,4) + if (rc /= 0) then + stop 'Unable to set ZMQ_IMMEDIATE on push socket' + endif + + rc = f77_zmq_setsockopt(new_zmq_push_socket, ZMQ_SNDTIMEO, 100000, 4) + if (rc /= 0) then + stop 'Unable to set send timout in new_zmq_push_socket' + endif + + if (thread == 1) then + rc = f77_zmq_connect(new_zmq_push_socket, zmq_socket_push_inproc_address) + else + rc = f77_zmq_connect(new_zmq_push_socket, zmq_socket_push_tcp_address) + endif + if (rc /= 0) then + stop 'Unable to connect new_zmq_push_socket' + endif + +end + + + +subroutine end_zmq_pair_socket(zmq_socket_pair) + use f77_zmq + implicit none + BEGIN_DOC + ! Terminate socket on which the results are sent. + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_socket_pair + integer :: rc + character*(8), external :: zmq_port + + rc = f77_zmq_unbind(zmq_socket_pair,zmq_socket_pair_inproc_address) +! if (rc /= 0) then +! print *, rc +! print *, irp_here, 'f77_zmq_unbind(zmq_socket_pair,zmq_socket_pair_inproc_address)' +! stop 'error' +! endif + + rc = f77_zmq_close(zmq_socket_pair) + if (rc /= 0) then + print *, 'f77_zmq_close(zmq_socket_pair)' + stop 'error' + endif + +end + +subroutine end_zmq_pull_socket(zmq_socket_pull) + use f77_zmq + implicit none + BEGIN_DOC + ! Terminate socket on which the results are sent. + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_socket_pull + integer :: rc + character*(8), external :: zmq_port + + rc = f77_zmq_unbind(zmq_socket_pull,zmq_socket_pull_inproc_address) +! if (rc /= 0) then +! print *, rc +! print *, irp_here, 'f77_zmq_unbind(zmq_socket_pull,zmq_socket_pull_inproc_address)' +! stop 'error' +! endif + + rc = f77_zmq_unbind(zmq_socket_pull,zmq_socket_pull_tcp_address) + if (rc /= 0) then + print *, rc + print *, irp_here, 'f77_zmq_unbind(zmq_socket_pull,zmq_socket_pull_tcp_address)' + stop 'error' + endif + + rc = f77_zmq_close(zmq_socket_pull) + if (rc /= 0) then + print *, 'f77_zmq_close(zmq_socket_pull)' + stop 'error' + endif + +end + + +subroutine end_zmq_push_socket(zmq_socket_push,thread) + implicit none + use f77_zmq + BEGIN_DOC + ! Terminate socket on which the results are sent. + END_DOC + integer, intent(in) :: thread + integer(ZMQ_PTR), intent(in) :: zmq_socket_push + integer :: rc + character*(8), external :: zmq_port + + if (thread == 1) then + rc = f77_zmq_disconnect(zmq_socket_push,zmq_socket_push_inproc_address) +! if (rc /= 0) then +! print *, 'f77_zmq_disconnect(zmq_socket_push,zmq_socket_push_inproc_address)' +! stop 'error' +! endif + else + rc = f77_zmq_disconnect(zmq_socket_push,zmq_socket_push_tcp_address) + if (rc /= 0) then + print *, 'f77_zmq_disconnect(zmq_socket_push,zmq_socket_push_tcp_address)' + stop 'error' + endif + endif + + + rc = f77_zmq_close(zmq_socket_push) + if (rc /= 0) then + print *, 'f77_zmq_close(zmq_socket_push)' + stop 'error' + endif + +end + + + +BEGIN_PROVIDER [ character*(128), zmq_state ] + implicit none + BEGIN_DOC + ! Threads executing work through the ZeroMQ interface + END_DOC + zmq_state = 'No_state' +END_PROVIDER + +subroutine new_parallel_job(zmq_to_qp_run_socket,name_in) + use f77_zmq + implicit none + BEGIN_DOC + ! Start a new parallel job with name 'name'. The slave tasks execute subroutine 'slave' + END_DOC + character*(*), intent(in) :: name_in + + character*(512) :: message, name + integer :: rc, sze + integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR), intent(out) :: zmq_to_qp_run_socket + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + name = name_in + sze = len(trim(name)) + call lowercase(name,sze) + message = 'new_job '//trim(name)//' '//zmq_socket_push_tcp_address//' '//zmq_socket_pull_inproc_address + sze = len(trim(message)) + rc = f77_zmq_send(zmq_to_qp_run_socket,message,sze,0) + if (rc /= sze) then + print *, irp_here, ':f77_zmq_send(zmq_to_qp_run_socket,message,sze,0)' + stop 'error' + endif + rc = f77_zmq_recv(zmq_to_qp_run_socket,message,510,0) + message = trim(message(1:rc)) + if (message(1:2) /= 'ok') then + print *, message + print *, 'Unable to start parallel job : '//name + stop 1 + endif + + zmq_state = trim(name) + +end + + +subroutine end_parallel_job(zmq_to_qp_run_socket,name_in) + use f77_zmq + implicit none + BEGIN_DOC + ! End a new parallel job with name 'name'. The slave tasks execute subroutine 'slave' + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + character*(*), intent(in) :: name_in + + character*(512) :: message, name + integer :: i,rc, sze + + name = name_in + sze = len(trim(name)) + call lowercase(name,sze) + if (name /= zmq_state) then + stop 'Wrong end of job' + endif + + rc = f77_zmq_send(zmq_to_qp_run_socket, 'end_job '//trim(zmq_state),8+len(trim(zmq_state)),0) + rc = f77_zmq_recv(zmq_to_qp_run_socket, zmq_state, 2, 0) + if (rc /= 2) then + print *, 'f77_zmq_recv(zmq_to_qp_run_socket, zmq_state, 2, 0)' + stop 'error' + endif + zmq_state = 'No_state' + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + +end + +subroutine connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) + use f77_zmq + implicit none + BEGIN_DOC + ! Connect to the task server and obtain the worker ID + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + integer, intent(out) :: worker_id + integer, intent(in) :: thread + + character*(512) :: message + character*(128) :: reply, state, address + integer :: rc + + if (thread == 1) then + rc = f77_zmq_send(zmq_to_qp_run_socket, "connect inproc", 14, 0) + if (rc /= 14) then + print *, 'f77_zmq_send(zmq_to_qp_run_socket, "connect inproc", 14, 0)' + stop 'error' + endif + else + rc = f77_zmq_send(zmq_to_qp_run_socket, "connect tcp", 11, 0) + if (rc /= 11) then + print *, 'f77_zmq_send(zmq_to_qp_run_socket, "connect tcp", 11, 0)' + stop 'error' + endif + endif + + rc = f77_zmq_recv(zmq_to_qp_run_socket, message, 510, 0) + message = trim(message(1:rc)) + read(message,*) reply, state, worker_id, address + if ( (trim(reply) /= 'connect_reply') .and. & + (trim(state) /= trim(zmq_state)) ) then + print *, 'Reply: ', trim(reply) + print *, 'State: ', trim(state), '/', trim(zmq_state) + print *, 'Address: ', trim(address) + stop -1 + endif + +end + +subroutine disconnect_from_taskserver(zmq_to_qp_run_socket, & + zmq_socket_push, worker_id) + use f77_zmq + implicit none + BEGIN_DOC + ! Disconnect from the task server + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + integer(ZMQ_PTR), intent(in) :: zmq_socket_push + integer, intent(in) :: worker_id + + integer :: rc, sze + character*(64) :: message, reply, state + write(message,*) 'disconnect '//trim(zmq_state), worker_id + + sze = len(trim(message)) + rc = f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0) + if (rc /= sze) then + print *, rc, sze + print *, irp_here, 'f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0)' + stop 'error' + endif + + rc = f77_zmq_recv(zmq_to_qp_run_socket, message, 510, 0) + message = trim(message(1:rc)) + + read(message,*) reply, state + if ( (trim(reply) /= 'disconnect_reply').or. & + (trim(state) /= zmq_state) ) then + print *, 'Unable to disconnect : ', zmq_state + print *, trim(message) + stop -1 + endif + +end + +subroutine add_task_to_taskserver(zmq_to_qp_run_socket,task) + use f77_zmq + implicit none + BEGIN_DOC + ! Get a task from the task server + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + character*(*), intent(in) :: task + + integer :: rc, sze + character*(512) :: message + write(message,*) 'add_task '//trim(zmq_state)//' '//trim(task) + + sze = len(trim(message)) + rc = f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0) + if (rc /= sze) then + print *, rc, sze + print *, irp_here,': f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0)' + stop 'error' + endif + + rc = f77_zmq_recv(zmq_to_qp_run_socket, message, 510, 0) + message = trim(message(1:rc)) + if (trim(message) /= 'ok') then + print *, trim(task) + print *, 'Unable to add the next task' + stop -1 + endif + +end + +subroutine task_done_to_taskserver(zmq_to_qp_run_socket,worker_id, task_id) + use f77_zmq + implicit none + BEGIN_DOC + ! Get a task from the task server + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + integer, intent(in) :: worker_id, task_id + + integer :: rc, sze + character*(512) :: message + write(message,*) 'task_done '//trim(zmq_state), worker_id, task_id + + sze = len(trim(message)) + rc = f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0) + if (rc /= sze) then + print *, irp_here, 'f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0)' + stop 'error' + endif + + rc = f77_zmq_recv(zmq_to_qp_run_socket, message, 510, 0) + message = trim(message(1:rc)) + if (trim(message) /= 'ok') then + print *, 'Unable to send task_done message' + stop -1 + endif + +end + +subroutine get_task_from_taskserver(zmq_to_qp_run_socket,worker_id,task_id,task) + use f77_zmq + implicit none + BEGIN_DOC + ! Get a task from the task server + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + integer, intent(in) :: worker_id + integer, intent(out) :: task_id + character*(512), intent(out) :: task + + character*(512) :: message + character*(64) :: reply + integer :: rc, sze + + write(message,*) 'get_task '//trim(zmq_state), worker_id + + sze = len(trim(message)) + rc = f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0) + if (rc /= sze) then + print *, irp_here, ':f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0)' + stop 'error' + endif + + rc = f77_zmq_recv(zmq_to_qp_run_socket, message, 510, 0) + message = trim(message(1:rc)) + read(message,*) reply + if (trim(reply) == 'get_task_reply') then + read(message,*) reply, task_id + rc = 15 + do while (message(rc:rc) == ' ') + rc += 1 + enddo + do while (message(rc:rc) /= ' ') + rc += 1 + enddo + rc += 1 + task = message(rc:) + else if (trim(reply) == 'terminate') then + task_id = 0 + task = 'terminate' + else + print *, 'Unable to get the next task' + print *, trim(message) + stop -1 + endif + +end + + +subroutine end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + use f77_zmq + implicit none + BEGIN_DOC +! Terminate the socket from the application to qp_run + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + character*(8), external :: zmq_port + integer :: rc + + rc = f77_zmq_disconnect(zmq_to_qp_run_socket, trim(qp_run_address)//':'//trim(zmq_port(0))) +! if (rc /= 0) then +! print *, 'f77_zmq_disconnect(zmq_to_qp_run_socket, trim(qp_run_address)//'':''//trim(zmq_port(0)))' +! stop 'error' +! endif + + rc = f77_zmq_close(zmq_to_qp_run_socket) + if (rc /= 0) then + print *, 'f77_zmq_close(zmq_to_qp_run_socket)' + stop 'error' + endif + +end + +subroutine zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more) + use f77_zmq + implicit none + BEGIN_DOC +! When a task is done, it has to be removed from the list of tasks on the qp_run +! queue. This guarantees that the results have been received in the pull. + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_socket_pull + integer, intent(in) :: task_id + integer, intent(out) :: more + integer :: rc + character*(512) :: msg + + write(msg,*) 'del_task ', zmq_state, task_id + rc = f77_zmq_send(zmq_to_qp_run_socket,msg,512,0) + if (rc /= 512) then + print *, 'f77_zmq_send(zmq_to_qp_run_socket,task_id,4,0)' + stop 'error' + endif + + character*(64) :: reply + reply = '' + rc = f77_zmq_recv(zmq_to_qp_run_socket,reply,64,0) + + if (reply(16:19) == 'more') then + more = 1 + else if (reply(16:19) == 'done') then + more = 0 + rc = f77_zmq_setsockopt(zmq_socket_pull, ZMQ_RCVTIMEO, 1000, 4) + if (rc /= 0) then + print *, 'f77_zmq_setsockopt(zmq_socket_pull, ZMQ_RCVTIMEO, 3000, 4)' + stop 'error' + endif + else + print *, reply + print *, 'f77_zmq_recv(zmq_to_qp_run_socket,reply,64,0)' + stop 'error' + endif +end + diff --git a/src/ZMQ/zmq.irp.f b/src/ZMQ/zmq.irp.f deleted file mode 100644 index 234271a0..00000000 --- a/src/ZMQ/zmq.irp.f +++ /dev/null @@ -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 - diff --git a/tests/bats/qp.bats b/tests/bats/qp.bats index 892d1a1b..de0cd1c8 100644 --- a/tests/bats/qp.bats +++ b/tests/bats/qp.bats @@ -24,8 +24,6 @@ function eq() { } - - # ___ # | ._ o _|_ # _|_ | | | |_ @@ -59,20 +57,20 @@ function run_HF() { test_exe SCF || skip ezfio set_file $1 ezfio set hartree_fock thresh_scf 1.e-10 - qp_run SCF $1 + qp_run SCF $1 energy="$(ezfio get hartree_fock energy)" eq $energy $2 $thresh } function run_FCI() { - thresh=1.e-5 + thresh=5.e-5 test_exe full_ci || skip ezfio set_file $1 ezfio set perturbation do_pt2_end True ezfio set determinants n_det_max $2 ezfio set determinants threshold_davidson 1.e-10 - qp_run full_ci $1 + qp_run full_ci $1 energy="$(ezfio get full_ci energy)" eq $energy $3 $thresh energy_pt2="$(ezfio get full_ci energy_pt2)" @@ -132,7 +130,8 @@ function run_all_1h_1p() { } @test "FCI H2O cc-pVDZ" { - run_FCI h2o.ezfio 10000 -0.762382562429778E+02 -0.762433933485226E+02 + qp_set_mo_class h2o.ezfio -core "[1]" -act "[2-12]" -del "[13-24]" + run_FCI h2o.ezfio 2000 -0.761255633582109E+02 -0.761258377850042E+02 } @test "CAS_SD H2O cc-pVDZ" { @@ -141,8 +140,8 @@ function run_all_1h_1p() { ezfio set_file $INPUT ezfio set perturbation do_pt2_end False ezfio set determinants n_det_max 1000 - qp_set_mo_class $INPUT -core "[1]" -inact "[2,5]" -act "[3,4,6,7]" -virt "[8-24]" - qp_run cas_sd_selected $INPUT + qp_set_mo_class $INPUT -core "[1]" -inact "[2,5]" -act "[3,4,6,7]" -virt "[8-24]" + qp_run cas_sd_selected $INPUT energy="$(ezfio get cas_sd energy)" eq $energy -0.762219854008117E+02 1.E-5 } @@ -154,7 +153,7 @@ function run_all_1h_1p() { ezfio set determinants threshold_generators 1. ezfio set determinants threshold_selectors 1. ezfio set determinants read_wf True - qp_run mrcc_cassd $INPUT + qp_run mrcc_cassd $INPUT energy="$(ezfio get mrcc_cassd energy)" eq $energy -0.762303253805911E+02 1.E-3 @@ -171,7 +170,8 @@ function run_all_1h_1p() { } @test "FCI H2O VDZ pseudo" { - run_FCI h2o_pseudo.ezfio 2000 -0.171550015498807E+02 -0.171645044185009E+02 + qp_set_mo_class h2o_pseudo.ezfio -core "[1]" -act "[2-12]" -del "[13-23]" + run_FCI h2o_pseudo.ezfio 2000 -0.170399597228904E+02 -0.170400168816800E+02 } #=== Convert @@ -179,7 +179,7 @@ function run_all_1h_1p() { cp ${QP_ROOT}/tests/input/HBO.out . qp_convert_output_to_ezfio.py HBO.out ezfio set_file HBO.out.ezfio - qp_run SCF HBO.out.ezfio + qp_run SCF HBO.out.ezfio # Check energy energy="$(ezfio get hartree_fock energy)" eq $energy -100.0185822590964 1.e-10 @@ -189,7 +189,7 @@ function run_all_1h_1p() { cp ${QP_ROOT}/tests/input/h2o.log . qp_convert_output_to_ezfio.py h2o.log ezfio set_file h2o.log.ezfio - qp_run SCF h2o.log.ezfio + qp_run SCF h2o.log.ezfio # Check energy energy="$(ezfio get hartree_fock energy)" eq $energy -76.0270218704265 1E-10 diff --git a/tests/bats_to_sh.py b/tests/bats_to_sh.py new file mode 100755 index 00000000..2c6b4a05 --- /dev/null +++ b/tests/bats_to_sh.py @@ -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") + + + diff --git a/tests/run_tests.sh b/tests/run_tests.sh index 96f299f9..2436c60c 100755 --- a/tests/run_tests.sh +++ b/tests/run_tests.sh @@ -1,6 +1,18 @@ #!/bin/bash -rm -rf work -exec bats bats/qp.bats +export QP_PREFIX="timeout -s 9 300" +export QP_TASK_DEBUG=1 + +BATS_FILE=bats/qp.bats + +rm -rf work output + +if [[ "$1" == "-v" ]] +then + echo "Verbose mode" + ./bats_to_sh.py $BATS_FILE | bash +else + bats $BATS_FILE +fi From 9cb91395373697cb5d9640d89d8a7a9eeec62c34 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 19 Feb 2016 15:07:38 +0100 Subject: [PATCH 02/23] Remove dead code --- plugins/Selectors_full/selectors.irp.f | 97 ----------- plugins/Selectors_no_sorted/selectors.irp.f | 97 ----------- src/Determinants/determinants.irp.f | 184 -------------------- 3 files changed, 378 deletions(-) diff --git a/plugins/Selectors_full/selectors.irp.f b/plugins/Selectors_full/selectors.irp.f index 73ae6371..826dcc4b 100644 --- a/plugins/Selectors_full/selectors.irp.f +++ b/plugins/Selectors_full/selectors.irp.f @@ -61,100 +61,3 @@ END_PROVIDER END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), psi_selectors_ab, (N_int,2,psi_selectors_size) ] -&BEGIN_PROVIDER [ double precision, psi_selectors_coef_ab, (psi_selectors_size,N_states) ] -&BEGIN_PROVIDER [ integer, psi_selectors_next_ab, (2,psi_selectors_size) ] - implicit none - BEGIN_DOC - ! Determinants on which we apply . - ! 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. - ! 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<--- 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_8), i+ishft(k-1,bit_kind_shift)) - icount -= 1 - if (icount == 0) then - return - endif - enddo - enddo -end - -subroutine filter_3_highest_electrons( det_in, det_out, Nint ) - implicit none - use bitmasks - integer,intent(in) :: Nint - integer(bit_kind) :: det_in(Nint), det_out(Nint) - BEGIN_DOC -! Returns a determinant with only the 3 highest electrons - END_DOC - integer :: i, k, icount - integer(bit_kind) :: ix - det_out = 0_8 - icount = 3 - do k=Nint,1,-1 - ix = det_in(k) - do while (ix /= 0_bit_kind) - i = bit_kind_size-1-leadz(ix) - ix = ibclr(ix,i) - det_out(k) = ibset(det_out(k),i) - icount -= 1 - if (icount == 0) then - return - endif - enddo - enddo -end BEGIN_PROVIDER [ double precision, psi_coef_max, (N_states) ] &BEGIN_PROVIDER [ double precision, psi_coef_min, (N_states) ] @@ -465,130 +405,6 @@ end END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_ab, (N_int,2,psi_det_size) ] -&BEGIN_PROVIDER [ double precision, psi_coef_sorted_ab, (N_det,N_states) ] -&BEGIN_PROVIDER [ integer, psi_det_sorted_next_ab, (2,psi_det_size) ] - implicit none - BEGIN_DOC - ! Determinants on which we apply . - ! 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 . - ! 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 Date: Fri, 19 Feb 2016 18:46:46 +0100 Subject: [PATCH 03/23] Removed qp_edit.ml from repository --- ocaml/qp_edit.ml | 314 ----------------------------------------------- 1 file changed, 314 deletions(-) delete mode 100644 ocaml/qp_edit.ml diff --git a/ocaml/qp_edit.ml b/ocaml/qp_edit.ml deleted file mode 100644 index 67dc9501..00000000 --- a/ocaml/qp_edit.ml +++ /dev/null @@ -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 -;; - - - From 21143afb4f80e5043d2a333280e3ac55b3932bd4 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 19 Feb 2016 19:04:03 +0100 Subject: [PATCH 04/23] Fixed #140 --- ocaml/qp_run.ml | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/ocaml/qp_run.ml b/ocaml/qp_run.ml index a20df362..2431139c 100644 --- a/ocaml/qp_run.ml +++ b/ocaml/qp_run.ml @@ -54,7 +54,11 @@ let run ~master exe ezfio_file = let executables = Lazy.force Qpackage.executables in if (not (List.exists ~f:(fun (x,_) -> x = exe) executables)) then - failwith ("Executable "^exe^" not found"); + begin + Printf.printf "\nPossible choices:\n"; + List.iter executables ~f:(fun (x,_) -> Printf.printf "* %s\n%!" x); + failwith ("Executable "^exe^" not found") + end; Printf.printf "%s\n" (Time.to_string time_start); Printf.printf "===============\nQuantum Package\n===============\n\n"; @@ -96,8 +100,8 @@ let run ~master exe ezfio_file = | None -> "" and exe = match (List.find ~f:(fun (x,_) -> x = exe) executables) with - | None -> assert false | Some (_,x) -> x^" " + | None -> assert false in match (Sys.command (prefix^exe^ezfio_file)) with | 0 -> () From e4043cda0d5df9e127dcb9cebbcaa3bddb72a829 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 19 Feb 2016 21:04:27 +0100 Subject: [PATCH 05/23] Accelerated qp_edit with large multi-determinant wave functions --- ocaml/Bitlist.ml | 43 ++++--- ocaml/Bitlist.mli | 10 +- ocaml/Determinant.ml | 16 ++- ocaml/Determinant.mli | 3 +- ocaml/Input_determinants_by_hand.ml | 175 ++++++++++++++++------------ ocaml/_tags | 1 + 6 files changed, 149 insertions(+), 99 deletions(-) diff --git a/ocaml/Bitlist.ml b/ocaml/Bitlist.ml index 4648ef6b..c1dc66d9 100644 --- a/ocaml/Bitlist.ml +++ b/ocaml/Bitlist.ml @@ -28,20 +28,30 @@ let of_string ?(zero='0') ?(one='1') s = else if (c = one) then Bit.One else (failwith ("Error in bitstring ") ) ) +let of_string_mp s = + String.to_list s + |> List.rev_map ~f:(function + | '-' -> Bit.Zero + | '+' -> Bit.One + | _ -> failwith ("Error in bitstring ") ) (* Create a bit list from an int64 *) let of_int64 i = - let rec do_work = function - | 0L -> [ Bit.Zero ] - | 1L -> [ Bit.One ] - | i -> let b = - match (Int64.bit_and i 1L ) with - | 0L -> Bit.Zero - | 1L -> Bit.One - | _ -> raise (Failure "i land 1 not in (0,1)") - in b:: ( do_work (Int64.shift_right_logical i 1) ) + + let rec do_work accu = function + | 0L -> Bit.Zero :: accu |> List.rev + | 1L -> Bit.One :: accu |> List.rev + | i -> + let b = + match (Int64.bit_and i 1L ) with + | 0L -> Bit.Zero + | 1L -> Bit.One + | _ -> raise (Failure "i land 1 not in (0,1)") + in + do_work (b :: accu) (Int64.shift_right_logical i 1) in + let adjust_length result = let rec do_work accu = function | 64 -> List.rev accu @@ -51,7 +61,7 @@ let of_int64 i = in do_work (List.rev result) (List.length result) in - adjust_length (do_work i) + adjust_length (do_work [] i) (* Create an int64 from a bit list *) @@ -102,6 +112,10 @@ let to_int64_list l = in List.rev_map ~f:to_int64 l +(* Create an array of int64 from a bit list *) +let to_int64_array l = + to_int64_list l + |> Array.of_list (* Create a bit list from a list of MO indices *) let of_mo_number_list n_int l = @@ -163,11 +177,10 @@ let not_operator b = logical_operator1 Bit.not_operator b let popcnt b = - let rec popcnt accu = function - | [] -> accu - | Bit.One::rest -> popcnt (accu+1) rest - | Bit.Zero::rest -> popcnt (accu) rest - in popcnt 0 b + List.fold_left b ~init:0 ~f:(fun accu -> function + | Bit.One -> accu+1 + | Bit.Zero -> accu + ) diff --git a/ocaml/Bitlist.mli b/ocaml/Bitlist.mli index c733712c..69019920 100644 --- a/ocaml/Bitlist.mli +++ b/ocaml/Bitlist.mli @@ -6,16 +6,20 @@ val zero : Qptypes.N_int_number.t -> t (** Convert to a string for printing *) val to_string : t -> string -(** Convert to a string for printing *) +(** Read from a string *) val of_string : ?zero:char -> ?one:char -> string -> t +(** Read from a string with the ++-- notation *) +val of_string_mp : string -> t + (** int64 conversion functions *) val of_int64 : int64 -> t val to_int64 : t -> int64 -val of_int64_list : int64 list -> t -val to_int64_list : t -> int64 list +val of_int64_list : int64 list -> t +val to_int64_list : t -> int64 list +val to_int64_array : t -> int64 array (** Get the number of needed int64 elements to encode the bit list *) val n_int_of_mo_tot_num : int -> Qptypes.N_int_number.t diff --git a/ocaml/Determinant.ml b/ocaml/Determinant.ml index 63dab9b9..13df7b38 100644 --- a/ocaml/Determinant.ml +++ b/ocaml/Determinant.ml @@ -55,12 +55,18 @@ let of_int64_array ~n_int ~alpha ~beta x = end; x +let of_int64_array_no_check x = x -let of_bitlist_couple ~alpha ~beta (xa,xb) = - let ba = Bitlist.to_int64_list xa in - let bb = Bitlist.to_int64_list xb in - let n_int = Bitlist.n_int_of_mo_tot_num (List.length xa) in - of_int64_array ~n_int:n_int ~alpha:alpha ~beta:beta (Array.of_list (ba@bb)) +let of_bitlist_couple ?n_int ~alpha ~beta (xa,xb) = + let ba, bb = + Bitlist.to_int64_array xa , + Bitlist.to_int64_array xb + and n_int = + match n_int with + | Some x -> x + | None -> Bitlist.n_int_of_mo_tot_num (List.length xa) + in + of_int64_array ~n_int ~alpha ~beta (Array.concat [ba;bb]) let to_string ~mo_tot_num x = diff --git a/ocaml/Determinant.mli b/ocaml/Determinant.mli index f01e49d9..da9fe02e 100644 --- a/ocaml/Determinant.mli +++ b/ocaml/Determinant.mli @@ -24,7 +24,8 @@ val to_alpha_beta : t -> (int64 array)*(int64 array) val to_bitlist_couple : t -> Bitlist.t * Bitlist.t (** Create from a bit list *) -val of_bitlist_couple : alpha:Qptypes.Elec_alpha_number.t -> +val of_bitlist_couple : ?n_int:Qptypes.N_int_number.t -> + alpha:Qptypes.Elec_alpha_number.t -> beta:Qptypes.Elec_beta_number.t -> Bitlist.t * Bitlist.t -> t diff --git a/ocaml/Input_determinants_by_hand.ml b/ocaml/Input_determinants_by_hand.ml index ff9eb520..13e05719 100644 --- a/ocaml/Input_determinants_by_hand.ml +++ b/ocaml/Input_determinants_by_hand.ml @@ -157,44 +157,58 @@ end = struct let read_psi_det () = - let n_int = read_n_int () - and n_alpha = Ezfio.get_electrons_elec_alpha_num () + let n_int = + read_n_int () + and alpha = + Ezfio.get_electrons_elec_alpha_num () |> Elec_alpha_number.of_int - and n_beta = Ezfio.get_electrons_elec_beta_num () + and beta = + Ezfio.get_electrons_elec_beta_num () |> Elec_beta_number.of_int - in - if not (Ezfio.has_determinants_psi_det ()) then - begin - let mo_tot_num = MO_number.get_max () in - let rec build_data accu = function - | 0 -> accu - | n -> build_data ((MO_number.of_int ~max:mo_tot_num n)::accu) (n-1) - in - let det_a = build_data [] (Elec_alpha_number.to_int n_alpha) - |> Bitlist.of_mo_number_list n_int - and det_b = build_data [] (Elec_beta_number.to_int n_beta) - |> Bitlist.of_mo_number_list n_int - in - let data = ( (Bitlist.to_int64_list det_a) @ - (Bitlist.to_int64_list det_b) ) - in - Ezfio.ezfio_array_of_list ~rank:3 ~dim:[| N_int_number.to_int n_int ; 2 ; 1 |] ~data:data - |> Ezfio.set_determinants_psi_det ; - end ; - let n_int = N_int_number.to_int n_int in - let psi_det_array = Ezfio.get_determinants_psi_det () in - let dim = psi_det_array.Ezfio.dim - and data = Ezfio.flattened_ezfio psi_det_array - in - assert (n_int = dim.(0)); - assert (dim.(1) = 2); - assert (dim.(2) = (Det_number.to_int (read_n_det ()))); - List.init dim.(2) ~f:(fun i -> - Array.sub ~pos:(2*n_int*i) ~len:(2*n_int) data) - |> List.map ~f:(Determinant.of_int64_array - ~n_int:(N_int_number.of_int n_int) - ~alpha:n_alpha ~beta:n_beta ) - |> Array.of_list + in + if not (Ezfio.has_determinants_psi_det ()) then + begin + let mo_tot_num = + MO_number.get_max () + in + let rec build_data accu = function + | 0 -> accu + | n -> build_data ((MO_number.of_int ~max:mo_tot_num n)::accu) (n-1) + in + let det_a = + build_data [] (Elec_alpha_number.to_int alpha) + |> Bitlist.of_mo_number_list n_int + and det_b = + build_data [] (Elec_beta_number.to_int beta) + |> Bitlist.of_mo_number_list n_int + in + let data = + ( (Bitlist.to_int64_list det_a) @ + (Bitlist.to_int64_list det_b) ) + in + Ezfio.ezfio_array_of_list ~rank:3 ~dim:[| N_int_number.to_int n_int ; 2 ; 1 |] ~data:data + |> Ezfio.set_determinants_psi_det ; + end ; + let n_int_i = + N_int_number.to_int n_int in + let psi_det_array = + Ezfio.get_determinants_psi_det () + in + let dim = + psi_det_array.Ezfio.dim + and data = + Ezfio.flattened_ezfio psi_det_array + in + assert (n_int_i = dim.(0)); + assert (dim.(1) = 2); + assert (dim.(2) = (Det_number.to_int (read_n_det ()))); + let len = + 2 * n_int_i + in + Array.init dim.(2) ~f:(fun i -> + Array.sub ~pos:(len * i) ~len data + |> Determinant.of_int64_array ~n_int ~alpha ~beta + ) ;; let write_psi_det ~n_int ~n_det d = @@ -358,15 +372,15 @@ psi_det = %s let psi_coef = let rec read_coefs accu = function | [] -> List.rev accu - | ""::""::tail -> read_coefs accu tail - | ""::c::tail -> + | "" :: "" :: tail -> read_coefs accu tail + | "" :: c :: tail -> let c = String.split ~on:'\t' c |> List.map ~f:(fun x -> Det_coef.of_float (Float.of_string x)) |> Array.of_list in - read_coefs (c::accu) tail - | _::tail -> read_coefs accu tail + read_coefs (c :: accu) tail + | _ :: tail -> read_coefs accu tail in let a = let buffer = @@ -380,35 +394,49 @@ psi_det = %s let i = i-1 in - List.map ~f:(fun x -> Det_coef.to_string x.(i)) buffer - |> String.concat ~sep:" " + List.map ~f:(fun x -> x.(i)) buffer in - let rec build_result = function - | 1 -> extract_state 1 - | i -> (build_result (i-1))^" "^(extract_state i) + let rec build_result accu = function + | 0 -> accu + | i -> + let new_accu = + (extract_state i) :: accu + in + build_result new_accu (i-1) in - build_result nstates + build_result [] nstates in - "(psi_coef ("^a^"))" + List.concat a + |> Array.of_list in +(* + let dets = match ( dets + |> String.split ~on:'\n' + |> List.map ~f:(String.strip) + ) with + | _::lines -> lines + | _ -> failwith "Error in determinants" + in +*) + (* Handle determinants *) let psi_det = - let n_alpha = Ezfio.get_electrons_elec_alpha_num () + let alpha = Ezfio.get_electrons_elec_alpha_num () |> Elec_alpha_number.of_int - and n_beta = Ezfio.get_electrons_elec_beta_num () + and beta = Ezfio.get_electrons_elec_beta_num () |> Elec_beta_number.of_int + and n_int = + N_int_number.get_max () + |> N_int_number.of_int in let rec read_dets accu = function - | [] -> List.rev accu - | ""::_::alpha::beta::tail -> + | [] -> List.rev accu + | ""::_::alpha_str::beta_str::tail -> begin let newdet = - (Bitlist.of_string ~zero:'-' ~one:'+' alpha , - Bitlist.of_string ~zero:'-' ~one:'+' beta) - |> Determinant.of_bitlist_couple ~alpha:n_alpha ~beta:n_beta - |> Determinant.sexp_of_t - |> Sexplib.Sexp.to_string + (Bitlist.of_string_mp alpha_str, Bitlist.of_string_mp beta_str) + |> Determinant.of_bitlist_couple ~n_int ~alpha ~beta in read_dets (newdet::accu) tail end @@ -417,29 +445,26 @@ psi_det = %s let dets = List.map ~f:String.rev dets in - let sze = - List.fold ~init:0 ~f:(fun accu x -> accu + (String.length x)) dets - in - let control = - Gc.get () - in - Gc.tune ~minor_heap_size:(sze) ~space_overhead:(sze/10) - ~max_overhead:100000 ~major_heap_increment:(sze/10) (); - let a = - read_dets [] dets - |> String.concat - in - Gc.set control; - "(psi_det ("^a^"))" + read_dets [] dets + |> Array.of_list in - let bitkind = Printf.sprintf "(bit_kind %d)" (Lazy.force Qpackage.bit_kind + let bitkind = + Printf.sprintf "(bit_kind %d)" (Lazy.force Qpackage.bit_kind |> Bit_kind.to_int) - and n_int = Printf.sprintf "(n_int %d)" (N_int_number.get_max ()) in - let s = String.concat [ header ; bitkind ; n_int ; psi_coef ; psi_det] + and n_int = + Printf.sprintf "(n_int %d)" (N_int_number.get_max ()) in - - Generic_input_of_rst.evaluate_sexp t_of_sexp s + let s = + [ header ; bitkind ; n_int ; "(psi_coef ())" ; "(psi_det ())"] + |> String.concat + in + let result = + Generic_input_of_rst.evaluate_sexp t_of_sexp s + in + match result with + | Some x -> Some { x with psi_coef ; psi_det } + | None -> None ;; end diff --git a/ocaml/_tags b/ocaml/_tags index 112ee73f..fd4c4804 100644 --- a/ocaml/_tags +++ b/ocaml/_tags @@ -1,2 +1,3 @@ true: package(core,sexplib.syntax,cryptokit,ZMQ) true: thread +false: profile From 32208d35f95b7bb3e66e7a7f4d068a09bb58b77b Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 19 Feb 2016 23:46:16 +0100 Subject: [PATCH 06/23] Using streams in determinants --- ocaml/Input_determinants_by_hand.ml | 171 ++++++++++++++++------------ 1 file changed, 98 insertions(+), 73 deletions(-) diff --git a/ocaml/Input_determinants_by_hand.ml b/ocaml/Input_determinants_by_hand.ml index 13e05719..2c9bcff4 100644 --- a/ocaml/Input_determinants_by_hand.ml +++ b/ocaml/Input_determinants_by_hand.ml @@ -340,7 +340,7 @@ psi_det = %s let idx = String.substr_index_exn r ~pos:0 ~pattern:"\nDeterminants" in let (header, dets) = - (String.prefix r idx, String.suffix r ((String.length r)-idx) ) + (String.prefix r idx, String.suffix r ((String.length r)-idx-1) ) in (* Handle header *) @@ -360,95 +360,120 @@ psi_det = %s |> String.concat in - (* Handle determinant coefs *) - let dets = match ( dets - |> String.split ~on:'\n' - |> List.map ~f:(String.strip) - ) with - | _::lines -> lines - | _ -> failwith "Error in determinants" - in + (* Handle determinants and coefs *) + let dets_stream = - let psi_coef = - let rec read_coefs accu = function - | [] -> List.rev accu - | "" :: "" :: tail -> read_coefs accu tail - | "" :: c :: tail -> - let c = - String.split ~on:'\t' c - |> List.map ~f:(fun x -> Det_coef.of_float (Float.of_string x)) - |> Array.of_list - in - read_coefs (c :: accu) tail - | _ :: tail -> read_coefs accu tail + let ipos, jmax = + ref (-1), String.length dets in - let a = - let buffer = - read_coefs [] dets - in - let nstates = - List.hd_exn buffer - |> Array.length - in - let extract_state i = - let i = - i-1 - in - List.map ~f:(fun x -> x.(i)) buffer - in - let rec build_result accu = function - | 0 -> accu - | i -> - let new_accu = - (extract_state i) :: accu + let next_line = + Stream.from (fun _ -> + let rec loop line = + let j = + !ipos + 1 in - build_result new_accu (i-1) - in - build_result [] nstates + ipos := j; + if (j < jmax) then + match dets.[j] with + | '\n' -> Some (String.of_char_list @@ List.rev line ) + | ' ' -> loop line + | c -> loop (c :: line) + else + None + in loop [] + ) in - List.concat a - |> Array.of_list + ignore @@ Stream.next next_line; (* Determinants :: *) + ignore @@ Stream.next next_line; (* *) + Stream.from (fun _ -> + try + begin + let result = + let coefs = + let line = + Stream.next next_line + in + String.split ~on:'\t' line + |> Array.of_list + |> Array.map ~f:(fun x -> Det_coef.of_float @@ Float.of_string x) + in + Some (coefs, + Stream.next next_line |> String.rev, + Stream.next next_line |> String.rev ) + in + ignore @@ Stream.next next_line; + result + end + with + | Stream.Failure -> None + ) in + + + + let psi_coef, psi_det = -(* - let dets = match ( dets - |> String.split ~on:'\n' - |> List.map ~f:(String.strip) - ) with - | _::lines -> lines - | _ -> failwith "Error in determinants" - in -*) - - (* Handle determinants *) - let psi_det = - let alpha = Ezfio.get_electrons_elec_alpha_num () + let alpha = + Ezfio.get_electrons_elec_alpha_num () |> Elec_alpha_number.of_int - and beta = Ezfio.get_electrons_elec_beta_num () + and beta = + Ezfio.get_electrons_elec_beta_num () |> Elec_beta_number.of_int and n_int = N_int_number.get_max () |> N_int_number.of_int in - let rec read_dets accu = function - | [] -> List.rev accu - | ""::_::alpha_str::beta_str::tail -> - begin - let newdet = - (Bitlist.of_string_mp alpha_str, Bitlist.of_string_mp beta_str) - |> Determinant.of_bitlist_couple ~n_int ~alpha ~beta + + let rec read coefs dets_bit = function + | None -> (List.rev coefs), (List.rev dets_bit) + | Some (c, alpha_str, beta_str) -> + begin + ignore @@ Stream.next dets_stream; + let new_coefs = + c :: coefs + and new_dets = + let newdet = + (Bitlist.of_string_mp alpha_str, Bitlist.of_string_mp beta_str) + |> Determinant.of_bitlist_couple ~n_int ~alpha ~beta + in + newdet :: dets_bit + in + read new_coefs new_dets (Stream.peek dets_stream) + end + in + + let coefs, dets_bit = + read [] [] (Stream.peek dets_stream) + in + let nstates = + List.hd_exn coefs |> Array.length + in + let a = + let extract_state i = + let i = + i-1 in - read_dets (newdet::accu) tail - end - | _::tail -> read_dets accu tail + List.map ~f:(fun x -> x.(i)) coefs + in + let rec build_result accu = function + | 0 -> accu + | i -> + let new_accu = + (extract_state i) :: accu + in + build_result new_accu (i-1) + in + build_result [] nstates in - let dets = - List.map ~f:String.rev dets + let new_coefs = + List.concat a |> Array.of_list + and new_dets = + Array.of_list dets_bit in - read_dets [] dets - |> Array.of_list + new_coefs, new_dets in + let bitkind = Printf.sprintf "(bit_kind %d)" (Lazy.force Qpackage.bit_kind |> Bit_kind.to_int) From f71fa7ff6b5b4eb234be9e12af716beeae41580b Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 19 Feb 2016 23:53:23 +0100 Subject: [PATCH 07/23] Reduced memory in qp_edit --- ocaml/Input_determinants_by_hand.ml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/ocaml/Input_determinants_by_hand.ml b/ocaml/Input_determinants_by_hand.ml index 2c9bcff4..65eb9204 100644 --- a/ocaml/Input_determinants_by_hand.ml +++ b/ocaml/Input_determinants_by_hand.ml @@ -333,18 +333,18 @@ psi_det = %s ;; let of_rst r = - let r = Rst_string.to_string r + let dets = Rst_string.to_string r in (* Split into header and determinants data *) - let idx = String.substr_index_exn r ~pos:0 ~pattern:"\nDeterminants" + let idx = String.substr_index_exn dets ~pos:0 ~pattern:"\nDeterminants" in - let (header, dets) = - (String.prefix r idx, String.suffix r ((String.length r)-idx-1) ) + let header = + String.prefix dets idx in (* Handle header *) - let header = r + let header = header |> String.split ~on:'\n' |> List.filter ~f:(fun line -> if (line = "") then @@ -364,7 +364,7 @@ psi_det = %s let dets_stream = let ipos, jmax = - ref (-1), String.length dets + ref idx, String.length dets in let next_line = Stream.from (fun _ -> From d49dcb7d8f97053ac58f60f8d6c6788363262946 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 22 Feb 2016 19:41:41 +0100 Subject: [PATCH 08/23] Terminating ZMQ context when parallel calculation is finished --- src/ZMQ/utils.irp.f | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/ZMQ/utils.irp.f b/src/ZMQ/utils.irp.f index b1bc2795..3dc9b2b4 100644 --- a/src/ZMQ/utils.irp.f +++ b/src/ZMQ/utils.irp.f @@ -12,7 +12,7 @@ BEGIN_PROVIDER [ integer(ZMQ_PTR), zmq_context ] ! Context for the ZeroMQ library END_DOC call omp_init_lock(zmq_lock) - zmq_context = f77_zmq_ctx_new () + zmq_context = 0_ZMQ_PTR END_PROVIDER @@ -421,7 +421,8 @@ subroutine new_parallel_job(zmq_to_qp_run_socket,name_in) 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 () zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() name = name_in sze = len(trim(name)) @@ -474,6 +475,11 @@ subroutine end_parallel_job(zmq_to_qp_run_socket,name_in) 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) From d17af2fdc7833095019cbb95d174b2ba2974b2a8 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 22 Feb 2016 20:17:48 +0100 Subject: [PATCH 09/23] Added clean context termination to ZMQ --- src/Determinants/H_apply_zmq.template.f | 9 +++----- .../ao_bielec_integrals_in_map_slave.irp.f | 1 + src/ZMQ/utils.irp.f | 23 +++++++++++++++++++ 3 files changed, 27 insertions(+), 6 deletions(-) diff --git a/src/Determinants/H_apply_zmq.template.f b/src/Determinants/H_apply_zmq.template.f index 363c2fe3..c492a739 100644 --- a/src/Determinants/H_apply_zmq.template.f +++ b/src/Determinants/H_apply_zmq.template.f @@ -24,10 +24,10 @@ subroutine $subroutine($params_main) integer(ZMQ_PTR), external :: new_zmq_pair_socket integer(ZMQ_PTR) :: zmq_socket_pair - zmq_socket_pair = new_zmq_pair_socket(.True.) integer(ZMQ_PTR) :: zmq_to_qp_run_socket call new_parallel_job(zmq_to_qp_run_socket,'$subroutine') + zmq_socket_pair = new_zmq_pair_socket(.True.) call zmq_put_psi(zmq_to_qp_run_socket,1) @@ -55,13 +55,9 @@ subroutine $subroutine($params_main) rc = pthread_join(collector_thread) + call end_zmq_pair_socket(zmq_socket_pair) call end_parallel_job(zmq_to_qp_run_socket,'$subroutine') - rc = f77_zmq_close(zmq_socket_pair) - if (rc /= 0) then - print *, 'f77_zmq_close(zmq_socket_pair)' - stop 'error' - endif $copy_buffer $generate_psi_guess @@ -182,6 +178,7 @@ subroutine $subroutine_slave(thread, iproc) 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 diff --git a/src/Integrals_Bielec/ao_bielec_integrals_in_map_slave.irp.f b/src/Integrals_Bielec/ao_bielec_integrals_in_map_slave.irp.f index 8b165e72..6102d119 100644 --- a/src/Integrals_Bielec/ao_bielec_integrals_in_map_slave.irp.f +++ b/src/Integrals_Bielec/ao_bielec_integrals_in_map_slave.irp.f @@ -114,6 +114,7 @@ subroutine ao_bielec_integrals_in_map_slave(thread,iproc) deallocate( buffer_i, buffer_value ) call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) call end_zmq_push_socket(zmq_socket_push,thread) end diff --git a/src/ZMQ/utils.irp.f b/src/ZMQ/utils.irp.f index 3dc9b2b4..d730f612 100644 --- a/src/ZMQ/utils.irp.f +++ b/src/ZMQ/utils.irp.f @@ -324,6 +324,11 @@ subroutine end_zmq_pair_socket(zmq_socket_pair) ! 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)' @@ -356,6 +361,11 @@ subroutine end_zmq_pull_socket(zmq_socket_pull) 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)' @@ -391,6 +401,11 @@ subroutine end_zmq_push_socket(zmq_socket_push,thread) 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)' @@ -423,6 +438,9 @@ subroutine new_parallel_job(zmq_to_qp_run_socket,name_in) 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)) @@ -685,6 +703,11 @@ subroutine end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) ! 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)' From b019cd04f0b08ef1cccc4e6b2ac4eaf6ad8e77c8 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 22 Feb 2016 23:33:30 +0100 Subject: [PATCH 10/23] Only 10k determinants max in qp_edit --- ocaml/Bitlist.ml | 6 ++++++ ocaml/Bitlist.mli | 1 + ocaml/Determinant.ml | 30 ++++++++++++++++------------- ocaml/Input_determinants_by_hand.ml | 23 +++++++++++----------- 4 files changed, 36 insertions(+), 24 deletions(-) diff --git a/ocaml/Bitlist.ml b/ocaml/Bitlist.ml index c1dc66d9..d7b9fc50 100644 --- a/ocaml/Bitlist.ml +++ b/ocaml/Bitlist.ml @@ -79,6 +79,12 @@ let of_int64_list l = List.map ~f:of_int64 l |> List.concat +(* Create a bit list from an array of int64 *) +let of_int64_array l = + Array.map ~f:of_int64 l + |> Array.to_list + |> List.concat + (* Compute n_int *) let n_int_of_mo_tot_num mo_tot_num = diff --git a/ocaml/Bitlist.mli b/ocaml/Bitlist.mli index 69019920..f67d86b7 100644 --- a/ocaml/Bitlist.mli +++ b/ocaml/Bitlist.mli @@ -18,6 +18,7 @@ val of_int64 : int64 -> t val to_int64 : t -> int64 val of_int64_list : int64 list -> t +val of_int64_array : int64 array -> t val to_int64_list : t -> int64 list val to_int64_array : t -> int64 array diff --git a/ocaml/Determinant.ml b/ocaml/Determinant.ml index 13df7b38..3791e07e 100644 --- a/ocaml/Determinant.ml +++ b/ocaml/Determinant.ml @@ -15,21 +15,25 @@ let to_alpha_beta x = let to_bitlist_couple x = let (xa,xb) = to_alpha_beta x in - let xa = to_int64_array xa - |> Array.to_list - |> Bitlist.of_int64_list - and xb = to_int64_array xb - |> Array.to_list - |> Bitlist.of_int64_list + let xa = + to_int64_array xa + |> Bitlist.of_int64_array + and xb = + to_int64_array xb + |> Bitlist.of_int64_array in (xa,xb) let bitlist_to_string ~mo_tot_num x = - List.map x ~f:(fun i -> match i with - | Bit.Zero -> "-" - | Bit.One -> "+" ) + let len = + MO_number.to_int mo_tot_num + in + List.map x ~f:(function + | Bit.Zero -> "-" + | Bit.One -> "+" + ) |> String.concat - |> String.sub ~pos:0 ~len:(MO_number.to_int mo_tot_num) + |> String.sub ~pos:0 ~len @@ -71,8 +75,8 @@ let of_bitlist_couple ?n_int ~alpha ~beta (xa,xb) = let to_string ~mo_tot_num x = let (xa,xb) = to_bitlist_couple x in - [ bitlist_to_string ~mo_tot_num:mo_tot_num xa ; - bitlist_to_string ~mo_tot_num:mo_tot_num xb ] - |> String.concat ~sep:"\n" + [ " " ; bitlist_to_string ~mo_tot_num xa ; "\n" ; + " " ; bitlist_to_string ~mo_tot_num xb ] + |> String.concat diff --git a/ocaml/Input_determinants_by_hand.ml b/ocaml/Input_determinants_by_hand.ml index 65eb9204..eecd87f0 100644 --- a/ocaml/Input_determinants_by_hand.ml +++ b/ocaml/Input_determinants_by_hand.ml @@ -29,7 +29,7 @@ end = struct let get_default = Qpackage.get_ezfio_default "determinants";; - let n_det_read_max = 50_000_000 ;; + let n_det_read_max = 10_000 ;; let read_n_int () = if not (Ezfio.has_determinants_n_int()) then @@ -258,11 +258,16 @@ end = struct let to_rst b = - let mo_tot_num = Ezfio.get_mo_basis_mo_tot_num () in - let mo_tot_num = MO_number.of_int mo_tot_num ~max:mo_tot_num in + let max = + Ezfio.get_mo_basis_mo_tot_num () + in + let mo_tot_num = + MO_number.of_int ~max max + in let det_text = let nstates = - read_n_states () |> States_number.to_int + read_n_states () + |> States_number.to_int and ndet = Det_number.to_int b.n_det in @@ -281,13 +286,9 @@ end = struct |> String.concat_array ~sep:"\t" in Array.init ndet ~f:(fun i -> - Printf.sprintf " %s\n%s\n" - (coefs_string i) - (Determinant.to_string ~mo_tot_num:mo_tot_num b.psi_det.(i) - |> String.split ~on:'\n' - |> List.map ~f:(fun x -> " "^x) - |> String.concat ~sep:"\n" - ) + String.concat [ " " ; + (coefs_string i) ; "\n" ; + (Determinant.to_string ~mo_tot_num b.psi_det.(i)) ; "\n" ] ) |> String.concat_array ~sep:"\n" in From 0e4b6c0b5363987d8799cb4c021db49441e96f55 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 23 Feb 2016 09:21:29 +0100 Subject: [PATCH 11/23] Minor change --- scripts/module/qp_module.py | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/scripts/module/qp_module.py b/scripts/module/qp_module.py index 63649df5..06ad5dd2 100755 --- a/scripts/module/qp_module.py +++ b/scripts/module/qp_module.py @@ -59,7 +59,8 @@ def save_new_module(path, l_child): with open(os.path.join(path, "%s.main.irp.f"%(module_name) ), "w") as f: f.write("program {0}".format(module_name) ) - f.write(""" implicit none + f.write(""" + implicit none BEGIN_DOC ! TODO END_DOC From fa2499bc4e0c32daab0b3acb4b1a28522e43591a Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Fri, 26 Feb 2016 14:17:05 +0100 Subject: [PATCH 12/23] Z are now Z effectif in block. --- plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py | 15 +++++---------- 1 file changed, 5 insertions(+), 10 deletions(-) diff --git a/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py b/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py index 9349b9e2..51a6c605 100755 --- a/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py +++ b/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py @@ -17,7 +17,7 @@ ezfio.set_file(ezfio_path) do_pseudo = ezfio.get_pseudo_do_pseudo() if do_pseudo: print "do_pseudo True" - zcore = ezfio.get_pseudo_nucl_charge_remove() + print "The charge of nucl will be decreasced for taking into acount the pseudo potentiel" else: print "do_pseudo False" @@ -68,11 +68,7 @@ print "nucl_num", len(l_label) print "Atomic coord in Bohr" for i, t in enumerate(zip(l_label, l_charge, l_coord_str)): - try: - l = (t[0], t[1] + zcore[i], t[2]) - except NameError: - l = t - print list_to_string(l) + print list_to_string(t) # # Call externet process to get the sysmetry @@ -305,8 +301,8 @@ if do_pseudo: if l_dump: l_str.append(l_dump) - str_ = "PARAMETERS FOR {0} ON ATOM {1} WITH ZCORE {2} AND LMAX {3} ARE" - print str_.format(a, i + 1, int(zcore[i]), int(len(l_str) - 1)) + str_ = "PARAMETERS FOR {0} ON ATOM {1} WITH ZCORE -1 AND LMAX {2} ARE" + print str_.format(a, i + 1, int(len(l_str) - 1)) for i, l in enumerate(l_str): str_ = "FOR L= {0} COEFF N ZETA" @@ -314,8 +310,7 @@ if do_pseudo: for ii, ll in enumerate(l): print " ", ii + 1, ll - str_ = "THE ECP RUN REMOVES {0} CORE ELECTRONS, AND THE SAME NUMBER OF PROTONS." - print str_.format(sum(zcore)) + str_ = "THE ECP RUN REMOVES -1 CORE ELECTRONS, AND THE SAME NUMBER OF PROTONS." print "END_PSEUDO" # _ From 3f38c8a81c71a434a37cdb122c1271428967949e Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Fri, 26 Feb 2016 17:07:36 +0100 Subject: [PATCH 13/23] It seem the Second 64 is always 0 in psi_det --- .../qmcpack/qp_convert_qmcpack_to_ezfio.py | 32 ++++++++++++------- 1 file changed, 20 insertions(+), 12 deletions(-) diff --git a/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py b/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py index 51a6c605..4b345d84 100755 --- a/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py +++ b/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py @@ -331,22 +331,30 @@ for c, (l_det_bit_alpha, l_det_bit_beta) in zip(psi_coef, psi_det): print c bin_det = "" - for i,int_det in enumerate(l_det_bit_alpha): - bin_det_raw = "{0:b}".format(int_det)[::-1] - if mo_num - 64*(i+1) > 0: - bin_det += bin_det_raw + "0" * (64*(i+1) - len(bin_det_raw)) - else: - bin_det += bin_det_raw + "0" * (mo_num-64*i - len(bin_det_raw)) + int_det = l_det_bit_alpha[0] + bin_det_raw = "{0:b}".format(int_det)[::-1] + bin_det += bin_det_raw + "0" * (mo_num - len(bin_det_raw)) + +# for i,int_det in enumerate(l_det_bit_alpha): +# bin_det_raw = "{0:b}".format(int_det)[::-1] +# if mo_num - 64*(i+1) > 0: +# bin_det += bin_det_raw + "0" * (64*(i+1) - len(bin_det_raw)) +# else: +# bin_det += bin_det_raw + "0" * (mo_num-64*i - len(bin_det_raw)) print bin_det bin_det = "" - for i,int_det in enumerate(l_det_bit_beta): - bin_det_raw = "{0:b}".format(int_det)[::-1] - if mo_num - 64*(i+1) > 0: - bin_det += bin_det_raw + "0" * (64*(i+1) - len(bin_det_raw)) - else: - bin_det += bin_det_raw + "0" * (mo_num-64*i - len(bin_det_raw)) + int_det = l_det_bit_beta[0] + bin_det_raw = "{0:b}".format(int_det)[::-1] + bin_det += bin_det_raw + "0" * (mo_num - len(bin_det_raw)) + +# 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 print "" From 590b0d6edbc380d74c31e20b98d07930e0b0dc96 Mon Sep 17 00:00:00 2001 From: TApplencourt Date: Mon, 29 Feb 2016 11:26:33 +0100 Subject: [PATCH 14/23] Fix qmcpack convert --- ocaml/qp_print_basis.ml | 21 +++++++++- .../qmcpack/qp_convert_qmcpack_to_ezfio.py | 38 ++++--------------- 2 files changed, 27 insertions(+), 32 deletions(-) diff --git a/ocaml/qp_print_basis.ml b/ocaml/qp_print_basis.ml index 3a481c21..16a2f721 100644 --- a/ocaml/qp_print_basis.ml +++ b/ocaml/qp_print_basis.ml @@ -35,7 +35,26 @@ let mo () = |> print_endline +let psi_det () = + let ezfio_filename = + Sys.argv.(1) + in + if (not (Sys.file_exists_exn ezfio_filename)) then + failwith "Error reading EZFIO file"; + Ezfio.set_file ezfio_filename; + let psi_det = + match Input.Determinants_by_hand.read () with + | Some psi_det -> psi_det + | _ -> failwith "Error reading the mo set" + in + Input.Determinants_by_hand.to_rst psi_det + |> Rst_string.to_string + |> print_endline + + + let () = basis (); - mo () + mo (); + psi_det (); diff --git a/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py b/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py index 4b345d84..f0bfe174 100755 --- a/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py +++ b/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py @@ -79,7 +79,8 @@ process = subprocess.Popen( stdout=subprocess.PIPE) out, err = process.communicate() -basis_raw, sym_raw, _= out.split("\n\n\n") +print len(out.split("\n\n\n")) +basis_raw, sym_raw, _ , det_raw, _ = out.split("\n\n\n") # _ __ # |_) _. _ o _ (_ _ _|_ @@ -324,39 +325,14 @@ print "mo_num", mo_num print "det_num", n_det print "" -psi_det = ezfio.get_determinants_psi_det() -psi_coef = ezfio.get_determinants_psi_coef()[0] -for c, (l_det_bit_alpha, l_det_bit_beta) in zip(psi_coef, psi_det): - print c - bin_det = "" - int_det = l_det_bit_alpha[0] - bin_det_raw = "{0:b}".format(int_det)[::-1] - bin_det += bin_det_raw + "0" * (mo_num - len(bin_det_raw)) - -# for i,int_det in enumerate(l_det_bit_alpha): -# bin_det_raw = "{0:b}".format(int_det)[::-1] -# if mo_num - 64*(i+1) > 0: -# bin_det += bin_det_raw + "0" * (64*(i+1) - len(bin_det_raw)) -# else: -# bin_det += bin_det_raw + "0" * (mo_num-64*i - len(bin_det_raw)) +token = "Determinants ::" +pos = det_raw.rfind(token) + len(token) - print bin_det +det_without_header = det_raw[pos+2::] - bin_det = "" - int_det = l_det_bit_beta[0] - bin_det_raw = "{0:b}".format(int_det)[::-1] - bin_det += bin_det_raw + "0" * (mo_num - len(bin_det_raw)) - -# 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 - print "" +print det_without_header print "END_DET" + From 54a001743bb7b6e6561ad0cdba0e5607a9df7e0b Mon Sep 17 00:00:00 2001 From: TApplencourt Date: Tue, 1 Mar 2016 15:42:16 +0100 Subject: [PATCH 15/23] qmcpack Transform +/- -> 10 --- plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py b/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py index f0bfe174..7430ad54 100755 --- a/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py +++ b/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py @@ -332,7 +332,19 @@ pos = det_raw.rfind(token) + len(token) det_without_header = det_raw[pos+2::] -print det_without_header +d_rep={"+":"1","-":"0"} + +det_without_header = det_raw[pos+2::] + +for line_raw in det_without_header.split("\n"): + line = line_raw + + if line_raw: + try: + float(line) + except ValueError: + line= "".join([d_rep[x] if x in d_rep else x for x in line_raw]) + + print line.strip() print "END_DET" - From 5dd55ffab9b3008f8c45e9a56fd9215c2ebb088a Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 4 Mar 2016 11:58:22 +0100 Subject: [PATCH 16/23] Corrected bug in qp_edit determinants --- ocaml/Input_determinants_by_hand.ml | 302 ++++++++++++---------------- 1 file changed, 131 insertions(+), 171 deletions(-) diff --git a/ocaml/Input_determinants_by_hand.ml b/ocaml/Input_determinants_by_hand.ml index eecd87f0..6d48c917 100644 --- a/ocaml/Input_determinants_by_hand.ml +++ b/ocaml/Input_determinants_by_hand.ml @@ -16,6 +16,7 @@ module Determinants_by_hand : sig val to_string : t -> string val to_rst : t -> Rst_string.t val of_rst : Rst_string.t -> t option + val read_n_int : unit -> N_int_number.t end = struct type t = { n_int : N_int_number.t; @@ -157,58 +158,44 @@ end = struct let read_psi_det () = - let n_int = - read_n_int () - and alpha = - Ezfio.get_electrons_elec_alpha_num () + let n_int = read_n_int () + and n_alpha = Ezfio.get_electrons_elec_alpha_num () |> Elec_alpha_number.of_int - and beta = - Ezfio.get_electrons_elec_beta_num () + and n_beta = Ezfio.get_electrons_elec_beta_num () |> Elec_beta_number.of_int - in - if not (Ezfio.has_determinants_psi_det ()) then - begin - let mo_tot_num = - MO_number.get_max () - in - let rec build_data accu = function - | 0 -> accu - | n -> build_data ((MO_number.of_int ~max:mo_tot_num n)::accu) (n-1) - in - let det_a = - build_data [] (Elec_alpha_number.to_int alpha) - |> Bitlist.of_mo_number_list n_int - and det_b = - build_data [] (Elec_beta_number.to_int beta) - |> Bitlist.of_mo_number_list n_int - in - let data = - ( (Bitlist.to_int64_list det_a) @ - (Bitlist.to_int64_list det_b) ) - in - Ezfio.ezfio_array_of_list ~rank:3 ~dim:[| N_int_number.to_int n_int ; 2 ; 1 |] ~data:data - |> Ezfio.set_determinants_psi_det ; - end ; - let n_int_i = - N_int_number.to_int n_int in - let psi_det_array = - Ezfio.get_determinants_psi_det () - in - let dim = - psi_det_array.Ezfio.dim - and data = - Ezfio.flattened_ezfio psi_det_array - in - assert (n_int_i = dim.(0)); - assert (dim.(1) = 2); - assert (dim.(2) = (Det_number.to_int (read_n_det ()))); - let len = - 2 * n_int_i - in - Array.init dim.(2) ~f:(fun i -> - Array.sub ~pos:(len * i) ~len data - |> Determinant.of_int64_array ~n_int ~alpha ~beta - ) + in + if not (Ezfio.has_determinants_psi_det ()) then + begin + let mo_tot_num = MO_number.get_max () in + let rec build_data accu = function + | 0 -> accu + | n -> build_data ((MO_number.of_int ~max:mo_tot_num n)::accu) (n-1) + in + let det_a = build_data [] (Elec_alpha_number.to_int n_alpha) + |> Bitlist.of_mo_number_list n_int + and det_b = build_data [] (Elec_beta_number.to_int n_beta) + |> Bitlist.of_mo_number_list n_int + in + let data = ( (Bitlist.to_int64_list det_a) @ + (Bitlist.to_int64_list det_b) ) + in + Ezfio.ezfio_array_of_list ~rank:3 ~dim:[| N_int_number.to_int n_int ; 2 ; 1 |] ~data:data + |> Ezfio.set_determinants_psi_det ; + end ; + let n_int = N_int_number.to_int n_int in + let psi_det_array = Ezfio.get_determinants_psi_det () in + let dim = psi_det_array.Ezfio.dim + and data = Ezfio.flattened_ezfio psi_det_array + in + assert (n_int = dim.(0)); + assert (dim.(1) = 2); + assert (dim.(2) = (Det_number.to_int (read_n_det ()))); + List.init dim.(2) ~f:(fun i -> + Array.sub ~pos:(2*n_int*i) ~len:(2*n_int) data) + |> List.map ~f:(Determinant.of_int64_array + ~n_int:(N_int_number.of_int n_int) + ~alpha:n_alpha ~beta:n_beta ) + |> Array.of_list ;; let write_psi_det ~n_int ~n_det d = @@ -286,9 +273,13 @@ end = struct |> String.concat_array ~sep:"\t" in Array.init ndet ~f:(fun i -> - String.concat [ " " ; - (coefs_string i) ; "\n" ; - (Determinant.to_string ~mo_tot_num b.psi_det.(i)) ; "\n" ] + Printf.sprintf " %s\n%s\n" + (coefs_string i) + (Determinant.to_string ~mo_tot_num:mo_tot_num b.psi_det.(i) + |> String.split ~on:'\n' + |> List.map ~f:(fun x -> " "^x) + |> String.concat ~sep:"\n" + ) ) |> String.concat_array ~sep:"\n" in @@ -334,18 +325,18 @@ psi_det = %s ;; let of_rst r = - let dets = Rst_string.to_string r + let r = Rst_string.to_string r in (* Split into header and determinants data *) - let idx = String.substr_index_exn dets ~pos:0 ~pattern:"\nDeterminants" + let idx = String.substr_index_exn r ~pos:0 ~pattern:"\nDeterminants" in - let header = - String.prefix dets idx + let (header, dets) = + (String.prefix r idx, String.suffix r ((String.length r)-idx) ) in (* Handle header *) - let header = header + let header = r |> String.split ~on:'\n' |> List.filter ~f:(fun line -> if (line = "") then @@ -361,117 +352,91 @@ psi_det = %s |> String.concat in - (* Handle determinants and coefs *) - let dets_stream = - - let ipos, jmax = - ref idx, String.length dets - in - let next_line = - Stream.from (fun _ -> - let rec loop line = - let j = - !ipos + 1 - in - ipos := j; - if (j < jmax) then - match dets.[j] with - | '\n' -> Some (String.of_char_list @@ List.rev line ) - | ' ' -> loop line - | c -> loop (c :: line) - else - None - in loop [] - ) - in - ignore @@ Stream.next next_line; (* Determinants :: *) - ignore @@ Stream.next next_line; (* *) - Stream.from (fun _ -> - try - begin - let result = - let coefs = - let line = - Stream.next next_line - in - String.split ~on:'\t' line - |> Array.of_list - |> Array.map ~f:(fun x -> Det_coef.of_float @@ Float.of_string x) - in - Some (coefs, - Stream.next next_line |> String.rev, - Stream.next next_line |> String.rev ) - in - ignore @@ Stream.next next_line; - result - end - with - | Stream.Failure -> None - ) + (* Handle determinant coefs *) + let dets = match ( dets + |> String.split ~on:'\n' + |> List.map ~f:(String.strip) + ) with + | _::lines -> lines + | _ -> failwith "Error in determinants" in - - - - let psi_coef, psi_det = - let alpha = - Ezfio.get_electrons_elec_alpha_num () - |> Elec_alpha_number.of_int - and beta = - Ezfio.get_electrons_elec_beta_num () - |> Elec_beta_number.of_int - and n_int = - N_int_number.get_max () - |> N_int_number.of_int - in - - let rec read coefs dets_bit = function - | None -> (List.rev coefs), (List.rev dets_bit) - | Some (c, alpha_str, beta_str) -> - begin - ignore @@ Stream.next dets_stream; - let new_coefs = - c :: coefs - and new_dets = - let newdet = - (Bitlist.of_string_mp alpha_str, Bitlist.of_string_mp beta_str) - |> Determinant.of_bitlist_couple ~n_int ~alpha ~beta - in - newdet :: dets_bit - in - read new_coefs new_dets (Stream.peek dets_stream) - end - in - - let coefs, dets_bit = - read [] [] (Stream.peek dets_stream) - in - let nstates = - List.hd_exn coefs |> Array.length + let psi_coef = + let rec read_coefs accu = function + | [] -> List.rev accu + | ""::""::tail -> read_coefs accu tail + | ""::c::tail -> + let c = + String.split ~on:'\t' c + |> List.map ~f:(fun x -> Det_coef.of_float (Float.of_string x)) + |> Array.of_list + in + read_coefs (c::accu) tail + | _::tail -> read_coefs accu tail in let a = - let extract_state i = - let i = - i-1 + let buffer = + read_coefs [] dets + in + let nstates = + List.hd_exn buffer + |> Array.length + in + let extract_state i = + let i = + i-1 + in + List.map ~f:(fun x -> Det_coef.to_string x.(i)) buffer + |> String.concat ~sep:" " + in + let rec build_result = function + | 1 -> extract_state 1 + | i -> (build_result (i-1))^" "^(extract_state i) + in + build_result nstates + in + "(psi_coef ("^a^"))" + in + + (* Handle determinants *) + let psi_det = + let n_alpha = Ezfio.get_electrons_elec_alpha_num () + |> Elec_alpha_number.of_int + and n_beta = Ezfio.get_electrons_elec_beta_num () + |> Elec_beta_number.of_int + in + let rec read_dets accu = function + | [] -> List.rev accu + | ""::_::alpha::beta::tail -> + begin + let newdet = + (Bitlist.of_string ~zero:'-' ~one:'+' alpha , + Bitlist.of_string ~zero:'-' ~one:'+' beta) + |> Determinant.of_bitlist_couple ~alpha:n_alpha ~beta:n_beta + |> Determinant.sexp_of_t + |> Sexplib.Sexp.to_string in - List.map ~f:(fun x -> x.(i)) coefs - in - let rec build_result accu = function - | 0 -> accu - | i -> - let new_accu = - (extract_state i) :: accu - in - build_result new_accu (i-1) - in - build_result [] nstates + read_dets (newdet::accu) tail + end + | _::tail -> read_dets accu tail in - let new_coefs = - List.concat a |> Array.of_list - and new_dets = - Array.of_list dets_bit + let dets = + List.map ~f:String.rev dets in - new_coefs, new_dets + let sze = + List.fold ~init:0 ~f:(fun accu x -> accu + (String.length x)) dets + in + let control = + Gc.get () + in + Gc.tune ~minor_heap_size:(sze) ~space_overhead:(sze/10) + ~max_overhead:100000 ~major_heap_increment:(sze/10) (); + let a = + read_dets [] dets + |> String.concat + in + Gc.set control; + "(psi_det ("^a^"))" in @@ -481,16 +446,11 @@ psi_det = %s and n_int = Printf.sprintf "(n_int %d)" (N_int_number.get_max ()) in - let s = - [ header ; bitkind ; n_int ; "(psi_coef ())" ; "(psi_det ())"] - |> String.concat + let s = + String.concat [ header ; bitkind ; n_int ; psi_coef ; psi_det] in - let result = - Generic_input_of_rst.evaluate_sexp t_of_sexp s - in - match result with - | Some x -> Some { x with psi_coef ; psi_det } - | None -> None + + Generic_input_of_rst.evaluate_sexp t_of_sexp s ;; end From 46e7005e7b3b3b3b6a4175700d96e1bafef54ec8 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 4 Mar 2016 12:11:38 +0100 Subject: [PATCH 17/23] Fixed #152 --- ocaml/TaskServer.ml | 21 +++++++++++++-------- ocaml/qp_run.ml | 4 ++-- 2 files changed, 15 insertions(+), 10 deletions(-) diff --git a/ocaml/TaskServer.ml b/ocaml/TaskServer.ml index 8f6e6ddf..28a7d0a7 100644 --- a/ocaml/TaskServer.ml +++ b/ocaml/TaskServer.ml @@ -32,14 +32,19 @@ let zmq_context = let bind_socket ~socket_type ~socket ~address = - try - ZMQ.Socket.bind socket address - with - | Unix.Unix_error (_, message, f) -> - failwith @@ Printf.sprintf - "\n%s\nUnable to bind the %s socket :\n %s\n%s" - f socket_type address message - | other_exception -> raise other_exception + let rec loop = function + | 0 -> failwith @@ Printf.sprintf + "Unable to bind the %s socket : %s " + socket_type address + | -1 -> (); + | i -> + try + ZMQ.Socket.bind socket address; + loop (-1) + with + | Unix.Unix_error _ -> (Time.pause @@ Time.Span.of_float 1. ; loop (i-1) ) + | other_exception -> raise other_exception + in loop 10 let hostname = lazy ( diff --git a/ocaml/qp_run.ml b/ocaml/qp_run.ml index 2431139c..1d44f35f 100644 --- a/ocaml/qp_run.ml +++ b/ocaml/qp_run.ml @@ -32,12 +32,12 @@ let run ~master exe ezfio_file = let address = Printf.sprintf "tcp://%s:%d" (Lazy.force TaskServer.ip_address) (port_number+i) in - TaskServer.bind_socket "REP" dummy_socket address ; + ZMQ.Socket.bind dummy_socket address; ZMQ.Socket.unbind dummy_socket address; ); port_number with - | Failure _ -> try_new_port (port_number+100) + | Unix.Unix_error _ -> try_new_port (port_number+100) in let result = try_new_port 41279 From 92094534e281206eb4ae0beaefc6b4d44cd0c441 Mon Sep 17 00:00:00 2001 From: TApplencourt Date: Mon, 7 Mar 2016 10:51:11 +0100 Subject: [PATCH 18/23] Fix qmc pack converter --- data/list_element.txt | 118 ++++++++++++++++++ .../qmcpack/qp_convert_qmcpack_to_ezfio.py | 24 +++- 2 files changed, 136 insertions(+), 6 deletions(-) create mode 100644 data/list_element.txt diff --git a/data/list_element.txt b/data/list_element.txt new file mode 100644 index 00000000..b2d081c1 --- /dev/null +++ b/data/list_element.txt @@ -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 \ No newline at end of file diff --git a/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py b/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py index 7430ad54..0dc99029 100755 --- a/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py +++ b/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py @@ -9,6 +9,7 @@ print "#QP -> QMCPACK" from ezfio import ezfio +import os import sys ezfio_path = sys.argv[1] @@ -17,7 +18,15 @@ ezfio.set_file(ezfio_path) do_pseudo = ezfio.get_pseudo_do_pseudo() if do_pseudo: print "do_pseudo True" - print "The charge of nucl will be decreasced for taking into acount the pseudo potentiel" + from qp_path import QP_ROOT + + l_ele_path = os.path.join(QP_ROOT,"data","list_element.txt") + with open(l_ele_path, "r") as f: + data_raw = f.read() + + l_element_raw = data_raw.split("\n") + l_element = [element_raw.split() for element_raw in l_element_raw] + d_z = dict((abr, z) for (z, abr, ele) in l_element) else: print "do_pseudo False" @@ -68,7 +77,10 @@ print "nucl_num", len(l_label) print "Atomic coord in Bohr" for i, t in enumerate(zip(l_label, l_charge, l_coord_str)): - print list_to_string(t) + t_1 = d_z[t[0]] if do_pseudo else t[1] + + t_new = [t[0],t_1,t[2]] + print list_to_string(t_new) # # Call externet process to get the sysmetry @@ -79,7 +91,6 @@ process = subprocess.Popen( stdout=subprocess.PIPE) out, err = process.communicate() -print len(out.split("\n\n\n")) basis_raw, sym_raw, _ , det_raw, _ = out.split("\n\n\n") # _ __ @@ -302,8 +313,8 @@ if do_pseudo: if l_dump: l_str.append(l_dump) - str_ = "PARAMETERS FOR {0} ON ATOM {1} WITH ZCORE -1 AND LMAX {2} ARE" - print str_.format(a, i + 1, int(len(l_str) - 1)) + str_ = "PARAMETERS FOR {0} ON ATOM {1} WITH ZCORE {2} AND LMAX {3} ARE" + print str_.format(a, i + 1, int(d_z[a])-int(l_charge[i]), int(len(l_str) - 1)) for i, l in enumerate(l_str): str_ = "FOR L= {0} COEFF N ZETA" @@ -311,7 +322,8 @@ if do_pseudo: for ii, ll in enumerate(l): print " ", ii + 1, ll - str_ = "THE ECP RUN REMOVES -1 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([int(d_z[a])-int(l_charge[i]) for i,a in enumerate(l_label)])) print "END_PSEUDO" # _ From 6b3ba6a99ed25eb13366512bc118c646a77d42a0 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 7 Mar 2016 20:13:43 +0100 Subject: [PATCH 19/23] Fixed QMCPACK bugs (Issue #154) --- ocaml/Input_determinants_by_hand.ml | 21 +++++++++++++-------- ocaml/TaskServer.ml | 2 +- ocaml/qp_print_basis.ml | 6 ++---- ocaml/test_message.ml | 4 ++-- plugins/qmcpack/save_for_qmcpack.irp.f | 6 ++++++ scripts/ezfio_interface/qp_edit_template | 2 +- src/AO_Basis/aos.irp.f | 3 --- 7 files changed, 25 insertions(+), 19 deletions(-) diff --git a/ocaml/Input_determinants_by_hand.ml b/ocaml/Input_determinants_by_hand.ml index 6d48c917..c69c8ad9 100644 --- a/ocaml/Input_determinants_by_hand.ml +++ b/ocaml/Input_determinants_by_hand.ml @@ -11,7 +11,8 @@ module Determinants_by_hand : sig psi_coef : Det_coef.t array; psi_det : Determinant.t array; } with sexp - val read : unit -> t option + val read : unit -> t + val read_maybe : unit -> t option val write : t -> unit val to_string : t -> string val to_rst : t -> Rst_string.t @@ -210,13 +211,6 @@ end = struct let read () = if (Ezfio.has_mo_basis_mo_tot_num ()) then - let n_det = - read_n_det () - in - if ( (Det_number.to_int n_det) > n_det_read_max ) then - None - else - Some { n_int = read_n_int () ; bit_kind = read_bit_kind () ; n_det = read_n_det () ; @@ -224,6 +218,17 @@ end = struct psi_coef = read_psi_coef () ; psi_det = read_psi_det () ; } + else + failwith "No molecular orbitals, so no determinants" + ;; + + let read_maybe () = + let n_det = + read_n_det () + in + if ( (Det_number.to_int n_det) < n_det_read_max ) then + try Some (read ()) with + | Failure _ -> None else None ;; diff --git a/ocaml/TaskServer.ml b/ocaml/TaskServer.ml index 28a7d0a7..67d5bb07 100644 --- a/ocaml/TaskServer.ml +++ b/ocaml/TaskServer.ml @@ -36,7 +36,7 @@ let bind_socket ~socket_type ~socket ~address = | 0 -> failwith @@ Printf.sprintf "Unable to bind the %s socket : %s " socket_type address - | -1 -> (); + | -1 -> () | i -> try ZMQ.Socket.bind socket address; diff --git a/ocaml/qp_print_basis.ml b/ocaml/qp_print_basis.ml index 16a2f721..aff52837 100644 --- a/ocaml/qp_print_basis.ml +++ b/ocaml/qp_print_basis.ml @@ -43,9 +43,7 @@ let psi_det () = failwith "Error reading EZFIO file"; Ezfio.set_file ezfio_filename; let psi_det = - match Input.Determinants_by_hand.read () with - | Some psi_det -> psi_det - | _ -> failwith "Error reading the mo set" + Input.Determinants_by_hand.read () in Input.Determinants_by_hand.to_rst psi_det |> Rst_string.to_string @@ -56,5 +54,5 @@ let psi_det () = let () = basis (); mo (); - psi_det (); + psi_det () diff --git a/ocaml/test_message.ml b/ocaml/test_message.ml index 90b73d5e..2f5592ec 100644 --- a/ocaml/test_message.ml +++ b/ocaml/test_message.ml @@ -1,7 +1,7 @@ open Core.Std let () = - Message.of_string "new_job tcp://127.0.0.1 inproc://ao_ints:12345 ao_integrals" + Message.of_string "new_job ao_integrals tcp://127.0.0.1 inproc://ao_ints:12345" |> Message.to_string |> print_endline ; @@ -37,7 +37,7 @@ let () = ; try - Message.of_string "new_job inproc://ao_ints tcp://127.0.0.1:12345 ao_integrals" + Message.of_string "new_job ao_integrals inproc://ao_ints tcp://127.0.0.1:12345" |> Message.to_string |> print_endline ; diff --git a/plugins/qmcpack/save_for_qmcpack.irp.f b/plugins/qmcpack/save_for_qmcpack.irp.f index 95e3320c..186ca616 100644 --- a/plugins/qmcpack/save_for_qmcpack.irp.f +++ b/plugins/qmcpack/save_for_qmcpack.irp.f @@ -14,6 +14,12 @@ program qmcpack enddo enddo call ezfio_set_ao_basis_ao_coef(ao_coef) + do j=1,mo_tot_num + do i=1,ao_num + mo_coef(i,j) *= 1.d0/ao_coef_normalization_factor(i) + enddo + enddo + call save_mos call system('rm '//trim(ezfio_filename)//'/mo_basis/ao_md5') call system('$QP_ROOT/src/qmcpack/qp_convert_qmcpack_to_ezfio.py '//trim(ezfio_filename)) diff --git a/scripts/ezfio_interface/qp_edit_template b/scripts/ezfio_interface/qp_edit_template index 218b21ae..408ca3f7 100644 --- a/scripts/ezfio_interface/qp_edit_template +++ b/scripts/ezfio_interface/qp_edit_template @@ -75,7 +75,7 @@ let get s = | Ao_basis -> f Ao_basis.(read, to_rst) | Determinants_by_hand -> - f Determinants_by_hand.(read, to_rst) + f Determinants_by_hand.(read_maybe, to_rst) {section_to_rst} end with diff --git a/src/AO_Basis/aos.irp.f b/src/AO_Basis/aos.irp.f index 8c2db90e..aa805093 100644 --- a/src/AO_Basis/aos.irp.f +++ b/src/AO_Basis/aos.irp.f @@ -50,9 +50,6 @@ END_PROVIDER enddo enddo ao_coef_normalization_factor(i) = 1.d0/sqrt(norm) - do j=1,ao_prim_num(i) - ao_coef_normalized(i,j) = ao_coef_normalized(i,j) * ao_coef_normalization_factor(i) - enddo enddo END_PROVIDER From 37f091845c58d1ba78cc24d672d384eab599d1e7 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 29 Mar 2016 14:13:02 +0200 Subject: [PATCH 20/23] Updated lambda MRCC --- config/ifort.cfg | 2 +- plugins/Full_CI/H_apply.irp.f | 10 +-- plugins/MRCC_CASSD/EZFIO.cfg | 13 ++++ plugins/MRCC_Utils/mrcc_utils.irp.f | 107 ++++++---------------------- 4 files changed, 39 insertions(+), 93 deletions(-) diff --git a/config/ifort.cfg b/config/ifort.cfg index cc848cba..2b2fe0a2 100644 --- a/config/ifort.cfg +++ b/config/ifort.cfg @@ -31,7 +31,7 @@ OPENMP : 1 ; Append OpenMP flags # -ftz : Flushes denormal results to zero # [OPT] -FCFLAGS : -xHost -O2 -ip -ftz -g +FCFLAGS : -xSSE4.2 -O2 -ip -ftz -g # Profiling flags ################# diff --git a/plugins/Full_CI/H_apply.irp.f b/plugins/Full_CI/H_apply.irp.f index 1eb2d45a..3dc1e0f0 100644 --- a/plugins/Full_CI/H_apply.irp.f +++ b/plugins/Full_CI/H_apply.irp.f @@ -2,20 +2,20 @@ use bitmasks BEGIN_SHELL [ /usr/bin/env python ] from generate_h_apply import * -s = H_apply_zmq("FCI") +s = H_apply("FCI") s.set_selection_pt2("epstein_nesbet_2x2") -s.unset_openmp() +#s.unset_openmp() print s s = H_apply_zmq("FCI_PT2") s.set_perturbation("epstein_nesbet_2x2") -s.unset_openmp() +#s.unset_openmp() print s -s = H_apply_zmq("FCI_no_skip") +s = H_apply("FCI_no_skip") s.set_selection_pt2("epstein_nesbet_2x2") s.unset_skip() -s.unset_openmp() +#s.unset_openmp() print s s = H_apply("FCI_mono") diff --git a/plugins/MRCC_CASSD/EZFIO.cfg b/plugins/MRCC_CASSD/EZFIO.cfg index 21cc5b98..e145c9e0 100644 --- a/plugins/MRCC_CASSD/EZFIO.cfg +++ b/plugins/MRCC_CASSD/EZFIO.cfg @@ -2,3 +2,16 @@ type: double precision doc: Calculated energy interface: ezfio + +[thresh_mrcc] +type: Threshold +doc: Threshold on the convergence of the MRCC energy +interface: ezfio,provider,ocaml +default: 1.e-7 + +[n_it_mrcc_max] +type: Strictly_positive_int +doc: Maximum number of MRCC iterations +interface: ezfio,provider,ocaml +default: 20 + diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 1e2f974d..79e9ef7c 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -1,102 +1,35 @@ - BEGIN_PROVIDER [integer, pert_determinants, (N_states, psi_det_size) ] - END_PROVIDER - - - BEGIN_PROVIDER [ double precision, lambda_mrcc, (N_states,psi_det_size) ] -&BEGIN_PROVIDER [ double precision, lambda_pert, (N_states,psi_det_size) ] +BEGIN_PROVIDER [ double precision, lambda_mrcc, (N_states,psi_det_size) ] implicit none BEGIN_DOC ! cm/ or perturbative 1/Delta_E(m) END_DOC - integer :: i,k,j - double precision :: ihpsi(N_states), hii,delta_e_eff,ihpsi_current(N_states),hij - integer :: i_ok,i_pert,i_pert_count - i_ok = 0 - - double precision :: phase_restart(N_states),tmp - do k = 1, N_states - phase_restart(k) = dsign(1.d0,psi_ref_coef_restart(1,k)/psi_ref_coef(1,k)) - enddo - i_pert_count = 0 + integer :: i,k + double precision :: ihpsi(N_states),ihpsi_current(N_states) + integer :: i_pert_count - do i=1,N_det_non_ref - call i_h_psi(psi_non_ref(1,1,i), psi_ref_restart, psi_ref_coef_restart, N_int, N_det_ref,& - size(psi_ref_coef_restart,1), n_states, ihpsi) - call i_H_j(psi_non_ref(1,1,i),psi_non_ref(1,1,i),N_int,hii) -! TODO --- Test perturbatif ------ - do k=1,N_states - lambda_pert(k,i) = 1.d0 / (psi_ref_energy_diagonalized(k)-hii) - ! TODO : i_h_psi peut sortir de la boucle? - call i_h_psi(psi_non_ref(1,1,i), psi_ref, psi_ref_coef, N_int, N_det_ref,size(psi_ref_coef,1), n_states, ihpsi_current) - if (ihpsi_current(k) == 0.d0) then - ihpsi_current(k) = 1.d-32 - endif - tmp = psi_non_ref_coef(i,k)/ihpsi_current(k) - i_pert = 0 - ! Perturbation only if 1st order < 0.5 x second order - if((ihpsi(k) * lambda_pert(k,i)) < 0.5d0 * psi_non_ref_coef_restart(i,k) )then - i_pert = 1 - else - do j = 1, N_det_ref - call i_H_j(psi_non_ref(1,1,i),psi_ref(1,1,j),N_int,hij) - ! Perturbation diverges when hij*tmp > 0.5 - if(dabs(hij * tmp).ge.0.5d0)then - i_pert_count +=1 - i_pert = 1 - exit - endif - enddo - endif - 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 ------ + i_pert_count = 0 + lambda_mrcc = 0.d0 + + do i=1,N_det_non_ref + call i_h_psi(psi_non_ref(1,1,i), psi_ref, psi_ref_coef, N_int, N_det_ref,size(psi_ref_coef,1), n_states, ihpsi_current) + do k=1,N_states + if (ihpsi_current(k) == 0.d0) then + ihpsi_current(k) = 1.d-32 + endif + if(dabs(ihpsi_current(k) * psi_non_ref_coef(i,k)) < 1d-5) then + i_pert_count +=1 + else + lambda_mrcc(k,i) = psi_non_ref_coef(i,k)/ihpsi_current(k) + endif + 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*,'Number of Perturbatively treated determinants = ',i_ok - print*,'i_pert_count = ',i_pert_count + print*,'Number of ignored determinants = ',i_pert_count print*,'psi_coef_ref_ratio = ',psi_ref_coef(2,1)/psi_ref_coef(1,1) - END_PROVIDER -BEGIN_PROVIDER [ double precision, lambda_mrcc_tmp, (N_states,psi_det_size) ] - implicit none - lambda_mrcc_tmp = 0.d0 -END_PROVIDER - -BEGIN_PROVIDER [ logical, oscillations ] - implicit none - oscillations = .False. -END_PROVIDER - - !BEGIN_PROVIDER [ double precision, delta_ij_non_ref, (N_det_non_ref, N_det_non_ref,N_states) ] From a6911ff85b0603e29d695fb05c5053a95d77b5e2 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 29 Mar 2016 21:16:40 +0200 Subject: [PATCH 21/23] Fixed compilation --- plugins/MRCC_Utils/mrcc_general.irp.f | 16 -- plugins/MRCC_Utils/mrcepa_dress.irp.f | 260 ------------------------ plugins/MRCC_Utils/mrcepa_general.irp.f | 97 --------- 3 files changed, 373 deletions(-) delete mode 100644 plugins/MRCC_Utils/mrcepa_dress.irp.f delete mode 100644 plugins/MRCC_Utils/mrcepa_general.irp.f diff --git a/plugins/MRCC_Utils/mrcc_general.irp.f b/plugins/MRCC_Utils/mrcc_general.irp.f index c567c76a..5d9acfc1 100644 --- a/plugins/MRCC_Utils/mrcc_general.irp.f +++ b/plugins/MRCC_Utils/mrcc_general.irp.f @@ -31,23 +31,7 @@ subroutine mrcc_iterations E_past(j) = E_new j +=1 - if(j>4)then - j=1 - endif - if(iteration > 4) then - if(delta_E > 1.d-10)then - if(dabs(E_past(1) - E_past(3)) .le. delta_E .and. dabs(E_past(2) - E_past(4)).le. delta_E)then - print*,'OSCILLATIONS !!!' - oscillations = .True. - i_oscillations +=1 - lambda_mrcc_tmp = lambda_mrcc - endif - endif - endif call save_wavefunction -! if (i_oscillations > 5) then -! exit -! endif if (iteration > 200) then exit endif diff --git a/plugins/MRCC_Utils/mrcepa_dress.irp.f b/plugins/MRCC_Utils/mrcepa_dress.irp.f deleted file mode 100644 index 9789b818..00000000 --- a/plugins/MRCC_Utils/mrcepa_dress.irp.f +++ /dev/null @@ -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) - - ! |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 - - ! - ! - 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 - - ! - 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 - - - - - - - - diff --git a/plugins/MRCC_Utils/mrcepa_general.irp.f b/plugins/MRCC_Utils/mrcepa_general.irp.f deleted file mode 100644 index 3479548b..00000000 --- a/plugins/MRCC_Utils/mrcepa_general.irp.f +++ /dev/null @@ -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 From c504518542287b43e243681b7de019f79b448666 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 29 Mar 2016 23:18:26 +0200 Subject: [PATCH 22/23] MRCC acceleration --- plugins/MRCC_Utils/H_apply.irp.f | 42 +--- plugins/MRCC_Utils/mrcc_dress.irp.f | 254 +++++++++++++---------- plugins/MRCC_Utils/mrcc_utils.irp.f | 52 ++--- plugins/Psiref_Utils/psi_ref_utils.irp.f | 25 +++ src/Determinants/slater_rules.irp.f | 72 +++---- src/Integrals_Bielec/map_integrals.irp.f | 4 +- 6 files changed, 238 insertions(+), 211 deletions(-) diff --git a/plugins/MRCC_Utils/H_apply.irp.f b/plugins/MRCC_Utils/H_apply.irp.f index 1cafc8de..decc5a75 100644 --- a/plugins/MRCC_Utils/H_apply.irp.f +++ b/plugins/MRCC_Utils/H_apply.irp.f @@ -3,19 +3,19 @@ BEGIN_SHELL [ /usr/bin/env python ] from generate_h_apply import * s = H_apply("mrcc") -s.data["parameters"] = ", delta_ij_, delta_ii_,Ndet_ref, Ndet_non_ref" +s.data["parameters"] = ", delta_ij_, delta_ii_, Nstates, Ndet_non_ref, Ndet_ref" s.data["declarations"] += """ - integer, intent(in) :: Ndet_ref,Ndet_non_ref - double precision, intent(in) :: delta_ij_(Ndet_ref,Ndet_non_ref,*) - double precision, intent(in) :: delta_ii_(Ndet_ref,*) + integer, intent(in) :: Nstates, Ndet_ref, Ndet_non_ref + double precision, intent(in) :: delta_ij_(Nstates, Ndet_non_ref, Ndet_ref) + double precision, intent(in) :: delta_ii_(Nstates, Ndet_ref) """ -s.data["keys_work"] = "call mrcc_dress(delta_ij_,delta_ii_,Ndet_ref,Ndet_non_ref,i_generator,key_idx,keys_out,N_int,iproc,key_mask)" -s.data["params_post"] += ", delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref" -s.data["params_main"] += "delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref" +s.data["keys_work"] = "call mrcc_dress(delta_ij_,delta_ii_,Nstates,Ndet_non_ref,Ndet_ref,i_generator,key_idx,keys_out,N_int,iproc,key_mask)" +s.data["params_post"] += ", delta_ij_, delta_ii_, Nstates, Ndet_non_ref, Ndet_ref" +s.data["params_main"] += "delta_ij_, delta_ii_, Nstates, Ndet_non_ref, Ndet_ref" s.data["decls_main"] += """ - integer, intent(in) :: Ndet_ref,Ndet_non_ref - double precision, intent(in) :: delta_ij_(Ndet_ref,Ndet_non_ref,*) - double precision, intent(in) :: delta_ii_(Ndet_ref,*) + integer, intent(in) :: Ndet_ref, Ndet_non_ref, Nstates + double precision, intent(in) :: delta_ij_(Nstates,Ndet_non_ref,Ndet_ref) + double precision, intent(in) :: delta_ii_(Nstates,Ndet_ref) """ s.data["finalization"] = "" s.data["copy_buffer"] = "" @@ -24,27 +24,5 @@ s.data["size_max"] = "3072" print s -s = H_apply("mrcepa") -s.data["parameters"] = ", delta_ij_, delta_ii_,Ndet_ref, Ndet_non_ref" -s.data["declarations"] += """ - integer, intent(in) :: Ndet_ref,Ndet_non_ref - double precision, intent(in) :: delta_ij_(Ndet_ref,Ndet_non_ref,*) - double precision, intent(in) :: delta_ii_(Ndet_ref,*) -""" -s.data["keys_work"] = "call mrcepa_dress(delta_ij_,delta_ii_,Ndet_ref,Ndet_non_ref,i_generator,key_idx,keys_out,N_int,iproc,key_mask)" -s.data["params_post"] += ", delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref" -s.data["params_main"] += "delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref" -s.data["decls_main"] += """ - integer, intent(in) :: Ndet_ref,Ndet_non_ref - double precision, intent(in) :: delta_ij_(Ndet_ref,Ndet_non_ref,*) - double precision, intent(in) :: delta_ii_(Ndet_ref,*) -""" -s.data["finalization"] = "" -s.data["copy_buffer"] = "" -s.data["generate_psi_guess"] = "" -s.data["size_max"] = "3072" -# print s - - END_SHELL diff --git a/plugins/MRCC_Utils/mrcc_dress.irp.f b/plugins/MRCC_Utils/mrcc_dress.irp.f index 5747b174..c3f3debf 100644 --- a/plugins/MRCC_Utils/mrcc_dress.irp.f +++ b/plugins/MRCC_Utils/mrcc_dress.irp.f @@ -14,14 +14,14 @@ BEGIN_PROVIDER [ integer(omp_lock_kind), psi_ref_lock, (psi_det_size) ] END_PROVIDER -subroutine mrcc_dress(delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref,i_generator,n_selected,det_buffer,Nint,iproc,key_mask) +subroutine mrcc_dress(delta_ij_, delta_ii_, Nstates, Ndet_non_ref, Ndet_ref,i_generator,n_selected,det_buffer,Nint,iproc,key_mask) use bitmasks implicit none integer, intent(in) :: i_generator,n_selected, Nint, iproc - integer, intent(in) :: Ndet_ref, Ndet_non_ref - double precision, intent(inout) :: delta_ij_(Ndet_ref,Ndet_non_ref,*) - double precision, intent(inout) :: delta_ii_(Ndet_ref,*) + integer, intent(in) :: Nstates, Ndet_ref, Ndet_non_ref + double precision, intent(inout) :: delta_ij_(Nstates,Ndet_non_ref,Ndet_ref) + double precision, intent(inout) :: delta_ii_(Nstates,Ndet_ref) integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) integer :: i,j,k,l @@ -32,10 +32,10 @@ subroutine mrcc_dress(delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref,i_generator,n integer(bit_kind) :: tq(Nint,2,n_selected) integer :: N_tq, c_ref ,degree - double precision :: hIk, hla, hIl, dIk(N_states), dka(N_states), dIa(N_states) + double precision :: hIk, hla, hIl, dIk(Nstates), dka(Nstates), dIa(Nstates) double precision, allocatable :: dIa_hla(:,:) double precision :: haj, phase, phase2 - double precision :: f(N_states), ci_inv(N_states) + double precision :: f(Nstates), ci_inv(Nstates) integer :: exc(0:2,2,2) integer :: h1,h2,p1,p2,s1,s2 integer(bit_kind) :: tmp_det(Nint,2) @@ -46,10 +46,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,allocatable :: idx_miniList(:) integer :: N_miniList, ni, leng + double precision, allocatable :: hij_cache(:) leng = max(N_det_generators, N_det_non_ref) - allocate(miniList(Nint, 2, leng), idx_miniList(leng)) + allocate(miniList(Nint, 2, leng), idx_miniList(leng), hij_cache(N_det_non_ref)) !create_minilist_find_previous(key_mask, fullList, miniList, N_fullList, N_miniList, fullMatch, Nint) call create_minilist_find_previous(key_mask, psi_det_generators, miniList, i_generator-1, N_miniList, fullMatch, Nint) @@ -60,124 +61,157 @@ 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) - - allocate (dIa_hla(N_states,Ndet_non_ref)) - + + allocate (dIa_hla(Nstates,Ndet_non_ref)) + ! |I> - + ! |alpha> - if(N_tq > 0) then - call create_minilist(key_mask, psi_non_ref, miniList, idx_miniList, N_det_non_ref, N_minilist, Nint) - end if + if(N_tq > 0) then + call create_minilist(key_mask, psi_non_ref, miniList, idx_miniList, N_det_non_ref, N_minilist, Nint) + 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(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) do j=1,idx_alpha(0) idx_alpha(j) = idx_miniList(idx_alpha(j)) 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> 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 - - ! |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 i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),Nint,hIk) - do i_state=1,N_states - dIk(i_state) = hIk * lambda_mrcc(i_state,idx_alpha(k_sd)) - enddo - ! |l> = Exc(k -> alpha) |I> - call get_excitation(psi_non_ref(1,1,idx_alpha(k_sd)),tq(1,1,i_alpha),exc,degree,phase,Nint) - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - do k=1,N_int - tmp_det(k,1) = psi_ref(k,1,i_I) - tmp_det(k,2) = psi_ref(k,2,i_I) - enddo - ! Hole (see list_to_bitstring) - iint = ishft(h1-1,-bit_kind_shift) + 1 - ipos = h1-ishft((iint-1),bit_kind_shift)-1 - tmp_det(iint,s1) = ibclr(tmp_det(iint,s1),ipos) - - ! Particle - iint = ishft(p1-1,-bit_kind_shift) + 1 - ipos = p1-ishft((iint-1),bit_kind_shift)-1 - tmp_det(iint,s1) = ibset(tmp_det(iint,s1),ipos) - if (degree_alpha(k_sd) == 2) then - ! Hole (see list_to_bitstring) - iint = ishft(h2-1,-bit_kind_shift) + 1 - ipos = h2-ishft((iint-1),bit_kind_shift)-1 - tmp_det(iint,s2) = ibclr(tmp_det(iint,s2),ipos) - - ! Particle - iint = ishft(p2-1,-bit_kind_shift) + 1 - ipos = p2-ishft((iint-1),bit_kind_shift)-1 - tmp_det(iint,s2) = ibset(tmp_det(iint,s2),ipos) - endif - - ! - do i_state=1,N_states - dka(i_state) = 0.d0 - enddo - do l_sd=k_sd+1,idx_alpha(0) - call get_excitation_degree(tmp_det,psi_non_ref(1,1,idx_alpha(l_sd)),degree,Nint) - if (degree == 0) then - call get_excitation(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),exc,degree,phase2,Nint) - call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hIl) - do i_state=1,N_states - dka(i_state) = hIl * lambda_mrcc(i_state,idx_alpha(l_sd)) * phase * phase2 - enddo - exit - endif - enddo - do i_state=1,N_states - dIa(i_state) = dIa(i_state) + dIk(i_state) * dka(i_state) - enddo - enddo - - do i_state=1,N_states - ci_inv(i_state) = 1.d0/psi_ref_coef(i_I,i_state) - enddo - do l_sd=1,idx_alpha(0) - k_sd = idx_alpha(l_sd) - call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hla) - do i_state=1,N_states - dIa_hla(i_state,k_sd) = dIa(i_state) * hla - enddo - enddo - call omp_set_lock( psi_ref_lock(i_I) ) - do l_sd=1,idx_alpha(0) - k_sd = idx_alpha(l_sd) - do i_state=1,N_states - delta_ij_(i_I,k_sd,i_state) += dIa_hla(i_state,k_sd) - if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5)then - delta_ii_(i_I,i_state) -= dIa_hla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef(k_sd,i_state) - else - delta_ii_(i_I,i_state) = 0.d0 - endif - enddo - enddo - call omp_unset_lock( psi_ref_lock(i_I) ) + ! Find triples and quadruple grand parents + call get_excitation_degree(tq(1,1,i_alpha),psi_ref(1,1,i_I),degree,Nint) + if (degree > 4) then + cycle + endif + + do i_state=1,Nstates + dIa(i_state) = 0.d0 + enddo + + ! |alpha> + do k_sd=1,idx_alpha(0) + + ! Loop if lambda == 0 + logical :: loop + loop = .True. + do i_state=1,Nstates + if (lambda_mrcc(i_state,idx_alpha(k_sd)) /= 0.d0) then + loop = .False. + exit + endif + enddo + if (loop) then + cycle + endif + + call get_excitation_degree(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),degree,Nint) + if (degree > 2) then + cycle + endif + + ! + ! + hIk = hij_mrcc(idx_alpha(k_sd),i_I) + ! call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),Nint,hIk) + do i_state=1,Nstates + dIk(i_state) = hIk * lambda_mrcc(i_state,idx_alpha(k_sd)) + enddo + ! |l> = Exc(k -> alpha) |I> + call get_excitation(psi_non_ref(1,1,idx_alpha(k_sd)),tq(1,1,i_alpha),exc,degree,phase,Nint) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + do k=1,N_int + tmp_det(k,1) = psi_ref(k,1,i_I) + tmp_det(k,2) = psi_ref(k,2,i_I) + enddo + ! Hole (see list_to_bitstring) + iint = ishft(h1-1,-bit_kind_shift) + 1 + ipos = h1-ishft((iint-1),bit_kind_shift)-1 + tmp_det(iint,s1) = ibclr(tmp_det(iint,s1),ipos) + + ! Particle + iint = ishft(p1-1,-bit_kind_shift) + 1 + ipos = p1-ishft((iint-1),bit_kind_shift)-1 + tmp_det(iint,s1) = ibset(tmp_det(iint,s1),ipos) + if (degree_alpha(k_sd) == 2) then + ! Hole (see list_to_bitstring) + iint = ishft(h2-1,-bit_kind_shift) + 1 + ipos = h2-ishft((iint-1),bit_kind_shift)-1 + tmp_det(iint,s2) = ibclr(tmp_det(iint,s2),ipos) + + ! Particle + iint = ishft(p2-1,-bit_kind_shift) + 1 + ipos = p2-ishft((iint-1),bit_kind_shift)-1 + tmp_det(iint,s2) = ibset(tmp_det(iint,s2),ipos) + endif + + ! + do i_state=1,Nstates + dka(i_state) = 0.d0 + enddo + do l_sd=k_sd+1,idx_alpha(0) + call get_excitation_degree(tmp_det,psi_non_ref(1,1,idx_alpha(l_sd)),degree,Nint) + if (degree == 0) then + + loop = .True. + do i_state=1,Nstates + if (lambda_mrcc(i_state,idx_alpha(l_sd)) /= 0.d0) then + loop = .False. + exit + endif + enddo + if (.not.loop) then + call get_excitation(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),exc,degree,phase2,Nint) + hIl = hij_mrcc(idx_alpha(l_sd),i_I) + ! call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hIl) + do i_state=1,Nstates + dka(i_state) = hIl * lambda_mrcc(i_state,idx_alpha(l_sd)) * phase * phase2 + enddo + endif + exit + endif + enddo + do i_state=1,Nstates + dIa(i_state) = dIa(i_state) + dIk(i_state) * dka(i_state) + enddo + enddo + + do i_state=1,Nstates + ci_inv(i_state) = 1.d0/psi_ref_coef(i_I,i_state) + enddo + do l_sd=1,idx_alpha(0) + k_sd = idx_alpha(l_sd) + hla = hij_cache(k_sd) +! call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hla) + do i_state=1,Nstates + dIa_hla(i_state,k_sd) = dIa(i_state) * hla + enddo + enddo + call omp_set_lock( psi_ref_lock(i_I) ) + do l_sd=1,idx_alpha(0) + k_sd = idx_alpha(l_sd) + do i_state=1,Nstates + delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + dIa_hla(i_state,k_sd) + if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5)then + delta_ii_(i_state,i_I) = delta_ii_(i_state,i_I) - dIa_hla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) + else + delta_ii_(i_state,i_I) = 0.d0 + endif + enddo + enddo + call omp_unset_lock( psi_ref_lock(i_I) ) enddo enddo - deallocate (dIa_hla) + deallocate (dIa_hla,hij_cache) deallocate(miniList, idx_miniList) end diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 79e9ef7c..c41a3431 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -41,8 +41,22 @@ END_PROVIDER !call H_apply_mrcc_simple(delta_ij_non_ref,N_det_non_ref) !END_PROVIDER - BEGIN_PROVIDER [ double precision, delta_ij, (N_det_ref,N_det_non_ref,N_states) ] -&BEGIN_PROVIDER [ double precision, delta_ii, (N_det_ref,N_states) ] +BEGIN_PROVIDER [ double precision, hij_mrcc, (N_det_non_ref,N_det_ref) ] + implicit none + BEGIN_DOC + ! < ref | H | Non-ref > matrix + END_DOC + integer :: i_I, k_sd + do i_I=1,N_det_ref + do k_sd=1,N_det_non_ref + call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,k_sd),N_int,hij_mrcc(k_sd,i_I)) + enddo + enddo + +END_PROVIDER + + BEGIN_PROVIDER [ double precision, delta_ij, (N_states,N_det_non_ref,N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ii, (N_states,N_det_ref) ] implicit none BEGIN_DOC ! Dressing matrix in N_det basis @@ -50,32 +64,7 @@ END_PROVIDER integer :: i,j,m delta_ij = 0.d0 delta_ii = 0.d0 - call H_apply_mrcc(delta_ij,delta_ii,N_det_ref,N_det_non_ref) - double precision :: max_delta - double precision :: accu - integer :: imax,jmax - max_delta = 0.d0 - accu = 0.d0 - do i = 1, N_det_ref - do j = 1, N_det_non_ref - accu += psi_non_ref_coef(j,1) * psi_ref_coef(i,1) * delta_ij(i,j,1) - if(dabs(delta_ij(i,j,1)).gt.max_delta)then - max_delta = dabs(delta_ij(i,j,1)) - imax = i - jmax = j - endif - enddo - enddo - print*,'' - print*,'' - print*,' = ',accu - print*,'MAX VAL OF DRESING = ',delta_ij(imax,jmax,1) - print*,'imax,jmax = ',imax,jmax - print*,'psi_ref_coef(imax,1) = ',psi_ref_coef(imax,1) - print*,'psi_non_ref_coef(jmax,1) = ',psi_non_ref_coef(jmax,1) - do i = 1, N_det_ref - print*,'delta_ii(i,1) = ',delta_ii(i,1) - enddo + call H_apply_mrcc(delta_ij,delta_ii,N_states,N_det_non_ref,N_det_ref) END_PROVIDER BEGIN_PROVIDER [ double precision, h_matrix_dressed, (N_det,N_det,N_states) ] @@ -92,11 +81,11 @@ BEGIN_PROVIDER [ double precision, h_matrix_dressed, (N_det,N_det,N_states) ] enddo do ii = 1, N_det_ref i =idx_ref(ii) - h_matrix_dressed(i,i,istate) += delta_ii(ii,istate) + h_matrix_dressed(i,i,istate) += delta_ii(istate,ii) do jj = 1, N_det_non_ref j =idx_non_ref(jj) - h_matrix_dressed(i,j,istate) += delta_ij(ii,jj,istate) - h_matrix_dressed(j,i,istate) += delta_ij(ii,jj,istate) + h_matrix_dressed(i,j,istate) += delta_ij(istate,jj,ii) + h_matrix_dressed(j,i,istate) += delta_ij(istate,jj,ii) enddo enddo enddo @@ -200,3 +189,4 @@ subroutine diagonalize_CI_dressed SOFT_TOUCH psi_coef end + diff --git a/plugins/Psiref_Utils/psi_ref_utils.irp.f b/plugins/Psiref_Utils/psi_ref_utils.irp.f index fb45b13d..5115ba23 100644 --- a/plugins/Psiref_Utils/psi_ref_utils.irp.f +++ b/plugins/Psiref_Utils/psi_ref_utils.irp.f @@ -14,6 +14,31 @@ use bitmasks END_PROVIDER +BEGIN_PROVIDER [ double precision, psi_ref_coef_transp, (n_states,psi_det_size) ] + implicit none + BEGIN_DOC +! Transposed psi_ref_coef + END_DOC + integer :: i,j + do j=1,N_det_ref + do i=1, n_states + psi_ref_coef_transp(i,j) = psi_ref_coef(j,i) + enddo + enddo +END_PROVIDER + +BEGIN_PROVIDER [ double precision, psi_non_ref_coef_transp, (n_states,psi_det_size) ] + implicit none + BEGIN_DOC +! Transposed psi_non_ref_coef + END_DOC + integer :: i,j + do j=1,N_det_non_ref + do i=1, n_states + psi_non_ref_coef_transp(i,j) = psi_non_ref_coef(j,i) + enddo + enddo +END_PROVIDER BEGIN_PROVIDER [ integer(bit_kind), psi_non_ref, (N_int,2,psi_det_size) ] &BEGIN_PROVIDER [ double precision, psi_non_ref_coef, (psi_det_size,n_states) ] diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index ec786941..b63ae69f 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -443,7 +443,7 @@ subroutine i_H_j(key_i,key_j,Nint,hij) integer :: exc(0:2,2,2) integer :: degree - double precision :: get_mo_bielec_integral_schwartz + double precision :: get_mo_bielec_integral integer :: m,n,p,q integer :: i,j,k integer :: occ(Nint*bit_kind_size,2) @@ -468,31 +468,31 @@ subroutine i_H_j(key_i,key_j,Nint,hij) call get_double_excitation(key_i,key_j,exc,phase,Nint) if (exc(0,1,1) == 1) then ! Mono alpha, mono beta - hij = phase*get_mo_bielec_integral_schwartz( & + hij = phase*get_mo_bielec_integral( & exc(1,1,1), & exc(1,1,2), & exc(1,2,1), & exc(1,2,2) ,mo_integrals_map) else if (exc(0,1,1) == 2) then ! Double alpha - hij = phase*(get_mo_bielec_integral_schwartz( & + hij = phase*(get_mo_bielec_integral( & exc(1,1,1), & exc(2,1,1), & exc(1,2,1), & exc(2,2,1) ,mo_integrals_map) - & - get_mo_bielec_integral_schwartz( & + get_mo_bielec_integral( & exc(1,1,1), & exc(2,1,1), & exc(2,2,1), & exc(1,2,1) ,mo_integrals_map) ) else if (exc(0,1,2) == 2) then ! Double beta - hij = phase*(get_mo_bielec_integral_schwartz( & + hij = phase*(get_mo_bielec_integral( & exc(1,1,2), & exc(2,1,2), & exc(1,2,2), & exc(2,2,2) ,mo_integrals_map) - & - get_mo_bielec_integral_schwartz( & + get_mo_bielec_integral( & exc(1,1,2), & exc(2,1,2), & exc(2,2,2), & @@ -510,15 +510,15 @@ subroutine i_H_j(key_i,key_j,Nint,hij) do k = 1, elec_alpha_num i = occ(k,1) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) - miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map) + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) has_mipi(i) = .True. endif enddo do k = 1, elec_beta_num i = occ(k,2) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) has_mipi(i) = .True. endif enddo @@ -537,15 +537,15 @@ subroutine i_H_j(key_i,key_j,Nint,hij) do k = 1, elec_beta_num i = occ(k,2) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) - miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map) + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) has_mipi(i) = .True. endif enddo do k = 1, elec_alpha_num i = occ(k,1) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) has_mipi(i) = .True. endif enddo @@ -579,7 +579,7 @@ subroutine i_H_j_phase_out(key_i,key_j,Nint,hij,phase,exc,degree) integer,intent(out) :: exc(0:2,2,2) integer,intent(out) :: degree - double precision :: get_mo_bielec_integral_schwartz + double precision :: get_mo_bielec_integral integer :: m,n,p,q integer :: i,j,k integer :: occ(Nint*bit_kind_size,2) @@ -604,31 +604,31 @@ subroutine i_H_j_phase_out(key_i,key_j,Nint,hij,phase,exc,degree) call get_double_excitation(key_i,key_j,exc,phase,Nint) if (exc(0,1,1) == 1) then ! Mono alpha, mono beta - hij = phase*get_mo_bielec_integral_schwartz( & + hij = phase*get_mo_bielec_integral( & exc(1,1,1), & exc(1,1,2), & exc(1,2,1), & exc(1,2,2) ,mo_integrals_map) else if (exc(0,1,1) == 2) then ! Double alpha - hij = phase*(get_mo_bielec_integral_schwartz( & + hij = phase*(get_mo_bielec_integral( & exc(1,1,1), & exc(2,1,1), & exc(1,2,1), & exc(2,2,1) ,mo_integrals_map) - & - get_mo_bielec_integral_schwartz( & + get_mo_bielec_integral( & exc(1,1,1), & exc(2,1,1), & exc(2,2,1), & exc(1,2,1) ,mo_integrals_map) ) else if (exc(0,1,2) == 2) then ! Double beta - hij = phase*(get_mo_bielec_integral_schwartz( & + hij = phase*(get_mo_bielec_integral( & exc(1,1,2), & exc(2,1,2), & exc(1,2,2), & exc(2,2,2) ,mo_integrals_map) - & - get_mo_bielec_integral_schwartz( & + get_mo_bielec_integral( & exc(1,1,2), & exc(2,1,2), & exc(2,2,2), & @@ -646,15 +646,15 @@ subroutine i_H_j_phase_out(key_i,key_j,Nint,hij,phase,exc,degree) do k = 1, elec_alpha_num i = occ(k,1) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) - miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map) + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) has_mipi(i) = .True. endif enddo do k = 1, elec_beta_num i = occ(k,2) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) has_mipi(i) = .True. endif enddo @@ -673,15 +673,15 @@ subroutine i_H_j_phase_out(key_i,key_j,Nint,hij,phase,exc,degree) do k = 1, elec_beta_num i = occ(k,2) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) - miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map) + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) has_mipi(i) = .True. endif enddo do k = 1, elec_alpha_num i = occ(k,1) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) has_mipi(i) = .True. endif enddo @@ -715,7 +715,7 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble) integer :: exc(0:2,2,2) integer :: degree - double precision :: get_mo_bielec_integral_schwartz + double precision :: get_mo_bielec_integral integer :: m,n,p,q integer :: i,j,k integer :: occ(Nint*bit_kind_size,2) @@ -742,31 +742,31 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble) call get_double_excitation(key_i,key_j,exc,phase,Nint) if (exc(0,1,1) == 1) then ! Mono alpha, mono beta - hij = phase*get_mo_bielec_integral_schwartz( & + hij = phase*get_mo_bielec_integral( & exc(1,1,1), & exc(1,1,2), & exc(1,2,1), & exc(1,2,2) ,mo_integrals_map) else if (exc(0,1,1) == 2) then ! Double alpha - hij = phase*(get_mo_bielec_integral_schwartz( & + hij = phase*(get_mo_bielec_integral( & exc(1,1,1), & exc(2,1,1), & exc(1,2,1), & exc(2,2,1) ,mo_integrals_map) - & - get_mo_bielec_integral_schwartz( & + get_mo_bielec_integral( & exc(1,1,1), & exc(2,1,1), & exc(2,2,1), & exc(1,2,1) ,mo_integrals_map) ) else if (exc(0,1,2) == 2) then ! Double beta - hij = phase*(get_mo_bielec_integral_schwartz( & + hij = phase*(get_mo_bielec_integral( & exc(1,1,2), & exc(2,1,2), & exc(1,2,2), & exc(2,2,2) ,mo_integrals_map) - & - get_mo_bielec_integral_schwartz( & + get_mo_bielec_integral( & exc(1,1,2), & exc(2,1,2), & exc(2,2,2), & @@ -784,15 +784,15 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble) do k = 1, elec_alpha_num i = occ(k,1) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) - miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map) + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) has_mipi(i) = .True. endif enddo do k = 1, elec_beta_num i = occ(k,2) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) has_mipi(i) = .True. endif enddo @@ -811,15 +811,15 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble) do k = 1, elec_beta_num i = occ(k,2) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) - miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map) + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) has_mipi(i) = .True. endif enddo do k = 1, elec_alpha_num i = occ(k,1) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) has_mipi(i) = .True. endif enddo diff --git a/src/Integrals_Bielec/map_integrals.irp.f b/src/Integrals_Bielec/map_integrals.irp.f index 84b08715..4041242e 100644 --- a/src/Integrals_Bielec/map_integrals.irp.f +++ b/src/Integrals_Bielec/map_integrals.irp.f @@ -324,9 +324,9 @@ double precision function mo_bielec_integral(i,j,k,l) ! Returns one integral in the MO basis END_DOC integer, intent(in) :: i,j,k,l - double precision :: get_mo_bielec_integral_schwartz + double precision :: get_mo_bielec_integral PROVIDE mo_bielec_integrals_in_map - mo_bielec_integral = get_mo_bielec_integral_schwartz(i,j,k,l,mo_integrals_map) + mo_bielec_integral = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) return end From 45b3a98e4ef659e0a44c65d5a6109c5aca308e8e Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 30 Mar 2016 01:21:36 +0200 Subject: [PATCH 23/23] Fixed MRCC test --- tests/bats/qp.bats | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/bats/qp.bats b/tests/bats/qp.bats index de0cd1c8..1be43412 100644 --- a/tests/bats/qp.bats +++ b/tests/bats/qp.bats @@ -155,7 +155,7 @@ function run_all_1h_1p() { ezfio set determinants read_wf True qp_run mrcc_cassd $INPUT energy="$(ezfio get mrcc_cassd energy)" - eq $energy -0.762303253805911E+02 1.E-3 + eq $energy -76.2289109271715 1.E-3 }