diff --git a/.travis.yml b/.travis.yml index f451f1d6..18a13949 100644 --- a/.travis.yml +++ b/.travis.yml @@ -24,7 +24,7 @@ python: script: - ./configure --production ./config/gfortran.cfg - - source ./quantum_package.rc ; qp_module.py install Full_CI Hartree_Fock CAS_SD MRCC_CASSD + - 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/README.md b/README.md index ce90ee61..e313f444 100644 --- a/README.md +++ b/README.md @@ -148,3 +148,20 @@ You have two or more ezfio configuration files for the same variable. Check file - rm $QP_ROOT/install/EZFIO/config/* - ninja + + +### Error: Seg Fault (139) + +``` +Segmentation fault (core dumped) +Program exited with code 139. +``` + +#### Why ? + +It's caused when we call the DGEM routine of LAPACK. + +##### Fix + +Set `ulimit -s unlimited`, before runing `qp_run`. It seem to fix the problem. + 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 4e5f3732..0f414621 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', @@ -334,7 +334,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", "" ] @@ -488,10 +488,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/data/basis/chipman-dzp b/data/basis/chipman-dzp new file mode 100644 index 00000000..b0178ef4 --- /dev/null +++ b/data/basis/chipman-dzp @@ -0,0 +1,168 @@ +HYDROGEN +S 3 + 1 127.9500000 0.0107360 + 2 19.2406000 0.1195440 + 3 2.8992000 0.9264160 +S 1 + 1 0.6534000 1.0000000 +S 1 + 1 0.1776000 1.0000000 +S 1 + 1 0.0483000 1.0000000 +P 1 + 1 1.0000000 1.0000000 + +BORON +S 5 + 1 2788.4100000 0.0021220 + 2 419.0390000 0.0161710 + 3 96.4683000 0.0783560 + 4 28.0694000 0.2632500 + 5 9.3760000 0.5967290 +S 1 + 1 1.3057000 1.0000000 +S 1 + 1 3.4062000 1.0000000 +S 1 + 1 0.3245000 1.0000000 +S 1 + 1 0.1022000 1.0000000 +S 1 + 1 0.0330000 1.0000000 +P 4 + 1 11.3413000 0.0179870 + 2 2.4360000 0.1103390 + 3 0.6836000 0.3831110 + 4 0.2134000 0.6478600 +P 1 + 1 0.0701000 1.0000000 +P 1 + 1 0.0226000 1.0000000 +D 1 + 1 0.1600000 1.0000000 +D 1 + 1 0.6400000 1.0000000 + +CARBON +S 5 + 1 5909.4400000 0.0020040 + 2 887.4510000 0.0153100 + 3 204.7490000 0.0742930 + 4 59.8376000 0.2533640 + 5 19.9981000 0.6005760 +S 1 + 1 2.6860000 1.0000000 +S 1 + 1 7.1927000 1.0000000 +S 1 + 1 0.7000000 1.0000000 +S 1 + 1 0.2133000 1.0000000 +S 1 + 1 0.0667000 1.0000000 +P 4 + 1 26.7860000 0.0182570 + 2 5.9564000 0.1164070 + 3 1.7074000 0.3901110 + 4 0.5314000 0.6372210 +P 1 + 1 0.1654000 1.0000000 +P 1 + 1 0.0517000 1.0000000 +D 1 + 1 0.3700000 1.0000000 +D 1 + 1 1.4800000 1.0000000 + +NITROGEN +S 5 + 1 5909.4400000 0.0020040 + 2 887.4510000 0.0153100 + 3 204.7490000 0.0742930 + 4 59.8376000 0.2533640 + 5 19.9981000 0.6005760 +S 1 + 1 2.6860000 1.0000000 +S 1 + 1 7.1927000 1.0000000 +S 1 + 1 0.7000000 1.0000000 +S 1 + 1 0.2133000 1.0000000 +S 1 + 1 0.0667000 1.0000000 +P 4 + 1 26.7860000 0.0182570 + 2 5.9564000 0.1164070 + 3 1.7074000 0.3901110 + 4 0.5314000 0.6372210 +P 1 + 1 0.1654000 1.0000000 +P 1 + 1 0.0517000 1.0000000 +D 1 + 1 0.3700000 1.0000000 +D 1 + 1 1.4800000 1.0000000 + +OXYGEN + S 5 + 1 7816.5400000 0.0020310 + 2 1175.8200000 0.0154360 + 3 273.1880000 0.0737710 + 4 81.1696000 0.2476060 + 5 27.1836000 0.6118320 +S 1 + 1 3.4136000 1.0000000 +S 1 + 1 9.5322000 1.0000000 +S 1 + 1 0.9398000 1.0000000 +S 1 + 1 0.2846000 1.0000000 +S 1 + 1 0.0862000 1.0000000 +P 4 + 1 35.1832000 0.0195800 + 2 7.9040000 0.1241890 + 3 2.3051000 0.3947270 + 4 0.7171000 0.6273750 +P 1 + 1 0.2137000 1.0000000 +P 1 + 1 0.0648000 1.0000000 +D 1 + 1 0.5500000 1.0000000 +D 1 + 1 2.2000000 1.0000000 + +FLUORINE +S 5 + 1 9994.7900000 0.0020170 + 2 1506.0300000 0.0152950 + 3 350.2690000 0.0731100 + 4 104.0530000 0.2464200 + 5 34.8432000 0.6125930 +S 1 + 1 4.3688000 1.0000000 +S 1 + 1 12.2164000 1.0000000 +S 1 + 1 1.2078000 1.0000000 +S 1 + 1 0.3634000 1.0000000 +S 1 + 1 0.1101000 1.0000000 +P 4 + 1 44.3555000 0.0208680 + 2 10.0820000 0.1300920 + 3 2.9959000 0.3962190 + 4 0.9383000 0.6203680 +P 1 + 1 0.2733000 1.0000000 +P 1 + 1 0.0828000 1.0000000 +D 1 + 1 0.6650000 1.0000000 +D 1 + 1 2.6600000 1.0000000 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/ocaml/.gitignore b/ocaml/.gitignore deleted file mode 100644 index 0f0c1ef9..00000000 --- a/ocaml/.gitignore +++ /dev/null @@ -1,60 +0,0 @@ -_build -ezfio.ml -.gitignore -Git.ml -Input_auto_generated.ml -Input_determinants.ml -Input_hartree_fock.ml -Input_integrals_bielec.ml -Input_perturbation.ml -Input_properties.ml -Input_pseudo.ml -qp_basis_clean -qp_basis_clean.native -qp_create_ezfio_from_xyz -qp_create_ezfio_from_xyz.native -qp_edit -qp_edit.ml -qp_edit.native -qp_print -qp_print_basis -qp_print_basis.native -qp_print.native -qp_run -qp_run.native -qp_set_ddci -qp_set_ddci.native -qp_set_mo_class -qp_set_mo_class.native -qptypes_generator.byte -Qptypes.ml -test_atom -test_atom.byte -test_basis -test_basis.byte -test_bitlist -test_bitlist.byte -test_determinants -test_determinants.byte -test_elements -test_elements.byte -test_excitation -test_excitation.byte -test_gto -test_gto.byte -test_message -test_message.byte -test_mo_label -test_mo_label.byte -test_molecule -test_molecule.byte -test_point3d -test_point3d.byte -test_pseudo -test_pseudo.byte -test_queuing_system -test_queuing_system.byte -test_symmetry -test_symmetry.byte -test_task_server -test_task_server.byte 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..d7b9fc50 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,39 +19,50 @@ let to_string b = in do_work new_accu tail in do_work "" b -;; + let of_string ?(zero='0') ?(one='1') s = String.to_list s |> List.rev_map ~f:( fun c -> if (c = zero) then Bit.Zero else if (c = one) then Bit.One - else (failwith ("Error in string "^s) ) ) -;; + else (failwith ("Error in bitstring ") ) ) + +let of_string_mp s = + String.to_list s + |> List.rev_map ~f:(function + | '-' -> Bit.Zero + | '+' -> Bit.One + | _ -> failwith ("Error in bitstring ") ) + (* Create a bit list from an int64 *) let of_int64 i = - let rec do_work = function - | 0L -> [ Bit.Zero ] - | 1L -> [ Bit.One ] - | i -> let b = - match (Int64.bit_and i 1L ) with - | 0L -> Bit.Zero - | 1L -> Bit.One - | _ -> raise (Failure "i land 1 not in (0,1)") - in b:: ( do_work (Int64.shift_right_logical i 1) ) + + let rec do_work accu = function + | 0L -> Bit.Zero :: accu |> List.rev + | 1L -> Bit.One :: accu |> List.rev + | i -> + let b = + match (Int64.bit_and i 1L ) with + | 0L -> Bit.Zero + | 1L -> Bit.One + | _ -> raise (Failure "i land 1 not in (0,1)") + in + do_work (b :: accu) (Int64.shift_right_logical i 1) in + let adjust_length result = let rec do_work accu = function - | 64 -> accu + | 64 -> List.rev accu | i when i>64 -> raise (Failure "Error in of_int64 > 64") | i when i<0 -> raise (Failure "Error in of_int64 < 0") - | i -> do_work (accu@[Bit.Zero]) (i+1) + | i -> do_work (Bit.Zero :: accu) (i+1) in - do_work result (List.length result) + do_work (List.rev result) (List.length result) in - adjust_length (do_work i) -;; + adjust_length (do_work [] i) + (* Create an int64 from a bit list *) let to_int64 l = @@ -61,26 +72,32 @@ let to_int64 l = | Bit.Zero::tail -> do_work Int64.(shift_left accu 1) tail | Bit.One::tail -> do_work Int64.(bit_or one (shift_left accu 1)) tail in do_work Int64.zero (List.rev l) -;; + (* Create a bit list from a list of int64 *) let of_int64_list l = List.map ~f:of_int64 l |> List.concat -;; + +(* Create a bit list from an array of int64 *) +let of_int64_array l = + Array.map ~f:of_int64 l + |> Array.to_list + |> List.concat + (* Compute n_int *) let n_int_of_mo_tot_num mo_tot_num = let bit_kind_size = Bit_kind_size.to_int (Lazy.force Qpackage.bit_kind_size) in N_int_number.of_int ( (mo_tot_num-1)/bit_kind_size + 1 ) -;; + (* Create a zero bit list *) let zero n_int = let n_int = N_int_number.to_int n_int in let a = Array.init n_int (fun i-> 0L) in of_int64_list ( Array.to_list a ) -;; + (* Create an int64 list from a bit list *) let to_int64_list l = @@ -100,7 +117,11 @@ let to_int64_list l = let l = do_work [] [] 1 l in List.rev_map ~f:to_int64 l -;; + +(* Create an array of int64 from a bit list *) +let to_int64_array l = + to_int64_list l + |> Array.of_list (* Create a bit list from a list of MO indices *) let of_mo_number_list n_int l = @@ -109,7 +130,7 @@ let of_mo_number_list n_int l = let a = Array.create length (Bit.Zero) in List.iter ~f:(fun i-> a.((MO_number.to_int i)-1) <- Bit.One) l; Array.to_list a -;; + let to_mo_number_list l = let a = Array.of_list l in @@ -127,7 +148,7 @@ let to_mo_number_list l = end in do_work [] (List.length l) -;; + @@ -142,7 +163,7 @@ let logical_operator2 op a b = in do_work_binary (newbit::result) ta tb in List.rev (do_work_binary [] a b) -;; + let logical_operator1 op b = let rec do_work_unary result b = @@ -153,20 +174,19 @@ let logical_operator1 op b = in do_work_unary (newbit::result) tb in List.rev (do_work_unary [] b) -;; -let and_operator a b = logical_operator2 Bit.and_operator a b;; -let xor_operator a b = logical_operator2 Bit.xor_operator a b;; -let or_operator a b = logical_operator2 Bit.or_operator a b;; -let not_operator b = logical_operator1 Bit.not_operator b ;; + +let and_operator a b = logical_operator2 Bit.and_operator a b +let xor_operator a b = logical_operator2 Bit.xor_operator a b +let or_operator a b = logical_operator2 Bit.or_operator a b +let not_operator b = logical_operator1 Bit.not_operator b let popcnt b = - let rec popcnt accu = function - | [] -> accu - | Bit.One::rest -> popcnt (accu+1) rest - | Bit.Zero::rest -> popcnt (accu) rest - in popcnt 0 b -;; + List.fold_left b ~init:0 ~f:(fun accu -> function + | Bit.One -> accu+1 + | Bit.Zero -> accu + ) + diff --git a/ocaml/Bitlist.mli b/ocaml/Bitlist.mli index c733712c..f67d86b7 100644 --- a/ocaml/Bitlist.mli +++ b/ocaml/Bitlist.mli @@ -6,16 +6,21 @@ val zero : Qptypes.N_int_number.t -> t (** Convert to a string for printing *) val to_string : t -> string -(** Convert to a string for printing *) +(** Read from a string *) val of_string : ?zero:char -> ?one:char -> string -> t +(** Read from a string with the ++-- notation *) +val of_string_mp : string -> t + (** int64 conversion functions *) val of_int64 : int64 -> t val to_int64 : t -> int64 -val of_int64_list : int64 list -> t -val to_int64_list : t -> int64 list +val of_int64_list : int64 list -> t +val of_int64_array : int64 array -> t +val to_int64_list : t -> int64 list +val to_int64_array : t -> int64 array (** Get the number of needed int64 elements to encode the bit list *) val n_int_of_mo_tot_num : int -> Qptypes.N_int_number.t diff --git a/ocaml/Determinant.ml b/ocaml/Determinant.ml index 96291904..3791e07e 100644 --- a/ocaml/Determinant.ml +++ b/ocaml/Determinant.ml @@ -4,33 +4,37 @@ open Qptypes;; type t = int64 array with sexp let to_int64_array (x:t) = (x:int64 array) -;; + let to_alpha_beta x = let x = to_int64_array x in let n_int = (Array.length x)/2 in ( Array.init n_int ~f:(fun i -> x.(i)) , Array.init n_int ~f:(fun i -> x.(i+n_int)) ) -;; + let to_bitlist_couple x = let (xa,xb) = to_alpha_beta x in - let xa = to_int64_array xa - |> Array.to_list - |> Bitlist.of_int64_list - and xb = to_int64_array xb - |> Array.to_list - |> Bitlist.of_int64_list + let xa = + to_int64_array xa + |> Bitlist.of_int64_array + and xb = + to_int64_array xb + |> Bitlist.of_int64_array in (xa,xb) -;; + let bitlist_to_string ~mo_tot_num x = - List.map x ~f:(fun i -> match i with - | Bit.Zero -> "-" - | Bit.One -> "+" ) + let len = + MO_number.to_int mo_tot_num + in + List.map x ~f:(function + | Bit.Zero -> "-" + | Bit.One -> "+" + ) |> String.concat - |> String.sub ~pos:0 ~len:(MO_number.to_int mo_tot_num) -;; + |> String.sub ~pos:0 ~len + let of_int64_array ~n_int ~alpha ~beta x = @@ -54,20 +58,25 @@ let of_int64_array ~n_int ~alpha ~beta x = %s" beta (bitlist_to_string ~mo_tot_num:mo_tot_num b) ) end; x -;; -let of_bitlist_couple ~alpha ~beta (xa,xb) = - let ba = Bitlist.to_int64_list xa in - let bb = Bitlist.to_int64_list xb in - let n_int = Bitlist.n_int_of_mo_tot_num (List.length xa) in - of_int64_array ~n_int:n_int ~alpha:alpha ~beta:beta (Array.of_list (ba@bb)) -;; +let of_int64_array_no_check x = x + +let of_bitlist_couple ?n_int ~alpha ~beta (xa,xb) = + let ba, bb = + Bitlist.to_int64_array xa , + Bitlist.to_int64_array xb + and n_int = + match n_int with + | Some x -> x + | None -> Bitlist.n_int_of_mo_tot_num (List.length xa) + in + of_int64_array ~n_int ~alpha ~beta (Array.concat [ba;bb]) + let to_string ~mo_tot_num x = let (xa,xb) = to_bitlist_couple x in - [ bitlist_to_string ~mo_tot_num:mo_tot_num xa ; - bitlist_to_string ~mo_tot_num:mo_tot_num xb ] - |> String.concat ~sep:"\n" -;; + [ " " ; bitlist_to_string ~mo_tot_num xa ; "\n" ; + " " ; bitlist_to_string ~mo_tot_num xb ] + |> String.concat 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 d78233ca..c69c8ad9 100644 --- a/ocaml/Input_determinants_by_hand.ml +++ b/ocaml/Input_determinants_by_hand.ml @@ -11,11 +11,13 @@ module Determinants_by_hand : sig psi_coef : Det_coef.t array; psi_det : Determinant.t array; } with sexp - val read : unit -> t option + val read : unit -> t + val read_maybe : unit -> t option val write : t -> unit val to_string : t -> string val to_rst : t -> Rst_string.t val of_rst : Rst_string.t -> t option + val read_n_int : unit -> N_int_number.t end = struct type t = { n_int : N_int_number.t; @@ -29,6 +31,8 @@ end = struct let get_default = Qpackage.get_ezfio_default "determinants";; + let n_det_read_max = 10_000 ;; + let read_n_int () = if not (Ezfio.has_determinants_n_int()) then Ezfio.get_mo_basis_mo_tot_num () @@ -207,14 +211,24 @@ end = struct let read () = if (Ezfio.has_mo_basis_mo_tot_num ()) then - Some - { n_int = read_n_int () ; - bit_kind = read_bit_kind () ; - n_det = read_n_det () ; - expected_s2 = read_expected_s2 () ; - psi_coef = read_psi_coef () ; - psi_det = read_psi_det () ; - } + { n_int = read_n_int () ; + bit_kind = read_bit_kind () ; + n_det = read_n_det () ; + expected_s2 = read_expected_s2 () ; + psi_coef = read_psi_coef () ; + psi_det = read_psi_det () ; + } + else + failwith "No molecular orbitals, so no determinants" + ;; + + let read_maybe () = + let n_det = + read_n_det () + in + if ( (Det_number.to_int n_det) < n_det_read_max ) then + try Some (read ()) with + | Failure _ -> None else None ;; @@ -236,11 +250,16 @@ end = struct let to_rst b = - let mo_tot_num = Ezfio.get_mo_basis_mo_tot_num () in - let mo_tot_num = MO_number.of_int mo_tot_num ~max:mo_tot_num in + let max = + Ezfio.get_mo_basis_mo_tot_num () + in + let mo_tot_num = + MO_number.of_int ~max max + in let det_text = let nstates = - read_n_states () |> States_number.to_int + read_n_states () + |> States_number.to_int and ndet = Det_number.to_int b.n_det in @@ -393,29 +412,47 @@ psi_det = %s in let rec read_dets accu = function | [] -> List.rev accu - | ""::c::alpha::beta::tail -> + | ""::_::alpha::beta::tail -> begin - let alpha = String.rev alpha |> Bitlist.of_string ~zero:'-' ~one:'+' - and beta = String.rev beta |> Bitlist.of_string ~zero:'-' ~one:'+' - in - let newdet = Determinant.of_bitlist_couple - ~alpha:n_alpha ~beta:n_beta (alpha,beta) - |> Determinant.sexp_of_t |> Sexplib.Sexp.to_string + let newdet = + (Bitlist.of_string ~zero:'-' ~one:'+' alpha , + Bitlist.of_string ~zero:'-' ~one:'+' beta) + |> Determinant.of_bitlist_couple ~alpha:n_alpha ~beta:n_beta + |> Determinant.sexp_of_t + |> Sexplib.Sexp.to_string in read_dets (newdet::accu) tail end | _::tail -> read_dets accu tail in - let a = read_dets [] dets - |> String.concat + let dets = + List.map ~f:String.rev dets in + let sze = + List.fold ~init:0 ~f:(fun accu x -> accu + (String.length x)) dets + in + let control = + Gc.get () + in + Gc.tune ~minor_heap_size:(sze) ~space_overhead:(sze/10) + ~max_overhead:100000 ~major_heap_increment:(sze/10) (); + let a = + read_dets [] dets + |> String.concat + in + Gc.set control; "(psi_det ("^a^"))" in - let bitkind = Printf.sprintf "(bit_kind %d)" (Lazy.force Qpackage.bit_kind + + let bitkind = + Printf.sprintf "(bit_kind %d)" (Lazy.force Qpackage.bit_kind |> Bit_kind.to_int) - and n_int = Printf.sprintf "(n_int %d)" (N_int_number.get_max ()) in - let s = String.concat [ header ; bitkind ; n_int ; psi_coef ; psi_det] + and n_int = + Printf.sprintf "(n_int %d)" (N_int_number.get_max ()) + in + let s = + String.concat [ header ; bitkind ; n_int ; psi_coef ; psi_det] in Generic_input_of_rst.evaluate_sexp t_of_sexp s 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..67d5bb07 100644 --- a/ocaml/TaskServer.ml +++ b/ocaml/TaskServer.ml @@ -1,47 +1,60 @@ open Core.Std open Qptypes -(** -The tasks server listens on a REQ socket and accepts the following commands: -* "new_job %s %s %s" state push_address_tcp push_address_inproc -> "OK" - -> "OK" +type t = +{ + queue : Queuing_system.t ; + state : Message.State.t option ; + address_tcp : Address.Tcp.t option ; + address_inproc : Address.Inproc.t option ; + psi : Message.Psi.t option; + progress_bar : Progress_bar.t option ; + running : bool; +} -* "connect %s" ["tcp"|"inproc"] - -> "%d %s %s" id state push_address -* "disconnect %d" id - -> "OK" -* "get_task %d %s" id state - -> "%d %s" task_id task +let debug_env = + match Sys.getenv "QP_TASK_DEBUG" with + | Some x -> x <> "" + | None -> false -* "task_done %d task_id %s" id state - -> "%d %s" task_id task -*) +let debug str = + if debug_env then + Printf.printf "TASK : %s%!" str + + + +let zmq_context = + ZMQ.Context.create () + let bind_socket ~socket_type ~socket ~address = - try - ZMQ.Socket.bind socket address - with - | Unix.Unix_error (_, message, f) -> - failwith @@ Printf.sprintf - "\n%s\nUnable to bind the %s socket :\n %s\n%s" - f socket_type address message - | other_exception -> raise other_exception + let rec loop = function + | 0 -> failwith @@ Printf.sprintf + "Unable to bind the %s socket : %s " + socket_type address + | -1 -> () + | i -> + try + ZMQ.Socket.bind socket address; + loop (-1) + with + | Unix.Unix_error _ -> (Time.pause @@ Time.Span.of_float 1. ; loop (i-1) ) + | other_exception -> raise other_exception + in loop 10 -(** Name of the host on which the server runs *) let hostname = lazy ( try Unix.gethostname () with | _ -> "localhost" - ) +) -(** IP address *) let ip_address = lazy ( match Sys.getenv "QP_NIC" with | None -> @@ -67,271 +80,540 @@ let ip_address = lazy ( ) +let reply_ok rep_socket = + Message.Ok_msg.create () + |> Message.Ok_msg.to_string + |> ZMQ.Socket.send rep_socket + +let reply_wrong_state rep_socket = + Printf.printf "WRONG STATE\n%!"; + Message.Error_msg.create "Wrong state" + |> Message.Error_msg.to_string + |> ZMQ.Socket.send rep_socket + + + let stop ~port = - let zmq_context = - ZMQ.Context.create () - in - let req_socket = - ZMQ.Socket.create zmq_context ZMQ.Socket.req - and address = - Printf.sprintf "tcp://%s:%d" (Lazy.force ip_address) port - in - ZMQ.Socket.connect req_socket address; + debug "STOP"; + let req_socket = + ZMQ.Socket.create zmq_context ZMQ.Socket.req + and address = + Printf.sprintf "tcp://%s:%d" (Lazy.force ip_address) port + in + ZMQ.Socket.set_linger_period req_socket 1_000_000; + ZMQ.Socket.connect req_socket address; - Message.Terminate (Message.Terminate_msg.create ()) - |> Message.to_string - |> ZMQ.Socket.send ~block:false req_socket ; + Message.Terminate (Message.Terminate_msg.create ()) + |> Message.to_string + |> ZMQ.Socket.send req_socket ; - let msg = - ZMQ.Socket.recv req_socket - |> Message.of_string - in - let () = - match msg with - | Message.Ok _ -> () - | _ -> failwith "Problem in termination" - in - ZMQ.Socket.set_linger_period req_socket 1000; - ZMQ.Socket.close req_socket - + let msg = + ZMQ.Socket.recv req_socket + |> Message.of_string + in + let () = + match msg with + | Message.Ok _ -> () + | _ -> failwith "Problem in termination" + in + ZMQ.Socket.set_linger_period req_socket 1_000; + ZMQ.Socket.close req_socket -(** Run the task server *) -let run ~port = - let zmq_context = - ZMQ.Context.create () - in +let new_job msg program_state rep_socket = - let rep_socket = - ZMQ.Socket.create zmq_context ZMQ.Socket.rep - and address = - Printf.sprintf "tcp://%s:%d" (Lazy.force ip_address) port - in - bind_socket "REP" rep_socket address; - - let pollitem = - ZMQ.Poll.mask_of - [| (rep_socket, ZMQ.Poll.In) |] - in - - Printf.printf "Task server running : %s\n%!" address; - - (** State variables *) - let q = ref - (Queuing_system.create ()) - and running = - ref true - and job = - ref None - in - - let get_state () = - match !job with - | None -> None - | Some j -> Some j.Message.Newjob_msg.state - in - - let get_tcp_address () = - match !job with - | Some j -> Address.Tcp j.Message.Newjob_msg.address_tcp - | None -> assert false - in - - let get_inproc_address () = - match !job with - | Some j -> Address.Inproc j.Message.Newjob_msg.address_inproc - | None -> assert false - in - - let ok = - Message.Ok (Message.Ok_msg.create ()) - in - - while ( !running ) - do - let state = - get_state () - and polling = - ZMQ.Poll.poll ~timeout:1000 pollitem + let state = + msg.Message.Newjob_msg.state in - let terminate () = - running := false; - Message.to_string ok - |> ZMQ.Socket.send ~block:false rep_socket + let progress_bar = + Progress_bar.init + ~start_value:0. + ~end_value:1. + ~bar_length:20 + ~title:(Message.State.to_string state) + in - and newjob x = - q := Queuing_system.create (); - job := Some x; - Message.to_string ok - |> ZMQ.Socket.send ~block:false rep_socket + let result = + { program_state with + state = Some state ; + progress_bar = Some progress_bar ; + address_tcp = Some msg.Message.Newjob_msg.address_tcp; + address_inproc = Some msg.Message.Newjob_msg.address_inproc; + } + in + reply_ok rep_socket; + result - and connect state msg = - let push_address = - match msg with - | Message.Connect_msg.Tcp -> get_tcp_address () - | Message.Connect_msg.Inproc -> get_inproc_address () - | Message.Connect_msg.Ipc -> assert false - in - let new_q, client_id = - Queuing_system.add_client !q - in - q := new_q; - Message.ConnectReply (Message.ConnectReply_msg.create - ~state ~client_id ~push_address) - |> Message.to_string - |> ZMQ.Socket.send ~block:false rep_socket - and disconnect state msg = - let s, c = - msg.Message.Disconnect_msg.state , - msg.Message.Disconnect_msg.client_id - in - assert (s = state); - let new_q = - Queuing_system.del_client ~client_id:c !q - in - q := new_q; - let finished = - Queuing_system.number_of_queued !q + - Queuing_system.number_of_running !q = 0 - in - Message.DisconnectReply (Message.DisconnectReply_msg.create - ~state ~finished) - |> Message.to_string - |> ZMQ.Socket.send ~block:false rep_socket +let end_job msg program_state rep_socket = - and add_task state msg = - let s, task = - msg.Message.AddTask_msg.state, - msg.Message.AddTask_msg.task - in - assert (s = state); - Message.to_string ok - |> ZMQ.Socket.send ~block:false rep_socket - ; + let failure () = + reply_wrong_state rep_socket; + program_state + + and success state = + reply_ok rep_socket; + { program_state with + state = None ; + progress_bar = None ; + } + + in + match program_state.state with + | None -> failure () + | Some state -> begin - match - String.split ~on:' ' msg.Message.AddTask_msg.task - |> List.filter ~f:(fun x -> x <> "") - with - | "triangle" :: str_l :: [] -> - begin - let l = - Int.of_string str_l - in - for j=1 to l - do - let task = - Printf.sprintf "%d %s" j str_l - in - let new_q, _ = - Queuing_system.add_task ~task !q - in - q := new_q - done - end - | "range" :: str_i :: str_j :: [] -> - begin - let i, j = - Int.of_string str_i, - Int.of_string str_j - in - for k=i to (j+1) - do - let task = - Int.to_string k - in - let new_q, task_id = - Queuing_system.add_task ~task !q - in - q := new_q - done - end - | _ -> - let new_q, task_id = - Queuing_system.add_task ~task !q - in - q := new_q + if (msg.Message.Endjob_msg.state = state) then + success state + else + failure () end - - and get_task state msg = - let s, client_id = - msg.Message.GetTask_msg.state, - msg.Message.GetTask_msg.client_id - in - assert (s = state); - let new_q, task_id, task = - Queuing_system.pop_task ~client_id !q - in - q := new_q; - let reply = + + +let connect msg program_state rep_socket = + + let state = + match program_state.state with + | Some state -> state + | None -> assert false + in + + let push_address = + match msg with + | Message.Connect_msg.Tcp -> + begin + match program_state.address_tcp with + | Some address -> Address.Tcp address + | None -> failwith "Error: No TCP address" + end + | Message.Connect_msg.Inproc -> + begin + match program_state.address_inproc with + | Some address -> Address.Inproc address + | None -> failwith "Error: No inproc address" + end + | Message.Connect_msg.Ipc -> assert false + in + + let new_queue, client_id = + Queuing_system.add_client program_state.queue + in + Message.ConnectReply (Message.ConnectReply_msg.create + ~state:state ~client_id ~push_address) + |> Message.to_string + |> ZMQ.Socket.send rep_socket ; + { program_state with + queue = new_queue + } + + +let disconnect msg program_state rep_socket = + + let state, client_id = + msg.Message.Disconnect_msg.state, + msg.Message.Disconnect_msg.client_id + in + + let failure () = + reply_wrong_state rep_socket; + program_state + + and success () = + + let new_program_state = + { program_state with + queue = Queuing_system.del_client ~client_id program_state.queue + } + in + Message.DisconnectReply (Message.DisconnectReply_msg.create ~state) + |> Message.to_string + |> ZMQ.Socket.send rep_socket ; + new_program_state + + in + + match program_state.state with + | None -> assert false + | Some state' -> + begin + if (state = state') then + success () + else + failure () + end + +let del_task msg program_state rep_socket = + + let state, task_id = + msg.Message.DelTask_msg.state, + msg.Message.DelTask_msg.task_id + in + + let failure () = + reply_wrong_state rep_socket; + program_state + + and success () = + + let new_program_state = + { program_state with + queue = Queuing_system.del_task ~task_id program_state.queue + } + in + let more = + (Queuing_system.number_of_queued new_program_state.queue + + Queuing_system.number_of_running new_program_state.queue) > 0 + in + Message.DelTaskReply (Message.DelTaskReply_msg.create ~task_id ~more) + |> Message.to_string + |> ZMQ.Socket.send ~block:true rep_socket ; (** /!\ Has to be blocking *) + new_program_state + + in + + match program_state.state with + | None -> assert false + | Some state' -> + begin + if (state = state') then + success () + else + failure () + end + + + +let add_task msg program_state rep_socket = + + let state, task = + msg.Message.AddTask_msg.state, + msg.Message.AddTask_msg.task + in + + let increment_progress_bar = function + | Some bar -> Some (Progress_bar.increment_end bar) + | None -> None + in + + let rec add_task_triangle program_state imax = function + | 0 -> program_state + | i -> + let task = + Printf.sprintf "%d %d" i imax + in + let new_program_state = + { program_state with + queue = Queuing_system.add_task ~task program_state.queue ; + progress_bar = increment_progress_bar program_state.progress_bar ; + } + in + add_task_triangle new_program_state imax (i-1) + in + + let rec add_task_range program_state i = function + | j when (j < i) -> program_state + | j -> + let task = + Printf.sprintf "%d" j + in + let new_program_state = + { program_state with + queue = Queuing_system.add_task ~task program_state.queue ; + progress_bar = increment_progress_bar program_state.progress_bar ; + } + in + add_task_range new_program_state i (j-1) + in + + let new_program_state = function + | "triangle" :: i_str :: [] -> + let imax = + Int.of_string i_str + in + add_task_triangle program_state imax imax + | "range" :: i_str :: j_str :: [] -> + let i, j = + Int.of_string i_str, + Int.of_string j_str + in + add_task_range program_state i j + | _ -> + { program_state with + queue = Queuing_system.add_task ~task program_state.queue ; + progress_bar = increment_progress_bar program_state.progress_bar ; + } + in + + let result = + String.split ~on:' ' task + |> List.filter ~f:(fun x -> x <> "") + |> new_program_state + in + reply_ok rep_socket; + result + + + +let get_task msg program_state rep_socket = + + let state, client_id = + msg.Message.GetTask_msg.state, + msg.Message.GetTask_msg.client_id + in + + let failure () = + reply_wrong_state rep_socket; + program_state + + and success () = + + let new_queue, task_id, task = + Queuing_system.pop_task ~client_id program_state.queue + in + + let new_program_state = + { program_state with + queue = new_queue + } + in + match (task, task_id) with - | Some task, Some task_id -> - Message.GetTaskReply (Message.GetTaskReply_msg.create ~task ~task_id) - | _ -> Message.Terminate (Message.Terminate_msg.create ()) - in - Message.to_string reply - |> ZMQ.Socket.send ~block:false rep_socket - - and task_done state msg = - let s, client_id, task_id = + | Some task, Some task_id -> + begin + Message.GetTaskReply (Message.GetTaskReply_msg.create ~task ~task_id) + |> Message.to_string + |> ZMQ.Socket.send rep_socket ; + new_program_state + end + | _ -> + begin + Message.Terminate (Message.Terminate_msg.create ()) + |> Message.to_string + |> ZMQ.Socket.send rep_socket ; + program_state + end + + in + + match program_state.state with + | None -> assert false + | Some state' -> + begin + if (state = state') then + success () + else + failure () + end + + + +let task_done msg program_state rep_socket = + + let state, client_id, task_id = msg.Message.TaskDone_msg.state, msg.Message.TaskDone_msg.client_id, msg.Message.TaskDone_msg.task_id - in - assert (s = state); - let new_q = - Queuing_system.end_task ~task_id ~client_id !q - in - q := new_q; - Message.to_string ok - |> ZMQ.Socket.send ~block:false rep_socket - - and error msg = - Message.Error (Message.Error_msg.create msg) - |> Message.to_string - |> ZMQ.Socket.send ~block:false rep_socket in - if (polling.(0) = Some ZMQ.Poll.In) then - let raw_message = - ZMQ.Socket.recv rep_socket - in - try - let message = - Message.of_string raw_message + let increment_progress_bar = function + | Some bar -> Some (Progress_bar.increment_cur bar) + | None -> None + in + + let failure () = + reply_wrong_state rep_socket; + program_state + + and success () = + let result = + { program_state with + queue = Queuing_system.end_task ~task_id ~client_id program_state.queue ; + progress_bar = increment_progress_bar program_state.progress_bar ; + } in -(* - Printf.printf "%d %d : %s\n%!" - (Queuing_system.number_of_queued !q) - (Queuing_system.number_of_running !q) - (Message.to_string message); - Printf.printf "%s\n%!" (Queuing_system.to_string !q); *) - match (state, message) with - | _ , Message.Terminate _ -> terminate () - | None , Message.Newjob x -> newjob x - | None , _ -> error "No job is running" - | _ , Message.Newjob _ -> error "A job is already running" - | Some s, Message.Connect x -> connect s x - | Some s, Message.Disconnect x -> disconnect s x - | Some s, Message.AddTask x -> add_task s x - | Some s, Message.GetTask x -> get_task s x - | Some s, Message.TaskDone x -> task_done s x - | _ , _ -> - error ("Invalid message : "^(Message.to_string message)) - with - | Failure f -> error (f^" : "^raw_message) - | Assert_failure (f,i,j) -> error (Printf.sprintf "%s:%d:%d : %s" f i j raw_message) - - done; - ZMQ.Socket.set_linger_period rep_socket 1000; - ZMQ.Socket.close rep_socket + reply_ok rep_socket; + result + in + + match program_state.state with + | None -> assert false + | Some state' -> + begin + if (state = state') then + success () + else + failure () + end -(* -let () = - Printf.printf "export QP_RUN_ADDRESS=tcp://%s:%d\n%!" (Lazy.force ip_address) (Lazy.force port) -*) +let put_psi msg rest_of_msg program_state rep_socket = + + let psi_local = + match msg.Message.PutPsi_msg.psi with + | Some x -> x + | None -> + begin + let psi_det, psi_coef = + match rest_of_msg with + | [ x ; y ] -> x, y + | _ -> failwith "Badly formed put_psi message" + in + Message.Psi.create + ~n_state:msg.Message.PutPsi_msg.n_state + ~n_det:msg.Message.PutPsi_msg.n_det + ~psi_det_size:msg.Message.PutPsi_msg.psi_det_size + ~n_det_generators:msg.Message.PutPsi_msg.n_det_generators + ~n_det_selectors:msg.Message.PutPsi_msg.n_det_selectors + ~psi_det + ~psi_coef + end + in + let new_program_state = + { program_state with + psi = Some psi_local + } + and client_id = + msg.Message.PutPsi_msg.client_id + in + Message.PutPsiReply (Message.PutPsiReply_msg.create ~client_id) + |> Message.to_string + |> ZMQ.Socket.send rep_socket; + + new_program_state +let get_psi msg program_state rep_socket = + + let client_id = + msg.Message.GetPsi_msg.client_id + in + match program_state.psi with + | None -> failwith "No wave function saved in TaskServer" + | Some psi -> + Message.GetPsiReply (Message.GetPsiReply_msg.create ~client_id ~psi) + |> Message.to_string_list + |> ZMQ.Socket.send_all rep_socket; + program_state + + + +let terminate program_state rep_socket = + reply_ok rep_socket; + { program_state with + running = false + } + + +let error msg program_state rep_socket = + Printf.printf "%s\n%!" msg; + Message.Error (Message.Error_msg.create msg) + |> Message.to_string + |> ZMQ.Socket.send rep_socket ; + program_state + + + +let run ~port = + + (** Bind REP socket *) + let rep_socket = + ZMQ.Socket.create zmq_context ZMQ.Socket.rep + and address = + Printf.sprintf "tcp://%s:%d" (Lazy.force ip_address) port + in + bind_socket "REP" rep_socket address; + ZMQ.Socket.set_linger_period rep_socket 1_000_000; + + let initial_program_state = + { queue = Queuing_system.create () ; + running = true ; + psi = None; + state = None; + address_tcp = None; + address_inproc = None; + progress_bar = None ; + } + in + + (** ZMR polling item *) + let pollitem = + ZMQ.Poll.mask_of + [| (rep_socket, ZMQ.Poll.In) |] + in + + Printf.printf "Task server running : %s\n%!" address; + + + (** Main loop *) + let rec main_loop program_state = function + | false -> () + | true -> + let polling = + ZMQ.Poll.poll ~timeout:1000 pollitem + in + if (polling.(0) <> Some ZMQ.Poll.In) then + main_loop program_state true + else + begin + let program_state = + match program_state.progress_bar with + | None -> program_state + | Some bar -> + if bar.Progress_bar.dirty then + { program_state with + progress_bar = Some (Progress_bar.display bar) + } + else + program_state + in + + (** Extract message *) + let raw_message, rest = + match ZMQ.Socket.recv_all rep_socket with + | x :: rest -> x, rest + | [] -> failwith "Badly formed message" + in + let message = + Message.of_string raw_message + in + + (** Debug input *) + Printf.sprintf "%d %d : %s\n%!" + (Queuing_system.number_of_queued program_state.queue) + (Queuing_system.number_of_running program_state.queue) + (Message.to_string message) + |> debug; + + let new_program_state = + try + match program_state.state, message with + | _ , Message.Terminate _ -> terminate program_state rep_socket + | _ , Message.PutPsi x -> put_psi x rest program_state rep_socket + | _ , Message.GetPsi x -> get_psi x program_state rep_socket + | None , Message.Newjob x -> new_job x program_state rep_socket + | _ , Message.Newjob _ -> error "A job is already running" program_state rep_socket + | Some _, Message.Endjob x -> end_job x program_state rep_socket + | None , _ -> error "No job is running" program_state rep_socket + | Some _, Message.Connect x -> connect x program_state rep_socket + | Some _, Message.Disconnect x -> disconnect x program_state rep_socket + | Some _, Message.AddTask x -> add_task x program_state rep_socket + | Some _, Message.DelTask x -> del_task x program_state rep_socket + | Some _, Message.GetTask x -> get_task x program_state rep_socket + | Some _, Message.TaskDone x -> task_done x program_state rep_socket + | _ , _ -> + error ("Invalid message : "^(Message.to_string message)) program_state rep_socket + with + | Failure f -> + error (f^" : "^raw_message) program_state rep_socket + | Assert_failure (f,i,j) -> + error (Printf.sprintf "%s:%d:%d : %s" f i j raw_message) program_state rep_socket + + in + main_loop new_program_state new_program_state.running + end + in main_loop initial_program_state true; + + + + 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 diff --git a/ocaml/qp_edit.ml b/ocaml/qp_edit.ml deleted file mode 100644 index 05a442e4..00000000 --- a/ocaml/qp_edit.ml +++ /dev/null @@ -1,308 +0,0 @@ -open Qputils;; -open Qptypes;; -open Core.Std;; - -(** Interactive editing of the input. - -WARNING -This file is autogenerad by -`${QP_ROOT}/script/ezfio_interface/ei_handler.py` -*) - - -(** Keywords used to define input sections *) -type keyword = -| Ao_basis -| Determinants_by_hand -| Electrons -| Mo_basis -| Nuclei -| Integrals_bielec -| Determinants -| Perturbation -| Properties -| Hartree_fock -| Pseudo -;; - - -let keyword_to_string = function -| Ao_basis -> "AO basis" -| Determinants_by_hand -> "Determinants_by_hand" -| Electrons -> "Electrons" -| Mo_basis -> "MO basis" -| Nuclei -> "Molecule" -| Integrals_bielec -> "Integrals_bielec" -| Determinants -> "Determinants" -| Perturbation -> "Perturbation" -| Properties -> "Properties" -| Hartree_fock -> "Hartree_fock" -| Pseudo -> "Pseudo" -;; - - - -(** 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) - | Integrals_bielec -> - f Integrals_bielec.(read, to_rst) - | Determinants -> - f Determinants.(read, to_rst) - | Perturbation -> - f Perturbation.(read, to_rst) - | Properties -> - f Properties.(read, to_rst) - | Hartree_fock -> - f Hartree_fock.(read, to_rst) - | Pseudo -> - f Pseudo.(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 - | Integrals_bielec -> write Integrals_bielec.(of_rst, write) s - | Determinants -> write Determinants.(of_rst, write) s - | Perturbation -> write Perturbation.(of_rst, write) s - | Properties -> write Properties.(of_rst, write) s - | Hartree_fock -> write Hartree_fock.(of_rst, write) s - | Pseudo -> write Pseudo.(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 ; - Integrals_bielec ; - Determinants ; - Perturbation ; - Properties ; - Hartree_fock ; - Pseudo ; - 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 -;; - - - diff --git a/ocaml/qp_print_basis.ml b/ocaml/qp_print_basis.ml index 3a481c21..aff52837 100644 --- a/ocaml/qp_print_basis.ml +++ b/ocaml/qp_print_basis.ml @@ -35,7 +35,24 @@ let mo () = |> print_endline +let psi_det () = + let ezfio_filename = + Sys.argv.(1) + in + if (not (Sys.file_exists_exn ezfio_filename)) then + failwith "Error reading EZFIO file"; + Ezfio.set_file ezfio_filename; + let psi_det = + Input.Determinants_by_hand.read () + in + Input.Determinants_by_hand.to_rst psi_det + |> Rst_string.to_string + |> print_endline + + + let () = basis (); - mo () + mo (); + psi_det () diff --git a/ocaml/qp_run.ml b/ocaml/qp_run.ml index 600c6f24..1d44f35f 100644 --- a/ocaml/qp_run.ml +++ b/ocaml/qp_run.ml @@ -1,21 +1,64 @@ -open Core.Std;; -open Qputils;; +open Core.Std +open Qputils + +(* Environment variables : + + QP_PREFIX=gdb : to run gdb (or valgrind, or whatever) + QP_TASK_DEBUG=1 : debug task server + +*) let print_list () = Lazy.force Qpackage.executables |> List.iter ~f:(fun (x,_) -> Printf.printf " * %s\n" x) -;; -let run exe ezfio_file = +let () = + Random.self_init () - let time_start = Time.now() in +let run ~master exe ezfio_file = + + + (** Check availability of the ports *) + let port_number = + let zmq_context = + ZMQ.Context.create () + in + let dummy_socket = + ZMQ.Socket.create zmq_context ZMQ.Socket.rep + in + let rec try_new_port port_number = + try + List.iter [ 0;1;2;3;4 ] ~f:(fun i -> + let address = + Printf.sprintf "tcp://%s:%d" (Lazy.force TaskServer.ip_address) (port_number+i) + in + ZMQ.Socket.bind dummy_socket address; + ZMQ.Socket.unbind dummy_socket address; + ); + port_number + with + | Unix.Unix_error _ -> try_new_port (port_number+100) + in + let result = + try_new_port 41279 + in + ZMQ.Socket.close dummy_socket; + result + in + let time_start = + Time.now () + in if (not (Sys.file_exists_exn ezfio_file)) then failwith ("EZFIO directory "^ezfio_file^" not found"); let executables = Lazy.force Qpackage.executables in if (not (List.exists ~f:(fun (x,_) -> x = exe) executables)) then - failwith ("Executable "^exe^" not found"); + begin + Printf.printf "\nPossible choices:\n"; + List.iter executables ~f:(fun (x,_) -> Printf.printf "* %s\n%!" x); + failwith ("Executable "^exe^" not found") + end; Printf.printf "%s\n" (Time.to_string time_start); Printf.printf "===============\nQuantum Package\n===============\n\n"; @@ -26,16 +69,18 @@ let run exe ezfio_file = (** Check input *) - match (Sys.command ("qp_edit -c "^ezfio_file)) with - | 0 -> () - | i -> failwith "Error: Input inconsistent\n"; - ; - + begin + match (Sys.command ("qp_edit -c "^ezfio_file)) with + | 0 -> () + | i -> failwith "Error: Input inconsistent\n" + end; + begin + match master with + | Some address -> Unix.putenv ~key:"QP_RUN_ADDRESS_MASTER" ~data:address + | None -> () + end; (** Start task server *) - let port_number = - 12345 - in let address = Printf.sprintf "tcp://%s:%d" (Lazy.force TaskServer.ip_address) port_number in @@ -49,12 +94,16 @@ let run exe ezfio_file = Unix.putenv ~key:"QP_RUN_ADDRESS" ~data:address; (** Run executable *) - let exe = + let prefix = + match Sys.getenv "QP_PREFIX" with + | Some x -> x^" " + | None -> "" + and exe = match (List.find ~f:(fun (x,_) -> x = exe) executables) with + | Some (_,x) -> x^" " | None -> assert false - | Some (_,x) -> x in - match (Sys.command (exe^" "^ezfio_file)) with + match (Sys.command (prefix^exe^ezfio_file)) with | 0 -> () | i -> Printf.printf "Program exited with code %d.\n%!" i; ; @@ -64,16 +113,19 @@ let run exe ezfio_file = let duration = Time.diff (Time.now()) time_start |> Core.Span.to_string in - Printf.printf "Wall time : %s\n\n" duration; -;; + Printf.printf "Wall time : %s\n\n" duration let spec = let open Command.Spec in empty + +> flag "master" (optional string) + ~doc:("address Address of the master process") +> anon ("executable" %: string) +> anon ("ezfio_file" %: string) ;; + + let () = Command.basic ~summary: "Quantum Package command" @@ -85,10 +137,9 @@ Executes a Quantum Package binary file among these:\n\n" ) ) spec - (fun exe ezfio_file () -> - run exe ezfio_file + (fun master exe ezfio_file () -> + run ~master exe ezfio_file ) |> Command.run ~version: Git.sha1 ~build_info: Git.message -;; 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_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/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/All_singles/EZFIO.cfg b/plugins/All_singles/EZFIO.cfg new file mode 100644 index 00000000..b2498c43 --- /dev/null +++ b/plugins/All_singles/EZFIO.cfg @@ -0,0 +1,5 @@ +[energy] +type: double precision +doc: Calculated Selected all_singles or all_1h_1p energy +interface: ezfio + diff --git a/plugins/All_singles/H_apply.irp.f b/plugins/All_singles/H_apply.irp.f new file mode 100644 index 00000000..d0a41f90 --- /dev/null +++ b/plugins/All_singles/H_apply.irp.f @@ -0,0 +1,18 @@ +use bitmasks +BEGIN_SHELL [ /usr/bin/env python ] +from generate_h_apply import * + +s = H_apply("just_1h_1p") +s.set_selection_pt2("epstein_nesbet_2x2") +s.unset_skip() +s.filter_only_1h1p() +print s + +s = H_apply("just_mono") +s.set_selection_pt2("epstein_nesbet_2x2") +s.unset_skip() +s.unset_double_excitations() +print s + +END_SHELL + diff --git a/plugins/All_singles/NEEDED_CHILDREN_MODULES b/plugins/All_singles/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..bb97ddb9 --- /dev/null +++ b/plugins/All_singles/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Generators_restart Perturbation Properties Selectors_no_sorted Utils diff --git a/plugins/All_singles/README.rst b/plugins/All_singles/README.rst new file mode 100644 index 00000000..b4b3f517 --- /dev/null +++ b/plugins/All_singles/README.rst @@ -0,0 +1,12 @@ +=========== +All_singles +=========== + +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. diff --git a/plugins/All_singles/all_1h_1p.irp.f b/plugins/All_singles/all_1h_1p.irp.f new file mode 100644 index 00000000..a2786248 --- /dev/null +++ b/plugins/All_singles/all_1h_1p.irp.f @@ -0,0 +1,76 @@ +program restart_more_singles + BEGIN_DOC + ! Generates and select single and double excitations of type 1h-1p + ! on the top of a given restart wave function of type CAS + END_DOC + read_wf = .true. + touch read_wf + print*,'ref_bitmask_energy = ',ref_bitmask_energy + call routine + +end +subroutine routine + implicit none + integer :: i,k + double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:),E_before(:) + integer :: N_st, degree + integer :: n_det_before + N_st = N_states + allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st)) + i = 0 + print*,'N_det = ',N_det + print*,'n_det_max = ',n_det_max + print*,'pt2_max = ',pt2_max + pt2=-1.d0 + E_before = ref_bitmask_energy + do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max) + n_det_before = N_det + i += 1 + print*,'-----------------------' + print*,'i = ',i + call H_apply_just_1h_1p(pt2, norm_pert, H_pert_diag, N_st) + call diagonalize_CI + print*,'N_det = ',N_det + print*,'E = ',CI_energy(1) + print*,'pt2 = ',pt2(1) + print*,'E+PT2 = ',E_before + pt2(1) + E_before = CI_energy + if(N_states_diag.gt.1)then + print*,'Variational Energy difference' + do i = 2, N_st + print*,'Delta E = ',CI_energy(i) - CI_energy(1) + enddo + endif + if(N_states.gt.1)then + print*,'Variational + perturbative Energy difference' + do i = 2, N_st + print*,'Delta E = ',E_before(i)+ pt2(i) - (E_before(1) + pt2(1)) + enddo + endif + call save_wavefunction + if(n_det_before == N_det)then + selection_criterion = selection_criterion * 0.5d0 + endif + + enddo + + threshold_davidson = 1.d-10 + soft_touch threshold_davidson davidson_criterion + call diagonalize_CI + if(N_states_diag.gt.1)then + print*,'Variational Energy difference' + do i = 2, N_st + print*,'Delta E = ',CI_energy(i) - CI_energy(1) + enddo + endif + if(N_states.gt.1)then + print*,'Variational + perturbative Energy difference' + do i = 2, N_st + print*,'Delta E = ',CI_energy(i)+ pt2(i) - (CI_energy(1) + pt2(1)) + enddo + endif + call ezfio_set_all_singles_energy(CI_energy) + + call save_wavefunction + deallocate(pt2,norm_pert) +end diff --git a/plugins/All_singles/all_singles.irp.f b/plugins/All_singles/all_singles.irp.f new file mode 100644 index 00000000..3b5c5cce --- /dev/null +++ b/plugins/All_singles/all_singles.irp.f @@ -0,0 +1,76 @@ +program restart_more_singles + BEGIN_DOC + ! Generates and select single excitations + ! on the top of a given restart wave function + END_DOC + read_wf = .true. + touch read_wf + call routine + +end +subroutine routine + implicit none + integer :: i,k + double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:) + integer :: N_st, degree + double precision,allocatable :: E_before(:) + integer :: n_det_before + N_st = N_states + allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st)) + i = 0 + print*,'N_det = ',N_det + print*,'n_det_max = ',n_det_max + print*,'pt2_max = ',pt2_max + pt2=-1.d0 + E_before = ref_bitmask_energy + pt2_max = 1.d-10 + n_det_max = 200000 + do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max) + n_det_before = N_det + i += 1 + print*,'-----------------------' + print*,'i = ',i + call H_apply_just_mono(pt2, norm_pert, H_pert_diag, N_st) + call diagonalize_CI + print*,'N_det = ',N_det + print*,'E = ',CI_energy + print*,'pt2 = ',pt2 + print*,'E+PT2 = ',E_before + pt2 + if(N_states_diag.gt.1)then + print*,'Variational Energy difference' + do i = 2, N_st + print*,'Delta E = ',CI_energy(i) - CI_energy(1) + enddo + endif + if(N_states.gt.1)then + print*,'Variational + perturbative Energy difference' + do i = 2, N_st + print*,'Delta E = ',E_before(i)+ pt2(i) - (E_before(1) + pt2(1)) + enddo + endif + E_before = CI_energy + call save_wavefunction + + if(n_det_before == N_det)then + selection_criterion = selection_criterion * 0.5d0 + endif + enddo + + threshold_davidson = 1.d-10 + soft_touch threshold_davidson davidson_criterion + call diagonalize_CI + if(N_states_diag.gt.1)then + print*,'Variational Energy difference' + do i = 2, N_st + print*,'Delta E = ',CI_energy(i) - CI_energy(1) + enddo + endif + if(N_states.gt.1)then + print*,'Variational + perturbative Energy difference' + do i = 2, N_st + print*,'Delta E = ',CI_energy(i)+ pt2(i) - (CI_energy(1) + pt2(1)) + enddo + endif + call save_wavefunction + deallocate(pt2,norm_pert,E_before) +end 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/H_apply.irp.f b/plugins/CAS_SD/H_apply.irp.f index 35c45fb6..aa393bc7 100644 --- a/plugins/CAS_SD/H_apply.irp.f +++ b/plugins/CAS_SD/H_apply.irp.f @@ -20,18 +20,22 @@ print s s = H_apply("CAS_S",do_double_exc=False) +s.unset_double_excitations() print s s = H_apply("CAS_S_selected_no_skip",do_double_exc=False) +s.unset_double_excitations() s.set_selection_pt2("epstein_nesbet_2x2") s.unset_skip() print s s = H_apply("CAS_S_selected",do_double_exc=False) +s.unset_double_excitations() s.set_selection_pt2("epstein_nesbet_2x2") print s s = H_apply("CAS_S_PT2",do_double_exc=False) +s.unset_double_excitations() s.set_perturbation("epstein_nesbet_2x2") print s 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/Dressed_Ref_Hamiltonian/Dressed_Ref_Hamiltonian.main.irp.f b/plugins/Dressed_Ref_Hamiltonian/Dressed_Ref_Hamiltonian.main.irp.f new file mode 100644 index 00000000..2e25f431 --- /dev/null +++ b/plugins/Dressed_Ref_Hamiltonian/Dressed_Ref_Hamiltonian.main.irp.f @@ -0,0 +1,37 @@ +program Dressed_Ref_Hamiltonian implicit none + BEGIN_DOC +! TODO + END_DOC + print *, ' _/ ' + print *, ' -:\_?, _Jm####La ' + print *, 'J"(:" > _]#AZ#Z#UUZ##, ' + print *, '_,::./ %(|i%12XmX1*1XL _?, ' + print *, ' \..\ _\(vmWQwodY+ia%lnL _",/ ( ' + print *, ' .:< ]J=mQD?WXn|,)nr" ' + print *, ' 4XZ#Xov1v}=)vnXAX1nnv;1n" ' + print *, ' ]XX#ZXoovvvivnnnlvvo2*i7 ' + print *, ' "23Z#1S2oo2XXSnnnoSo2>v" ' + print *, ' miX#L -~`""!!1}oSoe|i7 ' + print *, ' 4cn#m, v221=|v[ ' + print *, ' ]hI3Zma,;..__wXSe=+vo ' + print *, ' ]Zov*XSUXXZXZXSe||vo2 ' + print *, ' ]Z#>=|< ' + print *, ' -ziiiii||||||+||==+> ' + print *, ' -%|+++||=|=+|=|==/ ' + print *, ' -a>====+|====-:- ' + print *, ' "~,- -- /- ' + print *, ' -. )> ' + print *, ' .~ +- ' + print *, ' . .... : . ' + print *, ' -------~ ' + print *, '' +end diff --git a/plugins/Dressed_Ref_Hamiltonian/NEEDED_CHILDREN_MODULES b/plugins/Dressed_Ref_Hamiltonian/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..55c429bc --- /dev/null +++ b/plugins/Dressed_Ref_Hamiltonian/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +MRCC_Utils diff --git a/plugins/Dressed_Ref_Hamiltonian/README.rst b/plugins/Dressed_Ref_Hamiltonian/README.rst new file mode 100644 index 00000000..71f2f099 --- /dev/null +++ b/plugins/Dressed_Ref_Hamiltonian/README.rst @@ -0,0 +1,16 @@ +======================= +Dressed_Ref_Hamiltonian +======================= +The following modules proposes to build an effective Hamiltonian +spanned on the reference determinants supposed to be the CAS ones. +The effective matrix Hamiltonian are built using the multi parentage +proposal used in the MR-CCSD formalism of Giner et. al. (JCP, 144, 064101 (2016); doi: 10.1063/1.4940781) + +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. diff --git a/plugins/Dressed_Ref_Hamiltonian/dressed_eigenvectors.irp.f b/plugins/Dressed_Ref_Hamiltonian/dressed_eigenvectors.irp.f new file mode 100644 index 00000000..2e66ff16 --- /dev/null +++ b/plugins/Dressed_Ref_Hamiltonian/dressed_eigenvectors.irp.f @@ -0,0 +1,41 @@ + BEGIN_PROVIDER [double precision, psi_ref_coef_dressed, (n_det_ref,N_states) ] +&BEGIN_PROVIDER [double precision, energies_ref_dressed, (N_states) ] + implicit none + integer :: i,j,k,l,istate,igoodstate + double precision, allocatable :: H_matrix_tmp(:,:) + double precision, allocatable :: eigvalues(:),eigvectors(:,:),psi_coef_ref_tmp(:) + double precision :: accu, accu1 + allocate(H_matrix_tmp(n_det_ref,n_det_ref)) + allocate(eigvalues(n_det_ref)) + allocate(eigvectors(n_det_ref,n_det_ref)) + allocate(psi_coef_ref_tmp(n_det_ref)) + do istate = 1, N_states + accu1 = 0.d0 + do j = 1, n_det_ref + accu1 += psi_ref_coef(j,istate)**2 ! norm of the "istate" eigenvector in the projected in the reference space + do k = 1, n_det_ref + H_matrix_tmp(j,k) = hamiltonian_total_dressed(j,k,istate) + enddo + enddo + accu1 = 1.d0/dsqrt(accu1) + do j = 1, n_det_ref + psi_coef_ref_tmp(j) = psi_ref_coef(j,istate) * accu1 + enddo + call lapack_diagd(eigvalues,eigvectors,H_matrix_tmp,n_det_ref,n_det_ref) + do j = 1, n_det_ref + accu = 0.d0 + do k = 1, n_det_ref + accu += eigvectors(k,j) * psi_coef_ref_tmp(k) + enddo + if(dabs(accu).gt.0.9d0)then + igoodstate = j + exit + endif + enddo + energies_ref_dressed(istate) = eigvalues(igoodstate) + do j = 1,n_det_ref + psi_ref_coef_dressed(j,istate) = eigvectors(j,igoodstate) + enddo + enddo + +END_PROVIDER diff --git a/plugins/Dressed_Ref_Hamiltonian/dressed_hamiltonian.irp.f b/plugins/Dressed_Ref_Hamiltonian/dressed_hamiltonian.irp.f new file mode 100644 index 00000000..90b27e07 --- /dev/null +++ b/plugins/Dressed_Ref_Hamiltonian/dressed_hamiltonian.irp.f @@ -0,0 +1,46 @@ +BEGIN_PROVIDER [double precision, dressing_ref_hamiltonian, (n_det_ref,n_det_ref,N_states)] + implicit none + integer :: i,j,k,l + integer :: ii,jj,istate + double precision :: hij,sec_order,H_ref(N_det_ref),hik,hkl + integer :: idx(0:N_det_ref) + double precision :: accu_negative,accu_positive,phase + integer :: degree_exc_ionic,degree_exc_neutral,exc(0:2,2,2) + dressing_ref_hamiltonian = 0.d0 + accu_negative = 0.d0 + accu_positive = 0.d0 + integer :: h1,p1,h2,p2,s1,s2 + do istate = 1, N_states + do i = 1, N_det_non_ref + call filter_connected_i_H_psi0(psi_ref,psi_non_ref(1,1,i),N_int,N_det_ref,idx) + H_ref = 0.d0 + do ii=1,idx(0) + k = idx(ii) + !DEC$ FORCEINLINE + call i_H_j(psi_ref(1,1,k),psi_non_ref(1,1,i),N_int,hij) + H_ref(k) = hij + enddo + do ii= 1, idx(0) + k = idx(ii) + hik = H_ref(k) * lambda_mrcc(istate,i) + do jj = 1, idx(0) + l = idx(jj) + dressing_ref_hamiltonian(k,l,istate) += hik * H_ref(l) + enddo + enddo + enddo + enddo +END_PROVIDER + +BEGIN_PROVIDER [double precision, hamiltonian_total_dressed, (n_det_ref,n_det_ref,N_states)] + implicit none + integer :: i,j,k + do k = 1, N_states + do i = 1, N_det_ref + do j = 1, N_det_ref + hamiltonian_total_dressed(j,i,k) = dressing_ref_hamiltonian(j,i,k) + ref_hamiltonian_matrix(j,i) + enddo + enddo + enddo + +END_PROVIDER diff --git a/plugins/Dressed_Ref_Hamiltonian/print_CAS_effective_Hamiltonian.irp.f b/plugins/Dressed_Ref_Hamiltonian/print_CAS_effective_Hamiltonian.irp.f new file mode 100644 index 00000000..aab716ac --- /dev/null +++ b/plugins/Dressed_Ref_Hamiltonian/print_CAS_effective_Hamiltonian.irp.f @@ -0,0 +1,108 @@ +program print + read_wf = .True. + touch read_wf + call provide_all_stuffs +end +subroutine provide_all_stuffs + implicit none + provide ref_hamiltonian_matrix dressing_ref_hamiltonian + integer :: i,j,istate + double precision, allocatable :: psi_restart_ref_normalized(:),psi_ref_zeroth_order(:),psi_ref_dressed(:) + double precision, allocatable :: eigvalues(:),eigvectors(:,:) + double precision, allocatable :: H_dressed(:,:) + double precision, allocatable :: H_print(:,:) + double precision :: accu_norm + allocate (H_dressed(N_det_ref,N_det_ref)) + allocate (H_print(N_det_ref,N_det_ref)) + allocate (psi_restart_ref_normalized(N_det_ref)) + allocate (psi_ref_zeroth_order(N_det_ref)) + print*,'# nuclear_repulsion = ',nuclear_repulsion + allocate (psi_ref_dressed(N_det_ref)) + allocate (eigvalues(N_det_ref)) + allocate (eigvectors(N_det_ref,N_det_ref)) + + + + do istate= 1, N_states + do i = 1, N_det_ref + do j = 1, N_det_ref + H_print(i,j) = ref_hamiltonian_matrix(j,i) + enddo + enddo + do i = 1, N_det_ref + H_print(i,i) -= ref_hamiltonian_matrix(1,1) + enddo + print*,'Ref Hamiltonian matrix emelent = ',ref_hamiltonian_matrix(1,1) + print*,'ISTATE = ',istate + accu_norm = 0.d0 + do i = 1, N_det_ref + accu_norm += psi_ref_coef(i,1) * psi_ref_coef(i,1) + enddo + print*,'accu_norm = ',accu_norm + accu_norm = 1.d0/dsqrt(accu_norm) + do i = 1, N_det_ref + psi_restart_ref_normalized(i) = psi_ref_coef(i,istate)* accu_norm + enddo + print*,'-------------------' + print*,'-------------------' + print*,'CAS MATRIX ' + print*,'' + do i = 1, N_det_ref + write(*,'(10(F8.5 ,4X))') H_print(i,:) + enddo + print*,'' + print*,'-------------------' + print*,'-------------------' + print*,'CAS MATRIX DRESSING' + print*,'' + do i = 1, N_det_ref + write(*,'(10(F8.5 ,4X))') dressing_ref_hamiltonian(i,:,istate) + enddo + print*,'' + print*,'-------------------' + print*,'-------------------' + do i = 1, N_det_ref + do j = 1, N_det_ref + H_dressed(j,i) = ref_hamiltonian_matrix(j,i) + dressing_ref_hamiltonian(j,i,istate) + H_print(i,j) += dressing_ref_hamiltonian(j,i,istate) + enddo + enddo + print*,'' + print*,'-------------------' + print*,'-------------------' + print*,'TOTAL DRESSED H MATRIX ' + print*,'' + do i = 1, N_det_ref + write(*,'(10(F8.5 ,4X))') H_print(i,:) + enddo + print*,'' + print*,'' + print*,'' + + + call lapack_diagd(eigvalues,eigvectors,ref_hamiltonian_matrix,n_det_ref,n_det_ref) + do i = 1, N_det_ref + psi_ref_zeroth_order(i) = eigvectors(i,istate) + enddo + + + call lapack_diagd(eigvalues,eigvectors,H_dressed,n_det_ref,n_det_ref) + do i = 1, N_det_ref + psi_ref_dressed(i) = eigvectors(i,istate) + enddo + print*,'E+PT2 = ',eigvalues(istate) + nuclear_repulsion + do i = 1, N_det_ref + write(*,'(10(F10.7 ,4X))') psi_ref_coef(i,istate)/psi_ref_coef(1,istate), psi_ref_dressed(i)/psi_ref_dressed(1),psi_ref_zeroth_order(i)/psi_ref_zeroth_order(1) + enddo + enddo + + deallocate (H_dressed) + deallocate (H_print) + deallocate (psi_restart_ref_normalized) + deallocate (psi_ref_zeroth_order) + deallocate (psi_ref_dressed) + + deallocate (eigvalues) + deallocate (eigvectors) + +end diff --git a/plugins/FOBOCI/EZFIO.cfg b/plugins/FOBOCI/EZFIO.cfg new file mode 100644 index 00000000..d4a10add --- /dev/null +++ b/plugins/FOBOCI/EZFIO.cfg @@ -0,0 +1,30 @@ +[threshold_singles] +type: double precision +doc: threshold to select the pertinent single excitations at second order +interface: ezfio,provider,ocaml +default: 0.01 + +[threshold_fobo_dm] +type: double precision +doc: threshold to eliminate small density matrix elements in the fobo procedure +interface: ezfio,provider,ocaml +default: 0.00001 + +[do_it_perturbative] +type: logical +doc: if true, you do the FOBOCI calculation perturbatively +interface: ezfio,provider,ocaml +default: .False. + +[second_order_h] +type: logical +doc: if true, you do the FOBOCI calculation using second order intermediate Hamiltonian +interface: ezfio,provider,ocaml +default: .False. + +[do_all_2p] +type: logical +doc: if true, you do all 2p type excitation on the LMCT +interface: ezfio,provider,ocaml +default: .True. + diff --git a/plugins/FOBOCI/H_apply.irp.f b/plugins/FOBOCI/H_apply.irp.f new file mode 100644 index 00000000..0a488753 --- /dev/null +++ b/plugins/FOBOCI/H_apply.irp.f @@ -0,0 +1,50 @@ +use bitmasks +BEGIN_SHELL [ /usr/bin/env python ] +from generate_h_apply import * + +s = H_apply("just_1h_1p") +s.set_selection_pt2("epstein_nesbet_2x2") +s.unset_skip() +s.filter_only_1h1p() +print s + + +s = H_apply("all_but_1h_and_1p") +s.set_selection_pt2("epstein_nesbet_2x2") +s.unset_skip() +s.filter_1h() +s.filter_1p() +print s + + + +s = H_apply("standard") +s.set_selection_pt2("epstein_nesbet") +s.unset_skip() +print s + +s = H_apply("just_mono",do_double_exc=False) +s.set_selection_pt2("epstein_nesbet_2x2") +s.unset_skip() +print s + + + +s = H_apply("just_mono_no_1h_no_1p",do_double_exc=False) +s.set_selection_pt2("epstein_nesbet_2x2") +s.unset_skip() +s.filter_1h() +s.filter_1p() +print s + +s = H_apply("just_mono_no_1h_no_1p_no_2p",do_double_exc=False) +s.set_selection_pt2("epstein_nesbet_2x2") +s.unset_skip() +s.filter_1h() +s.filter_1p() +s.filter_2p() +print s + + +END_SHELL + diff --git a/plugins/FOBOCI/H_apply_dressed_autonom.irp.f b/plugins/FOBOCI/H_apply_dressed_autonom.irp.f new file mode 100644 index 00000000..657ea22e --- /dev/null +++ b/plugins/FOBOCI/H_apply_dressed_autonom.irp.f @@ -0,0 +1,570 @@ +subroutine H_apply_dressed_pert_diexc(key_in, hole_1,particl_1, hole_2, particl_2, i_generator, iproc_in , delta_ij_generators_, Ndet_generators,psi_det_generators_input,E_ref ) + use omp_lib + use bitmasks + implicit none + BEGIN_DOC + ! Generate all double excitations of key_in using the bit masks of holes and + ! particles. + ! Assume N_int is already provided. + END_DOC + integer,parameter :: size_max = 3072 + + integer, intent(in) :: Ndet_generators + double precision, intent(inout) :: delta_ij_generators_(Ndet_generators,Ndet_generators),E_ref + integer(bit_kind), intent(in) :: psi_det_generators_input(N_int,2,Ndet_generators) + + integer ,intent(in) :: i_generator + integer(bit_kind),intent(in) :: key_in(N_int,2) + integer(bit_kind),allocatable :: keys_out(:,:,:) + integer(bit_kind), intent(in) :: hole_1(N_int,2), particl_1(N_int,2) + integer(bit_kind), intent(in) :: hole_2(N_int,2), particl_2(N_int,2) + integer, intent(in) :: iproc_in + integer(bit_kind), allocatable :: hole_save(:,:) + integer(bit_kind), allocatable :: key(:,:),hole(:,:), particle(:,:) + integer(bit_kind), allocatable :: hole_tmp(:,:), particle_tmp(:,:) + integer(bit_kind), allocatable :: key_union_hole_part(:) + integer :: ii,i,jj,j,k,ispin,l + integer, allocatable :: occ_particle(:,:), occ_hole(:,:) + integer, allocatable :: occ_particle_tmp(:,:), occ_hole_tmp(:,:) + integer :: kk,pp,other_spin,key_idx + integer :: N_elec_in_key_hole_1(2),N_elec_in_key_part_1(2) + integer :: N_elec_in_key_hole_2(2),N_elec_in_key_part_2(2) + + double precision :: mo_bielec_integral + logical :: is_a_two_holes_two_particles + integer, allocatable :: ia_ja_pairs(:,:,:) + integer, allocatable :: ib_jb_pairs(:,:) + double precision :: diag_H_mat_elem + integer :: iproc + integer :: jtest_vvvv + integer(omp_lock_kind), save :: lck, ifirst=0 + if (ifirst == 0) then +!$ call omp_init_lock(lck) + ifirst=1 + endif + + logical :: check_double_excitation + logical :: is_a_1h1p + logical :: b_cycle + check_double_excitation = .True. + iproc = iproc_in + + + + + PROVIDE elec_num_tab +! !$OMP PARALLEL DEFAULT(SHARED) & +! !$OMP PRIVATE(i,j,k,l,keys_out,hole,particle, & +! !$OMP occ_particle,occ_hole,j_a,k_a,other_spin, & +! !$OMP hole_save,ispin,jj,l_a,ib_jb_pairs,array_pairs, & +! !$OMP accu,i_a,hole_tmp,particle_tmp,occ_particle_tmp, & +! !$OMP occ_hole_tmp,key_idx,i_b,j_b,key,N_elec_in_key_part_1,& +! !$OMP N_elec_in_key_hole_1,N_elec_in_key_part_2, & +! !$OMP N_elec_in_key_hole_2,ia_ja_pairs,key_union_hole_part) & +! !$OMP SHARED(key_in,N_int,elec_num_tab,mo_tot_num, & +! !$OMP hole_1, particl_1, hole_2, particl_2, & +! !$OMP elec_alpha_num,i_generator) FIRSTPRIVATE(iproc) +!$ iproc = omp_get_thread_num() + allocate (keys_out(N_int,2,size_max), hole_save(N_int,2), & + key(N_int,2),hole(N_int,2), particle(N_int,2), hole_tmp(N_int,2),& + particle_tmp(N_int,2), occ_particle(N_int*bit_kind_size,2), & + occ_hole(N_int*bit_kind_size,2), occ_particle_tmp(N_int*bit_kind_size,2),& + occ_hole_tmp(N_int*bit_kind_size,2),key_union_hole_part(N_int)) + + + + + !!!! First couple hole particle + do j = 1, N_int + hole(j,1) = iand(hole_1(j,1),key_in(j,1)) + hole(j,2) = iand(hole_1(j,2),key_in(j,2)) + particle(j,1) = iand(xor(particl_1(j,1),key_in(j,1)),particl_1(j,1)) + particle(j,2) = iand(xor(particl_1(j,2),key_in(j,2)),particl_1(j,2)) + enddo + call bitstring_to_list(particle(1,1),occ_particle(1,1),N_elec_in_key_part_1(1),N_int) + call bitstring_to_list(particle(1,2),occ_particle(1,2),N_elec_in_key_part_1(2),N_int) + call bitstring_to_list(hole(1,1),occ_hole(1,1),N_elec_in_key_hole_1(1),N_int) + call bitstring_to_list(hole(1,2),occ_hole(1,2),N_elec_in_key_hole_1(2),N_int) + allocate (ia_ja_pairs(2,0:(elec_alpha_num)*mo_tot_num,2), & + ib_jb_pairs(2,0:(elec_alpha_num)*mo_tot_num)) + + do ispin=1,2 + i=0 + do ii=N_elec_in_key_hole_1(ispin),1,-1 ! hole + i_a = occ_hole(ii,ispin) + ASSERT (i_a > 0) + ASSERT (i_a <= mo_tot_num) + + do jj=1,N_elec_in_key_part_1(ispin) !particle + j_a = occ_particle(jj,ispin) + ASSERT (j_a > 0) + ASSERT (j_a <= mo_tot_num) + i += 1 + ia_ja_pairs(1,i,ispin) = i_a + ia_ja_pairs(2,i,ispin) = j_a + enddo + enddo + ia_ja_pairs(1,0,ispin) = i + enddo + + key_idx = 0 + + integer :: i_a,j_a,i_b,j_b,k_a,l_a,k_b,l_b + integer(bit_kind) :: test(N_int,2) + double precision :: accu + logical, allocatable :: array_pairs(:,:) + allocate(array_pairs(mo_tot_num,mo_tot_num)) + accu = 0.d0 + do ispin=1,2 + other_spin = iand(ispin,1)+1 +! !$OMP DO SCHEDULE (static) + do ii=1,ia_ja_pairs(1,0,ispin) + i_a = ia_ja_pairs(1,ii,ispin) + ASSERT (i_a > 0) + ASSERT (i_a <= mo_tot_num) + j_a = ia_ja_pairs(2,ii,ispin) + ASSERT (j_a > 0) + ASSERT (j_a <= mo_tot_num) + hole = key_in + k = ishft(i_a-1,-bit_kind_shift)+1 + j = i_a-ishft(k-1,bit_kind_shift)-1 + hole(k,ispin) = ibclr(hole(k,ispin),j) + k_a = ishft(j_a-1,-bit_kind_shift)+1 + l_a = j_a-ishft(k_a-1,bit_kind_shift)-1 + hole(k_a,ispin) = ibset(hole(k_a,ispin),l_a) + + !!!! Second couple hole particle + do j = 1, N_int + hole_tmp(j,1) = iand(hole_2(j,1),hole(j,1)) + hole_tmp(j,2) = iand(hole_2(j,2),hole(j,2)) + particle_tmp(j,1) = iand(xor(particl_2(j,1),hole(j,1)),particl_2(j,1)) + particle_tmp(j,2) = iand(xor(particl_2(j,2),hole(j,2)),particl_2(j,2)) + enddo + + call bitstring_to_list(particle_tmp(1,1),occ_particle_tmp(1,1),N_elec_in_key_part_2(1),N_int) + call bitstring_to_list(particle_tmp(1,2),occ_particle_tmp(1,2),N_elec_in_key_part_2(2),N_int) + call bitstring_to_list(hole_tmp (1,1),occ_hole_tmp (1,1),N_elec_in_key_hole_2(1),N_int) + call bitstring_to_list(hole_tmp (1,2),occ_hole_tmp (1,2),N_elec_in_key_hole_2(2),N_int) + + ! hole = a^(+)_j_a(ispin) a_i_a(ispin)|key_in> : mono exc :: orb(i_a,ispin) --> orb(j_a,ispin) + hole_save = hole + + ! Build array of the non-zero integrals of second excitation + array_pairs = .True. + if (ispin == 1) then + integer :: jjj + + i=0 + do kk = 1,N_elec_in_key_hole_2(other_spin) + i_b = occ_hole_tmp(kk,other_spin) + ASSERT (i_b > 0) + ASSERT (i_b <= mo_tot_num) + do jjj=1,N_elec_in_key_part_2(other_spin) ! particule + j_b = occ_particle_tmp(jjj,other_spin) + ASSERT (j_b > 0) + ASSERT (j_b <= mo_tot_num) + if (array_pairs(i_b,j_b)) then + + i+= 1 + ib_jb_pairs(1,i) = i_b + ib_jb_pairs(2,i) = j_b + endif + enddo + enddo + ib_jb_pairs(1,0) = i + + do kk = 1,ib_jb_pairs(1,0) + hole = hole_save + i_b = ib_jb_pairs(1,kk) + j_b = ib_jb_pairs(2,kk) + k = ishft(i_b-1,-bit_kind_shift)+1 + j = i_b-ishft(k-1,bit_kind_shift)-1 + hole(k,other_spin) = ibclr(hole(k,other_spin),j) + key = hole + k = ishft(j_b-1,-bit_kind_shift)+1 + l = j_b-ishft(k-1,bit_kind_shift)-1 + key(k,other_spin) = ibset(key(k,other_spin),l) + + + key_idx += 1 + do k=1,N_int + keys_out(k,1,key_idx) = key(k,1) + keys_out(k,2,key_idx) = key(k,2) + enddo + ASSERT (key_idx <= size_max) + if (key_idx == size_max) then + 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 + enddo + endif + + ! does all the mono excitations of the same spin + i=0 + do kk = 1,N_elec_in_key_hole_2(ispin) + i_b = occ_hole_tmp(kk,ispin) + if (i_b <= i_a.or.i_b == j_a) cycle + ASSERT (i_b > 0) + ASSERT (i_b <= mo_tot_num) + do jjj=1,N_elec_in_key_part_2(ispin) ! particule + j_b = occ_particle_tmp(jjj,ispin) + ASSERT (j_b > 0) + ASSERT (j_b <= mo_tot_num) + if (j_b <= j_a) cycle + if (array_pairs(i_b,j_b)) then + + i+= 1 + ib_jb_pairs(1,i) = i_b + ib_jb_pairs(2,i) = j_b + endif + enddo + enddo + ib_jb_pairs(1,0) = i + + do kk = 1,ib_jb_pairs(1,0) + hole = hole_save + i_b = ib_jb_pairs(1,kk) + j_b = ib_jb_pairs(2,kk) + k = ishft(i_b-1,-bit_kind_shift)+1 + j = i_b-ishft(k-1,bit_kind_shift)-1 + hole(k,ispin) = ibclr(hole(k,ispin),j) + key = hole + k = ishft(j_b-1,-bit_kind_shift)+1 + l = j_b-ishft(k-1,bit_kind_shift)-1 + key(k,ispin) = ibset(key(k,ispin),l) + + + key_idx += 1 + do k=1,N_int + keys_out(k,1,key_idx) = key(k,1) + keys_out(k,2,key_idx) = key(k,2) + enddo + ASSERT (key_idx <= size_max) + if (key_idx == size_max) then + 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 + enddo ! kk + + enddo ! ii +! !$OMP ENDDO NOWAIT + enddo ! ispin + 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) + + deallocate (ia_ja_pairs, ib_jb_pairs, & + keys_out, hole_save, & + key,hole, particle, hole_tmp,& + particle_tmp, occ_particle, & + occ_hole, occ_particle_tmp,& + occ_hole_tmp,array_pairs,key_union_hole_part) +! !$OMP END PARALLEL + +end + +subroutine H_apply_dressed_pert_monoexc(key_in, hole_1,particl_1,i_generator,iproc_in , delta_ij_generators_, Ndet_generators,psi_det_generators_input,E_ref ) + use omp_lib + use bitmasks + implicit none + BEGIN_DOC + ! Generate all single excitations of key_in using the bit masks of holes and + ! particles. + ! Assume N_int is already provided. + END_DOC + integer,parameter :: size_max = 3072 + + integer, intent(in) :: Ndet_generators + double precision, intent(in) :: delta_ij_generators_(Ndet_generators,Ndet_generators),E_ref + integer(bit_kind), intent(in) :: psi_det_generators_input(N_int,2,Ndet_generators) + + integer ,intent(in) :: i_generator + integer(bit_kind),intent(in) :: key_in(N_int,2) + integer(bit_kind),intent(in) :: hole_1(N_int,2), particl_1(N_int,2) + integer, intent(in) :: iproc_in + integer(bit_kind),allocatable :: keys_out(:,:,:) + integer(bit_kind),allocatable :: hole_save(:,:) + integer(bit_kind),allocatable :: key(:,:),hole(:,:), particle(:,:) + integer(bit_kind),allocatable :: hole_tmp(:,:), particle_tmp(:,:) + integer(bit_kind),allocatable :: hole_2(:,:), particl_2(:,:) + integer :: ii,i,jj,j,k,ispin,l + integer,allocatable :: occ_particle(:,:), occ_hole(:,:) + integer,allocatable :: occ_particle_tmp(:,:), occ_hole_tmp(:,:) + integer,allocatable :: ib_jb_pairs(:,:) + integer :: kk,pp,other_spin,key_idx + integer :: N_elec_in_key_hole_1(2),N_elec_in_key_part_1(2) + integer :: N_elec_in_key_hole_2(2),N_elec_in_key_part_2(2) + logical :: is_a_two_holes_two_particles + integer(bit_kind), allocatable :: key_union_hole_part(:) + + integer, allocatable :: ia_ja_pairs(:,:,:) + logical, allocatable :: array_pairs(:,:) + double precision :: diag_H_mat_elem + integer(omp_lock_kind), save :: lck, ifirst=0 + integer :: iproc + + logical :: check_double_excitation + logical :: is_a_1h1p + logical :: is_a_1h + logical :: is_a_1p + iproc = iproc_in + + check_double_excitation = .True. + + check_double_excitation = .False. + + + + + if (ifirst == 0) then + ifirst=1 +!!$ call omp_init_lock(lck) + endif + + + + PROVIDE elec_num_tab +! !$OMP PARALLEL DEFAULT(SHARED) & +! !$OMP PRIVATE(i,j,k,l,keys_out,hole,particle, & +! !$OMP occ_particle,occ_hole,j_a,k_a,other_spin, & +! !$OMP hole_save,ispin,jj,l_a,ib_jb_pairs,array_pairs, & +! !$OMP accu,i_a,hole_tmp,particle_tmp,occ_particle_tmp, & +! !$OMP occ_hole_tmp,key_idx,i_b,j_b,key,N_elec_in_key_part_1,& +! !$OMP N_elec_in_key_hole_1,N_elec_in_key_part_2, & +! !$OMP N_elec_in_key_hole_2,ia_ja_pairs,key_union_hole_part) & +! !$OMP SHARED(key_in,N_int,elec_num_tab,mo_tot_num, & +! !$OMP hole_1, particl_1, hole_2, particl_2, & +! !$OMP elec_alpha_num,i_generator) FIRSTPRIVATE(iproc) +!!$ iproc = omp_get_thread_num() + allocate (keys_out(N_int,2,size_max), hole_save(N_int,2), & + key(N_int,2),hole(N_int,2), particle(N_int,2), hole_tmp(N_int,2),& + particle_tmp(N_int,2), occ_particle(N_int*bit_kind_size,2), & + occ_hole(N_int*bit_kind_size,2), occ_particle_tmp(N_int*bit_kind_size,2),& + occ_hole_tmp(N_int*bit_kind_size,2),key_union_hole_part(N_int)) + + !!!! First couple hole particle + do j = 1, N_int + hole(j,1) = iand(hole_1(j,1),key_in(j,1)) + hole(j,2) = iand(hole_1(j,2),key_in(j,2)) + particle(j,1) = iand(xor(particl_1(j,1),key_in(j,1)),particl_1(j,1)) + particle(j,2) = iand(xor(particl_1(j,2),key_in(j,2)),particl_1(j,2)) + enddo + + call bitstring_to_list(particle(1,1),occ_particle(1,1),N_elec_in_key_part_1(1),N_int) + call bitstring_to_list(particle(1,2),occ_particle(1,2),N_elec_in_key_part_1(2),N_int) + call bitstring_to_list(hole (1,1),occ_hole (1,1),N_elec_in_key_hole_1(1),N_int) + call bitstring_to_list(hole (1,2),occ_hole (1,2),N_elec_in_key_hole_1(2),N_int) + allocate (ia_ja_pairs(2,0:(elec_alpha_num)*mo_tot_num,2)) + + do ispin=1,2 + i=0 + do ii=N_elec_in_key_hole_1(ispin),1,-1 ! hole + i_a = occ_hole(ii,ispin) + do jj=1,N_elec_in_key_part_1(ispin) !particule + j_a = occ_particle(jj,ispin) + i += 1 + ia_ja_pairs(1,i,ispin) = i_a + ia_ja_pairs(2,i,ispin) = j_a + enddo + enddo + ia_ja_pairs(1,0,ispin) = i + enddo + + key_idx = 0 + + integer :: i_a,j_a,i_b,j_b,k_a,l_a,k_b,l_b + integer(bit_kind) :: test(N_int,2) + double precision :: accu + accu = 0.d0 + integer :: jjtest,na,nb + do ispin=1,2 + other_spin = iand(ispin,1)+1 +! !$OMP DO SCHEDULE (static) + do ii=1,ia_ja_pairs(1,0,ispin) + i_a = ia_ja_pairs(1,ii,ispin) + j_a = ia_ja_pairs(2,ii,ispin) + hole = key_in + k = ishft(i_a-1,-bit_kind_shift)+1 + j = i_a-ishft(k-1,bit_kind_shift)-1 + + hole(k,ispin) = ibclr(hole(k,ispin),j) + k_a = ishft(j_a-1,-bit_kind_shift)+1 + l_a = j_a-ishft(k_a-1,bit_kind_shift)-1 + + hole(k_a,ispin) = ibset(hole(k_a,ispin),l_a) + na = 0 + nb = 0 +! if (is_a_1h(hole)) then +! cycle +! endif +! if (is_a_1p(hole)) then +! cycle +! endif + + + key_idx += 1 + do k=1,N_int + keys_out(k,1,key_idx) = hole(k,1) + keys_out(k,2,key_idx) = hole(k,2) + enddo + if (key_idx == size_max) then + 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 + enddo ! ii +! !$OMP ENDDO NOWAIT + enddo ! ispin + 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) + + deallocate (ia_ja_pairs, & + keys_out, hole_save, & + key,hole, particle, hole_tmp,& + particle_tmp, occ_particle, & + occ_hole, occ_particle_tmp,& + occ_hole_tmp,key_union_hole_part) +! !$OMP END PARALLEL + + +end + + +subroutine H_apply_dressed_pert(delta_ij_generators_, Ndet_generators,psi_det_generators_input,E_ref) + 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 + + + integer, intent(in) :: Ndet_generators + integer(bit_kind), intent(in) :: psi_det_generators_input(N_int,2,Ndet_generators),E_ref + double precision, intent(in) :: delta_ij_generators_(Ndet_generators,Ndet_generators) + + + 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 + + + PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map + + nmax = mod( Ndet_generators,nproc ) + + +! !$ call omp_init_lock(lck) + call wall_time(wall_0) + + iproc = 0 + allocate( mask(N_int,2,6) ) + do i_generator=1,nmax + +! ! 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_input(k,ispin,i_generator) ) + mask(k,ispin,s_part) = & + iand(generators_bitmask(k,ispin,s_part,i_bitmask_gen), & + not(psi_det_generators_input(k,ispin,i_generator)) ) + mask(k,ispin,d_hole1) = & + iand(generators_bitmask(k,ispin,d_hole1,i_bitmask_gen), & + psi_det_generators_input(k,ispin,i_generator) ) + mask(k,ispin,d_part1) = & + iand(generators_bitmask(k,ispin,d_part1,i_bitmask_gen), & + not(psi_det_generators_input(k,ispin,i_generator)) ) + mask(k,ispin,d_hole2) = & + iand(generators_bitmask(k,ispin,d_hole2,i_bitmask_gen), & + psi_det_generators_input(k,ispin,i_generator) ) + mask(k,ispin,d_part2) = & + iand(generators_bitmask(k,ispin,d_part2,i_bitmask_gen), & + not(psi_det_generators_input(k,ispin,i_generator)) ) + enddo + enddo + if(.False.)then + call H_apply_dressed_pert_diexc(psi_det_generators_input(1,1,i_generator), & + mask(1,1,d_hole1), mask(1,1,d_part1), & + mask(1,1,d_hole2), mask(1,1,d_part2), & + i_generator, iproc , delta_ij_generators_, Ndet_generators,psi_det_generators_input,E_ref) + endif + if(.True.)then + call H_apply_dressed_pert_monoexc(psi_det_generators_input(1,1,i_generator), & + mask(1,1,s_hole ), mask(1,1,s_part ), & + i_generator, iproc , delta_ij_generators_, Ndet_generators,psi_det_generators_input,E_ref) + endif + call wall_time(wall_1) + + if (wall_1 - wall_0 > 2.d0) then + write(output_determinants,*) & + 100.*float(i_generator)/float(Ndet_generators), '% in ', wall_1-wall_0, 's' + wall_0 = wall_1 + endif + enddo + + deallocate( mask ) + +! !$OMP PARALLEL DEFAULT(SHARED) & +! !$OMP PRIVATE(i_generator,wall_1,wall_0,ispin,k,mask,iproc) + call wall_time(wall_0) +! !$ iproc = omp_get_thread_num() + allocate( mask(N_int,2,6) ) +! !$OMP DO SCHEDULE(dynamic,1) + do i_generator=nmax+1,Ndet_generators + + ! 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_input(k,ispin,i_generator) ) + mask(k,ispin,s_part) = & + iand(generators_bitmask(k,ispin,s_part,i_bitmask_gen), & + not(psi_det_generators_input(k,ispin,i_generator)) ) + mask(k,ispin,d_hole1) = & + iand(generators_bitmask(k,ispin,d_hole1,i_bitmask_gen), & + psi_det_generators_input(k,ispin,i_generator) ) + mask(k,ispin,d_part1) = & + iand(generators_bitmask(k,ispin,d_part1,i_bitmask_gen), & + not(psi_det_generators_input(k,ispin,i_generator)) ) + mask(k,ispin,d_hole2) = & + iand(generators_bitmask(k,ispin,d_hole2,i_bitmask_gen), & + psi_det_generators_input(k,ispin,i_generator) ) + mask(k,ispin,d_part2) = & + iand(generators_bitmask(k,ispin,d_part2,i_bitmask_gen), & + not (psi_det_generators_input(k,ispin,i_generator)) ) + enddo + enddo + + if(.False.)then + call H_apply_dressed_pert_diexc(psi_det_generators_input(1,1,i_generator), & + mask(1,1,d_hole1), mask(1,1,d_part1), & + mask(1,1,d_hole2), mask(1,1,d_part2), & + i_generator, iproc , delta_ij_generators_, Ndet_generators,psi_det_generators_input,E_ref) + endif + if(.True.)then + call H_apply_dressed_pert_monoexc(psi_det_generators_input(1,1,i_generator), & + mask(1,1,s_hole ), mask(1,1,s_part ), & + i_generator, iproc , delta_ij_generators_, Ndet_generators,psi_det_generators_input,E_ref) + endif +! !$ call omp_set_lock(lck) + call wall_time(wall_1) + + if (wall_1 - wall_0 > 2.d0) then + write(output_determinants,*) & + 100.*float(i_generator)/float(Ndet_generators), '% in ', wall_1-wall_0, 's' + wall_0 = wall_1 + endif +! !$ call omp_unset_lock(lck) + enddo +! !$OMP END DO + deallocate( mask ) +! !$OMP END PARALLEL +! !$ call omp_destroy_lock(lck) + + +end + + diff --git a/plugins/FOBOCI/NEEDED_CHILDREN_MODULES b/plugins/FOBOCI/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..adeefe99 --- /dev/null +++ b/plugins/FOBOCI/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Perturbation Generators_restart Selectors_no_sorted diff --git a/plugins/FOBOCI/README.rst b/plugins/FOBOCI/README.rst new file mode 100644 index 00000000..95a09211 --- /dev/null +++ b/plugins/FOBOCI/README.rst @@ -0,0 +1,12 @@ +====== +FOBOCI +====== + +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. diff --git a/plugins/FOBOCI/all_singles.irp.f b/plugins/FOBOCI/all_singles.irp.f new file mode 100644 index 00000000..e2c4c01e --- /dev/null +++ b/plugins/FOBOCI/all_singles.irp.f @@ -0,0 +1,362 @@ +subroutine all_single + implicit none + integer :: i,k + double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:) + integer :: N_st, degree + double precision,allocatable :: E_before(:) + N_st = N_states + allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st)) + selection_criterion = 1.d-8 + soft_touch selection_criterion + threshold_davidson = 1.d-5 + soft_touch threshold_davidson davidson_criterion + i = 0 + print*,'Doing all the mono excitations !' + print*,'N_det = ',N_det + print*,'n_det_max = ',n_det_max + print*,'pt2_max = ',pt2_max + print*,'N_det_generators = ',N_det_generators + pt2=-1.d0 + E_before = ref_bitmask_energy + + print*,'Initial Step ' + print*,'Inital determinants ' + print*,'N_det = ',N_det + do i = 1, N_states_diag + print*,'' + print*,'i = ',i + print*,'E = ',CI_energy(i) + print*,'S^2 = ',CI_eigenvectors_s2(i) + enddo + n_det_max = 100000 + do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max) + i += 1 + print*,'-----------------------' + print*,'i = ',i + call H_apply_just_mono(pt2, norm_pert, H_pert_diag, N_st) + call diagonalize_CI + print*,'N_det = ',N_det + print*,'E = ',CI_energy(1) + print*,'pt2 = ',pt2(1) + print*,'E+PT2 = ',E_before + pt2(1) + if(N_states_diag.gt.1)then + print*,'Variational Energy difference' + do i = 2, N_st + print*,'Delta E = ',CI_energy(i) - CI_energy(1) + enddo + endif + if(N_states.gt.1)then + print*,'Variational + perturbative Energy difference' + do i = 2, N_st + print*,'Delta E = ',E_before(i)+ pt2(i) - (E_before(1) + pt2(1)) + enddo + endif + E_before = CI_energy + enddo + threshold_davidson = 1.d-10 + soft_touch threshold_davidson davidson_criterion + call diagonalize_CI + print*,'Final Step ' + print*,'N_det = ',N_det + do i = 1, N_states_diag + print*,'' + print*,'i = ',i + print*,'E = ',CI_energy(i) + print*,'S^2 = ',CI_eigenvectors_s2(i) + enddo + do i = 1, 2 + print*,'psi_coef = ',psi_coef(i,1) + enddo +! call save_wavefunction + deallocate(pt2,norm_pert,E_before) +end + +subroutine all_single_no_1h_or_1p + implicit none + integer :: i,k + double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:) + integer :: N_st, degree + double precision,allocatable :: E_before(:) + N_st = N_states + allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st)) + threshold_davidson = 1.d-5 + soft_touch threshold_davidson davidson_criterion + i = 0 + print*,'Doing all the mono excitations !' + print*,'N_det = ',N_det + print*,'n_det_max = ',n_det_max + print*,'pt2_max = ',pt2_max + print*,'N_det_generators = ',N_det_generators + pt2=-1.d0 + E_before = ref_bitmask_energy + + print*,'Initial Step ' + print*,'Inital determinants ' + print*,'N_det = ',N_det + do i = 1, N_states_diag + print*,'' + print*,'i = ',i + print*,'E = ',CI_energy(i) + print*,'S^2 = ',CI_eigenvectors_s2(i) + enddo + n_det_max = 100000 + do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max) + i += 1 + print*,'-----------------------' + print*,'i = ',i + call H_apply_just_mono_no_1h_no_1p(pt2, norm_pert, H_pert_diag, N_st) + call diagonalize_CI + print*,'N_det = ',N_det + print*,'E = ',CI_energy(1) + print*,'pt2 = ',pt2(1) + print*,'E+PT2 = ',E_before + pt2(1) + if(N_states_diag.gt.1)then + print*,'Variational Energy difference' + do i = 2, N_st + print*,'Delta E = ',CI_energy(i) - CI_energy(1) + enddo + endif + if(N_states.gt.1)then + print*,'Variational + perturbative Energy difference' + do i = 2, N_st + print*,'Delta E = ',E_before(i)+ pt2(i) - (E_before(1) + pt2(1)) + enddo + endif + E_before = CI_energy + enddo + threshold_davidson = 1.d-10 + soft_touch threshold_davidson davidson_criterion + call diagonalize_CI + print*,'Final Step ' + print*,'N_det = ',N_det + do i = 1, N_states_diag + print*,'' + print*,'i = ',i + print*,'E = ',CI_energy(i) + print*,'S^2 = ',CI_eigenvectors_s2(i) + enddo + do i = 1, 2 + print*,'psi_coef = ',psi_coef(i,1) + enddo +! call save_wavefunction + deallocate(pt2,norm_pert,E_before) +end + +subroutine all_single_no_1h_or_1p_or_2p + implicit none + integer :: i,k + double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:) + integer :: N_st, degree + double precision,allocatable :: E_before(:) + N_st = N_states + allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st)) + selection_criterion = 0.d0 + soft_touch selection_criterion + threshold_davidson = 1.d-5 + soft_touch threshold_davidson davidson_criterion + i = 0 + print*,'Doing all the mono excitations !' + print*,'N_det = ',N_det + print*,'n_det_max = ',n_det_max + print*,'pt2_max = ',pt2_max + print*,'N_det_generators = ',N_det_generators + pt2=-1.d0 + E_before = ref_bitmask_energy + + print*,'Initial Step ' + print*,'Inital determinants ' + print*,'N_det = ',N_det + do i = 1, N_states_diag + print*,'' + print*,'i = ',i + print*,'E = ',CI_energy(i) + print*,'S^2 = ',CI_eigenvectors_s2(i) + enddo + n_det_max = 100000 + do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max) + i += 1 + print*,'-----------------------' + print*,'i = ',i + call H_apply_just_mono_no_1h_no_1p_no_2p(pt2, norm_pert, H_pert_diag, N_st) + call diagonalize_CI + print*,'N_det = ',N_det + print*,'E = ',CI_energy(1) + print*,'pt2 = ',pt2(1) + print*,'E+PT2 = ',E_before + pt2(1) + if(N_states_diag.gt.1)then + print*,'Variational Energy difference' + do i = 2, N_st + print*,'Delta E = ',CI_energy(i) - CI_energy(1) + enddo + endif + if(N_states.gt.1)then + print*,'Variational + perturbative Energy difference' + do i = 2, N_st + print*,'Delta E = ',E_before(i)+ pt2(i) - (E_before(1) + pt2(1)) + enddo + endif + E_before = CI_energy + enddo + threshold_davidson = 1.d-10 + soft_touch threshold_davidson davidson_criterion + call diagonalize_CI + print*,'Final Step ' + print*,'N_det = ',N_det + do i = 1, N_states_diag + print*,'' + print*,'i = ',i + print*,'E = ',CI_energy(i) + print*,'S^2 = ',CI_eigenvectors_s2(i) + enddo + do i = 1, 2 + print*,'psi_coef = ',psi_coef(i,1) + enddo +! call save_wavefunction + deallocate(pt2,norm_pert,E_before) +end + + +subroutine all_2p + implicit none + integer :: i,k + double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:) + integer :: N_st, degree + double precision,allocatable :: E_before(:) + N_st = N_states + allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st)) + selection_criterion = 0.d0 + soft_touch selection_criterion + threshold_davidson = 1.d-5 + soft_touch threshold_davidson davidson_criterion + i = 0 + print*,'' + print*,'' + print*,'' + print*,'' + print*,'' + print*,'*****************************' + print*,'Doing all the 2P excitations' + print*,'*****************************' + print*,'' + print*,'' + print*,'N_det = ',N_det + print*,'n_det_max = ',n_det_max + print*,'pt2_max = ',pt2_max + print*,'N_det_generators = ',N_det_generators + pt2=-1.d0 + E_before = ref_bitmask_energy + + print*,'Initial Step ' + print*,'Inital determinants ' + print*,'N_det = ',N_det + do i = 1, N_states_diag + print*,'' + print*,'i = ',i + print*,'E = ',CI_energy(i) + print*,'S^2 = ',CI_eigenvectors_s2(i) + enddo + n_det_max = 100000 + i = 0 + do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max) + i += 1 + print*,'-----------------------' + print*,'i = ',i + call H_apply_standard(pt2, norm_pert, H_pert_diag, N_st) + call diagonalize_CI + print*,'N_det = ',N_det + print*,'E = ',CI_energy(1) + print*,'pt2 = ',pt2(1) + print*,'E+PT2 = ',E_before + pt2(1) + if(N_states_diag.gt.1)then + print*,'Variational Energy difference' + do i = 2, N_st + print*,'Delta E = ',CI_energy(i) - CI_energy(1) + enddo + endif + if(N_states.gt.1)then + print*,'Variational + perturbative Energy difference' + do i = 2, N_st + print*,'Delta E = ',E_before(i)+ pt2(i) - (E_before(1) + pt2(1)) + enddo + endif + E_before = CI_energy + + enddo + print*,'Final Step ' + print*,'N_det = ',N_det + do i = 1, N_states_diag + print*,'' + print*,'i = ',i + print*,'E = ',CI_energy(i) + print*,'S^2 = ',CI_eigenvectors_s2(i) + enddo +! call save_wavefunction + deallocate(pt2,norm_pert,E_before) +end + +subroutine all_1h_1p_routine + implicit none + integer :: i,k + double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:) + integer :: N_st, degree + double precision :: E_before + integer :: n_det_before + N_st = N_states + allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st)) + i = 0 + print*,'N_det = ',N_det + print*,'n_det_max = ',n_det_max + print*,'pt2_max = ',pt2_max + pt2=-1.d0 + E_before = ref_bitmask_energy + do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max) + n_det_before = N_det + i += 1 + print*,'-----------------------' + print*,'i = ',i + call H_apply_just_1h_1p(pt2, norm_pert, H_pert_diag, N_st) + call diagonalize_CI + print*,'N_det = ',N_det + print*,'E = ',CI_energy(1) + print*,'pt2 = ',pt2(1) + print*,'E+PT2 = ',E_before + pt2(1) + E_before = CI_energy(1) + if(n_det_before == N_det)then + selection_criterion = selection_criterion * 0.5d0 + endif + enddo + deallocate(pt2,norm_pert) +end +subroutine all_but_1h_1p_routine + implicit none + integer :: i,k + double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:) + integer :: N_st, degree + double precision :: E_before + integer :: n_det_before + N_st = N_states + allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st)) + i = 0 + print*,'N_det = ',N_det + print*,'n_det_max = ',n_det_max + print*,'pt2_max = ',pt2_max + pt2=-1.d0 + E_before = ref_bitmask_energy + do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max) + n_det_before = N_det + i += 1 + print*,'-----------------------' + print*,'i = ',i + call H_apply_all_but_1h_and_1p(pt2, norm_pert, H_pert_diag, N_st) + call diagonalize_CI + print*,'N_det = ',N_det + print*,'E = ',CI_energy(1) + print*,'pt2 = ',pt2(1) + print*,'E+PT2 = ',E_before + pt2(1) + E_before = CI_energy(1) + if(n_det_before == N_det)then + selection_criterion = selection_criterion * 0.5d0 + endif + enddo + deallocate(pt2,norm_pert) +end diff --git a/plugins/FOBOCI/all_singles_split.irp.f b/plugins/FOBOCI/all_singles_split.irp.f new file mode 100644 index 00000000..e7b0943f --- /dev/null +++ b/plugins/FOBOCI/all_singles_split.irp.f @@ -0,0 +1,243 @@ +subroutine all_single_split(psi_det_generators_input,psi_coef_generators_input,Ndet_generators_input,dressing_matrix) + implicit none + use bitmasks + integer, intent(in) :: Ndet_generators_input + integer(bit_kind), intent(in) :: psi_det_generators_input(N_int,2,Ndet_generators_input) + double precision, intent(inout) :: dressing_matrix(Ndet_generators_input,Ndet_generators_input) + double precision, intent(in) :: psi_coef_generators_input(ndet_generators_input,n_states) + integer :: i,i_hole + n_det_max_jacobi = 50 + soft_touch n_det_max_jacobi + do i = 1, n_inact_orb + i_hole = list_inact(i) + print*,'' + print*,'Doing all the single excitations from the orbital ' + print*,i_hole + print*,'' + print*,'' + threshold_davidson = 1.d-4 + soft_touch threshold_davidson davidson_criterion + call modify_bitmasks_for_hole(i_hole) + call set_bitmask_particl_as_input(reunion_of_bitmask) + call set_generators_as_input_psi(ndet_generators_input,psi_det_generators_input,psi_coef_generators_input) + call set_psi_det_as_input_psi(ndet_generators_input,psi_det_generators_input,psi_coef_generators_input) + call all_single + threshold_davidson = 1.d-10 + soft_touch threshold_davidson davidson_criterion + call diagonalize_CI + call provide_matrix_dressing(dressing_matrix,ndet_generators_input,psi_det_generators_input) + enddo + n_det_max_jacobi = 1000 + soft_touch n_det_max_jacobi +end + + +subroutine all_single_for_1h(dressing_matrix_1h1p,dressing_matrix_2h1p) + implicit none + use bitmasks + double precision, intent(inout) :: dressing_matrix_1h1p(N_det_generators,N_det_generators) + double precision, intent(inout) :: dressing_matrix_2h1p(N_det_generators,N_det_generators) + integer :: i,i_hole + n_det_max_jacobi = 50 + soft_touch n_det_max_jacobi + + integer :: n_det_1h1p,n_det_2h1p + integer(bit_kind), allocatable :: psi_ref_out(:,:,:) + integer(bit_kind), allocatable :: psi_1h1p(:,:,:) + integer(bit_kind), allocatable :: psi_2h1p(:,:,:) + double precision, allocatable :: psi_ref_coef_out(:,:) + double precision, allocatable :: psi_coef_1h1p(:,:) + double precision, allocatable :: psi_coef_2h1p(:,:) + call all_single_no_1h_or_1p + + threshold_davidson = 1.d-12 + soft_touch threshold_davidson davidson_criterion + call diagonalize_CI + call give_n_1h1p_and_n_2h1p_in_psi_det(n_det_1h1p,n_det_2h1p) + allocate(psi_ref_out(N_int,2,N_det_generators)) + allocate(psi_1h1p(N_int,2,n_det_1h1p)) + allocate(psi_2h1p(N_int,2,n_det_2h1p)) + allocate(psi_ref_coef_out(N_det_generators,N_states)) + allocate(psi_coef_1h1p(n_det_1h1p,N_states)) + allocate(psi_coef_2h1p(n_det_2h1p,N_states)) + call split_wf_generators_and_1h1p_and_2h1p(n_det_1h1p,n_det_2h1p,psi_ref_out,psi_ref_coef_out,psi_1h1p,psi_coef_1h1p,psi_2h1p,psi_coef_2h1p) + call provide_matrix_dressing_general(dressing_matrix_1h1p,psi_ref_out,psi_ref_coef_out,N_det_generators, & + psi_1h1p,psi_coef_1h1p,n_det_1h1p) + call provide_matrix_dressing_general(dressing_matrix_2h1p,psi_ref_out,psi_ref_coef_out,N_det_generators, & + psi_2h1p,psi_coef_2h1p,n_det_2h1p) + + deallocate(psi_ref_out) + deallocate(psi_1h1p) + deallocate(psi_2h1p) + deallocate(psi_ref_coef_out) + deallocate(psi_coef_1h1p) + deallocate(psi_coef_2h1p) + +end + + + + +subroutine all_single_split_for_1h(dressing_matrix_1h1p,dressing_matrix_2h1p) + implicit none + use bitmasks + double precision, intent(inout) :: dressing_matrix_1h1p(N_det_generators,N_det_generators) + double precision, intent(inout) :: dressing_matrix_2h1p(N_det_generators,N_det_generators) + integer :: i,i_hole + n_det_max_jacobi = 50 + soft_touch n_det_max_jacobi + + integer :: n_det_1h1p,n_det_2h1p + integer(bit_kind), allocatable :: psi_ref_out(:,:,:) + integer(bit_kind), allocatable :: psi_1h1p(:,:,:) + integer(bit_kind), allocatable :: psi_2h1p(:,:,:) + double precision, allocatable :: psi_ref_coef_out(:,:) + double precision, allocatable :: psi_coef_1h1p(:,:) + double precision, allocatable :: psi_coef_2h1p(:,:) + do i = 1, n_inact_orb + i_hole = list_inact(i) + print*,'' + print*,'Doing all the single excitations from the orbital ' + print*,i_hole + print*,'' + print*,'' + threshold_davidson = 1.d-4 + soft_touch threshold_davidson davidson_criterion + selection_criterion_factor = 1.d-4 + soft_touch selection_criterion_factor selection_criterion selection_criterion_min + call modify_bitmasks_for_hole(i_hole) + call set_bitmask_particl_as_input(reunion_of_bitmask) + call set_generators_as_input_psi(n_det_generators,psi_det_generators,psi_coef_generators) + call set_psi_det_as_input_psi(n_det_generators,psi_det_generators,psi_coef_generators) + call all_single_no_1h_or_1p + threshold_davidson = 1.d-10 + soft_touch threshold_davidson davidson_criterion + call diagonalize_CI + call give_n_1h1p_and_n_2h1p_in_psi_det(n_det_1h1p,n_det_2h1p) + allocate(psi_ref_out(N_int,2,N_det_generators)) + allocate(psi_1h1p(N_int,2,n_det_1h1p)) + allocate(psi_2h1p(N_int,2,n_det_2h1p)) + allocate(psi_ref_coef_out(N_det_generators,N_states)) + allocate(psi_coef_1h1p(n_det_1h1p,N_states)) + allocate(psi_coef_2h1p(n_det_2h1p,N_states)) + call split_wf_generators_and_1h1p_and_2h1p(n_det_1h1p,n_det_2h1p,psi_ref_out,psi_ref_coef_out,psi_1h1p,psi_coef_1h1p,psi_2h1p,psi_coef_2h1p) + call provide_matrix_dressing_general(dressing_matrix_1h1p,psi_ref_out,psi_ref_coef_out,N_det_generators, & + psi_1h1p,psi_coef_1h1p,n_det_1h1p) + call provide_matrix_dressing_general(dressing_matrix_2h1p,psi_ref_out,psi_ref_coef_out,N_det_generators, & + psi_2h1p,psi_coef_2h1p,n_det_2h1p) + + deallocate(psi_ref_out) + deallocate(psi_1h1p) + deallocate(psi_2h1p) + deallocate(psi_ref_coef_out) + deallocate(psi_coef_1h1p) + deallocate(psi_coef_2h1p) + enddo + n_det_max_jacobi = 1000 + soft_touch n_det_max_jacobi +end + + +subroutine all_single_split_for_1p(dressing_matrix_1h1p,dressing_matrix_1h2p) + implicit none + use bitmasks + double precision, intent(inout) :: dressing_matrix_1h1p(N_det_generators,N_det_generators) + double precision, intent(inout) :: dressing_matrix_1h2p(N_det_generators,N_det_generators) + integer :: i,i_hole + n_det_max_jacobi = 50 + soft_touch n_det_max_jacobi + + integer :: n_det_1h1p,n_det_1h2p + integer(bit_kind), allocatable :: psi_ref_out(:,:,:) + integer(bit_kind), allocatable :: psi_1h1p(:,:,:) + integer(bit_kind), allocatable :: psi_1h2p(:,:,:) + double precision, allocatable :: psi_ref_coef_out(:,:) + double precision, allocatable :: psi_coef_1h1p(:,:) + double precision, allocatable :: psi_coef_1h2p(:,:) + do i = 1, n_inact_orb + i_hole = list_inact(i) + print*,'' + print*,'Doing all the single excitations from the orbital ' + print*,i_hole + print*,'' + print*,'' + threshold_davidson = 1.d-4 + soft_touch threshold_davidson davidson_criterion + selection_criterion_factor = 1.d-4 + soft_touch selection_criterion_factor selection_criterion selection_criterion_min + call modify_bitmasks_for_hole(i_hole) + call set_bitmask_particl_as_input(reunion_of_bitmask) + call set_generators_as_input_psi(n_det_generators,psi_det_generators,psi_coef_generators) + call set_psi_det_as_input_psi(n_det_generators,psi_det_generators,psi_coef_generators) + call all_single_no_1h_or_1p + threshold_davidson = 1.d-10 + soft_touch threshold_davidson davidson_criterion + call diagonalize_CI + call give_n_1h1p_and_n_1h2p_in_psi_det(n_det_1h1p,n_det_1h2p) + allocate(psi_ref_out(N_int,2,N_det_generators)) + allocate(psi_1h1p(N_int,2,n_det_1h1p)) + allocate(psi_1h2p(N_int,2,n_det_1h2p)) + allocate(psi_ref_coef_out(N_det_generators,N_states)) + allocate(psi_coef_1h1p(n_det_1h1p,N_states)) + allocate(psi_coef_1h2p(n_det_1h2p,N_states)) + call split_wf_generators_and_1h1p_and_1h2p(n_det_1h1p,n_det_1h2p,psi_ref_out,psi_ref_coef_out,psi_1h1p,psi_coef_1h1p,psi_1h2p,psi_coef_1h2p) + call provide_matrix_dressing_general(dressing_matrix_1h1p,psi_ref_out,psi_ref_coef_out,N_det_generators, & + psi_1h1p,psi_coef_1h1p,n_det_1h1p) + call provide_matrix_dressing_general(dressing_matrix_1h2p,psi_ref_out,psi_ref_coef_out,N_det_generators, & + psi_1h2p,psi_coef_1h2p,n_det_1h2p) + + deallocate(psi_ref_out) + deallocate(psi_1h1p) + deallocate(psi_1h2p) + deallocate(psi_ref_coef_out) + deallocate(psi_coef_1h1p) + deallocate(psi_coef_1h2p) + enddo + n_det_max_jacobi = 1000 + soft_touch n_det_max_jacobi +end + +subroutine all_single_for_1p(dressing_matrix_1h1p,dressing_matrix_1h2p) + implicit none + use bitmasks + double precision, intent(inout) :: dressing_matrix_1h1p(N_det_generators,N_det_generators) + double precision, intent(inout) :: dressing_matrix_1h2p(N_det_generators,N_det_generators) + integer :: i,i_hole + n_det_max_jacobi = 50 + soft_touch n_det_max_jacobi + + integer :: n_det_1h1p,n_det_1h2p + integer(bit_kind), allocatable :: psi_ref_out(:,:,:) + integer(bit_kind), allocatable :: psi_1h1p(:,:,:) + integer(bit_kind), allocatable :: psi_1h2p(:,:,:) + double precision, allocatable :: psi_ref_coef_out(:,:) + double precision, allocatable :: psi_coef_1h1p(:,:) + double precision, allocatable :: psi_coef_1h2p(:,:) + call all_single_no_1h_or_1p_or_2p + + threshold_davidson = 1.d-12 + soft_touch threshold_davidson davidson_criterion + call diagonalize_CI + call give_n_1h1p_and_n_1h2p_in_psi_det(n_det_1h1p,n_det_1h2p) + allocate(psi_ref_out(N_int,2,N_det_generators)) + allocate(psi_1h1p(N_int,2,n_det_1h1p)) + allocate(psi_1h2p(N_int,2,n_det_1h2p)) + allocate(psi_ref_coef_out(N_det_generators,N_states)) + allocate(psi_coef_1h1p(n_det_1h1p,N_states)) + allocate(psi_coef_1h2p(n_det_1h2p,N_states)) + call split_wf_generators_and_1h1p_and_1h2p(n_det_1h1p,n_det_1h2p,psi_ref_out,psi_ref_coef_out,psi_1h1p,psi_coef_1h1p,psi_1h2p,psi_coef_1h2p) + call provide_matrix_dressing_general(dressing_matrix_1h1p,psi_ref_out,psi_ref_coef_out,N_det_generators, & + psi_1h1p,psi_coef_1h1p,n_det_1h1p) + call provide_matrix_dressing_general(dressing_matrix_1h2p,psi_ref_out,psi_ref_coef_out,N_det_generators, & + psi_1h2p,psi_coef_1h2p,n_det_1h2p) + + deallocate(psi_ref_out) + deallocate(psi_1h1p) + deallocate(psi_1h2p) + deallocate(psi_ref_coef_out) + deallocate(psi_coef_1h1p) + deallocate(psi_coef_1h2p) + +end + + diff --git a/plugins/FOBOCI/create_1h_or_1p.irp.f b/plugins/FOBOCI/create_1h_or_1p.irp.f new file mode 100644 index 00000000..140ed504 --- /dev/null +++ b/plugins/FOBOCI/create_1h_or_1p.irp.f @@ -0,0 +1,218 @@ +subroutine create_restart_and_1h(i_hole) + implicit none + use bitmasks + integer, intent(in) :: i_hole + integer(bit_kind) :: key_tmp(N_int,2) + integer :: i,j,i_part_act,ispin,k,l,i_ok + integer :: n_new_det + integer(bit_kind), allocatable :: new_det(:,:,:) + integer(bit_kind), allocatable :: old_psi_det(:,:,:) + allocate (old_psi_det(N_int,2,n_det)) + do i = 1, N_det + do j = 1, N_int + old_psi_det(j,1,i) = psi_det(j,1,i) + old_psi_det(j,2,i) = psi_det(j,2,i) + enddo + enddo + n_new_det = 0 + do j = 1, n_act_orb + i_part_act = list_act(j) ! index of the particle in the active space + do i = 1, N_det + do ispin = 1,2 + do k = 1, N_int + key_tmp(k,1) = psi_det(k,1,i) + key_tmp(k,2) = psi_det(k,2,i) + enddo + call do_mono_excitation(key_tmp,i_hole,i_part_act,ispin,i_ok) + if(i_ok .ne. 1)cycle + n_new_det +=1 + enddo + enddo + enddo + + integer :: N_det_old + N_det_old = N_det + N_det += n_new_det + allocate (new_det(N_int,2,n_new_det)) + if (psi_det_size < N_det) then + psi_det_size = N_det + TOUCH psi_det_size + endif + do i = 1, N_det_old + do k = 1, N_int + psi_det(k,1,i) = old_psi_det(k,1,i) + psi_det(k,2,i) = old_psi_det(k,2,i) + enddo + enddo + + n_new_det = 0 + do j = 1, n_act_orb + i_part_act = list_act(j) ! index of the particle in the active space + do i = 1, N_det_old + do ispin = 1,2 + do k = 1, N_int + key_tmp(k,1) = psi_det(k,1,i) + key_tmp(k,2) = psi_det(k,2,i) + enddo + call do_mono_excitation(key_tmp,i_hole,i_part_act,ispin,i_ok) + if(i_ok .ne. 1)cycle + n_new_det +=1 + do k = 1, N_int + psi_det(k,1,n_det_old+n_new_det) = key_tmp(k,1) + psi_det(k,2,n_det_old+n_new_det) = key_tmp(k,2) + enddo + psi_coef(n_det_old+n_new_det,:) = 0.d0 + enddo + enddo + enddo + + SOFT_TOUCH N_det psi_det psi_coef + logical :: found_duplicates + call remove_duplicates_in_psi_det(found_duplicates) +end + +subroutine create_restart_and_1p(i_particle) + implicit none + integer, intent(in) :: i_particle + use bitmasks + integer(bit_kind) :: key_tmp(N_int,2) + integer :: i,j,i_hole_act,ispin,k,l,i_ok + integer :: n_new_det + integer(bit_kind), allocatable :: new_det(:,:,:) + integer(bit_kind), allocatable :: old_psi_det(:,:,:) + allocate (old_psi_det(N_int,2,n_det)) + do i = 1, N_det + do j = 1, N_int + old_psi_det(j,1,i) = psi_det(j,1,i) + old_psi_det(j,2,i) = psi_det(j,2,i) + enddo + enddo + n_new_det = 0 + do j = 1, n_act_orb + i_hole_act = list_act(j) ! index of the particle in the active space + do i = 1, N_det + do ispin = 1,2 + do k = 1, N_int + key_tmp(k,1) = psi_det(k,1,i) + key_tmp(k,2) = psi_det(k,2,i) + enddo + call do_mono_excitation(key_tmp,i_hole_act,i_particle,ispin,i_ok) + if(i_ok .ne. 1)cycle + n_new_det +=1 + enddo + enddo + enddo + + integer :: N_det_old + N_det_old = N_det + N_det += n_new_det + allocate (new_det(N_int,2,n_new_det)) + if (psi_det_size < N_det) then + psi_det_size = N_det + TOUCH psi_det_size + endif + do i = 1, N_det_old + do k = 1, N_int + psi_det(k,1,i) = old_psi_det(k,1,i) + psi_det(k,2,i) = old_psi_det(k,2,i) + enddo + enddo + + n_new_det = 0 + do j = 1, n_act_orb + i_hole_act = list_act(j) ! index of the particle in the active space + do i = 1, N_det_old + do ispin = 1,2 + do k = 1, N_int + key_tmp(k,1) = psi_det(k,1,i) + key_tmp(k,2) = psi_det(k,2,i) + enddo + call do_mono_excitation(key_tmp,i_hole_act,i_particle,ispin,i_ok) + if(i_ok .ne. 1)cycle + n_new_det +=1 + do k = 1, N_int + psi_det(k,1,n_det_old+n_new_det) = key_tmp(k,1) + psi_det(k,2,n_det_old+n_new_det) = key_tmp(k,2) + enddo + psi_coef(n_det_old+n_new_det,:) = 0.d0 + enddo + enddo + enddo + + SOFT_TOUCH N_det psi_det psi_coef + logical :: found_duplicates + call remove_duplicates_in_psi_det(found_duplicates) +end + +subroutine create_restart_1h_1p(i_hole,i_part) + implicit none + use bitmasks + integer, intent(in) :: i_hole + integer, intent(in) :: i_part + + integer :: i,j,i_part_act,ispin,k,l,i_ok + integer(bit_kind) :: key_tmp(N_int,2) + integer :: n_new_det + integer(bit_kind), allocatable :: new_det(:,:,:) + integer(bit_kind), allocatable :: old_psi_det(:,:,:) + + allocate (old_psi_det(N_int,2,n_det)) + do i = 1, N_det + do j = 1, N_int + old_psi_det(j,1,i) = psi_det(j,1,i) + old_psi_det(j,2,i) = psi_det(j,2,i) + enddo + enddo + n_new_det = 0 + i_part_act = i_part ! index of the particle in the active space + do i = 1, N_det + do ispin = 1,2 + do k = 1, N_int + key_tmp(k,1) = psi_det(k,1,i) + key_tmp(k,2) = psi_det(k,2,i) + enddo + call do_mono_excitation(key_tmp,i_hole,i_part_act,ispin,i_ok) + if(i_ok .ne. 1)cycle + n_new_det +=1 + enddo + enddo + + integer :: N_det_old + N_det_old = N_det + N_det += n_new_det + allocate (new_det(N_int,2,n_new_det)) + if (psi_det_size < N_det) then + psi_det_size = N_det + TOUCH psi_det_size + endif + do i = 1, N_det_old + do k = 1, N_int + psi_det(k,1,i) = old_psi_det(k,1,i) + psi_det(k,2,i) = old_psi_det(k,2,i) + enddo + enddo + + n_new_det = 0 + i_part_act = i_part ! index of the particle in the active space + do i = 1, N_det_old + do ispin = 1,2 + do k = 1, N_int + key_tmp(k,1) = psi_det(k,1,i) + key_tmp(k,2) = psi_det(k,2,i) + enddo + call do_mono_excitation(key_tmp,i_hole,i_part_act,ispin,i_ok) + if(i_ok .ne. 1)cycle + n_new_det +=1 + do k = 1, N_int + psi_det(k,1,n_det_old+n_new_det) = key_tmp(k,1) + psi_det(k,2,n_det_old+n_new_det) = key_tmp(k,2) + enddo + psi_coef(n_det_old+n_new_det,:) = 0.d0 + enddo + enddo + + SOFT_TOUCH N_det psi_det psi_coef + logical :: found_duplicates + call remove_duplicates_in_psi_det(found_duplicates) + +end diff --git a/plugins/FOBOCI/density_matrix.irp.f b/plugins/FOBOCI/density_matrix.irp.f new file mode 100644 index 00000000..aaf80c4f --- /dev/null +++ b/plugins/FOBOCI/density_matrix.irp.f @@ -0,0 +1,133 @@ + BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha_generators_restart, (mo_tot_num_align,mo_tot_num) ] +&BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta_generators_restart, (mo_tot_num_align,mo_tot_num) ] +&BEGIN_PROVIDER [ double precision, norm_generators_restart] + implicit none + BEGIN_DOC + ! Alpha and beta one-body density matrix for the generators restart + END_DOC + + integer :: j,k,l,m + integer :: occ(N_int*bit_kind_size,2) + double precision :: ck, cl, ckl + double precision :: phase + integer :: h1,h2,p1,p2,s1,s2, degree + integer :: exc(0:2,2,2),n_occ_alpha + double precision, allocatable :: tmp_a(:,:), tmp_b(:,:) + integer :: degree_respect_to_HF_k + integer :: degree_respect_to_HF_l,index_ref_generators_restart + double precision :: inv_coef_ref_generators_restart + integer :: i + + do i = 1, N_det_generators_restart + ! Find the reference determinant for intermediate normalization + call get_excitation_degree(ref_generators_restart,psi_det_generators_restart(1,1,i),degree,N_int) + if(degree == 0)then + index_ref_generators_restart = i + inv_coef_ref_generators_restart = 1.d0/psi_coef_generators_restart(i,1) + exit + endif + enddo + norm_generators_restart = 0.d0 + do i = 1, N_det_generators_restart + psi_coef_generators_restart(i,1) = psi_coef_generators_restart(i,1) * inv_coef_ref_generators_restart + norm_generators_restart += psi_coef_generators_restart(i,1)**2 + enddo + + + one_body_dm_mo_alpha_generators_restart = 0.d0 + one_body_dm_mo_beta_generators_restart = 0.d0 + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(j,k,l,m,occ,ck, cl, ckl,phase,h1,h2,p1,p2,s1,s2, degree,exc, & + !$OMP tmp_a, tmp_b, n_occ_alpha)& + !$OMP SHARED(psi_det_generators_restart,psi_coef_generators_restart,N_int,elec_alpha_num,& + !$OMP elec_beta_num,one_body_dm_mo_alpha_generators_restart,one_body_dm_mo_beta_generators_restart,N_det_generators_restart,mo_tot_num_align,& + !$OMP mo_tot_num,N_states, state_average_weight) + allocate(tmp_a(mo_tot_num_align,mo_tot_num), tmp_b(mo_tot_num_align,mo_tot_num) ) + tmp_a = 0.d0 + tmp_b = 0.d0 + !$OMP DO SCHEDULE(dynamic) + do k=1,N_det_generators_restart + call bitstring_to_list(psi_det_generators_restart(1,1,k), occ(1,1), n_occ_alpha, N_int) + call bitstring_to_list(psi_det_generators_restart(1,2,k), occ(1,2), n_occ_alpha, N_int) + do m=1,N_states + ck = psi_coef_generators_restart(k,m)*psi_coef_generators_restart(k,m) * state_average_weight(m) + do l=1,elec_alpha_num + j = occ(l,1) + tmp_a(j,j) += ck + enddo + do l=1,elec_beta_num + j = occ(l,2) + tmp_b(j,j) += ck + enddo + enddo + do l=1,k-1 + call get_excitation_degree(psi_det_generators_restart(1,1,k),psi_det_generators_restart(1,1,l),degree,N_int) + if (degree /= 1) then + cycle + endif + call get_mono_excitation(psi_det_generators_restart(1,1,k),psi_det_generators_restart(1,1,l),exc,phase,N_int) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + do m=1,N_states + ckl = psi_coef_generators_restart(k,m) * psi_coef_generators_restart(l,m) * phase * state_average_weight(m) + if (s1==1) then + tmp_a(h1,p1) += ckl + tmp_a(p1,h1) += ckl + else + tmp_b(h1,p1) += ckl + tmp_b(p1,h1) += ckl + endif + enddo + enddo + enddo + !$OMP END DO NOWAIT + !$OMP CRITICAL + one_body_dm_mo_alpha_generators_restart = one_body_dm_mo_alpha_generators_restart + tmp_a + !$OMP END CRITICAL + !$OMP CRITICAL + one_body_dm_mo_beta_generators_restart = one_body_dm_mo_beta_generators_restart + tmp_b + !$OMP END CRITICAL + deallocate(tmp_a,tmp_b) + !$OMP BARRIER + !$OMP END PARALLEL + + do i = 1, mo_tot_num + print*,'DM restat',i,one_body_dm_mo_beta_generators_restart(i,i) + one_body_dm_mo_alpha_generators_restart(i,i) + enddo + +END_PROVIDER + + + +BEGIN_PROVIDER [ double precision, one_body_dm_mo_generators_restart, (mo_tot_num_align,mo_tot_num) ] + implicit none + BEGIN_DOC + ! One-body density matrix for the generators_restart + END_DOC + one_body_dm_mo_generators_restart = one_body_dm_mo_alpha_generators_restart + one_body_dm_mo_beta_generators_restart +END_PROVIDER + +BEGIN_PROVIDER [ double precision, one_body_spin_density_mo_generators_restart, (mo_tot_num_align,mo_tot_num) ] + implicit none + BEGIN_DOC + ! rho(alpha) - rho(beta) + END_DOC + one_body_spin_density_mo_generators_restart = one_body_dm_mo_alpha_generators_restart - one_body_dm_mo_beta_generators_restart +END_PROVIDER + + + BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha_osoci, (mo_tot_num_align,mo_tot_num) ] +&BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta_osoci, (mo_tot_num_align,mo_tot_num) ] + implicit none + BEGIN_DOC + ! Alpha and beta one-body density matrix that will be used for the OSOCI approach + END_DOC +END_PROVIDER + + BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha_1h1p, (mo_tot_num_align,mo_tot_num) ] +&BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta_1h1p, (mo_tot_num_align,mo_tot_num) ] + implicit none + BEGIN_DOC + ! Alpha and beta one-body density matrix that will be used for the 1h1p approach + END_DOC +END_PROVIDER + diff --git a/plugins/FOBOCI/diag_fock_inactiv_virt.irp.f b/plugins/FOBOCI/diag_fock_inactiv_virt.irp.f new file mode 100644 index 00000000..a4c6b652 --- /dev/null +++ b/plugins/FOBOCI/diag_fock_inactiv_virt.irp.f @@ -0,0 +1,35 @@ +subroutine diag_inactive_virt_and_update_mos + implicit none + integer :: i,j,i_inact,j_inact,i_virt,j_virt + double precision :: tmp(mo_tot_num_align,mo_tot_num) + character*(64) :: label + tmp = 0.d0 + do i = 1, mo_tot_num + tmp(i,i) = Fock_matrix_mo(i,i) + enddo + + do i = 1, n_inact_orb + i_inact = list_inact(i) + do j = i+1, n_inact_orb + j_inact = list_inact(j) + tmp(i_inact,j_inact) = Fock_matrix_mo(i_inact,j_inact) + tmp(j_inact,i_inact) = Fock_matrix_mo(j_inact,i_inact) + enddo + enddo + + do i = 1, n_virt_orb + i_virt = list_virt(i) + do j = i+1, n_virt_orb + j_virt = list_virt(j) + tmp(i_virt,j_virt) = Fock_matrix_mo(i_virt,j_virt) + tmp(j_virt,i_virt) = Fock_matrix_mo(j_virt,i_virt) + enddo + enddo + + + label = "Canonical" + call mo_as_eigvectors_of_mo_matrix(tmp,size(tmp,1),size(tmp,2),label,1) + soft_touch mo_coef + + +end diff --git a/plugins/FOBOCI/dress_simple.irp.f b/plugins/FOBOCI/dress_simple.irp.f new file mode 100644 index 00000000..2f662f4d --- /dev/null +++ b/plugins/FOBOCI/dress_simple.irp.f @@ -0,0 +1,358 @@ + +subroutine standard_dress(delta_ij_generators_,size_buffer,Ndet_generators,i_generator,n_selected,det_buffer,Nint,iproc,psi_det_generators_input,E_ref) + use bitmasks + implicit none + + integer, intent(in) :: i_generator,n_selected, Nint, iproc + integer, intent(in) :: Ndet_generators,size_buffer + double precision, intent(inout) :: delta_ij_generators_(Ndet_generators,Ndet_generators),E_ref + + integer(bit_kind), intent(in) :: det_buffer(Nint,2,size_buffer) + integer(bit_kind), intent(in) :: psi_det_generators_input(N_int,2,Ndet_generators) + integer :: i,j,k,m + integer :: new_size + integer :: degree(Ndet_generators) + integer :: idx(0:Ndet_generators) + logical :: good + + integer :: c_ref + integer :: connected_to_ref + + + double precision :: hka, haa + double precision :: haj + double precision :: f + integer :: connected_to_ref_by_mono + logical :: is_in_wavefunction + double precision :: H_array(Ndet_generators) + double precision :: H_matrix_tmp(Ndet_generators+1,Ndet_generators+1) + double precision :: eigenvectors(Ndet_generators+1,Ndet_generators+1), eigenvalues(Ndet_generators+1) + double precision :: contrib,lambda_i,accu + + do k = 1, Ndet_generators + call i_h_j(psi_det_generators_input(1,1,k),psi_det_generators_input(1,1,k),Nint,hka) + H_matrix_tmp(k,k) = hka + do j = k+1, Ndet_generators + call i_h_j(psi_det_generators_input(1,1,k),psi_det_generators_input(1,1,j),Nint,hka) + H_matrix_tmp(k,j) = hka + H_matrix_tmp(j,k) = hka + enddo + H_matrix_tmp(k,Ndet_generators+1) = 0.d0 + enddo + + do i=1,n_selected + c_ref = connected_to_ref_by_mono(det_buffer(1,1,i),psi_det_generators_input,N_int,i_generator,Ndet_generators) + if (c_ref /= 0) then + cycle + endif + if (is_in_wavefunction(det_buffer(1,1,i),Nint)) then + cycle + endif + call get_excitation_degree_vector(psi_det_generators_input,det_buffer(1,1,i),degree,N_int,Ndet_generators,idx) + H_array = 0.d0 + do k=1,idx(0) + call i_h_j(det_buffer(1,1,i),psi_det_generators_input(1,1,idx(k)),Nint,hka) + H_array(idx(k)) = hka + enddo + + call i_h_j(det_buffer(1,1,i),det_buffer(1,1,i),Nint,haa) + f = 1.d0/(E_ref-haa) + + if(second_order_h)then + lambda_i = f + else + ! You write the new Hamiltonian matrix + do k = 1, Ndet_generators + H_matrix_tmp(k,Ndet_generators+1) = H_array(k) + H_matrix_tmp(Ndet_generators+1,k) = H_array(k) + enddo + H_matrix_tmp(Ndet_generators+1,Ndet_generators+1) = haa + ! Then diagonalize it + call lapack_diag(eigenvalues,eigenvectors,H_matrix_tmp,Ndet_generators+1,Ndet_generators+1) + ! Then you extract the effective denominator + accu = 0.d0 + do k = 1, Ndet_generators + accu += eigenvectors(k,1) * H_array(k) + enddo + lambda_i = eigenvectors(Ndet_generators+1,1)/accu + endif + do k=1,idx(0) + contrib = H_array(idx(k)) * H_array(idx(k)) * lambda_i + delta_ij_generators_(idx(k), idx(k)) += contrib + do j=k+1,idx(0) + contrib = H_array(idx(k)) * H_array(idx(j)) * lambda_i + delta_ij_generators_(idx(k), idx(j)) += contrib + delta_ij_generators_(idx(j), idx(k)) += contrib + enddo + enddo +! H_matrix_tmp_bis(idx(k),idx(k)) += contrib +! H_matrix_tmp_bis(idx(k),idx(j)) += contrib +! H_matrix_tmp_bis(idx(j),idx(k)) += contrib +! do k = 1, Ndet_generators +! do j = 1, Ndet_generators +! H_matrix_tmp_bis(k,j) = H_matrix_tmp(k,j) +! enddo +! enddo +! double precision :: H_matrix_tmp_bis(Ndet_generators,Ndet_generators) +! double precision :: eigenvectors_bis(Ndet_generators,Ndet_generators), eigenvalues_bis(Ndet_generators) +! call lapack_diag(eigenvalues_bis,eigenvectors_bis,H_matrix_tmp_bis,Ndet_generators,Ndet_generators) +! print*,'f,lambda_i = ',f,lambda_i +! print*,'eigenvalues_bi(1)',eigenvalues_bis(1) +! print*,'eigenvalues ',eigenvalues(1) +! do k = 1, Ndet_generators +! print*,'coef,coef_dres = ', eigenvectors(k,1), eigenvectors_bis(k,1) +! enddo +! pause +! accu = 0.d0 +! do k = 1, Ndet_generators +! do j = 1, Ndet_generators +! accu += eigenvectors(k,1) * eigenvectors(j,1) * (H_matrix_tmp(k,j) + delta_ij_generators_(k,j)) +! enddo +! enddo +! print*,'accu,eigv = ',accu,eigenvalues(1) +! pause + + enddo +end + + +subroutine is_a_good_candidate(threshold,is_ok,verbose) + use bitmasks + implicit none + double precision, intent(in) :: threshold + logical, intent(out) :: is_ok + logical, intent(in) :: verbose + + integer :: l,k,m + double precision,allocatable :: dressed_H_matrix(:,:) + double precision,allocatable :: psi_coef_diagonalized_tmp(:,:) + integer(bit_kind), allocatable :: psi_det_generators_input(:,:,:) + + allocate(psi_det_generators_input(N_int,2,N_det_generators),dressed_H_matrix(N_det_generators,N_det_generators)) + allocate(psi_coef_diagonalized_tmp(N_det_generators,N_states)) + dressed_H_matrix = 0.d0 + do k = 1, N_det_generators + do l = 1, N_int + psi_det_generators_input(l,1,k) = psi_det_generators(l,1,k) + psi_det_generators_input(l,2,k) = psi_det_generators(l,2,k) + enddo + enddo +!call H_apply_dressed_pert(dressed_H_matrix,N_det_generators,psi_det_generators_input) + call dress_H_matrix_from_psi_det_input(psi_det_generators_input,N_det_generators,is_ok,psi_coef_diagonalized_tmp, dressed_H_matrix,threshold,verbose) + if(do_it_perturbative)then + if(is_ok)then + N_det = N_det_generators + do m = 1, N_states + do k = 1, N_det_generators + do l = 1, N_int + psi_det(l,1,k) = psi_det_generators_input(l,1,k) + psi_det(l,2,k) = psi_det_generators_input(l,2,k) + enddo + psi_coef(k,m) = psi_coef_diagonalized_tmp(k,m) + enddo + enddo + touch psi_coef psi_det N_det + endif + endif + + deallocate(psi_det_generators_input,dressed_H_matrix,psi_coef_diagonalized_tmp) + + + + +end + +subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_generators,is_ok,psi_coef_diagonalized_tmp, dressed_H_matrix,threshold,verbose) + use bitmasks + implicit none + integer(bit_kind), intent(in) :: psi_det_generators_input(N_int,2,Ndet_generators) + integer, intent(in) :: Ndet_generators + double precision, intent(in) :: threshold + logical, intent(in) :: verbose + logical, intent(out) :: is_ok + double precision, intent(out) :: psi_coef_diagonalized_tmp(Ndet_generators,N_states) + double precision, intent(inout) :: dressed_H_matrix(Ndet_generators, Ndet_generators) + + + integer :: i,j,degree,index_ref_generators_restart,i_count,k,i_det_no_ref + double precision :: eigvalues(Ndet_generators), eigvectors(Ndet_generators,Ndet_generators),hij + double precision :: psi_coef_ref(Ndet_generators,N_states),diag_h_mat_average,diag_h_mat_no_ref_average + logical :: is_a_ref_det(Ndet_generators) + + is_a_ref_det = .False. + do i = 1, N_det_generators + do j = 1, N_det_generators_restart + call get_excitation_degree(psi_det_generators_input(1,1,i),psi_det_generators_restart(1,1,j),degree,N_int) + if(degree == 0)then + is_a_ref_det(i) = .True. + exit + endif + enddo + enddo + + + do i = 1, Ndet_generators + call get_excitation_degree(ref_generators_restart,psi_det_generators_input(1,1,i),degree,N_int) + if(degree == 0)then + index_ref_generators_restart = i + endif + do j = 1, Ndet_generators + call i_h_j(psi_det_generators_input(1,1,j),psi_det_generators_input(1,1,i),N_int,hij) ! Fill the zeroth order H matrix + dressed_H_matrix(i,j) = hij + enddo + enddo + i_det_no_ref = 0 + diag_h_mat_average = 0.d0 + do i = 1, Ndet_generators + if(is_a_ref_det(i))cycle + i_det_no_ref +=1 + diag_h_mat_average+=dressed_H_matrix(i,i) + enddo + diag_h_mat_average = diag_h_mat_average/dble(i_det_no_ref) + print*,'diag_h_mat_average = ',diag_h_mat_average + print*,'ref h_mat = ',dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart) + integer :: number_of_particles, number_of_holes + ! Filter the the MLCT that are higher than 27.2 eV in energy with respect to the reference determinant + do i = 1, Ndet_generators + if(is_a_ref_det(i))cycle + if(number_of_holes(psi_det_generators_input(1,1,i)).eq.0 .and. number_of_particles(psi_det_generators_input(1,1,i)).eq.1)then + if(diag_h_mat_average - dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart) .gt.2.d0)then + is_ok = .False. + return + endif + endif + + ! Filter the the LMCT that are higher than 54.4 eV in energy with respect to the reference determinant + if(number_of_holes(psi_det_generators_input(1,1,i)).eq.1 .and. number_of_particles(psi_det_generators_input(1,1,i)).eq.0)then + if(diag_h_mat_average - dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart) .gt.2.d0)then + is_ok = .False. + return + endif + endif + exit + enddo + + call lapack_diagd(eigvalues,eigvectors,dressed_H_matrix,Ndet_generators,Ndet_generators) ! Diagonalize the Dressed_H_matrix + + double precision :: s2,E_ref(N_states) + integer :: i_state(N_states) + integer :: n_state_good + n_state_good = 0 + if(s2_eig)then + do i = 1, Ndet_generators + call get_s2_u0(psi_det_generators_input,eigvectors(1,i),Ndet_generators,Ndet_generators,s2) + print*,'s2 = ',s2 + print*,dabs(s2-expected_s2) + if(dabs(s2-expected_s2).le.0.3d0)then + n_state_good +=1 + i_state(n_state_good) = i + E_ref(n_state_good) = eigvalues(i) + endif + if(n_state_good==N_states)then + exit + endif + enddo + else + do i = 1, N_states + i_state(i) = i + E_ref(i) = eigvalues(i) + enddo + endif + do i = 1,N_states + print*,'i_state = ',i_state(i) + enddo + do k = 1, N_states + print*,'state ',k + do i = 1, Ndet_generators + psi_coef_diagonalized_tmp(i,k) = eigvectors(i,i_state(k)) / eigvectors(index_ref_generators_restart,i_state(k)) + psi_coef_ref(i,k) = eigvectors(i,i_state(k)) + print*,'psi_coef_ref(i) = ',psi_coef_ref(i,k) + enddo + enddo + if(verbose)then + print*,'Zeroth order space :' + do i = 1, Ndet_generators + write(*,'(10(F16.8),X)')dressed_H_matrix(i,:) + enddo + print*,'' + print*,'Zeroth order space Diagonalized :' + do k = 1, N_states + print*,'state ',k + do i = 1, Ndet_generators + print*,'coef, = ',psi_coef_diagonalized_tmp(i,k),dressed_H_matrix(i,i)-dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart),is_a_ref_det(i) + enddo + enddo + endif + double precision :: E_ref_average + E_ref_average = 0.d0 + do i = 1, N_states + E_ref_average += E_ref(i) + enddo + E_ref_average = E_ref_average / dble(N_states) + + call H_apply_dressed_pert(dressed_H_matrix,Ndet_generators,psi_det_generators_input,E_ref_average) ! Calculate the dressing of the H matrix + if(verbose)then + print*,'Zeroth order space Dressed by outer space:' + do i = 1, Ndet_generators + write(*,'(10(F16.8),X)')dressed_H_matrix(i,:) + enddo + endif + call lapack_diagd(eigvalues,eigvectors,dressed_H_matrix,Ndet_generators,Ndet_generators) ! Diagonalize the Dressed_H_matrix + integer :: i_good_state(0:N_states) + i_good_state(0) = 0 + do i = 1, Ndet_generators + call get_s2_u0(psi_det_generators_input,eigvectors(1,i),Ndet_generators,Ndet_generators,s2) + ! State following + do k = 1, N_states + accu = 0.d0 + do j =1, Ndet_generators + accu += eigvectors(j,i) * psi_coef_ref(j,k) + enddo + if(dabs(accu).ge.0.8d0)then + i_good_state(0) +=1 + i_good_state(i_good_state(0)) = i + endif + enddo + if(i_good_state(0)==N_states)then + exit + endif + enddo + do i = 1, N_states + i_state(i) = i_good_state(i) + E_ref(i) = eigvalues(i_good_state(i)) + enddo + double precision :: accu + accu = 0.d0 + do k = 1, N_states + do i = 1, Ndet_generators + psi_coef_diagonalized_tmp(i,k) = eigvectors(i,i_state(k)) / eigvectors(index_ref_generators_restart,i_state(k)) + enddo + enddo + if(verbose)then + do k = 1, N_states + print*,'state ',k + do i = 1, Ndet_generators + print*,'coef, = ',psi_coef_diagonalized_tmp(i,k),dressed_H_matrix(i,i)-dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart),is_a_ref_det(i) + enddo + enddo + endif + is_ok = .False. + do i = 1, Ndet_generators + if(is_a_ref_det(i))cycle + do k = 1, N_states + if(dabs(psi_coef_diagonalized_tmp(i,k)) .gt.threshold)then + is_ok = .True. + exit + endif + enddo + if(is_ok)then + exit + endif + enddo + if(verbose)then + print*,'is_ok = ',is_ok + endif + + +end + diff --git a/plugins/FOBOCI/fobo_coupled_ci.irp.f b/plugins/FOBOCI/fobo_coupled_ci.irp.f new file mode 100644 index 00000000..29513f25 --- /dev/null +++ b/plugins/FOBOCI/fobo_coupled_ci.irp.f @@ -0,0 +1,5 @@ +program osoci_program +implicit none + call new_approach +! call save_natural_mos +end diff --git a/plugins/FOBOCI/fobo_diff_dm.irp.f b/plugins/FOBOCI/fobo_diff_dm.irp.f new file mode 100644 index 00000000..b0368007 --- /dev/null +++ b/plugins/FOBOCI/fobo_diff_dm.irp.f @@ -0,0 +1,18 @@ +program osoci_program +call debug_det(ref_bitmask,N_int) + +implicit none + call FOBOCI_lmct_mlct_old_thr + call provide_all_the_rest +end +subroutine provide_all_the_rest +implicit none +integer :: i + call update_one_body_dm_mo + call provide_properties + call save_osoci_natural_mos + call save_mos + + + +end diff --git a/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f b/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f new file mode 100644 index 00000000..087f791b --- /dev/null +++ b/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f @@ -0,0 +1,315 @@ + +subroutine FOBOCI_lmct_mlct_old_thr + use bitmasks + implicit none + integer :: i,j,k,l + integer(bit_kind),allocatable :: unpaired_bitmask(:,:) + integer, allocatable :: occ(:,:) + integer :: n_occ_alpha, n_occ_beta + double precision :: norm_tmp(N_states),norm_total(N_states) + logical :: test_sym + double precision :: thr,hij + double precision :: threshold + double precision, allocatable :: dressing_matrix(:,:) + logical :: verbose,is_ok + verbose = .True. + threshold = threshold_singles + print*,'threshold = ',threshold + thr = 1.d-12 + allocate(unpaired_bitmask(N_int,2)) + allocate (occ(N_int*bit_kind_size,2)) + do i = 1, N_int + unpaired_bitmask(i,1) = unpaired_alpha_electrons(i) + unpaired_bitmask(i,2) = unpaired_alpha_electrons(i) + enddo + norm_total = 0.d0 + call initialize_density_matrix_osoci + call bitstring_to_list(inact_bitmask(1,1), occ(1,1), n_occ_beta, N_int) + print*,'' + print*,'' + print*,'mulliken spin population analysis' + accu =0.d0 + do i = 1, nucl_num + accu += mulliken_spin_densities(i) + print*,i,nucl_charge(i),mulliken_spin_densities(i) + enddo + print*,'' + print*,'' + print*,'DOING FIRST LMCT !!' + do i = 1, n_inact_orb + integer :: i_hole_osoci + i_hole_osoci = list_inact(i) + print*,'--------------------------' + ! First set the current generators to the one of restart + call set_generators_to_generators_restart + call set_psi_det_to_generators + call check_symetry(i_hole_osoci,thr,test_sym) + if(.not.test_sym)cycle + print*,'i_hole_osoci = ',i_hole_osoci + call create_restart_and_1h(i_hole_osoci) + call set_generators_to_psi_det + print*,'Passed set generators' + call set_bitmask_particl_as_input(reunion_of_bitmask) + call set_bitmask_hole_as_input(reunion_of_bitmask) + call is_a_good_candidate(threshold,is_ok,verbose) + print*,'is_ok = ',is_ok + if(.not.is_ok)cycle + ! so all the mono excitation on the new generators + allocate(dressing_matrix(N_det_generators,N_det_generators)) + if(.not.do_it_perturbative)then +! call all_single + dressing_matrix = 0.d0 + do k = 1, N_det_generators + do l = 1, N_det_generators + call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl) + dressing_matrix(k,l) = hkl + enddo + enddo + double precision :: hkl +! call all_single_split(psi_det_generators,psi_coef_generators,N_det_generators,dressing_matrix) +! call diag_dressed_matrix_and_set_to_psi_det(psi_det_generators,N_det_generators,dressing_matrix) + call debug_det(reunion_of_bitmask,N_int) + call all_single + endif + call set_intermediate_normalization_lmct_old(norm_tmp,i_hole_osoci) + do k = 1, N_states + print*,'norm_tmp = ',norm_tmp(k) + norm_total(k) += norm_tmp(k) + enddo + call update_density_matrix_osoci + deallocate(dressing_matrix) + enddo + + if(.True.)then + print*,'' + print*,'DOING THEN THE MLCT !!' + do i = 1, n_virt_orb + integer :: i_particl_osoci + i_particl_osoci = list_virt(i) + print*,'--------------------------' + ! First set the current generators to the one of restart + call set_generators_to_generators_restart + call set_psi_det_to_generators + call check_symetry(i_particl_osoci,thr,test_sym) + if(.not.test_sym)cycle + print*,'i_particl_osoci= ',i_particl_osoci + ! Initialize the bitmask to the restart ones + call initialize_bitmask_to_restart_ones + ! Impose that only the hole i_hole_osoci can be done + call modify_bitmasks_for_particl(i_particl_osoci) + call print_generators_bitmasks_holes + ! Impose that only the active part can be reached + call set_bitmask_hole_as_input(unpaired_bitmask) +!! call all_single_h_core + call create_restart_and_1p(i_particl_osoci) +!! ! Update the generators + call set_generators_to_psi_det + call set_bitmask_particl_as_input(reunion_of_bitmask) + call set_bitmask_hole_as_input(reunion_of_bitmask) +!! ! so all the mono excitation on the new generators + call is_a_good_candidate(threshold,is_ok,verbose) + print*,'is_ok = ',is_ok + if(.not.is_ok)cycle + allocate(dressing_matrix(N_det_generators,N_det_generators)) + if(.not.do_it_perturbative)then + dressing_matrix = 0.d0 + do k = 1, N_det_generators + do l = 1, N_det_generators + call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl) + dressing_matrix(k,l) = hkl + enddo + enddo + ! call all_single_split(psi_det_generators,psi_coef_generators,N_det_generators,dressing_matrix) + ! call diag_dressed_matrix_and_set_to_psi_det(psi_det_generators,N_det_generators,dressing_matrix) + call all_single + endif + call set_intermediate_normalization_mlct_old(norm_tmp,i_particl_osoci) + do k = 1, N_states + print*,'norm_tmp = ',norm_tmp(k) + norm_total(k) += norm_tmp(k) + enddo + call update_density_matrix_osoci + deallocate(dressing_matrix) + enddo + endif + if(.False.)then + print*,'LAST loop for all the 1h-1p' + print*,'--------------------------' + ! First set the current generators to the one of restart + call set_generators_to_generators_restart + call set_psi_det_to_generators + call initialize_bitmask_to_restart_ones + ! Impose that only the hole i_hole_osoci can be done + call set_bitmask_particl_as_input(inact_virt_bitmask) + call set_bitmask_hole_as_input(inact_virt_bitmask) +! call set_bitmask_particl_as_input(reunion_of_bitmask) +! call set_bitmask_hole_as_input(reunion_of_bitmask) + call all_single + call set_intermediate_normalization_1h1p(norm_tmp) + norm_total += norm_tmp + call update_density_matrix_osoci + endif + + + print*,'norm_total = ',norm_total + norm_total = norm_generators_restart + norm_total = 1.d0/norm_total +! call rescale_density_matrix_osoci(norm_total) + double precision :: accu + accu = 0.d0 + do i = 1, mo_tot_num + accu += one_body_dm_mo_alpha_osoci(i,i) + one_body_dm_mo_beta_osoci(i,i) + enddo + print*,'accu = ',accu +end + + +subroutine FOBOCI_mlct_old + use bitmasks + implicit none + integer :: i,j,k,l + integer(bit_kind),allocatable :: unpaired_bitmask(:,:) + integer, allocatable :: occ(:,:) + integer :: n_occ_alpha, n_occ_beta + double precision :: norm_tmp,norm_total + logical :: test_sym + double precision :: thr + double precision :: threshold + logical :: verbose,is_ok + verbose = .False. + threshold = 1.d-2 + thr = 1.d-12 + allocate(unpaired_bitmask(N_int,2)) + allocate (occ(N_int*bit_kind_size,2)) + do i = 1, N_int + unpaired_bitmask(i,1) = unpaired_alpha_electrons(i) + unpaired_bitmask(i,2) = unpaired_alpha_electrons(i) + enddo + norm_total = 0.d0 + call initialize_density_matrix_osoci + call bitstring_to_list(inact_bitmask(1,1), occ(1,1), n_occ_beta, N_int) + print*,'' + print*,'' + print*,'' + print*,'DOING FIRST MLCT !!' + do i = 1, n_virt_orb + integer :: i_particl_osoci + i_particl_osoci = list_virt(i) + print*,'--------------------------' + ! First set the current generators to the one of restart + call set_generators_to_generators_restart + call set_psi_det_to_generators + call check_symetry(i_particl_osoci,thr,test_sym) + if(.not.test_sym)cycle + print*,'i_particl_osoci= ',i_particl_osoci + ! Initialize the bitmask to the restart ones + call initialize_bitmask_to_restart_ones + ! Impose that only the hole i_hole_osoci can be done + call modify_bitmasks_for_particl(i_particl_osoci) + call print_generators_bitmasks_holes + ! Impose that only the active part can be reached + call set_bitmask_hole_as_input(unpaired_bitmask) +! call all_single_h_core + call create_restart_and_1p(i_particl_osoci) +! ! Update the generators + call set_generators_to_psi_det + call set_bitmask_particl_as_input(reunion_of_bitmask) + call set_bitmask_hole_as_input(reunion_of_bitmask) +! ! so all the mono excitation on the new generators + call is_a_good_candidate(threshold,is_ok,verbose) + print*,'is_ok = ',is_ok + is_ok =.True. + if(.not.is_ok)cycle + call all_single + call set_intermediate_normalization_mlct_old(norm_tmp,i_particl_osoci) + print*,'norm_tmp = ',norm_tmp + norm_total += norm_tmp + call update_density_matrix_osoci + enddo + + print*,'norm_total = ',norm_total + norm_total += 1.d0 + norm_total = 1.d0/norm_total + call rescale_density_matrix_osoci(norm_total) + double precision :: accu + accu = 0.d0 + do i = 1, mo_tot_num + accu += one_body_dm_mo_alpha_osoci(i,i) + one_body_dm_mo_beta_osoci(i,i) + enddo + print*,'accu = ',accu +end + + +subroutine FOBOCI_lmct_old + use bitmasks + implicit none + integer :: i,j,k,l + integer(bit_kind),allocatable :: unpaired_bitmask(:,:) + integer, allocatable :: occ(:,:) + integer :: n_occ_alpha, n_occ_beta + double precision :: norm_tmp,norm_total + logical :: test_sym + double precision :: thr + double precision :: threshold + logical :: verbose,is_ok + verbose = .False. + threshold = 1.d-2 + thr = 1.d-12 + allocate(unpaired_bitmask(N_int,2)) + allocate (occ(N_int*bit_kind_size,2)) + do i = 1, N_int + unpaired_bitmask(i,1) = unpaired_alpha_electrons(i) + unpaired_bitmask(i,2) = unpaired_alpha_electrons(i) + enddo + norm_total = 0.d0 + call initialize_density_matrix_osoci + call bitstring_to_list(inact_bitmask(1,1), occ(1,1), n_occ_beta, N_int) + print*,'' + print*,'' + print*,'DOING FIRST LMCT !!' + do i = 1, n_inact_orb + integer :: i_hole_osoci + i_hole_osoci = list_inact(i) + print*,'--------------------------' + ! First set the current generators to the one of restart + call set_generators_to_generators_restart + call set_psi_det_to_generators + call check_symetry(i_hole_osoci,thr,test_sym) + if(.not.test_sym)cycle + print*,'i_hole_osoci = ',i_hole_osoci + ! Initialize the bitmask to the restart ones + call initialize_bitmask_to_restart_ones + ! Impose that only the hole i_hole_osoci can be done + call modify_bitmasks_for_hole(i_hole_osoci) + call print_generators_bitmasks_holes + ! Impose that only the active part can be reached + call set_bitmask_particl_as_input(unpaired_bitmask) +! call all_single_h_core + call create_restart_and_1h(i_hole_osoci) +! ! Update the generators + call set_generators_to_psi_det + call set_bitmask_particl_as_input(reunion_of_bitmask) + call set_bitmask_hole_as_input(reunion_of_bitmask) + call is_a_good_candidate(threshold,is_ok,verbose) + print*,'is_ok = ',is_ok + if(.not.is_ok)cycle +! ! so all the mono excitation on the new generators + call all_single +! call set_intermediate_normalization_lmct_bis(norm_tmp,i_hole_osoci) + call set_intermediate_normalization_lmct_old(norm_tmp,i_hole_osoci) + print*,'norm_tmp = ',norm_tmp + norm_total += norm_tmp + call update_density_matrix_osoci + enddo + + print*,'norm_total = ',norm_total + norm_total += 1.d0 + norm_total = 1.d0/norm_total + call rescale_density_matrix_osoci(norm_total) + double precision :: accu + accu = 0.d0 + do i = 1, mo_tot_num + accu += one_body_dm_mo_alpha_osoci(i,i) + one_body_dm_mo_beta_osoci(i,i) + enddo + print*,'accu = ',accu +end diff --git a/plugins/FOBOCI/generators_restart_save.irp.f b/plugins/FOBOCI/generators_restart_save.irp.f new file mode 100644 index 00000000..dca4c901 --- /dev/null +++ b/plugins/FOBOCI/generators_restart_save.irp.f @@ -0,0 +1,126 @@ +use bitmasks + +BEGIN_PROVIDER [ integer, N_det_generators_restart ] + implicit none + BEGIN_DOC + ! Number of determinants in the wave function + END_DOC + logical :: exists + character*64 :: label + integer, save :: ifirst = 0 +!if(ifirst == 0)then + PROVIDE ezfio_filename + call ezfio_has_determinants_n_det(exists) + print*,'exists = ',exists + if(.not.exists)then + print*,'The OSOCI needs a restart WF' + print*,'There are none in the EZFIO file ...' + print*,'Stopping ...' + stop + endif + print*,'passed N_det_generators_restart' + call ezfio_get_determinants_n_det(N_det_generators_restart) + ASSERT (N_det_generators_restart > 0) + ifirst = 1 +!endif +END_PROVIDER + + + BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators_restart, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ integer(bit_kind), ref_generators_restart, (N_int,2) ] + implicit none + BEGIN_DOC + ! The wave function determinants. Initialized with Hartree-Fock if the EZFIO file + ! is empty + END_DOC + integer :: i + logical :: exists + character*64 :: label + + integer, save :: ifirst = 0 +!if(ifirst == 0)then + provide N_det_generators_restart + if(.True.)then + call ezfio_has_determinants_N_int(exists) + if (exists) then + call ezfio_has_determinants_bit_kind(exists) + if (exists) then + call ezfio_has_determinants_N_det(exists) + if (exists) then + call ezfio_has_determinants_N_states(exists) + if (exists) then + call ezfio_has_determinants_psi_det(exists) + endif + endif + endif + endif + + if(.not.exists)then + print*,'The OSOCI needs a restart WF' + print*,'There are none in the EZFIO file ...' + print*,'Stopping ...' + stop + endif + print*,'passed psi_det_generators_restart' + + call read_dets(psi_det_generators_restart,N_int,N_det_generators_restart) + do i = 1, N_int + ref_generators_restart(i,1) = psi_det_generators_restart(i,1,1) + ref_generators_restart(i,2) = psi_det_generators_restart(i,2,1) + enddo + endif + ifirst = 1 +!endif + +END_PROVIDER + + + +BEGIN_PROVIDER [ double precision, psi_coef_generators_restart, (psi_det_size,N_states_diag) ] + implicit none + BEGIN_DOC + ! The wave function coefficients. Initialized with Hartree-Fock if the EZFIO file + ! is empty + END_DOC + + integer :: i,k, N_int2 + logical :: exists + double precision, allocatable :: psi_coef_read(:,:) + character*(64) :: label + + integer, save :: ifirst = 0 +!if(ifirst == 0)then + psi_coef_generators_restart = 0.d0 + do i=1,N_states_diag + psi_coef_generators_restart(i,i) = 1.d0 + enddo + + call ezfio_has_determinants_psi_coef(exists) + + if(.not.exists)then + print*,'The OSOCI needs a restart WF' + print*,'There are none in the EZFIO file ...' + print*,'Stopping ...' + stop + endif + print*,'passed psi_coef_generators_restart' + + if (exists) then + + allocate (psi_coef_read(N_det_generators_restart,N_states)) + call ezfio_get_determinants_psi_coef(psi_coef_read) + do k=1,N_states + do i=1,N_det_generators_restart + psi_coef_generators_restart(i,k) = psi_coef_read(i,k) + enddo + enddo + deallocate(psi_coef_read) + + endif + ifirst = 1 +!endif + + + +END_PROVIDER + diff --git a/plugins/FOBOCI/modify_generators.irp.f b/plugins/FOBOCI/modify_generators.irp.f new file mode 100644 index 00000000..c756f0c2 --- /dev/null +++ b/plugins/FOBOCI/modify_generators.irp.f @@ -0,0 +1,157 @@ +subroutine set_generators_to_psi_det + implicit none + BEGIN_DOC +! subroutines that sets psi_det_generators to +! the current psi_det + END_DOC + N_det_generators = N_det + integer :: i,k + do i=1,N_det_generators + do k=1,N_int + psi_det_generators(k,1,i) = psi_det(k,1,i) + psi_det_generators(k,2,i) = psi_det(k,2,i) + enddo + do k = 1, N_states + psi_coef_generators(i,k) = psi_coef(i,k) + enddo + enddo + + touch N_det_generators psi_coef_generators psi_det_generators + +end + +subroutine set_generators_as_input_psi(ndet_input,psi_det_input,psi_coef_input) + implicit none + integer, intent(in) :: ndet_input + integer(bit_kind), intent(in) :: psi_det_input(N_int,2,ndet_input) + double precision, intent(in) :: psi_coef_input(ndet_input,N_states) + BEGIN_DOC +! subroutines that sets psi_det_generators to +! the current psi_det + END_DOC + N_det_generators = ndet_input + integer :: i,k + do i=1,N_det_generators + do k=1,N_int + psi_det_generators(k,1,i) = psi_det_input(k,1,i) + psi_det_generators(k,2,i) = psi_det_input(k,2,i) + enddo + do k = 1, N_states + psi_coef_generators(i,k) = psi_coef_input(i,k) + enddo + enddo + + touch N_det_generators psi_coef_generators psi_det_generators + +end + +subroutine set_psi_det_as_input_psi(ndet_input,psi_det_input,psi_coef_input) + implicit none + integer, intent(in) :: ndet_input + integer(bit_kind), intent(in) :: psi_det_input(N_int,2,ndet_input) + double precision, intent(in) :: psi_coef_input(ndet_input,N_states) + BEGIN_DOC +! subroutines that sets psi_det_generators to +! the current psi_det + END_DOC + N_det= ndet_input + if (psi_det_size < N_det) then + psi_det_size = N_det + TOUCH psi_det_size + endif + + integer :: i,k + do i=1,N_det + do k=1,N_int + psi_det(k,1,i) = psi_det_input(k,1,i) + psi_det(k,2,i) = psi_det_input(k,2,i) + enddo + do k = 1, N_states + psi_coef(i,k) = psi_coef_input(i,k) + enddo + enddo + + soft_touch N_det psi_coef psi_det + +end + + +subroutine set_psi_det_to_generators + implicit none + BEGIN_DOC +! subroutines that sets psi_det_generators to +! the current psi_det + END_DOC + N_det= N_det_generators + integer :: i,k + do i = 1, psi_det_size + do k=1,N_int + psi_det(k,1,i) = 0_bit_kind + psi_det(k,2,i) = 0_bit_kind + enddo + do k = 1, N_states + psi_coef(i,k) = 0.d0 + enddo + enddo + do i=1,N_det_generators + do k=1,N_int + psi_det(k,1,i) = psi_det_generators(k,1,i) + psi_det(k,2,i) = psi_det_generators(k,2,i) + enddo + do k = 1, N_states + psi_coef(i,k) = psi_coef_generators(i,k) + enddo + enddo + + touch N_det psi_coef psi_det + +end + + + +subroutine set_generators_to_generators_restart + implicit none + BEGIN_DOC +! subroutines that sets psi_det_generators to +! the current psi_det + END_DOC + N_det_generators = N_det_generators_restart + integer :: i,k + do i=1,N_det_generators + do k=1,N_int + psi_det_generators(k,1,i) = psi_det_generators_restart(k,1,i) + psi_det_generators(k,2,i) = psi_det_generators_restart(k,2,i) + enddo + do k = 1, N_states + psi_coef_generators(i,k) = psi_coef_generators_restart(i,k) + enddo + enddo + + touch N_det_generators psi_coef_generators psi_det_generators + +end + + +subroutine set_psi_det_to_generators_restart + implicit none + BEGIN_DOC +! subroutines that sets psi_det_generators to +! the current psi_det + END_DOC + N_det = N_det_generators_restart + integer :: i,k + do i=1,N_det_generators + do k=1,N_int + psi_det(k,1,i) = psi_det_generators_restart(k,1,i) + psi_det(k,2,i) = psi_det_generators_restart(k,2,i) + enddo + do k = 1, N_states + psi_coef(i,k) = psi_coef_generators_restart(i,k) + enddo + enddo + + touch N_det psi_coef psi_det + +end + + diff --git a/plugins/FOBOCI/new_approach.irp.f b/plugins/FOBOCI/new_approach.irp.f new file mode 100644 index 00000000..49dcafc3 --- /dev/null +++ b/plugins/FOBOCI/new_approach.irp.f @@ -0,0 +1,413 @@ + +subroutine new_approach + use bitmasks + implicit none + integer :: n_max_good_det + n_max_good_det = n_inact_orb * n_act_orb *n_det_generators_restart + n_virt_orb * n_act_orb * n_det_generators_restart + integer :: n_good_det,n_good_hole, n_good_particl + n_good_det = 0 + n_good_hole = 0 + n_good_particl = 0 + integer(bit_kind), allocatable :: psi_good_det(:,:,:) + double precision, allocatable :: dressing_restart_good_det(:,:) + double precision, allocatable :: dressing_matrix_restart_1h1p(:,:) + double precision, allocatable :: dressing_matrix_restart_2h1p(:,:) + double precision, allocatable :: dressing_matrix_restart_1h2p(:,:) + double precision, allocatable :: dressing_diag_good_det(:) + + double precision :: hjk + + integer :: i,j,k,l,i_hole_foboci + logical :: test_sym + double precision :: thr,hij + double precision :: threshold,accu + double precision, allocatable :: dressing_matrix_1h1p(:,:) + double precision, allocatable :: dressing_matrix_2h1p(:,:) + double precision, allocatable :: dressing_matrix_1h2p(:,:) + double precision, allocatable :: H_matrix_tmp(:,:) + logical :: verbose,is_ok + + double precision,allocatable :: eigenvectors(:,:), eigenvalues(:) + + + allocate(psi_good_det(N_int,2,n_max_good_det)) + allocate(dressing_restart_good_det(n_max_good_det,n_det_generators_restart)) + allocate(dressing_matrix_restart_1h1p(N_det_generators_restart, N_det_generators_restart)) + allocate(dressing_matrix_restart_2h1p(N_det_generators_restart, N_det_generators_restart)) + allocate(dressing_matrix_restart_1h2p(N_det_generators_restart, N_det_generators_restart)) + allocate(dressing_diag_good_det(n_max_good_det)) + + dressing_restart_good_det = 0.d0 + dressing_matrix_restart_1h1p = 0.d0 + dressing_matrix_restart_2h1p = 0.d0 + dressing_matrix_restart_1h2p = 0.d0 + dressing_diag_good_det = 0.d0 + + + verbose = .True. + threshold = threshold_singles + print*,'threshold = ',threshold + thr = 1.d-12 + print*,'' + print*,'' + print*,'mulliken spin population analysis' + accu =0.d0 + do i = 1, nucl_num + accu += mulliken_spin_densities(i) + print*,i,nucl_charge(i),mulliken_spin_densities(i) + enddo + print*,'' + print*,'' + print*,'DOING FIRST LMCT !!' + integer :: i_particl_osoci + + do i = 1, n_inact_orb + i_hole_foboci = list_inact(i) + print*,'--------------------------' + ! First set the current generators to the one of restart + call set_generators_to_generators_restart + call set_psi_det_to_generators + call check_symetry(i_hole_foboci,thr,test_sym) + if(.not.test_sym)cycle + print*,'i_hole_foboci = ',i_hole_foboci + call create_restart_and_1h(i_hole_foboci) +! ! Update the generators + call set_generators_to_psi_det + call set_bitmask_particl_as_input(reunion_of_bitmask) + call set_bitmask_hole_as_input(reunion_of_bitmask) + call is_a_good_candidate(threshold,is_ok,verbose) + print*,'is_ok = ',is_ok + if(.not.is_ok)cycle + ! so all the mono excitation on the new generators + allocate(dressing_matrix_1h1p(N_det_generators,N_det_generators)) + allocate(dressing_matrix_2h1p(N_det_generators,N_det_generators)) + dressing_matrix_1h1p = 0.d0 + dressing_matrix_2h1p = 0.d0 + if(.not.do_it_perturbative)then + n_good_hole +=1 +! call all_single_split_for_1h(dressing_matrix_1h1p,dressing_matrix_2h1p) + call all_single_for_1h(dressing_matrix_1h1p,dressing_matrix_2h1p) + allocate(H_matrix_tmp(N_det_generators,N_det_generators)) + do j = 1,N_det_generators + do k = 1, N_det_generators + call i_h_j(psi_det_generators(1,1,j),psi_det_generators(1,1,k),N_int,hjk) + H_matrix_tmp(j,k) = hjk + enddo + enddo + do j = 1, N_det_generators + do k = 1, N_det_generators + H_matrix_tmp(j,k) += dressing_matrix_1h1p(j,k) + dressing_matrix_2h1p(j,k) + enddo + enddo + hjk = H_matrix_tmp(1,1) + do j = 1, N_det_generators + H_matrix_tmp(j,j) -= hjk + enddo + print*,'-----------------------' + print*,'-----------------------' + print*,'-----------------------' + print*,'-----------------------' + print*,'-----------------------' + print*,'Dressed matrix :' + do j = 1, N_det_generators + write(*,'(100(X,F8.5))') H_matrix_tmp(j,:) + enddo + allocate(eigenvectors(N_det_generators,N_det_generators), eigenvalues(N_det_generators)) + call lapack_diag(eigenvalues,eigenvectors,H_matrix_tmp,N_det_generators,N_det_generators) + print*,'Eigenvector of the dressed matrix :' + do j = 1, N_det_generators + print*,'coef = ',eigenvectors(j,1) + enddo + print*,'-----------------------' + print*,'-----------------------' + print*,'-----------------------' + print*,'-----------------------' + print*,'-----------------------' + deallocate(eigenvectors, eigenvalues) + deallocate(H_matrix_tmp) + call update_dressing_matrix(dressing_matrix_1h1p,dressing_matrix_2h1p,dressing_restart_good_det,dressing_matrix_restart_1h1p, & + dressing_matrix_restart_2h1p,dressing_diag_good_det,psi_good_det,n_good_det,n_max_good_det) + endif + deallocate(dressing_matrix_1h1p) + deallocate(dressing_matrix_2h1p) + enddo + + print*,'' + print*,'' + print*,'DOING THEN THE MLCT !!' + do i = 1, n_virt_orb + i_particl_osoci = list_virt(i) + print*,'--------------------------' + ! First set the current generators to the one of restart + call set_generators_to_generators_restart + call set_psi_det_to_generators + call check_symetry(i_particl_osoci,thr,test_sym) + if(.not.test_sym)cycle + print*,'i_part_foboci = ',i_particl_osoci + call create_restart_and_1p(i_particl_osoci) + ! Update the generators + call set_generators_to_psi_det + call set_bitmask_particl_as_input(reunion_of_bitmask) + call set_bitmask_hole_as_input(reunion_of_bitmask) + call is_a_good_candidate(threshold,is_ok,verbose) + print*,'is_ok = ',is_ok + if(.not.is_ok)cycle + ! so all the mono excitation on the new generators + allocate(dressing_matrix_1h1p(N_det_generators,N_det_generators)) + allocate(dressing_matrix_1h2p(N_det_generators,N_det_generators)) + dressing_matrix_1h1p = 0.d0 + dressing_matrix_1h2p = 0.d0 + if(.not.do_it_perturbative)then + n_good_hole +=1 +! call all_single_split_for_1p(dressing_matrix_1h1p,dressing_matrix_1h2p) + call all_single_for_1p(dressing_matrix_1h1p,dressing_matrix_1h2p) + allocate(H_matrix_tmp(N_det_generators,N_det_generators)) + do j = 1,N_det_generators + do k = 1, N_det_generators + call i_h_j(psi_det_generators(1,1,j),psi_det_generators(1,1,k),N_int,hjk) + H_matrix_tmp(j,k) = hjk + enddo + enddo + do j = 1, N_det_generators + do k = 1, N_det_generators + H_matrix_tmp(j,k) += dressing_matrix_1h1p(j,k) + dressing_matrix_1h2p(j,k) + enddo + enddo + hjk = H_matrix_tmp(1,1) + do j = 1, N_det_generators + H_matrix_tmp(j,j) -= hjk + enddo + print*,'-----------------------' + print*,'-----------------------' + print*,'-----------------------' + print*,'-----------------------' + print*,'-----------------------' + print*,'Dressed matrix :' + do j = 1, N_det_generators + write(*,'(100(F8.5))') H_matrix_tmp(j,:) + enddo + allocate(eigenvectors(N_det_generators,N_det_generators), eigenvalues(N_det_generators)) + call lapack_diag(eigenvalues,eigenvectors,H_matrix_tmp,N_det_generators,N_det_generators) + print*,'Eigenvector of the dressed matrix :' + do j = 1, N_det_generators + print*,'coef = ',eigenvectors(j,1) + enddo + print*,'-----------------------' + print*,'-----------------------' + print*,'-----------------------' + print*,'-----------------------' + print*,'-----------------------' + deallocate(eigenvectors, eigenvalues) + deallocate(H_matrix_tmp) + call update_dressing_matrix(dressing_matrix_1h1p,dressing_matrix_1h2p,dressing_restart_good_det,dressing_matrix_restart_1h1p, & + dressing_matrix_restart_1h2p,dressing_diag_good_det,psi_good_det,n_good_det,n_max_good_det) + + endif + deallocate(dressing_matrix_1h1p) + deallocate(dressing_matrix_1h2p) + enddo + double precision, allocatable :: H_matrix_total(:,:) + integer :: n_det_total + n_det_total = N_det_generators_restart + n_good_det + allocate(H_matrix_total(n_det_total, n_det_total)) + ! Building of the effective Hamiltonian + ! We assume that the first determinants are the n_det_generators_restart ones + ! and then come the n_good_det determinants in psi_good_det + H_matrix_total = 0.d0 + do i = 1, N_det_generators_restart + do j = 1, N_det_generators_restart + call i_H_j(psi_det_generators_restart(1,1,i),psi_det_generators_restart(1,1,j),N_int,hij) + H_matrix_total(i,j) = hij + !!! Adding the averaged dressing coming from the 1h1p that are redundant for each of the "n_good_hole" 1h + H_matrix_total(i,j) += dressing_matrix_restart_1h1p(i,j)/dble(n_good_hole+n_good_particl) + !!! Adding the dressing coming from the 2h1p that are not redundant for the any of CI calculations + H_matrix_total(i,j) += dressing_matrix_restart_2h1p(i,j) + enddo + enddo + do i = 1, n_good_det + call i_H_j(psi_good_det(1,1,i),psi_good_det(1,1,i),N_int,hij) + !!! Adding the diagonal dressing coming from the singles + H_matrix_total(n_det_generators_restart+i,n_det_generators_restart+i) = hij + dressing_diag_good_det(i) + do j = 1, N_det_generators_restart + !!! Adding the extra diagonal dressing between the references and the singles + print*,' dressing_restart_good_det = ',dressing_restart_good_det(i,j) + call i_H_j(psi_good_det(1,1,i),psi_det_generators_restart(1,1,j),N_int,hij) + H_matrix_total(n_det_generators_restart+i,j) += hij + H_matrix_total(j,n_det_generators_restart+i) += hij + H_matrix_total(j,n_det_generators_restart+i) += dressing_restart_good_det(i,j) + H_matrix_total(n_det_generators_restart+i,j) += dressing_restart_good_det(i,j) + enddo + do j = i+1, n_good_det + !!! Building the naked Hamiltonian matrix between the singles + call i_H_j(psi_good_det(1,1,i),psi_good_det(1,1,j),N_int,hij) + H_matrix_total(n_det_generators_restart+i,n_det_generators_restart+j) = hij + H_matrix_total(n_det_generators_restart+j,n_det_generators_restart+i) = hij + enddo + enddo + print*,'H matrix to diagonalize' + double precision :: href + href = H_matrix_total(1,1) + do i = 1, n_det_total + H_matrix_total(i,i) -= href + enddo + do i = 1, n_det_total + write(*,'(100(X,F16.8))')H_matrix_total(i,:) + enddo + double precision, allocatable :: eigvalues(:),eigvectors(:,:) + allocate(eigvalues(n_det_total),eigvectors(n_det_total,n_det_total)) + call lapack_diag(eigvalues,eigvectors,H_matrix_total,n_det_total,n_det_total) + print*,'e_dressed = ',eigvalues(1) + nuclear_repulsion + href + do i = 1, n_det_total + print*,'coef = ',eigvectors(i,1) + enddo + integer(bit_kind), allocatable :: psi_det_final(:,:,:) + double precision, allocatable :: psi_coef_final(:,:) + double precision :: norm + allocate(psi_coef_final(n_det_total, N_states)) + allocate(psi_det_final(N_int,2,n_det_total)) + do i = 1, N_det_generators_restart + do j = 1,N_int + psi_det_final(j,1,i) = psi_det_generators_restart(j,1,i) + psi_det_final(j,2,i) = psi_det_generators_restart(j,2,i) + enddo + enddo + do i = 1, n_good_det + do j = 1,N_int + psi_det_final(j,1,n_det_generators_restart+i) = psi_good_det(j,1,i) + psi_det_final(j,2,n_det_generators_restart+i) = psi_good_det(j,2,i) + enddo + enddo + norm = 0.d0 + do i = 1, n_det_total + do j = 1, N_states + psi_coef_final(i,j) = eigvectors(i,j) + enddo + norm += psi_coef_final(i,1)**2 +! call debug_det(psi_det_final(1, 1, i), N_int) + enddo + print*,'norm = ',norm + + call set_psi_det_as_input_psi(n_det_total,psi_det_final,psi_coef_final) + print*,'' +!do i = 1, N_det +! call debug_det(psi_det(1,1,i),N_int) +! print*,'coef = ',psi_coef(i,1) +!enddo + provide one_body_dm_mo + + integer :: i_core,iorb,jorb,i_inact,j_inact,i_virt,j_virt,j_core + do i = 1, n_core_orb + i_core = list_core(i) + one_body_dm_mo(i_core,i_core) = 10.d0 + do j = i+1, n_core_orb + j_core = list_core(j) + one_body_dm_mo(i_core,j_core) = 0.d0 + one_body_dm_mo(j_core,i_core) = 0.d0 + enddo + do j = 1, n_inact_orb + iorb = list_inact(j) + one_body_dm_mo(i_core,iorb) = 0.d0 + one_body_dm_mo(iorb,i_core) = 0.d0 + enddo + do j = 1, n_act_orb + iorb = list_act(j) + one_body_dm_mo(i_core,iorb) = 0.d0 + one_body_dm_mo(iorb,i_core) = 0.d0 + enddo + do j = 1, n_virt_orb + iorb = list_virt(j) + one_body_dm_mo(i_core,iorb) = 0.d0 + one_body_dm_mo(iorb,i_core) = 0.d0 + enddo + enddo + ! Set to Zero the inact-inact part to avoid arbitrary rotations + do i = 1, n_inact_orb + i_inact = list_inact(i) + do j = i+1, n_inact_orb + j_inact = list_inact(j) + one_body_dm_mo(i_inact,j_inact) = 0.d0 + one_body_dm_mo(j_inact,i_inact) = 0.d0 + enddo + enddo + + ! Set to Zero the inact-virt part to avoid arbitrary rotations + do i = 1, n_inact_orb + i_inact = list_inact(i) + do j = 1, n_virt_orb + j_virt = list_virt(j) + one_body_dm_mo(i_inact,j_virt) = 0.d0 + one_body_dm_mo(j_virt,i_inact) = 0.d0 + enddo + enddo + + ! Set to Zero the virt-virt part to avoid arbitrary rotations + do i = 1, n_virt_orb + i_virt = list_virt(i) + do j = i+1, n_virt_orb + j_virt = list_virt(j) + one_body_dm_mo(i_virt,j_virt) = 0.d0 + one_body_dm_mo(j_virt,i_virt) = 0.d0 + enddo + enddo + + + print*,'' + print*,'Inactive-active Part of the One body DM' + print*,'' + do i = 1,n_act_orb + iorb = list_act(i) + print*,'' + print*,'ACTIVE ORBITAL ',iorb + do j = 1, n_inact_orb + jorb = list_inact(j) + if(dabs(one_body_dm_mo(iorb,jorb)).gt.threshold_singles)then + print*,'INACTIVE ' + print*,'DM ',iorb,jorb,dabs(one_body_dm_mo(iorb,jorb)) + endif + enddo + do j = 1, n_virt_orb + jorb = list_virt(j) + if(dabs(one_body_dm_mo(iorb,jorb)).gt.threshold_singles)then + print*,'VIRT ' + print*,'DM ',iorb,jorb,dabs(one_body_dm_mo(iorb,jorb)) + endif + enddo + enddo + do i = 1, mo_tot_num + do j = i+1, mo_tot_num + if(dabs(one_body_dm_mo(i,j)).le.threshold_fobo_dm)then + one_body_dm_mo(i,j) = 0.d0 + one_body_dm_mo(j,i) = 0.d0 + endif + enddo + enddo + + + + + + + label = "Natural" + character*(64) :: label + integer :: sign + sign = -1 + + call mo_as_eigvectors_of_mo_matrix(one_body_dm_mo,size(one_body_dm_mo,1),size(one_body_dm_mo,2),label,sign) + soft_touch mo_coef + call save_mos + + deallocate(eigvalues,eigvectors,psi_det_final,psi_coef_final) + + + + + deallocate(H_matrix_total) + deallocate(psi_good_det) + deallocate(dressing_restart_good_det) + deallocate(dressing_matrix_restart_1h1p) + deallocate(dressing_matrix_restart_2h1p) + deallocate(dressing_diag_good_det) + +end + + diff --git a/plugins/FOBOCI/routine_new_approach.irp.f b/plugins/FOBOCI/routine_new_approach.irp.f new file mode 100644 index 00000000..34274b76 --- /dev/null +++ b/plugins/FOBOCI/routine_new_approach.irp.f @@ -0,0 +1,56 @@ +subroutine update_dressing_matrix(dressing_matrix_1h1p,dressing_matrix_2h1p,dressing_restart_good_det,dressing_matrix_restart_1h1p, & + dressing_matrix_restart_2h1p,dressing_diag_good_det,psi_good_det,n_good_det,n_max_good_det) + implicit none + integer, intent(in) :: n_max_good_det + integer, intent(inout) :: n_good_det + integer(bit_kind), intent(inout) :: psi_good_det(N_int,2,n_max_good_det) + double precision, intent(in) :: dressing_matrix_1h1p(N_det_generators,N_det_generators) + double precision, intent(in) :: dressing_matrix_2h1p(N_det_generators,N_det_generators) + double precision, intent(inout) :: dressing_matrix_restart_1h1p(N_det_generators_restart, N_det_generators_restart) + double precision, intent(inout) :: dressing_matrix_restart_2h1p(N_det_generators_restart, N_det_generators_restart) + double precision, intent(inout) :: dressing_restart_good_det(n_max_good_det,N_det_generators_restart) + double precision, intent(inout) :: dressing_diag_good_det(n_max_good_det) + use bitmasks + integer :: k,l,degree + logical, allocatable :: is_a_ref_det(:) + integer, allocatable :: index_restart_generators(:) + allocate(is_a_ref_det(N_det_generators),index_restart_generators(N_det_generators)) + is_a_ref_det = .False. + do k = 1, N_det_generators + do l = 1, N_det_generators_restart + call get_excitation_degree(psi_det_generators(1,1,k),psi_det_generators_restart(1,1,l), degree, N_int) + if(degree==0)then + is_a_ref_det(k) = .True. + index_restart_generators(k) = l + endif + enddo + enddo + do k = 1, N_det_generators + if(is_a_ref_det(k))then + do l = 1, N_det_generators + if(.not.is_a_ref_det(l))cycle + !!!! Dressing of the reference space in the order of the restart determinants + dressing_matrix_restart_1h1p(index_restart_generators(l),index_restart_generators(k)) += dressing_matrix_1h1p(k,l) + print*,' dressing_matrix_1h1p(k,l) = ',dressing_matrix_1h1p(k,l) + dressing_matrix_restart_2h1p(index_restart_generators(l),index_restart_generators(k)) += dressing_matrix_2h1p(k,l) + enddo + else + !!!! Incrementing the counting of the good determinants + n_good_det +=1 + !!!! Adding the good determinant to the global_list (psi_good_det) + do l = 1, N_int + psi_good_det(l,1,n_good_det) = psi_det_generators(l,1,k) + psi_good_det(l,2,n_good_det) = psi_det_generators(l,2,k) + enddo + !!! Storing the diagonal dressing of the good det + dressing_diag_good_det(n_good_det) = dressing_matrix_1h1p(k,k) + dressing_matrix_2h1p(k,k) + do l = 1, N_det_generators + if(.not.is_a_ref_det(l))cycle + !!! Storing the extra diagonal dressing of the good det with the restart determinants + dressing_restart_good_det(n_good_det,index_restart_generators(l)) = dressing_matrix_1h1p(k,l) + dressing_matrix_2h1p(k,l) + enddo + endif + enddo + deallocate(is_a_ref_det,index_restart_generators) + +end diff --git a/plugins/FOBOCI/routines_dressing.irp.f b/plugins/FOBOCI/routines_dressing.irp.f new file mode 100644 index 00000000..910f1109 --- /dev/null +++ b/plugins/FOBOCI/routines_dressing.irp.f @@ -0,0 +1,457 @@ +subroutine provide_matrix_dressing(dressing_matrix,ndet_generators_input,psi_det_generators_input) + use bitmasks + implicit none + integer, intent(in) :: ndet_generators_input + integer(bit_kind), intent(in) :: psi_det_generators_input(N_int,2,ndet_generators_input) + double precision, intent(inout) :: dressing_matrix(ndet_generators_input,ndet_generators_input) + double precision :: H_array(N_det),hka + logical :: is_a_ref_det(N_det) + integer :: i,j,n_det_ref_tmp + integer :: connected_to_ref_by_mono,degree + double precision :: coef_ref(Ndet_generators_input) + double precision :: accu,lambda_i + integer :: k + integer :: index_ref_tmp(N_det) + is_a_ref_det = .False. + n_det_ref_tmp = 0 + do i = 1, N_det + do j = 1, Ndet_generators_input + call get_excitation_degree(psi_det(1,1,i),psi_det_generators_input(1,1,j),degree,N_int) + if(degree == 0)then + is_a_ref_det(i) = .True. + n_det_ref_tmp +=1 + index_ref_tmp(n_det_ref_tmp) = i + coef_ref(n_det_ref_tmp) = psi_coef(i,1) + exit + endif + enddo + enddo + if( ndet_generators_input .ne. n_det_ref_tmp)then + print*,'Problem !!!! ' + print*,' ndet_generators .ne. n_det_ref_tmp !!!' + print*,'ndet_generators,n_det_ref_tmp' + print*,ndet_generators_input,n_det_ref_tmp + stop + endif + + call i_h_j(psi_det_generators_input(1,1,1),psi_det_generators_input(1,1,1),N_int,href) + integer :: i_pert, i_pert_count + i_pert_count = 0 + do i = 1, N_det + if(is_a_ref_det(i))cycle + call i_h_j(psi_det(1,1,i),psi_det(1,1,i),N_int,hka) + double precision :: f,href + f = 1.d0/(href - hka) + H_array = 0.d0 + accu = 0.d0 + do j=1,ndet_generators_input + call i_h_j(psi_det(1,1,i),psi_det_generators_input(1,1,j),N_int,hka) + H_array(j) = hka + accu += coef_ref(j) * hka + enddo + lambda_i = psi_coef(i,1)/accu + i_pert = 1 + if(accu * f / psi_coef(i,1) .gt. 0.5d0 .and. accu * f/psi_coef(i,1).gt.0.d0)then + i_pert = 0 + endif + do j = 1, ndet_generators_input + if(dabs(H_array(j)*lambda_i).gt.0.5d0)then + i_pert = 1 + exit + endif + enddo +! print*,'' +! print*,'lambda_i,f = ',lambda_i,f +! print*,'i_pert = ',i_pert +! print*,'' + if(i_pert==1)then + lambda_i = f + i_pert_count +=1 + endif + do k=1,ndet_generators_input + double precision :: contrib + contrib = H_array(k) * H_array(k) * lambda_i + dressing_matrix(k, k) += contrib + do j=k+1,ndet_generators_input + contrib = H_array(k) * H_array(j) * lambda_i + dressing_matrix(k, j) += contrib + dressing_matrix(j, k) += contrib + enddo + enddo + enddo +!print*,'i_pert_count = ',i_pert_count +end + +subroutine provide_matrix_dressing_general(dressing_matrix,psi_det_ref_input,psi_coef_ref_input,n_det_ref_input, & + psi_det_outer_input,psi_coef_outer_input,n_det_outer_input) + use bitmasks + implicit none + integer, intent(in) :: n_det_ref_input + integer(bit_kind), intent(in) :: psi_det_ref_input(N_int,2,n_det_ref_input) + double precision, intent(in) :: psi_coef_ref_input(n_det_ref_input,N_states) + integer, intent(in) :: n_det_outer_input + integer(bit_kind), intent(in) :: psi_det_outer_input(N_int,2,n_det_outer_input) + double precision, intent(in) :: psi_coef_outer_input(n_det_outer_input,N_states) + + double precision, intent(inout) :: dressing_matrix(n_det_ref_input,n_det_ref_input) + + + integer :: i_pert, i_pert_count,i,j,k + double precision :: f,href,hka,lambda_i + double precision :: H_array(n_det_ref_input),accu + call i_h_j(psi_det_ref_input(1,1,1),psi_det_ref_input(1,1,1),N_int,href) + i_pert_count = 0 + do i = 1, n_det_outer_input + call i_h_j(psi_det_outer_input(1,1,i),psi_det_outer_input(1,1,i),N_int,hka) + f = 1.d0/(href - hka) + H_array = 0.d0 + accu = 0.d0 + do j=1,n_det_ref_input + call i_h_j(psi_det_outer_input(1,1,i),psi_det_ref_input(1,1,j),N_int,hka) + H_array(j) = hka + accu += psi_coef_ref_input(j,1) * hka + enddo + lambda_i = psi_coef_outer_input(i,1)/accu + i_pert = 1 + if(accu * f / psi_coef_outer_input(i,1) .gt. 0.5d0 .and. accu * f/psi_coef_outer_input(i,1).gt.0.d0)then + i_pert = 0 + endif + do j = 1, n_det_ref_input + if(dabs(H_array(j)*lambda_i).gt.0.3d0)then + i_pert = 1 + exit + endif + enddo + if(i_pert==1)then + lambda_i = f + i_pert_count +=1 + endif + do k=1,n_det_ref_input + double precision :: contrib + contrib = H_array(k) * H_array(k) * lambda_i + dressing_matrix(k, k) += contrib + do j=k+1,n_det_ref_input + contrib = H_array(k) * H_array(j) * lambda_i + dressing_matrix(k, j) += contrib + dressing_matrix(j, k) += contrib + enddo + enddo + enddo +end + + +subroutine diag_dressed_matrix_and_set_to_psi_det(psi_det_generators_input,Ndet_generators_input,dressing_matrix) + use bitmasks + implicit none + integer, intent(in) :: ndet_generators_input + integer(bit_kind), intent(in) :: psi_det_generators_input(N_int,2,ndet_generators_input) + double precision, intent(inout) :: dressing_matrix(ndet_generators_input,ndet_generators_input) + integer :: i,j + + double precision :: eigenvectors(Ndet_generators_input,Ndet_generators_input), eigenvalues(Ndet_generators_input) + + call lapack_diag(eigenvalues,eigenvectors,dressing_matrix,Ndet_generators_input,Ndet_generators_input) + print*,'Dressed eigenvalue, to be compared with the CI one' + print*,'E = ',eigenvalues(1)+nuclear_repulsion + print*,'Dressed matrix, to be compared to the intermediate Hamiltonian one' + do i = 1, Ndet_generators_input + write(*,'(100(F12.5,X))')dressing_matrix(i,:) + enddo + n_det = Ndet_generators_input + do i = 1, Ndet_generators_input + psi_coef(i,1) = eigenvectors(i,1) + do j = 1, N_int + psi_det(j,1,i) = psi_det_generators_input(j,1,i) + psi_det(j,2,i) = psi_det_generators_input(j,2,i) + enddo + enddo + + touch N_det psi_coef psi_det + +end + +subroutine give_n_1h1p_and_n_2h1p_in_psi_det(n_det_1h1p,n_det_2h1p) + use bitmasks + implicit none + integer, intent(out) :: n_det_1h1p, n_det_2h1p + integer :: i + integer :: n_det_ref_restart_tmp,n_det_1h + integer :: number_of_holes,n_h, number_of_particles,n_p + n_det_ref_restart_tmp = 0 + n_det_1h = 0 + n_det_1h1p = 0 + n_det_2h1p = 0 + do i = 1, N_det + n_h = number_of_holes(psi_det(1,1,i)) + n_p = number_of_particles(psi_det(1,1,i)) + if(n_h == 0 .and. n_p == 0)then + n_det_ref_restart_tmp +=1 + else if (n_h ==1 .and. n_p==0)then + n_det_1h +=1 + else if (n_h ==1 .and. n_p==1)then + n_det_1h1p +=1 + else if (n_h ==2 .and. n_p==1)then + n_det_2h1p +=1 + else + print*,'PB !!!!' + print*,'You have something else than a 1h, 1h1p or 2h1p' + call debug_det(psi_det(1,1,i),N_int) + stop + endif + enddo +! if(n_det_1h.ne.1)then +! print*,'PB !! You have more than one 1h' +! stop +! endif + if(n_det_ref_restart_tmp + n_det_1h .ne. n_det_generators)then + print*,'PB !!!!' + print*,'You have forgotten something in your generators ... ' + stop + endif + + +end + +subroutine give_n_1h1p_and_n_1h2p_in_psi_det(n_det_1h1p,n_det_1h2p) + use bitmasks + implicit none + integer, intent(out) :: n_det_1h1p, n_det_1h2p + integer :: i + integer :: n_det_ref_restart_tmp,n_det_1h + integer :: number_of_holes,n_h, number_of_particles,n_p + n_det_ref_restart_tmp = 0 + n_det_1h = 0 + n_det_1h1p = 0 + n_det_1h2p = 0 + do i = 1, N_det + n_h = number_of_holes(psi_det(1,1,i)) + n_p = number_of_particles(psi_det(1,1,i)) + if(n_h == 0 .and. n_p == 0)then + n_det_ref_restart_tmp +=1 + else if (n_h ==0 .and. n_p==1)then + n_det_1h +=1 + else if (n_h ==1 .and. n_p==1)then + n_det_1h1p +=1 + else if (n_h ==1 .and. n_p==2)then + n_det_1h2p +=1 + else + print*,'PB !!!!' + print*,'You have something else than a 1p, 1h1p or 1h2p' + call debug_det(psi_det(1,1,i),N_int) + stop + endif + enddo + if(n_det_ref_restart_tmp + n_det_1h .ne. n_det_generators)then + print*,'PB !!!!' + print*,'You have forgotten something in your generators ... ' + stop + endif + + +end + + +subroutine split_wf_generators_and_1h1p_and_2h1p(n_det_1h1p,n_det_2h1p,psi_ref_out,psi_ref_coef_out,psi_1h1p,psi_coef_1h1p,psi_2h1p,psi_coef_2h1p) + use bitmasks + implicit none + integer, intent(in) :: n_det_1h1p,n_det_2h1p + integer(bit_kind), intent(out) :: psi_ref_out(N_int,2,N_det_generators) + integer(bit_kind), intent(out) :: psi_1h1p(N_int,2,n_det_1h1p) + integer(bit_kind), intent(out) :: psi_2h1p(N_int,2,n_det_2h1p) + double precision, intent(out) :: psi_ref_coef_out(N_det_generators,N_states) + double precision, intent(out) :: psi_coef_1h1p(n_det_1h1p, N_states) + double precision, intent(out) :: psi_coef_2h1p(n_det_2h1p, N_states) + + integer :: i,j + integer :: degree + integer :: number_of_holes,n_h, number_of_particles,n_p + integer :: n_det_generators_tmp,n_det_1h1p_tmp,n_det_2h1p_tmp + integer, allocatable :: index_generator(:) + integer, allocatable :: index_1h1p(:) + integer, allocatable :: index_2h1p(:) + + allocate(index_1h1p(n_det)) + allocate(index_2h1p(n_det)) + allocate(index_generator(N_det)) + + + n_det_generators_tmp = 0 + n_det_1h1p_tmp = 0 + n_det_2h1p_tmp = 0 + do i = 1, n_det + n_h = number_of_holes(psi_det(1,1,i)) + n_p = number_of_particles(psi_det(1,1,i)) + if (n_h ==1 .and. n_p==1)then + n_det_1h1p_tmp +=1 + index_1h1p(n_det_1h1p_tmp) = i + else if (n_h ==2 .and. n_p==1)then + n_det_2h1p_tmp +=1 + index_2h1p(n_det_2h1p_tmp) = i + endif + do j = 1, N_det_generators + call get_excitation_degree(psi_det_generators(1,1,j),psi_det(1,1,i), degree, N_int) + if(degree == 0)then + n_det_generators_tmp +=1 + index_generator(n_det_generators_tmp) = i + endif + enddo + enddo + if(n_det_1h1p_tmp.ne.n_det_1h1p)then + print*,'PB !!!' + print*,'n_det_1h1p_tmp.ne.n_det_1h1p)' + stop + endif + + + if(n_det_2h1p_tmp.ne.n_det_2h1p)then + print*,'PB !!!' + print*,'n_det_2h1p_tmp.ne.n_det_2h1p)' + stop + endif + + if(N_det_generators_tmp.ne.n_det_generators)then + print*,'PB !!!' + print*,'N_det_generators_tmp.ne.n_det_generators' + stop + endif + + do i = 1,N_det_generators + do j = 1, N_int + psi_ref_out(j,1,i) = psi_det(j,1,index_generator(i)) + psi_ref_out(j,2,i) = psi_det(j,2,index_generator(i)) + enddo + do j = 1, N_states + psi_ref_coef_out(i,j) = psi_coef(index_generator(i),j) + enddo + enddo + + do i = 1, n_det_1h1p + do j = 1, N_int + psi_1h1p(j,1,i) = psi_det(j,1,index_1h1p(i)) + psi_1h1p(j,2,i) = psi_det(j,2,index_1h1p(i)) + enddo + do j = 1, N_states + psi_coef_1h1p(i,j) = psi_coef(index_1h1p(i),j) + enddo + enddo + + do i = 1, n_det_2h1p + do j = 1, N_int + psi_2h1p(j,1,i) = psi_det(j,1,index_2h1p(i)) + psi_2h1p(j,2,i) = psi_det(j,2,index_2h1p(i)) + enddo + do j = 1, N_states + psi_coef_2h1p(i,j) = psi_coef(index_2h1p(i),j) + enddo + enddo + + + deallocate(index_generator) + deallocate(index_1h1p) + deallocate(index_2h1p) + +end + + +subroutine split_wf_generators_and_1h1p_and_1h2p(n_det_1h1p,n_det_1h2p,psi_ref_out,psi_ref_coef_out,psi_1h1p,psi_coef_1h1p,psi_1h2p,psi_coef_1h2p) + use bitmasks + implicit none + integer, intent(in) :: n_det_1h1p,n_det_1h2p + integer(bit_kind), intent(out) :: psi_ref_out(N_int,2,N_det_generators) + integer(bit_kind), intent(out) :: psi_1h1p(N_int,2,n_det_1h1p) + integer(bit_kind), intent(out) :: psi_1h2p(N_int,2,n_det_1h2p) + double precision, intent(out) :: psi_ref_coef_out(N_det_generators,N_states) + double precision, intent(out) :: psi_coef_1h1p(n_det_1h1p, N_states) + double precision, intent(out) :: psi_coef_1h2p(n_det_1h2p, N_states) + + integer :: i,j + integer :: degree + integer :: number_of_holes,n_h, number_of_particles,n_p + integer :: n_det_generators_tmp,n_det_1h1p_tmp,n_det_1h2p_tmp + integer, allocatable :: index_generator(:) + integer, allocatable :: index_1h1p(:) + integer, allocatable :: index_1h2p(:) + + allocate(index_1h1p(n_det)) + allocate(index_1h2p(n_det)) + allocate(index_generator(N_det)) + + + n_det_generators_tmp = 0 + n_det_1h1p_tmp = 0 + n_det_1h2p_tmp = 0 + do i = 1, n_det + n_h = number_of_holes(psi_det(1,1,i)) + n_p = number_of_particles(psi_det(1,1,i)) + if (n_h ==1 .and. n_p==1)then + n_det_1h1p_tmp +=1 + index_1h1p(n_det_1h1p_tmp) = i + else if (n_h ==1 .and. n_p==2)then + n_det_1h2p_tmp +=1 + index_1h2p(n_det_1h2p_tmp) = i + endif + do j = 1, N_det_generators + call get_excitation_degree(psi_det_generators(1,1,j),psi_det(1,1,i), degree, N_int) + if(degree == 0)then + n_det_generators_tmp +=1 + index_generator(n_det_generators_tmp) = i + endif + enddo + enddo + if(n_det_1h1p_tmp.ne.n_det_1h1p)then + print*,'PB !!!' + print*,'n_det_1h1p_tmp.ne.n_det_1h1p)' + stop + endif + + + if(n_det_1h2p_tmp.ne.n_det_1h2p)then + print*,'PB !!!' + print*,'n_det_1h2p_tmp.ne.n_det_1h2p)' + stop + endif + + if(N_det_generators_tmp.ne.n_det_generators)then + print*,'PB !!!' + print*,'N_det_generators_tmp.ne.n_det_generators' + stop + endif + + do i = 1,N_det_generators + do j = 1, N_int + psi_ref_out(j,1,i) = psi_det(j,1,index_generator(i)) + psi_ref_out(j,2,i) = psi_det(j,2,index_generator(i)) + enddo + do j = 1, N_states + psi_ref_coef_out(i,j) = psi_coef(index_generator(i),j) + enddo + enddo + + do i = 1, n_det_1h1p + do j = 1, N_int + psi_1h1p(j,1,i) = psi_det(j,1,index_1h1p(i)) + psi_1h1p(j,2,i) = psi_det(j,2,index_1h1p(i)) + enddo + do j = 1, N_states + psi_coef_1h1p(i,j) = psi_coef(index_1h1p(i),j) + enddo + enddo + + do i = 1, n_det_1h2p + do j = 1, N_int + psi_1h2p(j,1,i) = psi_det(j,1,index_1h2p(i)) + psi_1h2p(j,2,i) = psi_det(j,2,index_1h2p(i)) + enddo + do j = 1, N_states + psi_coef_1h2p(i,j) = psi_coef(index_1h2p(i),j) + enddo + enddo + + + deallocate(index_generator) + deallocate(index_1h1p) + deallocate(index_1h2p) + +end + + diff --git a/plugins/FOBOCI/routines_foboci.irp.f b/plugins/FOBOCI/routines_foboci.irp.f new file mode 100644 index 00000000..696011a9 --- /dev/null +++ b/plugins/FOBOCI/routines_foboci.irp.f @@ -0,0 +1,616 @@ +subroutine set_intermediate_normalization_lmct_old(norm,i_hole) + implicit none + integer, intent(in) :: i_hole + double precision, intent(out) :: norm(N_states) + integer :: i,j,degree,index_ref_generators_restart,k + integer:: number_of_holes,n_h, number_of_particles,n_p + integer, allocatable :: index_one_hole(:),index_one_hole_one_p(:),index_two_hole_one_p(:),index_two_hole(:) + integer, allocatable :: index_one_p(:) + integer :: n_one_hole,n_one_hole_one_p,n_two_hole_one_p,n_two_hole,n_one_p + logical :: is_the_hole_in_det + double precision :: inv_coef_ref_generators_restart(N_states),hij,hii,accu + integer :: index_good_hole(1000) + integer :: n_good_hole + logical,allocatable :: is_a_ref_det(:) + allocate(index_one_hole(n_det),index_one_hole_one_p(n_det),index_two_hole_one_p(N_det),index_two_hole(N_det),index_one_p(N_det),is_a_ref_det(N_det)) + + n_one_hole = 0 + n_one_hole_one_p = 0 + n_two_hole_one_p = 0 + n_two_hole = 0 + n_one_p = 0 + n_good_hole = 0 + ! Find the one holes and one hole one particle + is_a_ref_det = .False. + do i = 1, N_det + ! Find the reference determinant for intermediate normalization + call get_excitation_degree(ref_generators_restart,psi_det(1,1,i),degree,N_int) + if(degree == 0)then + index_ref_generators_restart = i + do k = 1, N_states + inv_coef_ref_generators_restart(k) = 1.d0/psi_coef(i,k) + enddo +! cycle + endif + + ! Find all the determinants present in the reference wave function + do j = 1, N_det_generators_restart + call get_excitation_degree(psi_det(1,1,i),psi_det_generators_restart(1,1,j),degree,N_int) + if(degree == 0)then + is_a_ref_det(i) = .True. + exit + endif + enddo + if(is_a_ref_det(i))cycle + n_h = number_of_holes(psi_det(1,1,i)) + n_p = number_of_particles(psi_det(1,1,i)) + if(n_h == 1 .and. n_p == 0)then + if(is_the_hole_in_det(psi_det(1,1,i),1,i_hole).or.is_the_hole_in_det(psi_det(1,1,i),2,i_hole))then + n_good_hole +=1 + index_good_hole(n_good_hole) = i + else + do k = 1, N_states + psi_coef(i,k) = 0.d0 + enddo + endif + else + do k = 1, N_states + psi_coef(i,k) = 0.d0 + enddo + endif + enddo +!do k = 1, N_det +! call debug_det(psi_det(1,1,k),N_int) +! print*,'k,coef = ',k,psi_coef(k,1)/psi_coef(index_ref_generators_restart,1) +!enddo + print*,'' + print*,'n_good_hole = ',n_good_hole + do k = 1,N_states + print*,'state ',k + do i = 1, n_good_hole + print*,'psi_coef(index_good_hole) = ',psi_coef(index_good_hole(i),k)/psi_coef(index_ref_generators_restart,k) + enddo + print*,'' + enddo + norm = 0.d0 + + ! Set the wave function to the intermediate normalization + do k = 1, N_states + do i = 1, N_det + psi_coef(i,k) = psi_coef(i,k) * inv_coef_ref_generators_restart(k) + enddo + enddo + do k = 1,N_states + print*,'state ',k + do i = 1, N_det +!! print*,'psi_coef(i_ref) = ',psi_coef(i,1) + if (is_a_ref_det(i))then + print*,'i,psi_coef_ref = ',psi_coef(i,k) + cycle + endif + norm(k) += psi_coef(i,k) * psi_coef(i,k) + enddo + print*,'norm = ',norm(k) + enddo + deallocate(index_one_hole,index_one_hole_one_p,index_two_hole_one_p,index_two_hole,index_one_p,is_a_ref_det) + soft_touch psi_coef +end + + +subroutine set_intermediate_normalization_mlct_old(norm,i_particl) + implicit none + integer, intent(in) :: i_particl + double precision, intent(out) :: norm(N_states) + integer :: i,j,degree,index_ref_generators_restart,k + integer:: number_of_holes,n_h, number_of_particles,n_p + integer, allocatable :: index_one_hole(:),index_one_hole_one_p(:),index_two_hole_one_p(:),index_two_hole(:) + integer, allocatable :: index_one_p(:),index_one_hole_two_p(:) + integer :: n_one_hole,n_one_hole_one_p,n_two_hole_one_p,n_two_hole,n_one_p,n_one_hole_two_p + logical :: is_the_particl_in_det + double precision :: inv_coef_ref_generators_restart(N_states) + integer :: exc(0:2,2,2) + double precision :: phase,hij,hii,accu + integer :: h1,p1,h2,p2,s1,s2 + integer :: index_good_particl(1000) + integer :: n_good_particl + logical,allocatable :: is_a_ref_det(:) + integer :: i_count + allocate(index_one_hole(n_det),index_one_hole_one_p(n_det),index_two_hole_one_p(N_det),index_two_hole(N_det),index_one_p(N_det),is_a_ref_det(N_det)) + allocate(index_one_hole_two_p(n_det)) + + n_one_hole = 0 + n_one_hole_one_p = 0 + n_two_hole_one_p = 0 + n_two_hole = 0 + n_one_p = 0 + n_one_hole_two_p = 0 + n_good_particl = 0 + ! Find the one holes and one hole one particle + i_count = 0 + is_a_ref_det = .False. + do i = 1, N_det + call get_excitation_degree(ref_generators_restart,psi_det(1,1,i),degree,N_int) + if(degree == 0)then + index_ref_generators_restart = i + do k = 1, N_states + inv_coef_ref_generators_restart(k) = 1.d0/psi_coef(i,k) + enddo +! cycle + endif + + ! Find all the determinants present in the reference wave function + do j = 1, N_det_generators_restart + call get_excitation_degree(psi_det(1,1,i),psi_det_generators_restart(1,1,j),degree,N_int) + if(degree == 0)then + is_a_ref_det(i) = .True. + exit + endif + enddo + if(is_a_ref_det(i))cycle + + + n_h = number_of_holes(psi_det(1,1,i)) + n_p = number_of_particles(psi_det(1,1,i)) + if(n_h == 0 .and. n_p == 1)then ! 1p + if(is_the_particl_in_det(psi_det(1,1,i),1,i_particl).or.is_the_particl_in_det(psi_det(1,1,i),2,i_particl))then + n_good_particl += 1 + index_good_particl(n_good_particl) = i + else + do k = 1, N_states + psi_coef(i,k) = 0.d0 + enddo + endif + else + do k = 1, N_states + psi_coef(i,k) = 0.d0 + enddo + endif + enddo + + norm = 0.d0 + print*,'' + print*,'n_good_particl = ',n_good_particl + do k = 1, N_states + print*,'state ',k + do i = 1, n_good_particl + print*,'psi_coef(index_good_particl,1) = ',psi_coef(index_good_particl(i),k)/psi_coef(index_ref_generators_restart,k) + enddo + print*,'' + enddo + + + ! Set the wave function to the intermediate normalization + do k = 1, N_states + do i = 1, N_det + psi_coef(i,k) = psi_coef(i,k) * inv_coef_ref_generators_restart(k) + enddo + enddo + do k = 1, N_states + print*,'state ',k + do i = 1, N_det +!! print*,'i = ',i, psi_coef(i,1) + if (is_a_ref_det(i))then + print*,'i,psi_coef_ref = ',psi_coef(i,k) + cycle + endif + norm(k) += psi_coef(i,k) * psi_coef(i,k) + enddo + print*,'norm = ',norm + enddo + soft_touch psi_coef + deallocate(index_one_hole,index_one_hole_one_p,index_two_hole_one_p,index_two_hole,index_one_p,is_a_ref_det) +end + + +subroutine update_density_matrix_osoci + implicit none + BEGIN_DOC + ! one_body_dm_mo_alpha_osoci += Delta rho alpha + ! one_body_dm_mo_beta_osoci += Delta rho beta + END_DOC + integer :: i,j + integer :: iorb,jorb + do i = 1, mo_tot_num + do j = 1, mo_tot_num + one_body_dm_mo_alpha_osoci(i,j) = one_body_dm_mo_alpha_osoci(i,j) + (one_body_dm_mo_alpha(i,j) - one_body_dm_mo_alpha_generators_restart(i,j)) + one_body_dm_mo_beta_osoci(i,j) = one_body_dm_mo_beta_osoci(i,j) + (one_body_dm_mo_beta(i,j) - one_body_dm_mo_beta_generators_restart(i,j)) + enddo + enddo + + +end + + +subroutine initialize_density_matrix_osoci + implicit none + one_body_dm_mo_alpha_osoci = one_body_dm_mo_alpha_generators_restart + one_body_dm_mo_beta_osoci = one_body_dm_mo_beta_generators_restart +end + +subroutine rescale_density_matrix_osoci(norm) + implicit none + double precision, intent(in) :: norm(N_states) + integer :: i,j + double precision :: norm_tmp + norm_tmp = 0.d0 + do i = 1, N_states + norm_tmp += norm(i) + enddo + print*,'norm = ',norm_tmp + + do i = 1, mo_tot_num + do j = 1,mo_tot_num + one_body_dm_mo_alpha_osoci(i,j) = one_body_dm_mo_alpha_osoci(i,j) * norm_tmp + one_body_dm_mo_beta_osoci(j,i) = one_body_dm_mo_beta_osoci(j,i) * norm_tmp + enddo + enddo +end + +subroutine save_osoci_natural_mos + + implicit none + BEGIN_DOC + ! Set natural orbitals, obtained by diagonalization of the one-body density matrix in the MO basis + END_DOC + character*(64) :: label + double precision, allocatable :: tmp(:,:),tmp_bis(:,:) + integer, allocatable :: occ(:,:) + integer :: n_occ_alpha,i,i_core,j_core,iorb,jorb,j,i_inact,j_inact,i_virt,j_virt + allocate(tmp(size(one_body_dm_mo_alpha_osoci,1),size(one_body_dm_mo_alpha_osoci,2))) + allocate(tmp_bis(size(one_body_dm_mo_alpha_osoci,1),size(one_body_dm_mo_alpha_osoci,2))) + allocate (occ(N_int*bit_kind_size,2)) + + ! Negation to have the occupied MOs first after the diagonalization + tmp_bis = -one_body_dm_mo_alpha_osoci - one_body_dm_mo_beta_osoci + ! Set to Zero the core-inact-act-virt part + do i = 1, n_core_orb + i_core = list_core(i) + tmp_bis(i_core,i_core) = -10.d0 + do j = i+1, n_core_orb + j_core = list_core(j) + tmp_bis(i_core,j_core) = 0.d0 + tmp_bis(j_core,i_core) = 0.d0 + enddo + do j = 1, n_inact_orb + iorb = list_inact(j) + tmp_bis(i_core,iorb) = 0.d0 + tmp_bis(iorb,i_core) = 0.d0 + enddo + do j = 1, n_act_orb + iorb = list_act(j) + tmp_bis(i_core,iorb) = 0.d0 + tmp_bis(iorb,i_core) = 0.d0 + enddo + do j = 1, n_virt_orb + iorb = list_virt(j) + tmp_bis(i_core,iorb) = 0.d0 + tmp_bis(iorb,i_core) = 0.d0 + enddo + enddo + do i = 1, n_core_orb + print*,'dm core = ',list_core(i),tmp_bis(list_core(i),list_core(i)) + enddo + ! Set to Zero the inact-inact part to avoid arbitrary rotations + do i = 1, n_inact_orb + i_inact = list_inact(i) + do j = i+1, n_inact_orb + j_inact = list_inact(j) + tmp_bis(i_inact,j_inact) = 0.d0 + tmp_bis(j_inact,i_inact) = 0.d0 + enddo + enddo + + ! Set to Zero the inact-virt part to avoid arbitrary rotations + do i = 1, n_inact_orb + i_inact = list_inact(i) + do j = 1, n_virt_orb + j_virt = list_virt(j) + tmp_bis(i_inact,j_virt) = 0.d0 + tmp_bis(j_virt,i_inact) = 0.d0 + enddo + enddo + + ! Set to Zero the virt-virt part to avoid arbitrary rotations + do i = 1, n_virt_orb + i_virt = list_virt(i) + do j = i+1, n_virt_orb + j_virt = list_virt(j) + tmp_bis(i_virt,j_virt) = 0.d0 + tmp_bis(j_virt,i_virt) = 0.d0 + enddo + enddo + + double precision :: accu + ! Set to Zero the act-act part to avoid arbitrary rotations + do i = 1,n_act_orb + iorb = list_act(i) + do j = i+1,n_act_orb + jorb = list_act(j) + tmp_bis(iorb,jorb) = 0.d0 + tmp_bis(jorb,iorb) = 0.d0 + enddo + enddo + + tmp = tmp_bis +!! Symetrization act-virt + do j = 1, n_virt_orb + j_virt= list_virt(j) + accu = 0.d0 + do i = 1, n_act_orb + jorb = list_act(i) + accu += dabs(tmp_bis(j_virt,jorb)) + enddo + do i = 1, n_act_orb + iorb = list_act(i) + tmp(j_virt,iorb) = dsign(accu/dble(n_act_orb),tmp_bis(j_virt,iorb)) + tmp(iorb,j_virt) = dsign(accu/dble(n_act_orb),tmp_bis(j_virt,iorb)) + enddo + enddo + +!! Symetrization act-inact +!do j = 1, n_inact_orb +! j_inact = list_inact(j) +! accu = 0.d0 +! do i = 1, n_act_orb +! jorb = list_act(i) +! accu += dabs(tmp_bis(j_inact,jorb)) +! enddo +! do i = 1, n_act_orb +! iorb = list_act(i) +! tmp(j_inact,iorb) = dsign(accu/dble(n_act_orb),tmp_bis(j_inact,iorb)) +! tmp(iorb,j_inact) = dsign(accu/dble(n_act_orb),tmp_bis(j_inact,iorb)) +! enddo +!enddo + +!!! Symetrization act-act +!!accu = 0.d0 +!!do i = 1, n_act_orb +!! iorb = list_act(i) +!! accu += tmp_bis(iorb,iorb) +!!enddo +!!do i = 1, n_act_orb +!! iorb = list_act(i) +!! tmp(iorb,iorb) = accu/dble(n_act_orb) +!!enddo + + call bitstring_to_list(reunion_of_bitmask(1,1), occ(1,1), n_occ_alpha, N_int) + double precision :: maxvaldm,imax,jmax + maxvaldm = 0.d0 + imax = 1 + jmax = 1 + print*,'' + print*,'Inactive-active Part of the One body DM' + print*,'' + do i = 1,n_act_orb + iorb = list_act(i) + print*,'' + print*,'ACTIVE ORBITAL ',iorb + do j = 1, n_inact_orb + jorb = list_inact(j) + if(dabs(tmp(iorb,jorb)).gt.threshold_singles)then + print*,'INACTIVE ' + print*,'DM ',iorb,jorb,dabs(tmp(iorb,jorb)) + endif + enddo + do j = 1, n_virt_orb + jorb = list_virt(j) + if(dabs(tmp(iorb,jorb)).gt.threshold_singles)then + print*,'VIRT ' + print*,'DM ',iorb,jorb,dabs(tmp(iorb,jorb)) + endif + enddo + enddo + do i = 1, mo_tot_num + do j = i+1, mo_tot_num + if(dabs(tmp(i,j)).le.threshold_fobo_dm)then + tmp(i,j) = 0.d0 + tmp(j,i) = 0.d0 + endif + enddo + enddo + + label = "Natural" + call mo_as_eigvectors_of_mo_matrix(tmp,size(tmp,1),size(tmp,2),label,1) + soft_touch mo_coef + deallocate(tmp,occ) + + +end + +subroutine set_osoci_natural_mos + + implicit none + BEGIN_DOC + ! Set natural orbitals, obtained by diagonalization of the one-body density matrix in the MO basis + END_DOC + character*(64) :: label + double precision, allocatable :: tmp(:,:),tmp_bis(:,:) + integer, allocatable :: occ(:,:) + integer :: n_occ_alpha,i,i_core,j_core,iorb,jorb,j,i_inact,j_inact,i_virt,j_virt + allocate(tmp(size(one_body_dm_mo_alpha_osoci,1),size(one_body_dm_mo_alpha_osoci,2))) + allocate(tmp_bis(size(one_body_dm_mo_alpha_osoci,1),size(one_body_dm_mo_alpha_osoci,2))) + allocate (occ(N_int*bit_kind_size,2)) + + ! Negation to have the occupied MOs first after the diagonalization + tmp_bis = -one_body_dm_mo_alpha_osoci - one_body_dm_mo_beta_osoci + ! Set to Zero the core-inact-act-virt part + do i = 1, n_core_orb + i_core = list_core(i) + tmp_bis(i_core,i_core) = -10.d0 + do j = i+1, n_core_orb + j_core = list_core(j) + tmp_bis(i_core,j_core) = 0.d0 + tmp_bis(j_core,i_core) = 0.d0 + enddo + do j = 1, n_inact_orb + iorb = list_inact(j) + tmp_bis(i_core,iorb) = 0.d0 + tmp_bis(iorb,i_core) = 0.d0 + enddo + do j = 1, n_act_orb + iorb = list_act(j) + tmp_bis(i_core,iorb) = 0.d0 + tmp_bis(iorb,i_core) = 0.d0 + enddo + do j = 1, n_virt_orb + iorb = list_virt(j) + tmp_bis(i_core,iorb) = 0.d0 + tmp_bis(iorb,i_core) = 0.d0 + enddo + enddo + do i = 1, n_core_orb + print*,'dm core = ',list_core(i),tmp_bis(list_core(i),list_core(i)) + enddo + ! Set to Zero the inact-inact part to avoid arbitrary rotations + do i = 1, n_inact_orb + i_inact = list_inact(i) + do j = i+1, n_inact_orb + j_inact = list_inact(j) + tmp_bis(i_inact,j_inact) = 0.d0 + tmp_bis(j_inact,i_inact) = 0.d0 + enddo + enddo + + ! Set to Zero the inact-virt part to avoid arbitrary rotations + do i = 1, n_inact_orb + i_inact = list_inact(i) + do j = 1, n_virt_orb + j_virt = list_virt(j) + tmp_bis(i_inact,j_virt) = 0.d0 + tmp_bis(j_virt,i_inact) = 0.d0 + enddo + enddo + + ! Set to Zero the virt-virt part to avoid arbitrary rotations + do i = 1, n_virt_orb + i_virt = list_virt(i) + do j = i+1, n_virt_orb + j_virt = list_virt(j) + tmp_bis(i_virt,j_virt) = 0.d0 + tmp_bis(j_virt,i_virt) = 0.d0 + enddo + enddo + + double precision :: accu + ! Set to Zero the act-act part to avoid arbitrary rotations + do i = 1,n_act_orb + iorb = list_act(i) + do j = i+1,n_act_orb + jorb = list_act(j) + tmp_bis(iorb,jorb) = 0.d0 + tmp_bis(jorb,iorb) = 0.d0 + enddo + enddo + + tmp = tmp_bis + + call bitstring_to_list(reunion_of_bitmask(1,1), occ(1,1), n_occ_alpha, N_int) + double precision :: maxvaldm,imax,jmax + maxvaldm = 0.d0 + imax = 1 + jmax = 1 + print*,'' + print*,'Inactive-active Part of the One body DM' + print*,'' + do i = 1,n_act_orb + iorb = list_act(i) + print*,'' + print*,'ACTIVE ORBITAL ',iorb + do j = 1, n_inact_orb + jorb = list_inact(j) + if(dabs(tmp(iorb,jorb)).gt.threshold_singles)then + print*,'INACTIVE ' + print*,'DM ',iorb,jorb,dabs(tmp(iorb,jorb)) + endif + enddo + do j = 1, n_virt_orb + jorb = list_virt(j) + if(dabs(tmp(iorb,jorb)).gt.threshold_singles)then + print*,'VIRT ' + print*,'DM ',iorb,jorb,dabs(tmp(iorb,jorb)) + endif + enddo + enddo + do i = 1, mo_tot_num + do j = i+1, mo_tot_num + if(dabs(tmp(i,j)).le.threshold_fobo_dm)then + tmp(i,j) = 0.d0 + tmp(j,i) = 0.d0 + endif + enddo + enddo + + label = "Natural" + call mo_as_eigvectors_of_mo_matrix(tmp,size(tmp,1),size(tmp,2),label,1) + soft_touch mo_coef + deallocate(tmp,occ) + + +end + +subroutine check_symetry(i_hole,thr,test) + implicit none + integer, intent(in) :: i_hole + double precision, intent(in) :: thr + logical, intent(out) :: test + integer :: i,j,k,l + double precision :: accu + accu = 0.d0 + do i = 1, n_act_orb + accu += dabs(mo_mono_elec_integral(i_hole,list_act(i))) + enddo + if(accu.gt.thr)then + test = .True. + else + test = .false. + endif +end + +subroutine check_symetry_1h1p(i_hole,i_part,thr,test) + implicit none + integer, intent(in) :: i_hole,i_part + double precision, intent(in) :: thr + logical, intent(out) :: test + integer :: i,j,k,l + double precision :: accu + accu = dabs(mo_mono_elec_integral(i_hole,i_part)) + if(accu.gt.thr)then + test = .True. + else + test = .false. + endif +end + + + subroutine update_one_body_dm_mo + implicit none + integer :: i + double precision :: accu_tot,accu_sd + print*,'touched the one_body_dm_mo_beta' + one_body_dm_mo_alpha = one_body_dm_mo_alpha_osoci + one_body_dm_mo_beta = one_body_dm_mo_beta_osoci + touch one_body_dm_mo_alpha one_body_dm_mo_beta + accu_tot = 0.d0 + accu_sd = 0.d0 + do i = 1, mo_tot_num + accu_tot += one_body_dm_mo_alpha(i,i) + one_body_dm_mo_beta(i,i) + accu_sd += one_body_dm_mo_alpha(i,i) - one_body_dm_mo_beta(i,i) + enddo + print*,'accu_tot = ',accu_tot + print*,'accu_sdt = ',accu_sd + end + + subroutine provide_properties + implicit none + integer :: i + double precision :: accu + if(.True.)then + accu= 0.d0 + do i = 1, nucl_num + accu += mulliken_spin_densities(i) + print*,i,nucl_charge(i),mulliken_spin_densities(i) + enddo + print*,'Sum of Mulliken SD = ',accu + endif + end + diff --git a/plugins/FOBOCI/save_fock_diag_inactiv_virt.irp.f b/plugins/FOBOCI/save_fock_diag_inactiv_virt.irp.f new file mode 100644 index 00000000..dceb8546 --- /dev/null +++ b/plugins/FOBOCI/save_fock_diag_inactiv_virt.irp.f @@ -0,0 +1,7 @@ +program save_fock_inactiv_virt_mos + implicit none + call diag_inactive_virt_and_update_mos + call save_mos + + +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 074ec7e1..e6d0f7f2 100644 --- a/plugins/Full_CI/full_ci.irp.f +++ b/plugins/Full_CI/full_ci.irp.f @@ -62,15 +62,28 @@ program full_ci endif print *, 'N_det = ', N_det print *, 'N_states = ', N_states - print *, 'PT2 = ', pt2 - print *, 'E = ', CI_energy - print *, 'E(before)+PT2 = ', E_CI_before+pt2 + do k = 1, N_states + print*,'State ',k + print *, 'PT2 = ', pt2(k) + print *, 'E = ', CI_energy(k) + print *, 'E(before)+PT2 = ', E_CI_before(k)+pt2(k) + enddo print *, '-----' E_CI_before = CI_energy - call ezfio_set_full_ci_energy(CI_energy) - if (abort_all) then - exit + if(N_states.gt.1)then + print*,'Variational Energy difference' + do i = 2, N_states + print*,'Delta E = ',CI_energy(i) - CI_energy(1) + enddo endif + if(N_states.gt.1)then + print*,'Variational + perturbative Energy difference' + do i = 2, N_states + print*,'Delta E = ',E_CI_before(i)+ pt2(i) - (E_CI_before(1) + pt2(1)) + enddo + endif + E_CI_before = CI_energy + call ezfio_set_full_ci_energy(CI_energy) 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/.gitignore b/plugins/Hartree_Fock/.gitignore index 9f1c0929..f1a4ff4f 100644 --- a/plugins/Hartree_Fock/.gitignore +++ b/plugins/Hartree_Fock/.gitignore @@ -5,7 +5,6 @@ AO_Basis Bitmask Electrons Ezfio_files -Huckel_guess IRPF90_man IRPF90_temp Integrals_Bielec @@ -16,7 +15,6 @@ Makefile Makefile.depend Nuclei Pseudo -SCF Utils ZMQ ezfio_interface.irp.f diff --git a/plugins/Hartree_Fock/EZFIO.cfg b/plugins/Hartree_Fock/EZFIO.cfg index d8207cc4..2fa29cf0 100644 --- a/plugins/Hartree_Fock/EZFIO.cfg +++ b/plugins/Hartree_Fock/EZFIO.cfg @@ -26,3 +26,10 @@ default: Huckel type: double precision doc: Calculated HF energy interface: ezfio + +[no_oa_or_av_opt] +type: logical +doc: If true, skip the (inactive+core) --> (active) and the (active) --> (virtual) orbital rotations within the SCF procedure +interface: ezfio,provider,ocaml +default: False + diff --git a/plugins/Hartree_Fock/NEEDED_CHILDREN_MODULES b/plugins/Hartree_Fock/NEEDED_CHILDREN_MODULES index 85bdd3ad..6fb87e35 100644 --- a/plugins/Hartree_Fock/NEEDED_CHILDREN_MODULES +++ b/plugins/Hartree_Fock/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Integrals_Bielec MOGuess +Integrals_Bielec MOGuess Bitmask 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/Hartree_Fock/diagonalize_fock.irp.f b/plugins/Hartree_Fock/diagonalize_fock.irp.f index 7c424aeb..c80077b3 100644 --- a/plugins/Hartree_Fock/diagonalize_fock.irp.f +++ b/plugins/Hartree_Fock/diagonalize_fock.irp.f @@ -11,63 +11,35 @@ double precision, allocatable :: work(:), F(:,:), S(:,:) -! if (mo_tot_num == ao_num) then -! ! Solve H.C = E.S.C in AO basis set -! -! allocate(F(ao_num_align,ao_num), S(ao_num_align,ao_num) ) -! do j=1,ao_num -! do i=1,ao_num -! S(i,j) = ao_overlap(i,j) -! F(i,j) = Fock_matrix_ao(i,j) -! enddo -! enddo -! -! n = ao_num -! lwork = 1+6*n + 2*n*n -! liwork = 3 + 5*n -! -! allocate(work(lwork), iwork(liwork) ) -! -! lwork = -1 -! liwork = -1 -! -! call dsygvd(1,'v','u',ao_num,F,size(F,1),S,size(S,1),& -! diagonal_Fock_matrix_mo, work, lwork, iwork, liwork, info) -! -! if (info /= 0) then -! print *, irp_here//' failed : ', info -! stop 1 -! endif -! lwork = int(work(1)) -! liwork = iwork(1) -! deallocate(work,iwork) -! allocate(work(lwork), iwork(liwork) ) -! -! call dsygvd(1,'v','u',ao_num,F,size(F,1),S,size(S,1),& -! diagonal_Fock_matrix_mo, work, lwork, iwork, liwork, info) -! -! if (info /= 0) then -! print *, irp_here//' failed : ', info -! stop 1 -! endif -! do j=1,mo_tot_num -! do i=1,ao_num -! eigenvectors_Fock_matrix_mo(i,j) = F(i,j) -! enddo -! enddo -! -! deallocate(work, iwork, F, S) -! -! else -! - ! Solve H.C = E.C in MO basis set - allocate( F(mo_tot_num_align,mo_tot_num) ) do j=1,mo_tot_num do i=1,mo_tot_num F(i,j) = Fock_matrix_mo(i,j) enddo enddo + if(no_oa_or_av_opt)then + integer :: iorb,jorb + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_inact_orb + jorb = list_inact(j) + F(iorb,jorb) = 0.d0 + F(jorb,iorb) = 0.d0 + enddo + do j = 1, n_virt_orb + jorb = list_virt(j) + F(iorb,jorb) = 0.d0 + F(jorb,iorb) = 0.d0 + enddo + do j = 1, n_core_orb + jorb = list_core(j) + F(iorb,jorb) = 0.d0 + F(jorb,iorb) = 0.d0 + enddo + enddo + endif + + ! Insert level shift here diff --git a/plugins/MRCC_Utils/NEEDED_CHILDREN_MODULES b/plugins/MRCC_Utils/NEEDED_CHILDREN_MODULES index 5b16423e..7392852a 100644 --- a/plugins/MRCC_Utils/NEEDED_CHILDREN_MODULES +++ b/plugins/MRCC_Utils/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Selectors_full Generators_full Psiref_Utils +Perturbation Selectors_full Generators_full Psiref_Utils Psiref_CAS 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/MRCC_Utils/mrcc_dummy.irp.f b/plugins/MRCC_Utils/mrcc_dummy.irp.f new file mode 100644 index 00000000..8f1deda8 --- /dev/null +++ b/plugins/MRCC_Utils/mrcc_dummy.irp.f @@ -0,0 +1,4 @@ +program pouet + + +end diff --git a/plugins/OVB/NEEDED_CHILDREN_MODULES b/plugins/OVB/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..05706cac --- /dev/null +++ b/plugins/OVB/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Determinants Psiref_CAS diff --git a/plugins/OVB/README.rst b/plugins/OVB/README.rst new file mode 100644 index 00000000..13488c7e --- /dev/null +++ b/plugins/OVB/README.rst @@ -0,0 +1,20 @@ +======================= +OVB +======================= +The present module proposes an orthogonal Valence Bond analysis +of the wave function, that are the printing of the various Hamiltonian +matrix elements on the basis of the level of ionicity of the components +of the wave function. + +Assumptions : it supposes that you have some orthogonal local orbitals within +the active space and that you performed a CI within the active orbitals. +Such CI might be complete or not, no matter. + +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. diff --git a/plugins/OVB/ovb_components.irp.f b/plugins/OVB/ovb_components.irp.f new file mode 100644 index 00000000..82f0f931 --- /dev/null +++ b/plugins/OVB/ovb_components.irp.f @@ -0,0 +1,510 @@ + + use bitmasks + BEGIN_PROVIDER [integer, max_number_ionic] +&BEGIN_PROVIDER [integer, min_number_ionic] + BEGIN_DOC + ! Maximum and minimum number of ionization in psi_ref + END_DOC + implicit none + integer :: i,j + integer :: n_closed_shell_cas + max_number_ionic = 0 + min_number_ionic = 100000 + do i = 1, N_det_ref + j = n_closed_shell_cas(psi_ref(1,1,i),n_int) + if(j> max_number_ionic)then + max_number_ionic = j + endif + if(j< min_number_ionic)then + min_number_ionic = j + endif + + enddo + print*,'max_number_ionic = ',max_number_ionic + print*,'min_number_ionic = ',min_number_ionic +END_PROVIDER + + BEGIN_PROVIDER [integer, ionic_index, (min_number_ionic:max_number_ionic,0:N_det_ref)] +&BEGIN_PROVIDER [double precision, normalization_factor_ionic, (min_number_ionic:max_number_ionic, N_states)] + BEGIN_DOC + ! Index of the various determinants in psi_ref according to their level of ionicity + ! ionic_index(i,0) = number of determinants in psi_ref having the degree of ionicity "i" + ! ionic_index(i,j) = index of the determinants having the degree of ionicity "i" + END_DOC + implicit none + integer :: i,j,k + integer :: n_closed_shell_cas + double precision :: accu + ionic_index = 0 + do i = 1, N_det_ref + j = n_closed_shell_cas(psi_ref(1,1,i),n_int) + ionic_index(j,0) +=1 + ionic_index(j,ionic_index(j,0)) = i + enddo + do i = min_number_ionic,max_number_ionic + accu = 0.d0 + do j = 1, N_states + do k = 1, ionic_index(i,0) + accu += psi_ref_coef_diagonalized(ionic_index(i,k),j) * psi_ref_coef_diagonalized(ionic_index(i,k),j) + enddo + normalization_factor_ionic(i,j) = 1.d0/dsqrt(accu) + enddo + enddo + +END_PROVIDER + + + BEGIN_PROVIDER [double precision, H_OVB_naked, (min_number_ionic:max_number_ionic, min_number_ionic:max_number_ionic, n_states)] + BEGIN_DOC + ! Hamiltonian matrix expressed in the basis of contracted forms in terms of ionic structures + END_DOC + implicit none + integer :: i,j,istate,k,l + double precision :: accu,hij + do i = min_number_ionic,max_number_ionic + do j = min_number_ionic,max_number_ionic + do istate = 1, N_states + accu = 0.d0 + do k = 1, ionic_index(i,0) + do l = 1, ionic_index(j,0) + hij = ref_hamiltonian_matrix(ionic_index(i,k),ionic_index(j,l)) + accu += psi_ref_coef_diagonalized(ionic_index(i,k),istate) * normalization_factor_ionic(i,istate) * & + psi_ref_coef_diagonalized(ionic_index(j,l),istate) * normalization_factor_ionic(j,istate) * hij + enddo + enddo + H_OVB_naked(i,j,istate) = accu + enddo + enddo + enddo + END_PROVIDER + + BEGIN_PROVIDER [integer, n_couples_act_orb] + implicit none + n_couples_act_orb = 3 + END_PROVIDER + + BEGIN_PROVIDER [integer, couples_act_orb, (n_couples_act_orb,2) ] + implicit none + + couples_act_orb(1,1) = 20 + couples_act_orb(1,2) = 21 + couples_act_orb(2,1) = 22 + couples_act_orb(2,2) = 23 + couples_act_orb(3,1) = 24 + couples_act_orb(3,2) = 25 + + END_PROVIDER + + + BEGIN_PROVIDER [double precision, H_matrix_between_ionic_on_given_atom , (n_act_orb,n_act_orb)] + implicit none + BEGIN_DOC +! Hamiltonian matrix elements between the various contracted functions +! that have a negative charge on a given active orbital + END_DOC + integer :: i,j,k,l,jj,ii + integer(bit_kind), allocatable :: key_1(:,:),key_2(:,:) + double precision :: accu,hij + double precision :: norm + allocate (key_1(N_int,2),key_2(N_int,2)) + do i = 1, n_act_orb + j = i ! Diagonal part + norm = 0.d0 + accu = 0.d0 + do k = 1, n_det_ionic_on_given_atom(i) + norm += psi_coef_mono_ionic_on_given_atom(k,i) **2 + do ii = 1, N_int + key_1(ii,1) = psi_det_mono_ionic_on_given_atom(ii,1,k,i) + key_1(ii,2) = psi_det_mono_ionic_on_given_atom(ii,2,k,i) + enddo + do l = 1, n_det_ionic_on_given_atom(j) + do jj = 1, N_int + key_2(jj,1) = psi_det_mono_ionic_on_given_atom(jj,1,l,j) + key_2(jj,2) = psi_det_mono_ionic_on_given_atom(jj,2,l,j) + enddo + call i_H_j(key_1,key_2,N_int,hij) + accu += psi_coef_mono_ionic_on_given_atom(l,j) * psi_coef_mono_ionic_on_given_atom(k,i) * hij + enddo + enddo + H_matrix_between_ionic_on_given_atom(i,j) = accu + + + do j = i+1, n_act_orb ! Extra diagonal part + accu = 0.d0 + do k = 1, n_det_ionic_on_given_atom(i) + do jj = 1, N_int + key_1(jj,1) = psi_det_mono_ionic_on_given_atom(jj,1,k,i) + key_1(jj,2) = psi_det_mono_ionic_on_given_atom(jj,2,k,i) + enddo + do l = 1, n_det_ionic_on_given_atom(j) + do jj = 1, N_int + key_2(jj,1) = psi_det_mono_ionic_on_given_atom(jj,1,l,j) + key_2(jj,2) = psi_det_mono_ionic_on_given_atom(jj,2,l,j) + enddo + call i_H_j(key_1,key_2,N_int,hij) + accu += psi_coef_mono_ionic_on_given_atom(l,j) * psi_coef_mono_ionic_on_given_atom(k,i) * hij + enddo + enddo + H_matrix_between_ionic_on_given_atom(i,j) = accu + H_matrix_between_ionic_on_given_atom(j,i) = accu + enddo + enddo + + END_PROVIDER + + BEGIN_PROVIDER [double precision, H_matrix_between_ionic_on_given_atom_and_others , (n_act_orb,min_number_ionic:max_number_ionic)] + implicit none + use bitmasks + BEGIN_DOC +! Hamiltonian matrix elements between the various contracted functions +! that have a negative charge on a given active orbital +! and all the other fully contracted OVB structures + END_DOC + integer :: i,j,k,l,jj,ii + integer(bit_kind), allocatable :: key_1(:,:),key_2(:,:) + double precision :: accu,hij + double precision :: norm + allocate (key_1(N_int,2),key_2(N_int,2)) + + do i = 1, n_act_orb + do j = min_number_ionic,max_number_ionic + if(j==1)then + H_matrix_between_ionic_on_given_atom_and_others(i,j) = 0.d0 + endif + accu = 0.d0 + do k = 1, n_det_ionic_on_given_atom(i) + do jj = 1, N_int + key_1(jj,1) = psi_det_mono_ionic_on_given_atom(jj,1,k,i) + key_1(jj,2) = psi_det_mono_ionic_on_given_atom(jj,2,k,i) + enddo + do l = 1, ionic_index(j,0) + do ii = 1, N_int + key_2(ii,1) = psi_det_ovb(ii,1,l,j) + key_2(ii,2) = psi_det_ovb(ii,2,l,j) + enddo + call i_H_j(key_1,key_2,N_int,hij) + accu += psi_coef_ovb(l,j) * psi_coef_mono_ionic_on_given_atom(k,i) * hij + enddo + enddo + H_matrix_between_ionic_on_given_atom_and_others(i,j) = accu + enddo + enddo + + print*,'H_matrix_between_ionic_on_given_atom_and_others' + print*,'' + do i = 1, n_act_orb + write(*,'(I3,X,100(F16.7))'),H_matrix_between_ionic_on_given_atom_and_others(i,:) + enddo + + + +END_PROVIDER + + BEGIN_PROVIDER [integer, n_det_ionic_on_given_atom, (n_act_orb)] +&BEGIN_PROVIDER [double precision, normalization_factor_ionic_on_given_atom, (n_act_orb) ] +&BEGIN_PROVIDER [double precision, psi_coef_mono_ionic_on_given_atom, (N_det_ref,n_act_orb) ] +&BEGIN_PROVIDER [integer(bit_kind), psi_det_mono_ionic_on_given_atom, (N_int,2,N_det_ref,n_act_orb)] + implicit none + use bitmasks + BEGIN_DOC +! number of determinants that are mono ionic with the negative charge +! on a given atom, normalization_factor, array of determinants,and coefficients + END_DOC + integer :: i,j,k,l + ionicity_level = 1 + integer :: ionicity_level + logical :: doubly_occupied_array(n_act_orb) + n_det_ionic_on_given_atom = 0 + normalization_factor_ionic_on_given_atom = 0.d0 + do i = 1, ionic_index(ionicity_level,0) + call give_index_of_doubly_occ_in_active_space(psi_det(1,1,ionic_index(ionicity_level,i)),doubly_occupied_array) + do j = 1, n_act_orb + if(doubly_occupied_array(j))then + n_det_ionic_on_given_atom(j) += 1 + normalization_factor_ionic_on_given_atom(j) += psi_ref_coef_diagonalized(ionic_index(1,i),1) **2 + do k = 1, N_int + psi_det_mono_ionic_on_given_atom(k,1,n_det_ionic_on_given_atom(j),j) = psi_det(k,1,ionic_index(ionicity_level,i)) + psi_det_mono_ionic_on_given_atom(k,2,n_det_ionic_on_given_atom(j),j) = psi_det(k,2,ionic_index(ionicity_level,i)) + enddo + psi_coef_mono_ionic_on_given_atom(n_det_ionic_on_given_atom(j),j) = psi_ref_coef_diagonalized(ionic_index(1,i),1) + endif + enddo + enddo + integer :: i_count + i_count = 0 + do j = 1, n_act_orb + i_count += n_det_ionic_on_given_atom(j) + normalization_factor_ionic_on_given_atom(j) = 1.d0/dsqrt(normalization_factor_ionic_on_given_atom(j)) + enddo + if(i_count.ne.ionic_index(ionicity_level,0))then + print*,'PB with n_det_ionic_on_given_atom' + print*,'i_count = ',i_count + print*,'ionic_index(ionicity_level,0)',ionic_index(ionicity_level,0) + stop + endif + do j = 1, n_act_orb + do i = 1, n_det_ionic_on_given_atom(j) + psi_coef_mono_ionic_on_given_atom(i,j) = psi_coef_mono_ionic_on_given_atom(i,j) * normalization_factor_ionic_on_given_atom(j) + enddo + enddo + + + END_PROVIDER + + BEGIN_PROVIDER [integer(bit_kind), psi_det_ovb, (N_int,2,N_det_ref,min_number_ionic:max_number_ionic)] +&BEGIN_PROVIDER [double precision, psi_coef_ovb, (N_det_ref,min_number_ionic:max_number_ionic) ] + implicit none + BEGIN_DOC +! Array of the determinants belonging to each ovb structures (neutral, mono ionic, bi ionic etc ...) +! together with the arrays of coefficients + END_DOC + integer :: i,j,k,l + use bitmasks + integer :: ionicity_level,i_count + double precision :: accu + + do ionicity_level = min_number_ionic,max_number_ionic + accu = 0.d0 + do i = 1, ionic_index(ionicity_level,0) + do j = 1, N_int + psi_det_ovb(j,1,i,ionicity_level) = psi_det(j,1,ionic_index(ionicity_level,i)) + psi_det_ovb(j,2,i,ionicity_level) = psi_det(j,2,ionic_index(ionicity_level,i)) + enddo + psi_coef_ovb(i,ionicity_level) = psi_ref_coef_diagonalized(ionic_index(ionicity_level,i),1) * normalization_factor_ionic(ionicity_level,1) + accu += psi_coef_ovb(i,ionicity_level)**2 + enddo + accu = 1.d0/dsqrt(accu) + do i = 1, ionic_index(ionicity_level,0) + psi_coef_ovb(i,ionicity_level) = psi_coef_ovb(i,ionicity_level) * accu + enddo + accu = 0.d0 + do i = 1, ionic_index(ionicity_level,0) + accu += psi_coef_ovb(i,ionicity_level) **2 + enddo + enddo + +END_PROVIDER + + BEGIN_PROVIDER [double precision, H_matrix_psi_det_ovb, (min_number_ionic:max_number_ionic,min_number_ionic:max_number_ionic)] + implicit none + BEGIN_DOC +! H matrix between the fully contracted OVB forms + END_DOC + integer :: i,j,k,l,jj,ii + integer(bit_kind), allocatable :: key_1(:,:),key_2(:,:) + use bitmasks + double precision :: accu,hij + double precision :: norm + allocate (key_1(N_int,2),key_2(N_int,2)) + do i = min_number_ionic,max_number_ionic + do j = min_number_ionic,max_number_ionic + accu = 0.d0 + do k = 1, ionic_index(i,0) + do ii = 1, N_int + key_1(ii,1) = psi_det_ovb(ii,1,k,i) + key_1(ii,2) = psi_det_ovb(ii,2,k,i) + enddo + do l = 1, ionic_index(j,0) + do ii = 1, N_int + key_2(ii,1) = psi_det_ovb(ii,1,l,j) + key_2(ii,2) = psi_det_ovb(ii,2,l,j) + enddo + call i_H_j(key_1,key_2,N_int,hij) + accu += psi_coef_ovb(l,j) * psi_coef_ovb(k,i) * hij + enddo + enddo + H_matrix_psi_det_ovb(i,j) = accu + enddo + enddo + + END_PROVIDER + + BEGIN_PROVIDER [integer, number_first_ionic_couples] +&BEGIN_PROVIDER [logical , is_a_first_ionic_couple, (N_det_ref)] +&BEGIN_PROVIDER [double precision, normalization_factor_special_first_ionic, (2)] + implicit none + BEGIN_DOC + ! Number of determinants belonging to the class of first ionic + ! AND that have a couple of positive/negative charge belonging + ! to a couple of orbital couples_act_orb + ! If is_a_first_ionic_couple(i) = .True. then this determinant is a first ionic + ! and have a couple of positive/negative charge belonging + ! to a couple of orbital couples_act_orb + ! normalization factor (1) = 1/(sum c_i^2 .with. is_a_first_ionic_couple(i) = .True.) + ! normalization factor (2) = 1/(sum c_i^2 .with. is_a_first_ionic_couple(i) = .False.) + END_DOC + integer :: i,j + use bitmasks + number_first_ionic_couples = 0 + integer :: ionicity_level + logical :: couples_out(0:n_couples_act_orb) + integer(bit_kind) :: key_tmp(N_int,2) + ionicity_level = 1 + normalization_factor_special_first_ionic = 0.d0 + do i = 1, ionic_index(ionicity_level,0) + do j = 1, N_int + key_tmp(j,1) = psi_det(j,1,ionic_index(ionicity_level,i)) + key_tmp(j,2) = psi_det(j,2,ionic_index(ionicity_level,i)) + enddo + call doubly_occ_empty_in_couple(key_tmp,n_couples_act_orb,couples_act_orb,couples_out) + if(couples_out(0))then + number_first_ionic_couples +=1 + is_a_first_ionic_couple(i) = .True. + normalization_factor_special_first_ionic(1) += psi_ref_coef_diagonalized(ionic_index(1,i),1) **2 + else + is_a_first_ionic_couple(i) = .False. + normalization_factor_special_first_ionic(2) += psi_ref_coef_diagonalized(ionic_index(1,i),1) **2 + endif + enddo + normalization_factor_special_first_ionic(1) = 1.d0/dsqrt(normalization_factor_special_first_ionic(1)) + normalization_factor_special_first_ionic(2) = 1.d0/dsqrt(normalization_factor_special_first_ionic(2)) + print*,'number_first_ionic_couples = ',number_first_ionic_couples + END_PROVIDER + + + BEGIN_PROVIDER [integer, number_neutral_no_hund_couples] +&BEGIN_PROVIDER [logical , is_a_neutral_no_hund_couple, (N_det_ref)] +&BEGIN_PROVIDER [double precision, normalization_factor_neutra_no_hund_couple, (2)] +&BEGIN_PROVIDER [double precision, ratio_hund_no_hund ] + implicit none + BEGIN_DOC + ! Number of determinants belonging to the class of neutral determinants + ! AND that have a couple of alpha beta electrons in couple of orbital couples_act_orb + ! If is_a_neutral_no_hund_couple(i) = .True. then this determinant is a neutral determinants + ! and have a a couple of alpha beta electrons in couple of orbital couples_act_orb + ! normalization factor (1) = 1/sqrt(sum c_i^2 .with. is_a_neutral_no_hund_couple(i) = .True.) + ! normalization factor (2) = 1/sqrt(sum c_i^2 .with. is_a_neutral_no_hund_couple(i) = .False.) + END_DOC + integer :: i,j + use bitmasks + number_neutral_no_hund_couples = 0 + integer :: ionicity_level + logical :: couples_out(0:n_couples_act_orb) + integer(bit_kind) :: key_tmp(N_int,2) + integer :: ifirst_hund,ifirst_no_hund + double precision :: coef_ref_hund,coef_ref_no_hund + ifirst_hund = 0 + ifirst_no_hund = 0 + ionicity_level = 0 + normalization_factor_neutra_no_hund_couple = 0.d0 + do i = 1, ionic_index(ionicity_level,0) + do j = 1, N_int + key_tmp(j,1) = psi_det(j,1,ionic_index(ionicity_level,i)) + key_tmp(j,2) = psi_det(j,2,ionic_index(ionicity_level,i)) + enddo + call neutral_no_hund_in_couple(key_tmp,n_couples_act_orb,couples_act_orb,couples_out) + if(couples_out(0))then + if(ifirst_no_hund == 0)then + coef_ref_no_hund = psi_ref_coef_diagonalized(ionic_index(ionicity_level,i),1) + ifirst_no_hund = 1 + endif + number_neutral_no_hund_couples +=1 + is_a_neutral_no_hund_couple(i) = .True. + normalization_factor_neutra_no_hund_couple(1) += psi_ref_coef_diagonalized(ionic_index(ionicity_level,i),1) **2 + else + if(ifirst_hund == 0)then + coef_ref_hund = psi_ref_coef_diagonalized(ionic_index(ionicity_level,i),1) + ifirst_hund = 1 + endif + is_a_neutral_no_hund_couple(i) = .False. + normalization_factor_neutra_no_hund_couple(2) += psi_ref_coef_diagonalized(ionic_index(ionicity_level,i),1) **2 + endif + enddo + ratio_hund_no_hund = coef_ref_no_hund/coef_ref_hund + + normalization_factor_neutra_no_hund_couple(1) = 1.d0/dsqrt(normalization_factor_neutra_no_hund_couple(1)) + normalization_factor_neutra_no_hund_couple(2) = 1.d0/dsqrt(normalization_factor_neutra_no_hund_couple(2)) + print*,'number_neutral_no_hund_couples = ',number_neutral_no_hund_couples + END_PROVIDER + + BEGIN_PROVIDER [double precision, H_OVB_naked_first_ionic, (2,min_number_ionic:max_number_ionic,n_states)] +&BEGIN_PROVIDER [double precision, H_OVB_naked_first_ionic_between_ionic, (2,2,n_states)] + BEGIN_DOC + ! H_OVB_naked_first_ionic(1,i) = H_matrix element between the first ionic determinants belonging to is_a_first_ionic_couple = True + ! and the contracted ith ionic form + ! if i == 1 not defined + ! H_OVB_naked_first_ionic(2,i) = H_matrix element between the first ionic determinants belonging to is_a_first_ionic_couple = False + ! and the contracted ith ionic form + ! if i == 1 not defined + ! H_OVB_naked_first_ionic_between_ionic(1,1) = H_matrix element between the first ionic determinants belonging to is_a_first_ionic_couple = True + ! and the first ionic determinants belonging to is_a_first_ionic_couple = True + ! H_OVB_naked_first_ionic_between_ionic(1,2) = H_matrix element between the first ionic determinants belonging to is_a_first_ionic_couple = True + ! and the first ionic determinants belonging to is_a_first_ionic_couple = False + ! H_OVB_naked_first_ionic_between_ionic(2,2) = H_matrix element between the first ionic determinants belonging to is_a_first_ionic_couple = False + ! and the first ionic determinants belonging to is_a_first_ionic_couple = False + END_DOC + implicit none + integer :: i,j,istate,k,l + double precision :: accu_1,accu_2,hij + H_OVB_naked_first_ionic = 0.d0 + H_OVB_naked_first_ionic_between_ionic = 0.d0 + i = 1 + do j = min_number_ionic,max_number_ionic + if(j==1)cycle + do istate = 1, N_states + accu_1 = 0.d0 + accu_2 = 0.d0 + do k = 1, ionic_index(i,0) + if(is_a_first_ionic_couple(k))then + do l = 1, ionic_index(j,0) + hij = ref_hamiltonian_matrix(ionic_index(i,k),ionic_index(j,l)) + accu_1 += psi_ref_coef_diagonalized(ionic_index(i,k),istate) * normalization_factor_special_first_ionic(1) * & + psi_ref_coef_diagonalized(ionic_index(j,l),istate) * normalization_factor_ionic(j,istate) * hij + enddo + else + do l = 1, ionic_index(j,0) + hij = ref_hamiltonian_matrix(ionic_index(i,k),ionic_index(j,l)) + accu_2 += psi_ref_coef_diagonalized(ionic_index(i,k),istate) * normalization_factor_special_first_ionic(2) * & + psi_ref_coef_diagonalized(ionic_index(j,l),istate) * normalization_factor_ionic(j,istate) * hij + enddo + endif + enddo + H_OVB_naked_first_ionic(1,j,istate) = accu_1 + H_OVB_naked_first_ionic(2,j,istate) = accu_2 + enddo + enddo + + + do istate = 1, N_states + accu_1 = 0.d0 + accu_2 = 0.d0 + integer :: i_count + i_count = 0 + do k = 1, ionic_index(1,0) + do l = 1, ionic_index(1,0) + hij = ref_hamiltonian_matrix(ionic_index(1,k),ionic_index(1,l)) + accu_1 = hij * psi_ref_coef_diagonalized(ionic_index(1,k),istate) * psi_ref_coef_diagonalized(ionic_index(1,l),istate) + if(is_a_first_ionic_couple(k).and. is_a_first_ionic_couple(l))then + H_OVB_naked_first_ionic_between_ionic(1,1,istate) += accu_1 * normalization_factor_special_first_ionic(1) **2 + elseif(is_a_first_ionic_couple(k).and. .not.is_a_first_ionic_couple(l))then + i_count += 1 + H_OVB_naked_first_ionic_between_ionic(1,2,istate) += accu_1 * & + normalization_factor_special_first_ionic(1) *normalization_factor_special_first_ionic(2) +! elseif(is_a_first_ionic_couple(l).and. .not.is_a_first_ionic_couple(k))then +! i_count += 1 +! H_OVB_naked_first_ionic_between_ionic(1,2,istate) += accu_1 * & +! normalization_factor_special_first_ionic(1) *normalization_factor_special_first_ionic(2) + elseif(.not.is_a_first_ionic_couple(k).and. .not.is_a_first_ionic_couple(l))then + H_OVB_naked_first_ionic_between_ionic(2,2,istate) += accu_1 * normalization_factor_special_first_ionic(2) **2 + endif + enddo + enddo + enddo + print*,'i_count = ',i_count + print*,'number_first_ionic_couples**2 = ',ionic_index(1,0) * number_first_ionic_couples + + double precision :: convert_hartree_ev + convert_hartree_ev = 27.211399d0 + print*,'Special H matrix' + do i = 1,2 + write(*,'(I4,X,10(F16.8 ,4X))')i, H_OVB_naked_first_ionic(i,:,1) + enddo + + print*,'Special H matrix bis' + do i = 1,2 + write(*,'(I4,X,10(F16.8 ,4X))')i, H_OVB_naked_first_ionic_between_ionic(i,:,1) + enddo + + + END_PROVIDER + diff --git a/plugins/OVB/print_ovb.irp.f b/plugins/OVB/print_ovb.irp.f new file mode 100644 index 00000000..9e333c15 --- /dev/null +++ b/plugins/OVB/print_ovb.irp.f @@ -0,0 +1,27 @@ +program print_OVB + implicit none + read_wf = .True. + call provide_all + +end + +subroutine provide_all + implicit none + integer :: i,j,k,l,istate + do istate= 1, N_states + print*,'-------------------' + print*,'ISTATE = ',istate + print*,'-------------------' + print*,'CAS MATRIX ' + print*,'' + do i = min_number_ionic,max_number_ionic + write(*,'(I4,X,10(F8.5 ,4X))')i, H_OVB_naked(i,:,istate) + enddo + print*,'' + print*,'-------------------' + print*,'-------------------' + enddo + + +end + diff --git a/plugins/OVB_effective_Hamiltonian/NEEDED_CHILDREN_MODULES b/plugins/OVB_effective_Hamiltonian/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..01b1f4b9 --- /dev/null +++ b/plugins/OVB_effective_Hamiltonian/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Dressed_Ref_Hamiltonian OVB diff --git a/plugins/OVB_effective_Hamiltonian/OVB_effective_H.irp.f b/plugins/OVB_effective_Hamiltonian/OVB_effective_H.irp.f new file mode 100644 index 00000000..4ef79aeb --- /dev/null +++ b/plugins/OVB_effective_Hamiltonian/OVB_effective_H.irp.f @@ -0,0 +1,59 @@ + BEGIN_PROVIDER [double precision, H_OVB_dressing, (min_number_ionic:max_number_ionic, min_number_ionic:max_number_ionic, n_states)] + BEGIN_DOC + ! Hamiltonian matrix expressed in the basis of all the + END_DOC + implicit none + integer :: i,j,istate,k,l + double precision :: accu,hij + do i = min_number_ionic,max_number_ionic + do j = min_number_ionic,max_number_ionic + accu = 0.d0 + do istate = 1, N_states + do k = 1, ionic_index(i,0) + do l = 1, ionic_index(j,0) + hij = dressing_ref_hamiltonian(ionic_index(i,k),ionic_index(j,l),istate) +! accu += psi_ref_coef(ionic_index(i,k),istate) * normalization_factor_ionic(i,istate) * & +! psi_ref_coef(ionic_index(j,l),istate) * normalization_factor_ionic(j,istate) * hij + accu += psi_ref_coef_dressed(ionic_index(i,k),istate) * normalization_factor_ionic_dressed(i,istate) * & + psi_ref_coef_dressed(ionic_index(j,l),istate) * normalization_factor_ionic_dressed(j,istate) * hij + enddo + enddo + H_OVB_dressing(i,j,istate) = accu + enddo + enddo + enddo + END_PROVIDER + + + + BEGIN_PROVIDER [double precision, H_OVB_total_dressed, (min_number_ionic:max_number_ionic, min_number_ionic:max_number_ionic, n_states)] + BEGIN_DOC + ! Hamiltonian matrix expressed in the basis of all the + END_DOC + implicit none + integer :: i,j,istate + double precision :: accu,hij + do i = min_number_ionic,max_number_ionic + do j = min_number_ionic,max_number_ionic + do istate = 1, N_states + H_OVB_total_dressed(i,j,istate) = H_OVB_dressing(i,j,istate) + H_OVB_naked(i,j,istate) + enddo + enddo + enddo + END_PROVIDER + + BEGIN_PROVIDER [double precision, normalization_factor_ionic_dressed, (min_number_ionic:max_number_ionic, N_states) ] + implicit none + integer :: i,j,istate,k + double precision :: accu + do j = min_number_ionic, max_number_ionic + do istate = 1, N_states + accu = 0.d0 + do k = 1, ionic_index(j,0) + accu += psi_ref_coef_dressed(ionic_index(j,k),istate) **2 + enddo + normalization_factor_ionic_dressed(j,istate) = 1.d0/dsqrt(accu) + enddo + enddo + + END_PROVIDER diff --git a/plugins/OVB_effective_Hamiltonian/README.rst b/plugins/OVB_effective_Hamiltonian/README.rst new file mode 100644 index 00000000..a21ffcc6 --- /dev/null +++ b/plugins/OVB_effective_Hamiltonian/README.rst @@ -0,0 +1,13 @@ +========================= +OVB_effective_Hamiltonian +========================= +Dressing of the OVB matrix by use of the Dressed_Ref_Hamiltonian dressing + +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. diff --git a/plugins/OVB_effective_Hamiltonian/print_OVB_effective_H_diagonalized.irp.f b/plugins/OVB_effective_Hamiltonian/print_OVB_effective_H_diagonalized.irp.f new file mode 100644 index 00000000..bbd29b8e --- /dev/null +++ b/plugins/OVB_effective_Hamiltonian/print_OVB_effective_H_diagonalized.irp.f @@ -0,0 +1,101 @@ +program print + read_wf = .True. + touch read_wf + call provide_all_stuffs +end +subroutine provide_all_stuffs + implicit none + provide ref_hamiltonian_matrix dressing_ref_hamiltonian + integer :: i,j,istate + double precision, allocatable :: psi_restart_ref_normalized(:),psi_ref_zeroth_order(:),psi_ref_dressed(:) + double precision, allocatable :: eigvalues(:),eigvectors(:,:) + double precision, allocatable :: H_naked(:,:) + double precision, allocatable :: H_dressed(:,:) + double precision, allocatable :: H_print(:,:) + double precision :: accu_norm + allocate (H_dressed(max_number_ionic+1,max_number_ionic+1)) + allocate (H_print(min_number_ionic:max_number_ionic,min_number_ionic:max_number_ionic)) + allocate (H_naked(max_number_ionic+1,max_number_ionic+1)) + allocate (psi_restart_ref_normalized(min_number_ionic:max_number_ionic)) + allocate (psi_ref_zeroth_order(min_number_ionic:max_number_ionic)) + print*,'# nuclear_repulsion = ',nuclear_repulsion + allocate (psi_ref_dressed(min_number_ionic:max_number_ionic)) + allocate (eigvalues(max_number_ionic+1)) + allocate (eigvectors(max_number_ionic+1,max_number_ionic+1)) + + do istate= 1, N_states + print*,'ISTATE = ',istate + do i = min_number_ionic,max_number_ionic + do j = min_number_ionic,max_number_ionic + H_print(i,j) = H_OVB_naked(j,i,istate) + enddo + enddo + do i = min_number_ionic,max_number_ionic + H_print(i,i) -= H_OVB_naked(min_number_ionic,min_number_ionic,istate) + enddo + + print*,'Ref Hamiltonian matrix emelent = ',H_OVB_naked(min_number_ionic,min_number_ionic,istate) + print*,'-------------------' + print*,'-------------------' + print*,'CAS MATRIX ' + print*,'' + do i = min_number_ionic,max_number_ionic + write(*,'(I4,X,10(F8.5 ,4X))')i, H_print(i,:) + enddo + print*,'CAS MATRIX DRESSING' + print*,'' + do i = min_number_ionic,max_number_ionic + write(*,'(I4,X,10(F8.5 ,4X))')i, H_OVB_dressing(i,:,istate) + enddo + print*,'' + print*,'-------------------' + print*,'-------------------' + print*,'CAS MATRIX DRESSED ' + print*,'' + do i = min_number_ionic,max_number_ionic + do j = min_number_ionic,max_number_ionic + H_print(i,j) = H_OVB_total_dressed(j,i,istate) + enddo + enddo + do i = min_number_ionic,max_number_ionic + H_print(i,i) -= H_OVB_total_dressed(min_number_ionic,min_number_ionic,istate) + enddo + do i = min_number_ionic,max_number_ionic + write(*,'(I4,X,10(F8.5 ,4X))')i, H_print(i,:) + enddo + print*,'' + do i = min_number_ionic,max_number_ionic + do j = min_number_ionic,max_number_ionic + H_dressed(j+1,i+1) = H_OVB_total_dressed(i,j,istate) + H_naked(j+1,i+1) = H_OVB_naked(i,j,istate) + enddo + enddo + + call lapack_diagd(eigvalues,eigvectors,H_naked,max_number_ionic+1,max_number_ionic+1) + print*,'E+PT2 = ',eigvalues(istate) + nuclear_repulsion + do i = min_number_ionic,max_number_ionic + psi_ref_zeroth_order(i) = eigvectors(i+1,istate) + enddo + + + + call lapack_diagd(eigvalues,eigvectors,H_dressed,max_number_ionic+1,max_number_ionic+1) + do i = min_number_ionic,max_number_ionic + psi_ref_dressed(i) = eigvectors(i+1,istate) + enddo + print*,'E+PT2 = ',eigvalues(istate) + nuclear_repulsion + do i = min_number_ionic,max_number_ionic + write(*,'(10(F10.7 ,4X))') psi_ref_dressed(i)/psi_ref_dressed(min_number_ionic) ,psi_ref_zeroth_order(i)/psi_ref_zeroth_order(min_number_ionic) + enddo + enddo + + deallocate (H_dressed) + deallocate (H_naked) + deallocate (psi_restart_ref_normalized) + deallocate (psi_ref_zeroth_order) + deallocate (psi_ref_dressed) + + deallocate (eigvalues) + deallocate (eigvectors) + +end diff --git a/plugins/OVB_effective_Hamiltonian/save_wf_only_ionic_and_1p_amplitudes.irp.f b/plugins/OVB_effective_Hamiltonian/save_wf_only_ionic_and_1p_amplitudes.irp.f new file mode 100644 index 00000000..4398b152 --- /dev/null +++ b/plugins/OVB_effective_Hamiltonian/save_wf_only_ionic_and_1p_amplitudes.irp.f @@ -0,0 +1,90 @@ +program save_wf + implicit none + read_wf = .True. + touch read_wf + call routine +end + +subroutine routine + implicit none + use bitmasks + integer :: i,j,k,l + integer(bit_kind), allocatable :: psi_save_final(:,:,:) + double precision, allocatable :: psi_coef_save_final(:,:) + integer :: index_ref_determinants_save(psi_det_size) + integer :: n_det_ref_determinants_save + integer :: index_non_ref_determinants_save(psi_det_size) + integer :: n_det_non_ref_determinants_save + + integer :: n_det_save_final + integer :: number_of_particles + n_det_ref_determinants_save = 0 + integer :: ionic_level + ionic_level = 1 + do i = 1, ionic_index(ionic_level,0) ! number of determinants in the ref wf that are neutrals + n_det_ref_determinants_save +=1 + index_ref_determinants_save(n_det_ref_determinants_save) = ionic_index(ionic_level,i) + enddo + ! save all the 1p determinants in order to have the single excitations + ! on the top of the neutral structures + n_det_non_ref_determinants_save = 0 + do i = 1, N_det_non_ref + if(number_of_particles(psi_non_ref(1,1,i))==1)then + n_det_non_ref_determinants_save +=1 + index_non_ref_determinants_save(n_det_non_ref_determinants_save) = i + endif + enddo + print*,'n_det_ref_determinants_save = ',n_det_ref_determinants_save + print*,'n_det_non_ref_determinants_save = ',n_det_non_ref_determinants_save + n_det_save_final = n_det_ref_determinants_save + n_det_non_ref_determinants_save + allocate (psi_save_final(N_int,2,n_det_save_final)) + allocate (psi_coef_save_final(n_det_save_final,1)) + integer :: n_det_tmp + n_det_tmp = 0 + do i = 1, n_det_ref_determinants_save ! set the CAS determinants to psi_save_final + n_det_tmp +=1 + do j = 1, N_int + psi_save_final(j,1,n_det_tmp) = psi_ref(j,1,index_ref_determinants_save(i)) + psi_save_final(j,2,n_det_tmp) = psi_ref(j,2,index_ref_determinants_save(i)) + enddo + psi_coef_save_final(n_det_tmp,1) = psi_ref_coef(index_ref_determinants_save(i),1) + enddo + pause + do i = 1, n_det_non_ref_determinants_save ! set the non ref determinants to psi_save_final + n_det_tmp +=1 + do j = 1, N_int + psi_save_final(j,1,n_det_tmp) = psi_non_ref(j,1,index_non_ref_determinants_save(i)) + psi_save_final(j,2,n_det_tmp) = psi_non_ref(j,2,index_non_ref_determinants_save(i)) + enddo + accu = 0.d0 + double precision :: t_ik,hij + do j = 1, n_det_ref_determinants_save + call i_H_j(psi_non_ref(1,1,index_non_ref_determinants_save(i)),psi_ref(1,1,index_ref_determinants_save(j)),N_int,hij) + t_ik = hij * lambda_mrcc(1,index_non_ref_determinants_save(i)) + accu += psi_ref_coef(index_ref_determinants_save(j),1) * t_ik + enddo + psi_coef_save_final(n_det_tmp,1) = accu + enddo + double precision :: accu + accu = 0.d0 + do i = 1, n_det_save_final + accu += psi_coef_save_final(i,1) * psi_coef_save_final(i,1) + enddo + accu = 1.d0/dsqrt(accu) + do i = 1, n_det_save_final + psi_coef_save_final(i,1) = accu * psi_coef_save_final(i,1) + enddo + + do i = 1, n_det_save_final + print*,'' + print*,'Det' + call debug_det(psi_save_final(1,1,i),N_int) + print*,'coef = ',psi_coef_save_final(i,1) + enddo + + call save_wavefunction_general(n_det_save_final,1,psi_save_final,n_det_save_final,psi_coef_save_final) + deallocate (psi_save_final) + deallocate (psi_coef_save_final) + + +end diff --git a/plugins/OVB_effective_Hamiltonian/save_wf_only_neutral_and_1p_amplitudes.irp.f b/plugins/OVB_effective_Hamiltonian/save_wf_only_neutral_and_1p_amplitudes.irp.f new file mode 100644 index 00000000..a4b83d33 --- /dev/null +++ b/plugins/OVB_effective_Hamiltonian/save_wf_only_neutral_and_1p_amplitudes.irp.f @@ -0,0 +1,88 @@ +program save_wf + implicit none + read_wf = .True. + touch read_wf + call routine +end + +subroutine routine + implicit none + use bitmasks + integer :: i,j,k,l + integer(bit_kind), allocatable :: psi_save_final(:,:,:) + double precision, allocatable :: psi_coef_save_final(:,:) + integer :: index_ref_determinants_save(psi_det_size) + integer :: n_det_ref_determinants_save + integer :: index_non_ref_determinants_save(psi_det_size) + integer :: n_det_non_ref_determinants_save + + integer :: n_det_save_final + integer :: number_of_particles + n_det_ref_determinants_save = 0 + do i = 1, ionic_index(0,0) ! number of determinants in the ref wf that are neutrals + n_det_ref_determinants_save +=1 + index_ref_determinants_save(n_det_ref_determinants_save) = ionic_index(0,i) + enddo + ! save all the 1p determinants in order to have the single excitations + ! on the top of the neutral structures + n_det_non_ref_determinants_save = 0 + do i = 1, N_det_non_ref + if(number_of_particles(psi_non_ref(1,1,i))==1)then + n_det_non_ref_determinants_save +=1 + index_non_ref_determinants_save(n_det_non_ref_determinants_save) = i + endif + enddo + print*,'n_det_ref_determinants_save = ',n_det_ref_determinants_save + print*,'n_det_non_ref_determinants_save = ',n_det_non_ref_determinants_save + n_det_save_final = n_det_ref_determinants_save + n_det_non_ref_determinants_save + allocate (psi_save_final(N_int,2,n_det_save_final)) + allocate (psi_coef_save_final(n_det_save_final,1)) + integer :: n_det_tmp + n_det_tmp = 0 + do i = 1, n_det_ref_determinants_save ! set the CAS determinants to psi_save_final + n_det_tmp +=1 + do j = 1, N_int + psi_save_final(j,1,n_det_tmp) = psi_ref(j,1,index_ref_determinants_save(i)) + psi_save_final(j,2,n_det_tmp) = psi_ref(j,2,index_ref_determinants_save(i)) + enddo + psi_coef_save_final(n_det_tmp,1) = psi_ref_coef(index_ref_determinants_save(i),1) + enddo + pause + do i = 1, n_det_non_ref_determinants_save ! set the non ref determinants to psi_save_final + n_det_tmp +=1 + do j = 1, N_int + psi_save_final(j,1,n_det_tmp) = psi_non_ref(j,1,index_non_ref_determinants_save(i)) + psi_save_final(j,2,n_det_tmp) = psi_non_ref(j,2,index_non_ref_determinants_save(i)) + enddo + accu = 0.d0 + double precision :: t_ik,hij + do j = 1, n_det_ref_determinants_save + call i_H_j(psi_non_ref(1,1,index_non_ref_determinants_save(i)),psi_ref(1,1,index_ref_determinants_save(j)),N_int,hij) + t_ik = hij * lambda_mrcc(1,index_non_ref_determinants_save(i)) + accu += psi_ref_coef(index_ref_determinants_save(j),1) * t_ik + enddo + psi_coef_save_final(n_det_tmp,1) = accu + enddo + double precision :: accu + accu = 0.d0 + do i = 1, n_det_save_final + accu += psi_coef_save_final(i,1) * psi_coef_save_final(i,1) + enddo + accu = 1.d0/dsqrt(accu) + do i = 1, n_det_save_final + psi_coef_save_final(i,1) = accu * psi_coef_save_final(i,1) + enddo + + do i = 1, n_det_save_final + print*,'' + print*,'Det' + call debug_det(psi_save_final(1,1,i),N_int) + print*,'coef = ',psi_coef_save_final(i,1) + enddo + + call save_wavefunction_general(n_det_save_final,1,psi_save_final,n_det_save_final,psi_coef_save_final) + deallocate (psi_save_final) + deallocate (psi_coef_save_final) + + +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/Properties/hyperfine_constants.irp.f b/plugins/Properties/hyperfine_constants.irp.f new file mode 100644 index 00000000..c1d88d2c --- /dev/null +++ b/plugins/Properties/hyperfine_constants.irp.f @@ -0,0 +1,135 @@ +BEGIN_PROVIDER [double precision, spin_density_at_nucleous, (nucl_num)] + implicit none + BEGIN_DOC +! value of the spin density at each nucleus + END_DOC + integer :: i,j,k + do i = 1, nucl_num + double precision :: r(3),accu,aos_array(ao_num) + accu = 0.d0 + r(1:3) = nucl_coord(i,1:3) + call give_all_aos_at_r(r,aos_array) + do j = 1, ao_num + do k = 1, ao_num + accu += one_body_spin_density_ao(k,j) * aos_array(k) * aos_array(j) + enddo + enddo + spin_density_at_nucleous(i) = accu + enddo +END_PROVIDER + + BEGIN_PROVIDER [double precision, spin_density_at_nucleous_from_mo, (nucl_num)] +&BEGIN_PROVIDER [double precision, spin_density_at_nucleous_contrib_per_mo, (nucl_num,mo_tot_num)] + implicit none + BEGIN_DOC +! value of the spin density at each nucleus + END_DOC + integer :: i,j,k,l,m + do i = 1, nucl_num + double precision :: r(3),accu,aos_array(ao_num) + double precision :: contrib + double precision :: mo_values(mo_tot_num) + accu = 0.d0 + r(1:3) = nucl_coord(i,1:3) + call give_all_aos_at_r(r,aos_array) + spin_density_at_nucleous_from_mo(i) = 0.d0 + do k = 1, mo_tot_num + mo_values(k) = 0.d0 + do j = 1, ao_num + mo_values(k) += mo_coef(j,k) * aos_array(j) + enddo + enddo + do k = 1, mo_tot_num + spin_density_at_nucleous_contrib_per_mo(i,k) = 0.d0 + do m = 1, mo_tot_num + contrib = one_body_spin_density_mo(k,m) * mo_values(k) * mo_values(m) + spin_density_at_nucleous_from_mo(i) += contrib + spin_density_at_nucleous_contrib_per_mo(i,k) += contrib + enddo + enddo + enddo +END_PROVIDER + + BEGIN_PROVIDER [double precision, spin_density_at_nucleous_contrib_mo, (nucl_num,mo_tot_num,mo_tot_num)] +&BEGIN_PROVIDER [double precision, spin_density_at_nucleous_contrib_mo_test, (nucl_num)] + implicit none + BEGIN_DOC +! value of the spin density at each nucleus + END_DOC + integer :: i,j,k,l,m + spin_density_at_nucleous_contrib_mo_test = 0.d0 + do i = 1, nucl_num + double precision :: r(3),accu,aos_array(ao_num) + double precision :: c_i1,c_j1 + r(1:3) = nucl_coord(i,1:3) + call give_all_aos_at_r(r,aos_array) + do k = 1, mo_tot_num + do m = 1, mo_tot_num + accu = 0.d0 + do j = 1, ao_num + c_i1 = mo_coef(j,k) + do l = 1, ao_num + c_j1 = c_i1*mo_coef(l,m) + accu += one_body_spin_density_mo(k,m) * aos_array(l) * aos_array(j) * c_j1 + enddo + enddo + spin_density_at_nucleous_contrib_mo(i,k,m) = accu + spin_density_at_nucleous_contrib_mo_test(i) += accu + enddo + enddo + enddo +END_PROVIDER + + BEGIN_PROVIDER [double precision, conversion_factor_mhz_hcc, (100)] +&BEGIN_PROVIDER [double precision, conversion_factor_gauss_hcc, (100)] +&BEGIN_PROVIDER [double precision, conversion_factor_cm_1_hcc, (100)] + BEGIN_DOC +! Conversion factor for the calculation of the hcc, according to the nuclear charge + END_DOC + + conversion_factor_mhz_hcc =0.d0 + conversion_factor_mhz_hcc =0.d0 + conversion_factor_mhz_hcc =0.d0 + + + ! hydrogen + conversion_factor_mhz_hcc(1) = 4469.84692227102460d0 + conversion_factor_gauss_hcc(1) = 1594.95296390862904d0 + conversion_factor_cm_1_hcc(1) = 1490.98044430157870d0 + + ! Li + conversion_factor_mhz_hcc(3) = 1737.2746512855997d0 + conversion_factor_gauss_hcc(3) = 619.9027742370165d0 + conversion_factor_cm_1_hcc(3) = 579.4924475562677d0 + + ! carbon + conversion_factor_mhz_hcc(6) = 1124.18303629792945d0 + conversion_factor_gauss_hcc(6) = 401.136570647523058d0 + conversion_factor_cm_1_hcc(6) = 374.987097339830086d0 + + ! nitrogen + conversion_factor_mhz_hcc(7) = 323.102093833793390d0 + conversion_factor_gauss_hcc(7) = 115.290892768082614d0 + conversion_factor_cm_1_hcc(7) = 107.775257586297698d0 + + ! Oxygen + conversion_factor_mhz_hcc(8) = -606.1958551736545d0 + conversion_factor_gauss_hcc(8) = -216.30574771560407d0 + conversion_factor_cm_1_hcc(8) = -202.20517197179822d0 + +END_PROVIDER + + BEGIN_PROVIDER [double precision, iso_hcc_mhz, (nucl_num)] +&BEGIN_PROVIDER [double precision, iso_hcc_gauss, (nucl_num)] +&BEGIN_PROVIDER [double precision, iso_hcc_cm_1, (nucl_num)] + BEGIN_DOC +! isotropic hyperfine coupling constants among the various atoms + END_DOC + integer :: i + do i = 1, nucl_num + iso_hcc_mhz(i) = conversion_factor_mhz_hcc(nint(nucl_charge(i))) * spin_density_at_nucleous(i) !* 0.5d0 + iso_hcc_gauss(i) = conversion_factor_gauss_hcc(nint(nucl_charge(i))) * spin_density_at_nucleous(i)!* 0.5d0 + iso_hcc_cm_1(i) = conversion_factor_cm_1_hcc(nint(nucl_charge(i))) * spin_density_at_nucleous(i) !*0.5d0 + enddo + +END_PROVIDER diff --git a/plugins/Properties/mulliken.irp.f b/plugins/Properties/mulliken.irp.f new file mode 100644 index 00000000..d56c9a44 --- /dev/null +++ b/plugins/Properties/mulliken.irp.f @@ -0,0 +1,107 @@ + +BEGIN_PROVIDER [double precision, spin_population, (ao_num_align,ao_num)] + implicit none + integer :: i,j + BEGIN_DOC +! spin population on the ao basis : +! spin_population(i,j) = rho_AO(alpha)(i,j) - rho_AO(beta)(i,j) * + END_DOC + spin_population = 0.d0 + do i = 1, ao_num + do j = 1, ao_num + spin_population(j,i) = one_body_spin_density_ao(i,j) * ao_overlap(i,j) + enddo + enddo +END_PROVIDER + +BEGIN_PROVIDER [double precision, spin_population_angular_momentum, (0:ao_l_max)] + implicit none + integer :: i + double precision :: accu + spin_population_angular_momentum = 0.d0 + do i = 1, ao_num + spin_population_angular_momentum(ao_l(i)) += spin_gross_orbital_product(i) + enddo + +END_PROVIDER + + +BEGIN_PROVIDER [double precision, spin_gross_orbital_product, (ao_num)] + implicit none + spin_gross_orbital_product = 0.d0 + integer :: i,j + BEGIN_DOC +! gross orbital product for the spin population + END_DOC + do i = 1, ao_num + do j = 1, ao_num + spin_gross_orbital_product(i) += spin_population(j,i) + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [double precision, mulliken_spin_densities, (nucl_num)] + implicit none + integer :: i,j + BEGIN_DOC +!ATOMIC SPIN POPULATION (ALPHA MINUS BETA) + END_DOC + mulliken_spin_densities = 0.d0 + do i = 1, ao_num + mulliken_spin_densities(ao_nucl(i)) += spin_gross_orbital_product(i) + enddo + +END_PROVIDER + + BEGIN_PROVIDER [double precision, electronic_population_alpha, (ao_num_align,ao_num)] +&BEGIN_PROVIDER [double precision, electronic_population_beta, (ao_num_align,ao_num)] + implicit none + integer :: i,j + BEGIN_DOC +! spin population on the ao basis : +! spin_population(i,j) = rho_AO(alpha)(i,j) - rho_AO(beta)(i,j) * + END_DOC + electronic_population_alpha = 0.d0 + electronic_population_beta = 0.d0 + do i = 1, ao_num + do j = 1, ao_num + electronic_population_alpha(j,i) = one_body_dm_ao_alpha(i,j) * ao_overlap(i,j) + electronic_population_beta(j,i) = one_body_dm_ao_beta(i,j) * ao_overlap(i,j) + enddo + enddo + +END_PROVIDER + + BEGIN_PROVIDER [double precision, gross_orbital_product_alpha, (ao_num)] +&BEGIN_PROVIDER [double precision, gross_orbital_product_beta, (ao_num)] + implicit none + spin_gross_orbital_product = 0.d0 + integer :: i,j + BEGIN_DOC +! gross orbital product + END_DOC + do i = 1, ao_num + do j = 1, ao_num + gross_orbital_product_alpha(i) += electronic_population_alpha(j,i) + gross_orbital_product_beta(i) += electronic_population_beta(j,i) + enddo + enddo + +END_PROVIDER + + BEGIN_PROVIDER [double precision, mulliken_densities_alpha, (nucl_num)] +&BEGIN_PROVIDER [double precision, mulliken_densities_beta, (nucl_num)] + implicit none + integer :: i,j + BEGIN_DOC +! + END_DOC + mulliken_densities_alpha = 0.d0 + mulliken_densities_beta = 0.d0 + do i = 1, ao_num + mulliken_densities_alpha(ao_nucl(i)) += gross_orbital_product_alpha(i) + mulliken_densities_beta(ao_nucl(i)) += gross_orbital_product_beta(i) + enddo + +END_PROVIDER diff --git a/plugins/Properties/print_hcc.irp.f b/plugins/Properties/print_hcc.irp.f new file mode 100644 index 00000000..f0091e1e --- /dev/null +++ b/plugins/Properties/print_hcc.irp.f @@ -0,0 +1,17 @@ +program print_hcc + implicit none + read_wf = .True. + touch read_wf + call test +end +subroutine test + implicit none + double precision :: accu + integer :: i,j + print*,'Z AU GAUSS MHZ cm^-1' + do i = 1, nucl_num + write(*,'(I2,X,F3.1,X,4(F16.6,X))')i,nucl_charge(i),spin_density_at_nucleous(i),iso_hcc_gauss(i),iso_hcc_mhz(i),iso_hcc_cm_1(i) + enddo + +end + diff --git a/plugins/Properties/print_mulliken.irp.f b/plugins/Properties/print_mulliken.irp.f new file mode 100644 index 00000000..100c8556 --- /dev/null +++ b/plugins/Properties/print_mulliken.irp.f @@ -0,0 +1,35 @@ +program print_mulliken + implicit none + read_wf = .True. + touch read_wf + print*,'Mulliken spin densities' + + call test +end +subroutine test + double precision :: accu + integer :: i + integer :: j + accu= 0.d0 + do i = 1, nucl_num + print*,i,nucl_charge(i),mulliken_spin_densities(i) + accu += mulliken_spin_densities(i) + enddo + print*,'Sum of Mulliken SD = ',accu + print*,'AO SPIN POPULATIONS' + accu = 0.d0 + do i = 1, ao_num + accu += spin_gross_orbital_product(i) + write(*,'(X,I3,X,A4,X,I2,X,A4,X,F10.7)')i,trim(element_name(int(nucl_charge(ao_nucl(i))))),ao_nucl(i),trim(l_to_charater(ao_l(i))),spin_gross_orbital_product(i) + enddo + print*,'sum = ',accu + accu = 0.d0 + print*,'Angular momentum analysis' + do i = 0, ao_l_max + accu += spin_population_angular_momentum(i) + print*,' ',trim(l_to_charater(i)),spin_population_angular_momentum(i) + print*,'sum = ',accu + enddo + +end + diff --git a/plugins/Psiref_Utils/psi_ref_utils.irp.f b/plugins/Psiref_Utils/psi_ref_utils.irp.f index f9cf1303..fb45b13d 100644 --- a/plugins/Psiref_Utils/psi_ref_utils.irp.f +++ b/plugins/Psiref_Utils/psi_ref_utils.irp.f @@ -125,7 +125,7 @@ BEGIN_PROVIDER [double precision, H_matrix_ref, (N_det_ref,N_det_ref)] enddo END_PROVIDER - BEGIN_PROVIDER [double precision, psi_coef_ref_diagonalized, (N_det_ref,N_states)] + BEGIN_PROVIDER [double precision, psi_ref_coef_diagonalized, (N_det_ref,N_states)] &BEGIN_PROVIDER [double precision, psi_ref_energy_diagonalized, (N_states)] implicit none integer :: i,j @@ -137,9 +137,11 @@ END_PROVIDER do i = 1, N_states psi_ref_energy_diagonalized(i) = eigenvalues(i) do j = 1, N_det_ref - psi_coef_ref_diagonalized(j,i) = eigenvectors(j,i) + psi_ref_coef_diagonalized(j,i) = eigenvectors(j,i) enddo enddo + deallocate (eigenvectors) + deallocate (eigenvalues) END_PROVIDER @@ -264,3 +266,18 @@ integer function get_index_in_psi_ref_sorted_bit(key,Nint) end +BEGIN_PROVIDER [double precision, ref_hamiltonian_matrix, (n_det_ref,n_det_ref)] + BEGIN_DOC + ! H matrix in the Reference space + END_DOC + implicit none + integer :: i,j + double precision :: hij + do i = 1, N_det_ref + do j = 1, N_det_ref + call i_H_j(psi_ref(1,1,i),psi_ref(1,1,j),N_int,hij) + ref_hamiltonian_matrix(i,j) = hij + enddo + enddo +END_PROVIDER + 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 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/plugins/Selectors_no_sorted/selectors.irp.f b/plugins/Selectors_no_sorted/selectors.irp.f index 8080e99c..9273c7bb 100644 --- a/plugins/Selectors_no_sorted/selectors.irp.f +++ b/plugins/Selectors_no_sorted/selectors.irp.f @@ -57,100 +57,3 @@ END_PROVIDER END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), psi_selectors_ab, (N_int,2,psi_selectors_size) ] -&BEGIN_PROVIDER [ double precision, psi_selectors_coef_ab, (psi_selectors_size,N_states) ] -&BEGIN_PROVIDER [ integer, psi_selectors_next_ab, (2,psi_selectors_size) ] - implicit none - BEGIN_DOC - ! Determinants on which we apply . - ! 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 QMCPACK" from ezfio import ezfio +import os import sys ezfio_path = sys.argv[1] @@ -17,7 +18,15 @@ ezfio.set_file(ezfio_path) do_pseudo = ezfio.get_pseudo_do_pseudo() if do_pseudo: print "do_pseudo True" - zcore = ezfio.get_pseudo_nucl_charge_remove() + from qp_path import QP_ROOT + + l_ele_path = os.path.join(QP_ROOT,"data","list_element.txt") + with open(l_ele_path, "r") as f: + data_raw = f.read() + + l_element_raw = data_raw.split("\n") + l_element = [element_raw.split() for element_raw in l_element_raw] + d_z = dict((abr, z) for (z, abr, ele) in l_element) else: print "do_pseudo False" @@ -68,11 +77,10 @@ print "nucl_num", len(l_label) print "Atomic coord in Bohr" for i, t in enumerate(zip(l_label, l_charge, l_coord_str)): - try: - l = (t[0], t[1] + zcore[i], t[2]) - except NameError: - l = t - print list_to_string(l) + t_1 = d_z[t[0]] if do_pseudo else t[1] + + t_new = [t[0],t_1,t[2]] + print list_to_string(t_new) # # Call externet process to get the sysmetry @@ -83,7 +91,7 @@ process = subprocess.Popen( stdout=subprocess.PIPE) out, err = process.communicate() -basis_raw, sym_raw, _= out.split("\n\n\n") +basis_raw, sym_raw, _ , det_raw, _ = out.split("\n\n\n") # _ __ # |_) _. _ o _ (_ _ _|_ @@ -248,7 +256,7 @@ def print_mo_coef(mo_coef_block, l_l_sym): i_a = int(l[1]) - 1 sym = l[2] - print l_label[i_a], sym, " ".join('{: 3.8f}'.format(i) + print l_label[i_a], sym, " ".join('{0: 3.8f}'.format(i) for i in a[i]) if i_block != nb_block - 1: @@ -306,7 +314,7 @@ if do_pseudo: l_str.append(l_dump) str_ = "PARAMETERS FOR {0} ON ATOM {1} WITH ZCORE {2} AND LMAX {3} ARE" - print str_.format(a, i + 1, int(zcore[i]), int(len(l_str) - 1)) + print str_.format(a, i + 1, int(d_z[a])-int(l_charge[i]), int(len(l_str) - 1)) for i, l in enumerate(l_str): str_ = "FOR L= {0} COEFF N ZETA" @@ -315,7 +323,7 @@ if do_pseudo: print " ", ii + 1, ll str_ = "THE ECP RUN REMOVES {0} CORE ELECTRONS, AND THE SAME NUMBER OF PROTONS." - print str_.format(sum(zcore)) + print str_.format(sum([int(d_z[a])-int(l_charge[i]) for i,a in enumerate(l_label)])) print "END_PSEUDO" # _ @@ -329,31 +337,26 @@ print "mo_num", mo_num print "det_num", n_det print "" -psi_det = ezfio.get_determinants_psi_det() -psi_coef = ezfio.get_determinants_psi_coef()[0] -for c, (l_det_bit_alpha, l_det_bit_beta) in zip(psi_coef, psi_det): - print c - bin_det = "" - for i,int_det in enumerate(l_det_bit_alpha): - bin_det_raw = "{0:b}".format(int_det)[::-1] - if mo_num - 64*(i+1) > 0: - bin_det += bin_det_raw + "0" * (64*(i+1) - len(bin_det_raw)) - else: - bin_det += bin_det_raw + "0" * (mo_num-64*i - len(bin_det_raw)) +token = "Determinants ::" +pos = det_raw.rfind(token) + len(token) - print bin_det +det_without_header = det_raw[pos+2::] - bin_det = "" - for i,int_det in enumerate(l_det_bit_beta): - bin_det_raw = "{0:b}".format(int_det)[::-1] - if mo_num - 64*(i+1) > 0: - bin_det += bin_det_raw + "0" * (64*(i+1) - len(bin_det_raw)) - else: - bin_det += bin_det_raw + "0" * (mo_num-64*i - len(bin_det_raw)) +d_rep={"+":"1","-":"0"} - print bin_det - print "" +det_without_header = det_raw[pos+2::] + +for line_raw in det_without_header.split("\n"): + line = line_raw + + if line_raw: + try: + float(line) + except ValueError: + line= "".join([d_rep[x] if x in d_rep else x for x in line_raw]) + + print line.strip() print "END_DET" 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/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/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/scripts/generate_h_apply.py b/scripts/generate_h_apply.py index 02524c3d..c6466569 100755 --- a/scripts/generate_h_apply.py +++ b/scripts/generate_h_apply.py @@ -1,39 +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 +deinit_thread +do_double_excitations +filter1h +filter1p +filter2h2p +filter2p +filterhole +filter_integrals +filter_only_1h1p_double +filter_only_1h1p_single +filterparticle +filter_vvvv_excitation finalization generate_psi_guess -init_thread -printout_now -printout_always -deinit_thread -skip +initialization init_main -filter_integrals -filter2h2p -filterhole -filterparticle -do_double_excitations -check_double_excitation -filter_vvvv_excitation +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] = "" @@ -42,7 +62,7 @@ class H_apply(object): self.selection_pt2 = None self.perturbation = None - + self.do_double_exc = do_double_exc #s["omp_parallel"] = """!$OMP PARALLEL DEFAULT(NONE) & s["omp_parallel"] = """ PROVIDE elec_num_tab !$OMP PARALLEL DEFAULT(SHARED) & @@ -117,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 @@ -150,6 +170,44 @@ class H_apply(object): self["filterparticle"] = """ if(iand(ibset(0_bit_kind,j_a),hole(k_a,other_spin)).eq.0_bit_kind )cycle """ + def filter_1h(self): + self["filter1h"] = """ +! ! DIR$ FORCEINLINE + if (is_a_1h(hole)) cycle + """ + def filter_2p(self): + self["filter2p"] = """ +! ! DIR$ FORCEINLINE + if (is_a_2p(hole)) cycle + """ + def filter_1p(self): + self["filter0p"] = """ +! ! DIR$ FORCEINLINE + if (is_a_1p(hole)) cycle + """ + + def filter_only_2p(self): + self["only_2p_single"] = """ +! ! DIR$ FORCEINLINE + if (.not. is_a_2p(hole)) cycle + """ + self["only_2p_double"] = """ +! ! DIR$ FORCEINLINE + if (.not. is_a_2p(key)) cycle + """ + + + def filter_only_1h1p(self): + self["filter_only_1h1p_single"] = """ +! ! DIR$ FORCEINLINE + if (is_a_1h1p(hole).eqv..False.) cycle + """ + self["filter_only_1h1p_double"] = """ +! ! DIR$ FORCEINLINE + if (is_a_1h1p(key).eqv..False.) cycle + """ + + def unset_skip(self): self["skip"] = """ """ @@ -202,10 +260,19 @@ class H_apply(object): self.data["initialization"] = """ PROVIDE psi_selectors_coef psi_selectors E_corr_per_selectors psi_det_sorted_bit """ - self.data["keys_work"] = """ - 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,) + 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) + """%(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["finalization"] = """ """ self.data["copy_buffer"] = "" @@ -227,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)') & '============', '========', '=========', '=========', '=========', & '=========' """ @@ -248,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) & @@ -292,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 @@ -304,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/scripts/module/module_handler.py b/scripts/module/module_handler.py index 136dc8cf..0667c376 100755 --- a/scripts/module/module_handler.py +++ b/scripts/module/module_handler.py @@ -40,7 +40,7 @@ def is_plugin(path_module_rel): def is_exe(fpath): - return os.path.isfile(fpath) and os.access(fpath, os.X_OK) + return os.path.isfile(fpath) and os.access(fpath, os.X_OK) and not fpath.endswith(".py") def get_dict_child(l_root_abs=None): 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 diff --git a/src/AO_Basis/aos.irp.f b/src/AO_Basis/aos.irp.f index 341d1453..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 @@ -146,3 +143,30 @@ integer function ao_power_index(nx,ny,nz) ao_power_index = ((l-nx)*(l-nx+1))/2 + nz + 1 end + BEGIN_PROVIDER [ integer, ao_l, (ao_num) ] +&BEGIN_PROVIDER [ integer, ao_l_max ] +&BEGIN_PROVIDER [ character*(128), ao_l_char, (ao_num) ] + implicit none + BEGIN_DOC +! ao_l = l value of the AO: a+b+c in x^a y^b z^c + END_DOC + integer :: i + do i=1,ao_num + ao_l(i) = ao_power(i,1) + ao_power(i,2) + ao_power(i,3) + ao_l_char(i) = l_to_charater(ao_l(i)) + enddo + ao_l_max = maxval(ao_l) +END_PROVIDER + +BEGIN_PROVIDER [ character*(128), l_to_charater, (0:4)] + BEGIN_DOC + ! character corresponding to the "L" value of an AO orbital + END_DOC + implicit none + l_to_charater(0)='S' + l_to_charater(1)='P' + l_to_charater(2)='D' + l_to_charater(3)='F' + l_to_charater(4)='G' +END_PROVIDER + diff --git a/src/AO_Basis/aos_value.irp.f b/src/AO_Basis/aos_value.irp.f new file mode 100644 index 00000000..a531ce50 --- /dev/null +++ b/src/AO_Basis/aos_value.irp.f @@ -0,0 +1,48 @@ +double precision function ao_value(i,r) + implicit none + BEGIN_DOC +! return the value of the ith ao at point r + END_DOC + double precision, intent(in) :: r(3) + integer, intent(in) :: i + + integer :: m,num_ao + double precision :: center_ao(3) + double precision :: beta + integer :: power_ao(3) + num_ao = ao_nucl(i) + power_ao(1:3)= ao_power(i,1:3) + center_ao(1:3) = nucl_coord(num_ao,1:3) + double precision :: accu,dx,dy,dz,r2 + dx = (r(1) - center_ao(1)) + dy = (r(2) - center_ao(2)) + dz = (r(3) - center_ao(3)) + r2 = dx*dx + dy*dy + dz*dz + dx = dx**power_ao(1) + dy = dy**power_ao(2) + dz = dz**power_ao(3) + + accu = 0.d0 + do m=1,ao_prim_num(i) + beta = ao_expo_ordered_transp(m,i) + accu += ao_coef_normalized_ordered_transp(m,i) * dexp(-beta*r2) + enddo + ao_value = accu * dx * dy * dz + +end + +subroutine give_all_aos_at_r(r,aos_array) + implicit none + BEGIN_dOC +! gives the values of aos at a given point r + END_DOC + double precision, intent(in) :: r(3) + double precision, intent(out) :: aos_array(ao_num) + integer :: i + double precision :: ao_value + do i = 1, ao_num + aos_array(i) = ao_value(i,r) + enddo + + +end diff --git a/src/Bitmask/bitmask_cas_routines.irp.f b/src/Bitmask/bitmask_cas_routines.irp.f index 776d4546..4441fb22 100644 --- a/src/Bitmask/bitmask_cas_routines.irp.f +++ b/src/Bitmask/bitmask_cas_routines.irp.f @@ -445,3 +445,47 @@ integer function number_of_particles_verbose(key_in) + popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) ) end +logical function is_a_1h1p(key_in) + implicit none + integer(bit_kind), intent(in) :: key_in(N_int,2) + integer :: number_of_particles, number_of_holes + is_a_1h1p = .False. + if(number_of_holes(key_in).eq.1 .and. number_of_particles(key_in).eq.1)then + is_a_1h1p = .True. + endif + +end + +logical function is_a_1h(key_in) + implicit none + integer(bit_kind), intent(in) :: key_in(N_int,2) + integer :: number_of_particles, number_of_holes + is_a_1h = .False. + if(number_of_holes(key_in).eq.1 .and. number_of_particles(key_in).eq.0)then + is_a_1h = .True. + endif + +end + +logical function is_a_1p(key_in) + implicit none + integer(bit_kind), intent(in) :: key_in(N_int,2) + integer :: number_of_particles, number_of_holes + is_a_1p = .False. + if(number_of_holes(key_in).eq.0 .and. number_of_particles(key_in).eq.1)then + is_a_1p = .True. + endif + +end + +logical function is_a_2p(key_in) + implicit none + integer(bit_kind), intent(in) :: key_in(N_int,2) + integer :: number_of_particles, number_of_holes + is_a_2p = .False. + if(number_of_holes(key_in).eq.0 .and. number_of_particles(key_in).eq.2)then + is_a_2p = .True. + endif + +end + diff --git a/src/Bitmask/bitmasks.irp.f b/src/Bitmask/bitmasks.irp.f index 70a84a42..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 @@ -289,7 +293,12 @@ END_PROVIDER &BEGIN_PROVIDER [ integer, n_virt_orb ] implicit none BEGIN_DOC - ! Bitmasks for the inactive orbitals that are excited in post CAS method + ! inact_bitmask : Bitmask of the inactive orbitals which are supposed to be doubly excited + ! in post CAS methods + ! n_inact_orb : Number of inactive orbitals + ! virt_bitmask : Bitmaks of vritual orbitals which are supposed to be recieve electrons + ! in post CAS methods + ! n_virt_orb : Number of virtual orbitals END_DOC logical :: exists integer :: j,i @@ -327,8 +336,14 @@ END_PROVIDER - BEGIN_PROVIDER [ integer, list_inact, (n_inact_orb)] + BEGIN_PROVIDER [ integer, list_inact, (n_inact_orb)] &BEGIN_PROVIDER [ integer, list_virt, (n_virt_orb)] + BEGIN_DOC + ! list_inact : List of the inactive orbitals which are supposed to be doubly excited + ! in post CAS methods + ! list_virt : List of vritual orbitals which are supposed to be recieve electrons + ! in post CAS methods + END_DOC implicit none integer :: occ_inact(N_int*bit_kind_size) integer :: itest,i @@ -348,6 +363,21 @@ END_PROVIDER END_PROVIDER + BEGIN_PROVIDER [ integer(bit_kind), reunion_of_core_inact_bitmask, (N_int,2)] + implicit none + BEGIN_DOC + ! Reunion of the inactive, active and virtual bitmasks + END_DOC + integer :: i,j + do i = 1, N_int + reunion_of_core_inact_bitmask(i,1) = ior(core_bitmask(i,1),inact_bitmask(i,1)) + reunion_of_core_inact_bitmask(i,2) = ior(core_bitmask(i,2),inact_bitmask(i,2)) + enddo + END_PROVIDER + + + + BEGIN_PROVIDER [ integer(bit_kind), reunion_of_bitmask, (N_int,2)] implicit none BEGIN_DOC @@ -373,18 +403,36 @@ END_PROVIDER enddo END_PROVIDER + BEGIN_PROVIDER [integer, list_core, (n_core_orb)] + BEGIN_DOC + ! List of the core orbitals that are never excited in post CAS method + END_DOC + implicit none + integer :: occ_core(N_int*bit_kind_size) + integer :: itest,i + occ_core = 0 + call bitstring_to_list(core_bitmask(1,1), occ_core(1), itest, N_int) + ASSERT(itest==n_core_orb) + do i = 1, n_core_orb + list_core(i) = occ_core(i) + enddo + END_PROVIDER + BEGIN_PROVIDER [ integer(bit_kind), core_bitmask, (N_int,2)] +&BEGIN_PROVIDER [ integer, n_core_orb] implicit none BEGIN_DOC - ! Reunion of the inactive, active and virtual bitmasks + ! Core orbitals bitmask END_DOC integer :: i,j + n_core_orb = 0 do i = 1, N_int - core_bitmask(i,1) = iand(ref_bitmask(i,1),reunion_of_bitmask(i,1)) - core_bitmask(i,2) = iand(ref_bitmask(i,2),reunion_of_bitmask(i,2)) + core_bitmask(i,1) = xor(closed_shell_ref_bitmask(i,1),reunion_of_cas_inact_bitmask(i,1)) + core_bitmask(i,2) = xor(closed_shell_ref_bitmask(i,2),reunion_of_cas_inact_bitmask(i,2)) + n_core_orb += popcnt(core_bitmask(i,1)) enddo - END_PROVIDER - + print*,'n_core_orb = ',n_core_orb + END_PROVIDER BEGIN_PROVIDER [ integer, i_bitmask_gen ] @@ -435,3 +483,27 @@ BEGIN_PROVIDER [integer, list_act, (n_act_orb)] enddo END_PROVIDER + + BEGIN_PROVIDER [integer(bit_kind), closed_shell_ref_bitmask, (N_int,2)] + implicit none + integer :: i,j + do i = 1, N_int + closed_shell_ref_bitmask(i,1) = ior(ref_bitmask(i,1),cas_bitmask(i,1,1)) + closed_shell_ref_bitmask(i,2) = ior(ref_bitmask(i,2),cas_bitmask(i,2,1)) + enddo + END_PROVIDER + + + BEGIN_PROVIDER [ integer(bit_kind), reunion_of_cas_inact_bitmask, (N_int,2)] + implicit none + BEGIN_DOC + ! Reunion of the inactive, active and virtual bitmasks + END_DOC + integer :: i,j + do i = 1, N_int + reunion_of_cas_inact_bitmask(i,1) = ior(cas_bitmask(i,1,1),inact_bitmask(i,1)) + reunion_of_cas_inact_bitmask(i,2) = ior(cas_bitmask(i,2,1),inact_bitmask(i,2)) + enddo + END_PROVIDER + + diff --git a/src/Bitmask/find_hole.irp.f b/src/Bitmask/find_hole.irp.f new file mode 100644 index 00000000..bc74ce52 --- /dev/null +++ b/src/Bitmask/find_hole.irp.f @@ -0,0 +1,55 @@ +logical function is_the_hole_in_det(key_in,ispin,i_hole) + use bitmasks + ! returns true if the electron ispin is absent from i_hole + implicit none + integer, intent(in) :: i_hole,ispin + integer(bit_kind), intent(in) :: key_in(N_int,2) + integer(bit_kind) :: key_tmp(N_int) + integer(bit_kind) :: itest(N_int) + integer :: i,j,k + do i = 1, N_int + itest(i) = 0_bit_kind + enddo + k = ishft(i_hole-1,-bit_kind_shift)+1 + j = i_hole-ishft(k-1,bit_kind_shift)-1 + itest(k) = ibset(itest(k),j) + j = 0 + do i = 1, N_int + key_tmp(i) = iand(itest(i),key_in(i,ispin)) + j += popcnt(key_tmp(i)) + enddo + if(j==0)then + is_the_hole_in_det = .True. + else + is_the_hole_in_det = .False. + endif + +end + +logical function is_the_particl_in_det(key_in,ispin,i_particl) + use bitmasks + ! returns true if the electron ispin is absent from i_particl + implicit none + integer, intent(in) :: i_particl,ispin + integer(bit_kind), intent(in) :: key_in(N_int,2) + integer(bit_kind) :: key_tmp(N_int) + integer(bit_kind) :: itest(N_int) + integer :: i,j,k + do i = 1, N_int + itest(i) = 0_bit_kind + enddo + k = ishft(i_particl-1,-bit_kind_shift)+1 + j = i_particl-ishft(k-1,bit_kind_shift)-1 + itest(k) = ibset(itest(k),j) + j = 0 + do i = 1, N_int + key_tmp(i) = iand(itest(i),key_in(i,ispin)) + j += popcnt(key_tmp(i)) + enddo + if(j==0)then + is_the_particl_in_det = .False. + else + is_the_particl_in_det = .True. + endif + +end diff --git a/src/Bitmask/modify_bitmasks.irp.f b/src/Bitmask/modify_bitmasks.irp.f new file mode 100644 index 00000000..51d77af6 --- /dev/null +++ b/src/Bitmask/modify_bitmasks.irp.f @@ -0,0 +1,280 @@ + +use bitmasks +subroutine initialize_bitmask_to_restart_ones + implicit none + integer :: i,j,k,l,m + integer :: ispin + BEGIN_DOC + ! Initialization of the generators_bitmask to the restart bitmask + END_DOC + do i = 1, N_int + do k=1,N_generators_bitmask + do ispin=1,2 + generators_bitmask(i,ispin,s_hole ,k) = generators_bitmask_restart(i,ispin,s_hole ,k) + generators_bitmask(i,ispin,s_part ,k) = generators_bitmask_restart(i,ispin,s_part ,k) + generators_bitmask(i,ispin,d_hole1,k) = generators_bitmask_restart(i,ispin,d_hole1,k) + generators_bitmask(i,ispin,d_part1,k) = generators_bitmask_restart(i,ispin,d_part1,k) + generators_bitmask(i,ispin,d_hole2,k) = generators_bitmask_restart(i,ispin,d_hole2,k) + generators_bitmask(i,ispin,d_part2,k) = generators_bitmask_restart(i,ispin,d_part2,k) + enddo + enddo + enddo +end + + +subroutine modify_bitmasks_for_hole(i_hole) + implicit none + integer, intent(in) :: i_hole + integer :: i,j,k,l,m + integer :: ispin + BEGIN_DOC +! modify the generators_bitmask in order that one can only excite +! the electrons occupying i_hole + END_DOC + + ! Set to Zero the holes + do k=1,N_generators_bitmask + do l = 1, 3 + i = index_holes_bitmask(l) + do ispin=1,2 + do j = 1, N_int + generators_bitmask(j,ispin,i,k) = 0_bit_kind + enddo + enddo + enddo + enddo + + k = ishft(i_hole-1,-bit_kind_shift)+1 + j = i_hole-ishft(k-1,bit_kind_shift)-1 + do m = 1, N_generators_bitmask + do l = 1, 3 + i = index_holes_bitmask(l) + do ispin=1,2 + generators_bitmask(k,ispin,i,m) = ibset(generators_bitmask(k,ispin,i,m),j) + enddo + enddo + enddo + +end + +subroutine modify_bitmasks_for_hole_in_out(i_hole) + implicit none + integer, intent(in) :: i_hole + integer :: i,j,k,l,m + integer :: ispin + BEGIN_DOC +! modify the generators_bitmask in order that one can only excite +! the electrons occupying i_hole + END_DOC + + k = ishft(i_hole-1,-bit_kind_shift)+1 + j = i_hole-ishft(k-1,bit_kind_shift)-1 + do m = 1, N_generators_bitmask + do l = 1, 3 + i = index_holes_bitmask(l) + do ispin=1,2 + generators_bitmask(k,ispin,i,m) = ibset(generators_bitmask(k,ispin,i,m),j) + enddo + enddo + enddo + +end + +subroutine modify_bitmasks_for_particl(i_part) + implicit none + integer, intent(in) :: i_part + integer :: i,j,k,l,m + integer :: ispin + BEGIN_DOC +! modify the generators_bitmask in order that one can only excite +! the electrons to the orbital i_part + END_DOC + + ! Set to Zero the particles + do k=1,N_generators_bitmask + do l = 1, 3 + i = index_particl_bitmask(l) + do ispin=1,2 + do j = 1, N_int + generators_bitmask(j,ispin,i,k) = 0_bit_kind + enddo + enddo + enddo + enddo + + k = ishft(i_part-1,-bit_kind_shift)+1 + j = i_part-ishft(k-1,bit_kind_shift)-1 + do m = 1, N_generators_bitmask + do l = 1, 3 + i = index_particl_bitmask(l) + do ispin=1,2 + generators_bitmask(k,ispin,i,m) = ibset(generators_bitmask(k,ispin,i,m),j) + enddo + enddo + enddo + +end + + +subroutine set_bitmask_particl_as_input(input_bimask) + implicit none + integer(bit_kind), intent(in) :: input_bimask(N_int,2) + integer :: i,j,k,l,m + integer :: ispin + BEGIN_DOC +! set the generators_bitmask for the particles +! as the input_bimask + END_DOC + + do k=1,N_generators_bitmask + do l = 1, 3 + i = index_particl_bitmask(l) + do ispin=1,2 + do j = 1, N_int + generators_bitmask(j,ispin,i,k) = input_bimask(j,ispin) + enddo + enddo + enddo + enddo + touch generators_bitmask + +end + + +subroutine set_bitmask_hole_as_input(input_bimask) + implicit none + integer(bit_kind), intent(in) :: input_bimask(N_int,2) + integer :: i,j,k,l,m + integer :: ispin + BEGIN_DOC +! set the generators_bitmask for the holes +! as the input_bimask + END_DOC + + do k=1,N_generators_bitmask + do l = 1, 3 + i = index_holes_bitmask(l) + do ispin=1,2 + do j = 1, N_int + generators_bitmask(j,ispin,i,k) = input_bimask(j,ispin) + enddo + enddo + enddo + enddo + touch generators_bitmask + +end + + +subroutine print_generators_bitmasks_holes + implicit none + integer :: i,j,k,l + integer(bit_kind),allocatable :: key_tmp(:,:) + + allocate(key_tmp(N_int,2)) + do l = 1, 3 + k = 1 + i = index_holes_bitmask(l) + do j = 1, N_int + key_tmp(j,1) = generators_bitmask(j,1,i,k) + key_tmp(j,2) = generators_bitmask(j,2,i,k) + enddo + print*,'' + print*,'index hole = ',i + call print_det(key_tmp,N_int) + print*,'' + enddo + deallocate(key_tmp) + +end + +subroutine print_generators_bitmasks_particles + implicit none + integer :: i,j,k,l + integer(bit_kind),allocatable :: key_tmp(:,:) + + allocate(key_tmp(N_int,2)) + do l = 1, 3 + k = 1 + i = index_particl_bitmask(l) + do j = 1, N_int + key_tmp(j,1) = generators_bitmask(j,1,i,k) + key_tmp(j,2) = generators_bitmask(j,2,i,k) + enddo + print*,'' + print*,'index particl ',i + call print_det(key_tmp,N_int) + print*,'' + enddo + deallocate(key_tmp) + +end + +subroutine print_generators_bitmasks_holes_for_one_generator(i_gen) + implicit none + integer, intent(in) :: i_gen + integer :: i,j,k,l + integer(bit_kind),allocatable :: key_tmp(:,:) + + allocate(key_tmp(N_int,2)) + do l = 1, 3 + k = i_gen + i = index_holes_bitmask(l) + do j = 1, N_int + key_tmp(j,1) = generators_bitmask(j,1,i,k) + key_tmp(j,2) = generators_bitmask(j,2,i,k) + enddo + print*,'' + print*,'index hole = ',i + call print_det(key_tmp,N_int) + print*,'' + enddo + deallocate(key_tmp) + +end + +subroutine print_generators_bitmasks_particles_for_one_generator(i_gen) + implicit none + integer, intent(in) :: i_gen + integer :: i,j,k,l + integer(bit_kind),allocatable :: key_tmp(:,:) + + allocate(key_tmp(N_int,2)) + do l = 1, 3 + k = i_gen + i = index_particl_bitmask(l) + do j = 1, N_int + key_tmp(j,1) = generators_bitmask(j,1,i,k) + key_tmp(j,2) = generators_bitmask(j,2,i,k) + enddo + print*,'' + print*,'index particl ',i + call print_det(key_tmp,N_int) + print*,'' + enddo + deallocate(key_tmp) + +end + + + BEGIN_PROVIDER [integer, index_holes_bitmask, (3)] + implicit none + BEGIN_DOC +! Index of the holes in the generators_bitmasks + END_DOC + index_holes_bitmask(1) = d_hole1 + index_holes_bitmask(2) = d_hole2 + index_holes_bitmask(3) = s_hole + + END_PROVIDER + + BEGIN_PROVIDER [integer, index_particl_bitmask, (3)] + implicit none + BEGIN_DOC +! Index of the holes in the generators_bitmasks + END_DOC + index_particl_bitmask(1) = d_part1 + index_particl_bitmask(2) = d_part2 + index_particl_bitmask(3) = s_part + + END_PROVIDER diff --git a/src/Determinants/EZFIO.cfg b/src/Determinants/EZFIO.cfg index 4ab84b7a..b1c459ba 100644 --- a/src/Determinants/EZFIO.cfg +++ b/src/Determinants/EZFIO.cfg @@ -40,6 +40,12 @@ doc: Force the wave function to be an eigenfunction of S^2 interface: ezfio,provider,ocaml default: False +[diagonalize_s2] +type: logical +doc: Diagonalize the S^2 operator within the n_states_diag states required. Notice : the vectors are sorted by increasing S^2 values. +interface: ezfio,provider,ocaml +default: True + [threshold_davidson] type: Threshold doc: Thresholds of Davidson's algorithm 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 48e5d335..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)) @@ -165,6 +174,10 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl endif logical :: check_double_excitation + logical :: is_a_1h1p + logical :: is_a_1h + logical :: is_a_1p + logical :: is_a_2p logical :: b_cycle check_double_excitation = .True. iproc = iproc_in @@ -225,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) @@ -298,6 +305,8 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl l = j_b-ishft(k-1,bit_kind_shift)-1 key(k,other_spin) = ibset(key(k,other_spin),l) $filter2h2p + $filter_only_1h1p_double + $only_2p_double key_idx += 1 do k=1,N_int keys_out(k,1,key_idx) = key(k,1) @@ -308,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 @@ -348,6 +354,8 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl l = j_b-ishft(k-1,bit_kind_shift)-1 key(k,ispin) = ibset(key(k,ispin),l) $filter2h2p + $filter_only_1h1p_double + $only_2p_double key_idx += 1 do k=1,N_int keys_out(k,1,key_idx) = key(k,1) @@ -358,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 @@ -418,8 +423,15 @@ subroutine $subroutine_monoexc(key_in, hole_1,particl_1,fock_diag_tmp,i_generato integer(bit_kind) :: key_mask(N_int, 2) logical :: check_double_excitation + logical :: is_a_1h1p + logical :: is_a_1h + 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 @@ -489,7 +501,12 @@ subroutine $subroutine_monoexc(key_in, hole_1,particl_1,fock_diag_tmp,i_generato l_a = j_a-ishft(k_a-1,bit_kind_shift)-1 $filterparticle hole(k_a,ispin) = ibset(hole(k_a,ispin),l_a) + $only_2p_single + $filter1h + $filter1p + $filter2p $filter2h2p + $filter_only_1h1p_single key_idx += 1 do k=1,N_int keys_out(k,1,key_idx) = hole(k,1) @@ -516,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..c492a739 --- /dev/null +++ b/src/Determinants/H_apply_zmq.template.f @@ -0,0 +1,245 @@ +subroutine $subroutine($params_main) + implicit none + use omp_lib + use bitmasks + use f77_zmq + BEGIN_DOC + ! Calls H_apply on the HF determinant and selects all connected single and double + ! excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. + END_DOC + + $decls_main + + integer :: i_generator + double precision :: wall_0, wall_1 + integer(omp_lock_kind) :: lck + integer(bit_kind), allocatable :: mask(:,:,:) + integer :: ispin, k + integer :: rc + character*(512) :: task + double precision, allocatable :: fock_diag_tmp(:,:) + + $initialization + PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators + + integer(ZMQ_PTR), external :: new_zmq_pair_socket + integer(ZMQ_PTR) :: zmq_socket_pair + + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + call new_parallel_job(zmq_to_qp_run_socket,'$subroutine') + zmq_socket_pair = new_zmq_pair_socket(.True.) + + call zmq_put_psi(zmq_to_qp_run_socket,1) + + do i_generator=N_det_generators,1,-1 + $skip + write(task,*) i_generator + call add_task_to_taskserver(zmq_to_qp_run_socket,task) + enddo + + integer(ZMQ_PTR) :: collector_thread + external :: $subroutine_collector + rc = pthread_create(collector_thread, $subroutine_collector) + + !$OMP PARALLEL DEFAULT(private) + !$OMP TASK PRIVATE(rc) + rc = omp_get_thread_num() + call $subroutine_slave_inproc(rc) + !$OMP END TASK + !$OMP TASKWAIT + !$OMP END PARALLEL + + + integer :: n, task_id + call pull_pt2(zmq_socket_pair, pt2, norm_pert, H_pert_diag, N_st, n, task_id) + + rc = pthread_join(collector_thread) + + call end_zmq_pair_socket(zmq_socket_pair) + call end_parallel_job(zmq_to_qp_run_socket,'$subroutine') + + + $copy_buffer + $generate_psi_guess + +end + +subroutine $subroutine_slave_tcp(iproc) + implicit none + integer, intent(in) :: iproc + BEGIN_DOC +! Computes a buffer over the network + END_DOC + call $subroutine_slave(0,iproc) +end + +subroutine $subroutine_slave_inproc(iproc) + implicit none + integer, intent(in) :: iproc + BEGIN_DOC +! Computes a buffer using threads + END_DOC + call $subroutine_slave(1,iproc) +end + + +subroutine $subroutine_slave(thread, iproc) + implicit none + use omp_lib + use bitmasks + use f77_zmq + integer, intent(in) :: thread + BEGIN_DOC + ! Calls H_apply on the HF determinant and selects all connected single and double + ! excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. + END_DOC + + integer, intent(in) :: iproc + integer :: i_generator + double precision :: wall_0, wall_1 + integer(bit_kind), allocatable :: mask(:,:,:) + integer :: ispin, k + double precision, allocatable :: fock_diag_tmp(:,:) + double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:) + + integer :: worker_id, task_id, rc, N_st + character*(512) :: task + integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + integer(ZMQ_PTR),external :: new_zmq_push_socket + integer(ZMQ_PTR) :: zmq_socket_push + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + zmq_socket_push = new_zmq_push_socket(thread) + + + N_st = N_states + allocate( pt2(N_st), norm_pert(N_st), H_pert_diag(N_st), & + mask(N_int,2,6), fock_diag_tmp(2,mo_tot_num+1) ) + + call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) + + do + call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task) + if (task_id == 0) exit + read(task,*) i_generator + + ! Compute diagonal of the Fock matrix + call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int) + + pt2 = 0.d0 + norm_pert = 0.d0 + H_pert_diag = 0.d0 + + ! Create bit masks for holes and particles + do ispin=1,2 + do k=1,N_int + mask(k,ispin,s_hole) = & + iand(generators_bitmask(k,ispin,s_hole,i_bitmask_gen), & + psi_det_generators(k,ispin,i_generator) ) + mask(k,ispin,s_part) = & + iand(generators_bitmask(k,ispin,s_part,i_bitmask_gen), & + not(psi_det_generators(k,ispin,i_generator)) ) + mask(k,ispin,d_hole1) = & + iand(generators_bitmask(k,ispin,d_hole1,i_bitmask_gen), & + psi_det_generators(k,ispin,i_generator) ) + mask(k,ispin,d_part1) = & + iand(generators_bitmask(k,ispin,d_part1,i_bitmask_gen), & + not(psi_det_generators(k,ispin,i_generator)) ) + mask(k,ispin,d_hole2) = & + iand(generators_bitmask(k,ispin,d_hole2,i_bitmask_gen), & + psi_det_generators(k,ispin,i_generator) ) + mask(k,ispin,d_part2) = & + iand(generators_bitmask(k,ispin,d_part2,i_bitmask_gen), & + not (psi_det_generators(k,ispin,i_generator)) ) + enddo + enddo + + if($do_double_excitations)then + call $subroutine_diexc(psi_det_generators(1,1,i_generator), & + psi_det_generators(1,1,1), & + mask(1,1,d_hole1), mask(1,1,d_part1), & + mask(1,1,d_hole2), mask(1,1,d_part2), & + fock_diag_tmp, i_generator, iproc $params_post) + endif + if($do_mono_excitations)then + call $subroutine_monoexc(psi_det_generators(1,1,i_generator), & + mask(1,1,s_hole ), mask(1,1,s_part ), & + fock_diag_tmp, i_generator, iproc $params_post) + endif + + call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id,1) + call push_pt2(zmq_socket_push,pt2,norm_pert,H_pert_diag,N_st,task_id) + + enddo + + call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) + + deallocate( mask, fock_diag_tmp, pt2, norm_pert, H_pert_diag ) + + call end_zmq_push_socket(zmq_socket_push,thread) + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + +end + +subroutine $subroutine_collector + use f77_zmq + implicit none + BEGIN_DOC +! Collects results from the selection + END_DOC + + integer :: k, rc + + integer(ZMQ_PTR), external :: new_zmq_pull_socket + integer(ZMQ_PTR) :: zmq_socket_pull + integer*8 :: control, accu + integer :: n, more, task_id + + integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + zmq_socket_pull = new_zmq_pull_socket() + + double precision, allocatable :: pt2(:,:), norm_pert(:,:), H_pert_diag(:,:) + allocate ( pt2(N_states,2), norm_pert(N_states,2), H_pert_diag(N_states,2)) + + pt2 = 0.d0 + norm_pert = 0.d0 + H_pert_diag = 0.d0 + accu = 0_8 + more = 1 + do while (more == 1) + + call pull_pt2(zmq_socket_pull, pt2, norm_pert, H_pert_diag, N_states, n, task_id) + if (n > 0) then + do k=1,N_states + pt2(k,2) = pt2(k,1) + pt2(k,2) + norm_pert(k,2) = norm_pert(k,1) + norm_pert(k,2) + H_pert_diag(k,2) = H_pert_diag(k,1) + H_pert_diag(k,2) + enddo + accu = accu + 1_8 + call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more) + endif + + enddo + + call end_zmq_pull_socket(zmq_socket_pull) + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + + + integer(ZMQ_PTR), external :: new_zmq_pair_socket + integer(ZMQ_PTR) :: socket_result + + socket_result = new_zmq_pair_socket(.False.) + + call push_pt2(socket_result, pt2(1,2), norm_pert(1,2), H_pert_diag(1,2), N_states,0) + + deallocate ( pt2, norm_pert, H_pert_diag) + + call end_zmq_pair_socket(socket_result) + +end + + 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/connected_to_ref.irp.f b/src/Determinants/connected_to_ref.irp.f index b93b18b6..7a54bdbc 100644 --- a/src/Determinants/connected_to_ref.irp.f +++ b/src/Determinants/connected_to_ref.irp.f @@ -189,6 +189,39 @@ logical function is_connected_to(key,keys,Nint,Ndet) enddo end +logical function is_connected_to_by_mono(key,keys,Nint,Ndet) + use bitmasks + implicit none + integer, intent(in) :: Nint, Ndet + integer(bit_kind), intent(in) :: keys(Nint,2,Ndet) + integer(bit_kind), intent(in) :: key(Nint,2) + + integer :: i, l + integer :: degree_x2 + + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + + is_connected_to_by_mono = .false. + + do i=1,Ndet + degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + & + popcnt(xor( key(1,2), keys(1,2,i))) + !DEC$ LOOP COUNT MIN(3) + do l=2,Nint + degree_x2 = degree_x2 + popcnt(xor( key(l,1), keys(l,1,i))) +& + popcnt(xor( key(l,2), keys(l,2,i))) + enddo + if (degree_x2 > 2) then + cycle + else + is_connected_to_by_mono = .true. + return + endif + enddo +end + integer function connected_to_ref(key,keys,Nint,N_past_in,Ndet) use bitmasks 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/density_matrix.irp.f b/src/Determinants/density_matrix.irp.f index e5d243f4..62d09381 100644 --- a/src/Determinants/density_matrix.irp.f +++ b/src/Determinants/density_matrix.irp.f @@ -206,3 +206,54 @@ BEGIN_PROVIDER [ double precision, state_average_weight, (N_states) ] state_average_weight = 1.d0/dble(N_states) END_PROVIDER + +BEGIN_PROVIDER [ double precision, one_body_spin_density_ao, (ao_num_align,ao_num) ] + BEGIN_DOC +! one body spin density matrix on the AO basis : rho_AO(alpha) - rho_AO(beta) + END_DOC + implicit none + integer :: i,j,k,l + double precision :: dm_mo + + one_body_spin_density_ao = 0.d0 + do k = 1, ao_num + do l = 1, ao_num + do i = 1, mo_tot_num + do j = 1, mo_tot_num + dm_mo = one_body_spin_density_mo(j,i) +! if(dabs(dm_mo).le.1.d-10)cycle + one_body_spin_density_ao(l,k) += mo_coef(k,i) * mo_coef(l,j) * dm_mo + + enddo + enddo + enddo + enddo + +END_PROVIDER + + BEGIN_PROVIDER [ double precision, one_body_dm_ao_alpha, (ao_num_align,ao_num) ] +&BEGIN_PROVIDER [ double precision, one_body_dm_ao_beta, (ao_num_align,ao_num) ] + BEGIN_DOC +! one body density matrix on the AO basis : rho_AO(alpha) , rho_AO(beta) + END_DOC + implicit none + integer :: i,j,k,l + double precision :: dm_mo + + one_body_spin_density_ao = 0.d0 + do k = 1, ao_num + do l = 1, ao_num + do i = 1, mo_tot_num + do j = 1, mo_tot_num + dm_mo = one_body_dm_mo_alpha(j,i) +! if(dabs(dm_mo).le.1.d-10)cycle + one_body_dm_ao_alpha(l,k) += mo_coef(k,i) * mo_coef(l,j) * dm_mo + one_body_dm_ao_beta(l,k) += mo_coef(k,i) * mo_coef(l,j) * dm_mo + + enddo + enddo + enddo + enddo + +END_PROVIDER + diff --git a/src/Determinants/determinants.irp.f b/src/Determinants/determinants.irp.f index 5fe18c49..4476ed45 100644 --- a/src/Determinants/determinants.irp.f +++ b/src/Determinants/determinants.irp.f @@ -386,66 +386,6 @@ subroutine sort_dets_by_det_search_key(Ndet, det_in, coef_in, det_out, coef_out) end -subroutine int_of_3_highest_electrons( det_in, res, Nint ) - implicit none - use bitmasks - integer,intent(in) :: Nint - integer(bit_kind) :: det_in(Nint) - integer*8 :: res - BEGIN_DOC -! Returns an integer*8 as : -! -! |_<--- 21 bits ---><--- 21 bits ---><--- 21 bits --->| -! -! |0<--- i1 ---><--- i2 ---><--- i3 --->| -! -! It encodes the value of the indices of the 3 highest MOs -! in descending order -! - END_DOC - integer :: i, k, icount - integer(bit_kind) :: ix - res = 0_8 - icount = 3 - do k=Nint,1,-1 - ix = det_in(k) - do while (ix /= 0_bit_kind) - i = bit_kind_size-1-leadz(ix) - ix = ibclr(ix,i) - res = ior(ishft(res, 21), i+ishft(k-1,bit_kind_shift)) - icount -= 1 - if (icount == 0) then - return - endif - enddo - enddo -end - -subroutine filter_3_highest_electrons( det_in, det_out, Nint ) - implicit none - use bitmasks - integer,intent(in) :: Nint - integer(bit_kind) :: det_in(Nint), det_out(Nint) - BEGIN_DOC -! Returns a determinant with only the 3 highest electrons - END_DOC - integer :: i, k, icount - integer(bit_kind) :: ix - det_out = 0_8 - icount = 3 - do k=Nint,1,-1 - ix = det_in(k) - do while (ix /= 0_bit_kind) - i = bit_kind_size-1-leadz(ix) - ix = ibclr(ix,i) - det_out(k) = ibset(det_out(k),i) - icount -= 1 - if (icount == 0) then - return - endif - enddo - enddo -end BEGIN_PROVIDER [ double precision, psi_coef_max, (N_states) ] &BEGIN_PROVIDER [ double precision, psi_coef_min, (N_states) ] @@ -465,130 +405,6 @@ end END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_ab, (N_int,2,psi_det_size) ] -&BEGIN_PROVIDER [ double precision, psi_coef_sorted_ab, (N_det,N_states) ] -&BEGIN_PROVIDER [ integer, psi_det_sorted_next_ab, (2,psi_det_size) ] - implicit none - BEGIN_DOC - ! Determinants on which we apply . - ! 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 1.and. n_det >= n_states_diag)then + ! Diagonalizing S^2 within the "n_states_diag" states found + allocate(s2_eigvalues(N_states_diag)) + call diagonalize_s2_betweenstates(psi_det,CI_eigenvectors,n_det,size(psi_det,3),size(CI_eigenvectors,1),min(n_states_diag,n_det),s2_eigvalues) + + do j = 1, N_states_diag + do i = 1, N_det + psi_coef(i,j) = CI_eigenvectors(i,j) + enddo + enddo + + if(s2_eig)then + + ! Browsing the "n_states_diag" states and getting the lowest in energy "n_states" ones that have the S^2 value + ! closer to the "expected_s2" set as input + + allocate(index_good_state_array(N_det),good_state_array(N_det)) + good_state_array = .False. + i_state = 0 + do j = 1, N_states_diag + if(dabs(s2_eigvalues(j)-expected_s2).le.0.3d0)then + good_state_array(j) = .True. + i_state +=1 + index_good_state_array(i_state) = j + endif + enddo + ! Sorting the i_state good states by energy + allocate(e_array(i_state),iorder(i_state)) + do j = 1, i_state + do i = 1, N_det + CI_eigenvectors(i,j) = psi_coef(i,index_good_state_array(j)) + enddo + CI_eigenvectors_s2(j) = s2_eigvalues(index_good_state_array(j)) + call u0_H_u_0(e_0,CI_eigenvectors(1,j),n_det,psi_det,N_int) + CI_electronic_energy(j) = e_0 + e_array(j) = e_0 + iorder(j) = j + enddo + call dsort(e_array,iorder,i_state) + do j = 1, i_state + CI_electronic_energy(j) = e_array(j) + CI_eigenvectors_s2(j) = s2_eigvalues(index_good_state_array(iorder(j))) + do i = 1, N_det + CI_eigenvectors(i,j) = psi_coef(i,index_good_state_array(iorder(j))) + enddo +! call u0_H_u_0(e_0,CI_eigenvectors(1,j),n_det,psi_det,N_int) +! print*,'e = ',CI_electronic_energy(j) +! print*,' = ',e_0 +! call get_s2_u0(psi_det,CI_eigenvectors(1,j),N_det,size(CI_eigenvectors,1),s2) +! print*,'s^2 = ',CI_eigenvectors_s2(j) +! print*,'= ',s2 + enddo + deallocate(e_array,iorder) + + ! Then setting the other states without any specific energy order + i_other_state = 0 + do j = 1, N_states_diag + if(good_state_array(j))cycle + i_other_state +=1 + do i = 1, N_det + CI_eigenvectors(i,i_state + i_other_state) = psi_coef(i,j) + enddo + CI_eigenvectors_s2(i_state + i_other_state) = s2_eigvalues(j) + call u0_H_u_0(e_0,CI_eigenvectors(1,i_state + i_other_state),n_det,psi_det,N_int) + CI_electronic_energy(i_state + i_other_state) = e_0 + enddo + deallocate(index_good_state_array,good_state_array) + + + else + + ! Sorting the N_states_diag by energy, whatever the S^2 value is + + allocate(e_array(n_states_diag),iorder(n_states_diag)) + do j = 1, N_states_diag + call u0_H_u_0(e_0,CI_eigenvectors(1,j),n_det,psi_det,N_int) + e_array(j) = e_0 + iorder(j) = j + enddo + call dsort(e_array,iorder,n_states_diag) + do j = 1, N_states_diag + CI_electronic_energy(j) = e_array(j) + do i = 1, N_det + CI_eigenvectors(i,j) = psi_coef(i,iorder(j)) + enddo + CI_eigenvectors_s2(j) = s2_eigvalues(iorder(j)) + enddo + deallocate(e_array,iorder) + endif + deallocate(s2_eigvalues) + endif + END_PROVIDER subroutine diagonalize_CI 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 6da7b8ec..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 @@ -214,4 +214,175 @@ subroutine get_s2_u0(psi_keys_tmp,psi_coefs_tmp,n,nmax,s2) deallocate (shortcut, sort_idx, sorted, version) end +subroutine get_uJ_s2_uI(psi_keys_tmp,psi_coefs_tmp,n,nmax_coefs,nmax_keys,s2,nstates) + implicit none + use bitmasks + integer(bit_kind), intent(in) :: psi_keys_tmp(N_int,2,nmax_keys) + integer, intent(in) :: n,nmax_coefs,nmax_keys,nstates + double precision, intent(in) :: psi_coefs_tmp(nmax_coefs,nstates) + double precision, intent(out) :: s2(nstates,nstates) + double precision :: s2_tmp,accu + integer :: i,j,l,jj,ll,kk + integer, allocatable :: idx(:) + double precision, allocatable :: tmp(:,:) + BEGIN_DOC + ! returns the matrix elements of S^2 "s2(i,j)" between the "nstates" states + ! psi_coefs_tmp(:,i) and psi_coefs_tmp(:,j) + END_DOC + s2 = 0.d0 + do ll = 1, nstates + do jj = 1, nstates + accu = 0.d0 + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE (i,j,kk,idx,tmp,s2_tmp) & + !$OMP SHARED (ll,jj,psi_keys_tmp,psi_coefs_tmp,N_int,n,nstates) & + !$OMP REDUCTION(+:accu) + allocate(idx(0:n)) + !$OMP DO SCHEDULE(dynamic) + do i = 1, n + call get_s2(psi_keys_tmp(1,1,i),psi_keys_tmp(1,1,i),s2_tmp,N_int) + accu += psi_coefs_tmp(i,ll) * s2_tmp * psi_coefs_tmp(i,jj) + call filter_connected(psi_keys_tmp,psi_keys_tmp(1,1,i),N_int,i-1,idx) + do kk=1,idx(0) + j = idx(kk) + call get_s2(psi_keys_tmp(1,1,i),psi_keys_tmp(1,1,j),s2_tmp,N_int) + accu += psi_coefs_tmp(i,ll) * s2_tmp * psi_coefs_tmp(j,jj) + psi_coefs_tmp(i,jj) * s2_tmp * psi_coefs_tmp(j,ll) + enddo + enddo + !$OMP END DO NOWAIT + deallocate(idx) + !$OMP BARRIER + !$OMP END PARALLEL + s2(ll,jj) += accu + enddo + enddo + do i = 1, nstates + do j =i+1,nstates + accu = 0.5d0 * (s2(i,j) + s2(j,i)) + s2(i,j) = accu + s2(j,i) = accu + enddo + enddo +end + +subroutine diagonalize_s2_betweenstates(keys_tmp,psi_coefs_inout,n,nmax_keys,nmax_coefs,nstates,s2_eigvalues) + BEGIN_DOC +! You enter with nstates vectors in psi_coefs_inout that may be coupled by S^2 +! The subroutine diagonalize the S^2 operator in the basis of these states. +! The vectors that you obtain in output are no more coupled by S^2, +! which does not necessary mean that they are eigenfunction of S^2. +! n,nmax,nstates = number of determinants, physical dimension of the arrays and number of states +! keys_tmp = array of integer(bit_kind) that represents the determinants +! psi_coefs(i,j) = coeff of the ith determinant in the jth state +! VECTORS ARE SUPPOSED TO BE ORTHONORMAL IN INPUT + END_DOC + implicit none + use bitmasks + integer, intent(in) :: n,nmax_keys,nmax_coefs,nstates + integer(bit_kind), intent(in) :: keys_tmp(N_int,2,nmax_keys) + double precision, intent(inout) :: psi_coefs_inout(nmax_coefs,nstates) + +!integer, intent(in) :: ndets_real,ndets_keys,ndets_coefs,nstates +!integer(bit_kind), intent(in) :: keys_tmp(N_int,2,ndets_keys) +!double precision, intent(inout) :: psi_coefs_inout(ndets_coefs,nstates) + double precision, intent(out) :: s2_eigvalues(nstates) + + + double precision,allocatable :: s2(:,:),overlap(:,:) + double precision, allocatable :: eigvalues(:),eigvectors(:,:) + integer :: i,j,k + double precision, allocatable :: psi_coefs_tmp(:,:) + double precision :: accu,coef_contract + double precision :: u_dot_u,u_dot_v + + print*,'' + print*,'*********************************************************************' + print*,'Cleaning the various vectors by diagonalization of the S^2 matrix ...' + print*,'' + print*,'nstates = ',nstates + allocate(s2(nstates,nstates),overlap(nstates,nstates)) + do i = 1, nstates + overlap(i,i) = u_dot_u(psi_coefs_inout(1,i),n) + do j = i+1, nstates + overlap(i,j) = u_dot_v(psi_coefs_inout(1,j),psi_coefs_inout(1,i),n) + overlap(j,i) = overlap(i,j) + enddo + enddo + print*,'Overlap matrix in the basis of the states considered' + do i = 1, nstates + write(*,'(10(F16.10,X))')overlap(i,:) + enddo + call ortho_lowdin(overlap,size(overlap,1),nstates,psi_coefs_inout,size(psi_coefs_inout,1),n) + print*,'passed ortho' + + do i = 1, nstates + overlap(i,i) = u_dot_u(psi_coefs_inout(1,i),n) + do j = i+1, nstates + overlap(i,j) = u_dot_v(psi_coefs_inout(1,j),psi_coefs_inout(1,i),n) + overlap(j,i) = overlap(i,j) + enddo + enddo + print*,'Overlap matrix in the basis of the Lowdin orthonormalized states ' + do i = 1, nstates + write(*,'(10(F16.10,X))')overlap(i,:) + enddo + + call get_uJ_s2_uI(keys_tmp,psi_coefs_inout,n_det,size(psi_coefs_inout,1),size(keys_tmp,3),s2,nstates) + print*,'S^2 matrix in the basis of the states considered' + double precision :: accu_precision_diag,accu_precision_of_diag + accu_precision_diag = 0.d0 + accu_precision_of_diag = 0.d0 + do i = 1, nstates + do j = i+1, nstates + if( ( dabs(s2(i,i) - s2(j,j)) .le.1.d-10 ) .and. (dabs(s2(i,j) + dabs(s2(i,j)))) .le.1.d-10) then + s2(i,j) = 0.d0 + s2(j,i) = 0.d0 + endif + enddo + enddo + do i = 1, nstates + write(*,'(10(F10.6,X))')s2(i,:) + enddo + + print*,'Diagonalizing the S^2 matrix' + + allocate(eigvalues(nstates),eigvectors(nstates,nstates)) + call lapack_diagd(eigvalues,eigvectors,s2,nstates,nstates) + print*,'Eigenvalues of s^2' + do i = 1, nstates + print*,'s2 = ',eigvalues(i) + s2_eigvalues(i) = eigvalues(i) + enddo + + print*,'Building the eigenvectors of the S^2 matrix' + allocate(psi_coefs_tmp(nmax_coefs,nstates)) + psi_coefs_tmp = 0.d0 + do j = 1, nstates + do k = 1, nstates + coef_contract = eigvectors(k,j) ! + do i = 1, n_det + psi_coefs_tmp(i,j) += psi_coefs_inout(i,k) * coef_contract + enddo + enddo + enddo + do j = 1, nstates + accu = 0.d0 + do i = 1, n_det + accu += psi_coefs_tmp(i,j) * psi_coefs_tmp(i,j) + enddo + print*,'Norm of vector = ',accu + accu = 1.d0/dsqrt(accu) + do i = 1, n_det + psi_coefs_inout(i,j) = psi_coefs_tmp(i,j) * accu + enddo + enddo +!call get_uJ_s2_uI(keys_tmp,psi_coefs_inout,n_det,size(psi_coefs_inout,1),size(keys_tmp,3),s2,nstates) +!print*,'S^2 matrix in the basis of the NEW states considered' +!do i = 1, nstates +! write(*,'(10(F16.10,X))')s2(i,:) +!enddo + + deallocate(s2,eigvalues,eigvectors,psi_coefs_tmp,overlap) + +end diff --git a/src/Determinants/save_HF_determinant.irp.f b/src/Determinants/save_HF_determinant.irp.f new file mode 100644 index 00000000..0b81f136 --- /dev/null +++ b/src/Determinants/save_HF_determinant.irp.f @@ -0,0 +1,5 @@ +program save_HF + implicit none + call save_ref_determinant + +end diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index 202d310d..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) @@ -1507,6 +1560,33 @@ subroutine get_occ_from_key(key,occ,Nint) end +subroutine u0_H_u_0(e_0,u_0,n,keys_tmp,Nint) + use bitmasks + implicit none + BEGIN_DOC + ! Computes e_0 = / + ! + ! n : number of determinants + ! + END_DOC + integer, intent(in) :: n,Nint + double precision, intent(out) :: e_0 + double precision, intent(in) :: u_0(n) + integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) + + double precision :: H_jj(n) + double precision :: v_0(n) + double precision :: u_dot_u,u_dot_v,diag_H_mat_elem + integer :: i,j + do i = 1, n + H_jj(i) = diag_H_mat_elem(keys_tmp(1,1,i),Nint) + enddo + + call H_u_0(v_0,u_0,H_jj,n,keys_tmp,Nint) + e_0 = u_dot_v(v_0,u_0,n)/u_dot_u(u_0,n) +end + + subroutine H_u_0(v_0,u_0,H_jj,n,keys_tmp,Nint) use bitmasks implicit none 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/Determinants/usefull_for_ovb.irp.f b/src/Determinants/usefull_for_ovb.irp.f new file mode 100644 index 00000000..7b89897b --- /dev/null +++ b/src/Determinants/usefull_for_ovb.irp.f @@ -0,0 +1,283 @@ + +integer function n_open_shell(det_in,nint) + implicit none + use bitmasks + integer(bit_kind), intent(in) :: det_in(nint,2),nint + integer :: i + n_open_shell = 0 + do i=1,Nint + n_open_shell += popcnt(iand(xor(det_in(i,1),det_in(i,2)),det_in(i,1))) + enddo +end + +integer function n_closed_shell(det_in,nint) + implicit none + use bitmasks + integer(bit_kind), intent(in) :: det_in(nint,2),nint + integer :: i + n_closed_shell = 0 + do i=1,Nint + n_closed_shell += popcnt(iand(det_in(i,1),det_in(i,2))) + enddo +end + +integer function n_closed_shell_cas(det_in,nint) + implicit none + use bitmasks + integer(bit_kind), intent(in) :: det_in(nint,2),nint + integer(bit_kind) :: det_tmp(nint,2) + integer :: i + n_closed_shell_cas = 0 + do i=1,Nint + det_tmp(i,1) = xor(det_in(i,1),reunion_of_core_inact_bitmask(i,1)) + det_tmp(i,2) = xor(det_in(i,2),reunion_of_core_inact_bitmask(i,2)) + enddo +!call debug_det(det_tmp,nint) + do i=1,Nint + n_closed_shell_cas += popcnt(iand(det_tmp(i,1),det_tmp(i,2))) + enddo +end + +subroutine doubly_occ_empty_in_couple(det_in,n_couples,couples,couples_out) + implicit none + use bitmasks + integer, intent(in) :: n_couples,couples(n_couples,2) + integer(bit_kind),intent(in) :: det_in(N_int,2) + logical, intent(out) :: couples_out(0:n_couples) + integer(bit_kind) :: det_tmp(N_int) + integer(bit_kind) :: det_tmp_bis(N_int) + BEGIN_DOC + ! n_couples is the number of couples of orbitals to be checked + ! couples(i,1) = first orbital of the ith couple + ! couples(i,2) = second orbital of the ith couple + ! returns the array couples_out + ! couples_out(i) = .True. if det_in contains + ! an orbital empty in the ith couple AND + ! an orbital doubly occupied in the ith couple + END_DOC + integer :: i,j,k,l + + ! det_tmp tells you if the orbitals are occupied or not + do j = 1, N_int + det_tmp(j) = ior(det_in(j,1),det_in(j,2)) + enddo + + couples_out(0) = .False. + do i = 1, n_couples + do j = 1, N_int + det_tmp_bis(j) = 0_bit_kind + enddo + call set_bit_to_integer(couples(i,1),det_tmp_bis,N_int) ! first orb + call set_bit_to_integer(couples(i,2),det_tmp_bis,N_int) ! second orb + ! det_tmp is zero except for the two orbitals of the couple + integer :: i_count + i_count = 0 + do j = 1, N_int + i_count += popcnt(iand(det_tmp(j),det_tmp_bis(j))) ! check if the two orbitals are both occupied + enddo + if(i_count .ne. 1)then + couples_out(i) = .False. + cycle + endif + + ! test if orbital there are two electrons or not + i_count = 0 + do j = 1, N_int + i_count += popcnt(iand(iand(det_in(j,1),det_in(j,2)),det_tmp_bis(j))) + enddo + if(i_count.ne.1)then + couples_out(i) = .False. + else + couples_out(i) = .True. + couples_out(0) = .True. + endif + enddo +end + +subroutine give_index_of_doubly_occ_in_active_space(det_in,doubly_occupied_array) + implicit none + use bitmasks + integer(bit_kind), intent(in) :: det_in(N_int,2) + logical, intent(out) :: doubly_occupied_array(n_act_orb) + integer(bit_kind) :: det_tmp(N_int) + integer(bit_kind) :: det_tmp_bis(N_int) + BEGIN_DOC + END_DOC + integer :: i,j,k,l + + ! det_tmp tells you if the orbitals are occupied or not + do j = 1, N_int + det_tmp(j) = ior(det_in(j,1),det_in(j,2)) + enddo + + do i = 1, n_act_orb + do j = 1, N_int + det_tmp_bis(j) = 0_bit_kind + enddo + i_bite = list_act(i) + call set_bit_to_integer(i_bite,det_tmp_bis,N_int) ! act orb + ! det_tmp is zero except for the orbital "ith" active orbital + integer :: i_count,i_bite + + ! test if orbital there are two electrons or not + i_count = 0 + do j = 1, N_int + i_count += popcnt(iand(iand(det_in(j,1),det_in(j,2)),det_tmp_bis(j))) + enddo + if(i_count.ne.1)then + doubly_occupied_array(i) = .False. + else + doubly_occupied_array(i) = .True. + endif + enddo +end + +subroutine doubly_occ_empty_in_couple_and_no_hund_elsewhere(det_in,n_couple_no_hund,couple_ion,couple_no_hund,is_ok) + implicit none + use bitmasks + integer, intent(in) :: n_couple_no_hund,couple_ion(2),couple_no_hund(n_couple_no_hund,2) + integer(bit_kind),intent(in) :: det_in(N_int,2) + logical, intent(out) :: is_ok + integer(bit_kind) :: det_tmp(N_int) + integer(bit_kind) :: det_tmp_bis(N_int) + BEGIN_DOC + ! n_couples is the number of couples of orbitals to be checked + ! couples(i,1) = first orbital of the ith couple + ! couples(i,2) = second orbital of the ith couple + ! returns the array couples_out + ! couples_out(i) = .True. if det_in contains + ! an orbital empty in the ith couple AND + ! an orbital doubly occupied in the ith couple + END_DOC + integer :: i,j,k,l + + ! det_tmp tells you if the orbitals are occupied or not + do j = 1, N_int + det_tmp(j) = ior(det_in(j,1),det_in(j,2)) + enddo + + is_ok = .False. + do j = 1, N_int + det_tmp_bis(j) = 0_bit_kind + enddo + call set_bit_to_integer(couple_ion(1),det_tmp_bis,N_int) ! first orb + call set_bit_to_integer(couple_ion(2),det_tmp_bis,N_int) ! second orb + ! det_tmp is zero except for the two orbitals of the couple + integer :: i_count + i_count = 0 + do j = 1, N_int + i_count += popcnt(iand(det_tmp(j),det_tmp_bis(j))) ! check if the two orbitals are both occupied + enddo + if(i_count .ne. 1)then + is_ok = .False. + return + endif + + ! test if orbital there are two electrons or not + i_count = 0 + do j = 1, N_int + i_count += popcnt(iand(iand(det_in(j,1),det_in(j,2)),det_tmp_bis(j))) + enddo + if(i_count.ne.1)then + is_ok = .False. + return + else + do i = 1, n_couple_no_hund + do j = 1, N_int + det_tmp_bis(j) = 0_bit_kind + enddo + call set_bit_to_integer(couple_no_hund (i,1),det_tmp_bis,N_int) ! first orb + call set_bit_to_integer(couple_no_hund (i,2),det_tmp_bis,N_int) ! second orb + ! det_tmp_bis is zero except for the two orbitals of the couple + i_count = 0 + do j = 1, N_int + i_count += popcnt(iand(det_tmp(j),det_tmp_bis(j))) ! check if the two orbitals are both occupied + enddo + if(i_count .ne. 2)then + is_ok = .False. + return + endif + ! test if orbital there are one alpha and one beta + integer :: i_count_alpha,i_count_beta + i_count_alpha = 0 + i_count_beta = 0 + do j = 1, N_int + i_count_alpha += popcnt(iand(det_in(j,1),det_tmp_bis(j))) + i_count_beta += popcnt(iand(det_in(j,2),det_tmp_bis(j))) + enddo + if(i_count_alpha==1.and.i_count_beta==1)then + is_ok = .True. + else + is_ok = .False. + return + endif + enddo + is_ok = .True. + endif +end + + +subroutine neutral_no_hund_in_couple(det_in,n_couples,couples,couples_out) + implicit none + use bitmasks + integer, intent(in) :: n_couples,couples(n_couples,2) + integer(bit_kind),intent(in) :: det_in(N_int,2) + logical, intent(out) :: couples_out(0:n_couples) + integer(bit_kind) :: det_tmp(N_int) + integer(bit_kind) :: det_tmp_bis(N_int) + BEGIN_DOC + ! n_couples is the number of couples of orbitals to be checked + ! couples(i,1) = first orbital of the ith couple + ! couples(i,2) = second orbital of the ith couple + ! returns the array couples_out + ! couples_out(i) = .True. if det_in contains + ! an orbital empty in the ith couple AND + ! an orbital doubly occupied in the ith couple + END_DOC + integer :: i,j,k,l + + ! det_tmp tells you if the orbitals are occupied or not + do j = 1, N_int + det_tmp(j) = ior(det_in(j,1),det_in(j,2)) + enddo + + couples_out(0) = .True. + do i = 1, n_couples + do j = 1, N_int + det_tmp_bis(j) = 0_bit_kind + enddo + call set_bit_to_integer(couples(i,1),det_tmp_bis,N_int) ! first orb + call set_bit_to_integer(couples(i,2),det_tmp_bis,N_int) ! second orb + ! det_tmp_bis is zero except for the two orbitals of the couple + integer :: i_count + i_count = 0 + do j = 1, N_int + i_count += popcnt(iand(det_tmp(j),det_tmp_bis(j))) ! check if the two orbitals are both occupied + enddo + if(i_count .ne. 2)then + couples_out(i) = .False. + cycle + endif + + ! test if orbital there are one alpha and one beta + integer :: i_count_alpha,i_count_beta + i_count_alpha = 0 + i_count_beta = 0 + do j = 1, N_int + i_count_alpha += popcnt(iand(det_in(j,1),det_tmp_bis(j))) + i_count_beta += popcnt(iand(det_in(j,2),det_tmp_bis(j))) + enddo + if(i_count_alpha==1.and.i_count_beta==1)then + couples_out(i) = .True. + else + couples_out(i) = .False. + endif + enddo + do i = 1, n_couples + if(.not.couples_out(i))then + couples_out(0) = .False. + endif + enddo +end + + diff --git a/src/Integrals_Bielec/.gitignore b/src/Integrals_Bielec/.gitignore index ad6b465d..1d52a821 100644 --- a/src/Integrals_Bielec/.gitignore +++ b/src/Integrals_Bielec/.gitignore @@ -17,5 +17,4 @@ ZMQ ezfio_interface.irp.f irpf90.make irpf90_entities -tags -test_integrals \ No newline at end of file +tags \ No newline at end of file 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..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 @@ -1,20 +1,73 @@ -subroutine ao_bielec_integrals_in_map_slave_tcp +subroutine ao_bielec_integrals_in_map_slave_tcp(i) implicit none + integer, intent(in) :: i BEGIN_DOC -! Computes a buffer of integrals +! Computes a buffer of integrals. i is the ID of the current thread. END_DOC - call ao_bielec_integrals_in_map_slave(0) + call ao_bielec_integrals_in_map_slave(0,i) end -subroutine ao_bielec_integrals_in_map_slave_inproc + +subroutine ao_bielec_integrals_in_map_slave_inproc(i) implicit none + integer, intent(in) :: i BEGIN_DOC -! Computes a buffer of integrals +! Computes a buffer of integrals. i is the ID of the current thread. END_DOC - call ao_bielec_integrals_in_map_slave(1) + call ao_bielec_integrals_in_map_slave(1,i) end -subroutine ao_bielec_integrals_in_map_slave(thread) + +subroutine push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, task_id) + use f77_zmq + use map_module + implicit none + BEGIN_DOC +! Push integrals in the push socket + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_socket_push + integer, intent(in) :: n_integrals + integer(key_kind), intent(in) :: buffer_i(*) + real(integral_kind), intent(in) :: buffer_value(*) + integer, intent(in) :: task_id + integer :: rc + + rc = f77_zmq_send( zmq_socket_push, n_integrals, 4, ZMQ_SNDMORE) + if (rc /= 4) then + print *, irp_here, 'f77_zmq_send( zmq_socket_push, n_integrals, 4, ZMQ_SNDMORE)' + stop 'error' + endif + + rc = f77_zmq_send( zmq_socket_push, buffer_i, key_kind*n_integrals, ZMQ_SNDMORE) + if (rc /= key_kind*n_integrals) then + print *, irp_here, 'f77_zmq_send( zmq_socket_push, buffer_i, key_kind*n_integrals, ZMQ_SNDMORE)' + stop 'error' + endif + + rc = f77_zmq_send( zmq_socket_push, buffer_value, integral_kind*n_integrals, ZMQ_SNDMORE) + if (rc /= integral_kind*n_integrals) then + print *, irp_here, 'f77_zmq_send( zmq_socket_push, buffer_value, integral_kind*n_integrals, 0)' + stop 'error' + endif + + rc = f77_zmq_send( zmq_socket_push, task_id, 4, 0) + if (rc /= 4) then + print *, irp_here, 'f77_zmq_send( zmq_socket_push, task_id, 4, 0)' + stop 'error' + endif + +! Activate is zmq_socket_push is a REQ +! integer :: idummy +! rc = f77_zmq_recv( zmq_socket_push, idummy, 4, 0) +! if (rc /= 4) then +! print *, irp_here, 'f77_zmq_send( zmq_socket_push, idummy, 4, 0)' +! stop 'error' +! endif +end + + + +subroutine ao_bielec_integrals_in_map_slave(thread,iproc) use map_module use f77_zmq implicit none @@ -22,7 +75,7 @@ subroutine ao_bielec_integrals_in_map_slave(thread) ! Computes a buffer of integrals END_DOC - integer, intent(in) :: thread + integer, intent(in) :: thread, iproc integer :: j,l,n_integrals integer :: rc @@ -35,19 +88,11 @@ subroutine ao_bielec_integrals_in_map_slave(thread) integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket integer(ZMQ_PTR) :: zmq_to_qp_run_socket - zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() - + integer(ZMQ_PTR), external :: new_zmq_push_socket integer(ZMQ_PTR) :: zmq_socket_push -! zmq_socket_push = f77_zmq_socket(zmq_context, ZMQ_PUSH) - zmq_socket_push = f77_zmq_socket(zmq_context, ZMQ_REQ ) - if (thread == 1) then - rc = f77_zmq_connect(zmq_socket_push, trim(zmq_socket_pull_inproc_address)) - else - rc = f77_zmq_connect(zmq_socket_push, trim(zmq_socket_push_tcp_address)) - endif - if (rc /= 0) then - stop 'Unable to connect zmq_socket_push_tcp' - endif + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + zmq_socket_push = new_zmq_push_socket(thread) allocate ( buffer_i(ao_num*ao_num), buffer_value(ao_num*ao_num) ) @@ -55,31 +100,78 @@ subroutine ao_bielec_integrals_in_map_slave(thread) do call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task) - if (task_id == 0) then - exit - endif - read(task,*) j, l - call compute_ao_integrals_jl(j,l,n_integrals,buffer_i,buffer_value) - rc = f77_zmq_send( zmq_socket_push, n_integrals, 4, ZMQ_SNDMORE) - rc = f77_zmq_send( zmq_socket_push, buffer_i, key_kind*n_integrals, ZMQ_SNDMORE) - rc = f77_zmq_send( zmq_socket_push, buffer_value, integral_kind*n_integrals, 0) - call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) - character*(2) :: ok - rc = f77_zmq_recv( zmq_socket_push, ok, 2, 0) + if (task_id == 0) exit + read(task,*) l + do j=1,l-1 + call compute_ao_integrals_jl(j,l,n_integrals,buffer_i,buffer_value) + call push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, 0) + enddo + call compute_ao_integrals_jl(l,l,n_integrals,buffer_i,buffer_value) + call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id,n_integrals) + call push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, task_id) enddo deallocate( buffer_i, buffer_value ) - integer :: finished - call disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id,finished) + call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + call end_zmq_push_socket(zmq_socket_push,thread) - if (finished /= 0) then - rc = f77_zmq_send( zmq_socket_push, -1, 4, 0) - rc = f77_zmq_recv( zmq_socket_push, ok, 2, ZMQ_NOBLOCK) +end + + +subroutine pull_integrals(zmq_socket_pull, n_integrals, buffer_i, buffer_value, task_id) + use f77_zmq + use map_module + implicit none + BEGIN_DOC + ! How the collector pulls the computed integrals + END_DOC + integer(ZMQ_PTR), intent(out) :: zmq_socket_pull + integer, intent(out) :: n_integrals + integer(key_kind), intent(out) :: buffer_i(*) + real(integral_kind), intent(out) :: buffer_value(*) + integer, intent(out) :: task_id + integer :: rc + + rc = f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0) + if (rc == -1) then + n_integrals = 0 + return + endif + if (rc /= 4) then + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0)' + stop 'error' + endif + + if (n_integrals >= 0) then + + rc = f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0) + if (rc /= key_kind*n_integrals) then + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0)' + stop 'error' + endif + + rc = f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0) + if (rc /= integral_kind*n_integrals) then + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0)' + stop 'error' + endif + + rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0) + if (rc /= 4) then + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, task_id, 4, 0)' + stop 'error' + endif + endif - rc = f77_zmq_disconnect(zmq_socket_push,trim(zmq_socket_push_tcp_address)) - rc = f77_zmq_close(zmq_socket_push) +! Activate if zmq_socket_pull is a REP +! rc = f77_zmq_send( zmq_socket_pull, 0, 4, 0) +! if (rc /= 4) then +! print *, irp_here, ' f77_zmq_send (zmq_socket_pull,...' +! stop 'error' +! endif end @@ -94,27 +186,54 @@ subroutine ao_bielec_integrals_in_map_collector integer :: j,l,n_integrals integer :: rc + real(integral_kind), allocatable :: buffer_value(:) integer(key_kind), allocatable :: buffer_i(:) + + integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + + integer(ZMQ_PTR), external :: new_zmq_pull_socket + integer(ZMQ_PTR) :: zmq_socket_pull + + integer*8 :: control, accu + integer :: task_id, more + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + zmq_socket_pull = new_zmq_pull_socket() allocate ( buffer_i(ao_num*ao_num), buffer_value(ao_num*ao_num) ) - n_integrals = 0 - do while (n_integrals >= 0) + accu = 0_8 + more = 1 + do while (more == 1) - rc = f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0) + call pull_integrals(zmq_socket_pull, n_integrals, buffer_i, buffer_value, task_id) if (n_integrals >= 0) then - rc = f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0) - rc = f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0) - rc = f77_zmq_send( zmq_socket_pull, 'ok', 2, 0) call insert_into_ao_integrals_map(n_integrals,buffer_i,buffer_value) - else - rc = f77_zmq_send( zmq_socket_pull, 'ok', 2, 0) + accu += n_integrals + if (task_id /= 0) then + call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more) + endif endif enddo deallocate( buffer_i, buffer_value ) + integer (map_size_kind) :: get_ao_map_size + control = get_ao_map_size(ao_integrals_map) + + if (control /= accu) then + print *, irp_here, 'Control : ', control + print *, 'Accu : ', accu + print *, 'Some integrals were lost during the parallel computation. (2)' + print *, 'Try to reduce the number of threads.' + stop + endif + + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + call end_zmq_pull_socket(zmq_socket_pull) + end 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/.gitignore b/src/Integrals_Monoelec/.gitignore index 577068de..e8bd9b05 100644 --- a/src/Integrals_Monoelec/.gitignore +++ b/src/Integrals_Monoelec/.gitignore @@ -12,9 +12,7 @@ Makefile.depend Nuclei Pseudo Utils -check_orthonormality ezfio_interface.irp.f irpf90.make irpf90_entities -save_ortho_mos tags \ No newline at end of file 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/MOGuess/.gitignore b/src/MOGuess/.gitignore index e9ba5cf5..797574f4 100644 --- a/src/MOGuess/.gitignore +++ b/src/MOGuess/.gitignore @@ -4,7 +4,6 @@ AO_Basis Electrons Ezfio_files -H_CORE_guess IRPF90_man IRPF90_temp Integrals_Monoelec @@ -15,8 +14,6 @@ Nuclei Pseudo Utils ezfio_interface.irp.f -guess_overlap irpf90.make irpf90_entities -tags -truncate_mos \ No newline at end of file +tags \ No newline at end of file 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..d730f612 --- /dev/null +++ b/src/ZMQ/utils.irp.f @@ -0,0 +1,759 @@ +use f77_zmq +use omp_lib + +integer, pointer :: thread_id +integer(omp_lock_kind) :: zmq_lock + + +BEGIN_PROVIDER [ integer(ZMQ_PTR), zmq_context ] + use f77_zmq + implicit none + BEGIN_DOC + ! Context for the ZeroMQ library + END_DOC + call omp_init_lock(zmq_lock) + zmq_context = 0_ZMQ_PTR +END_PROVIDER + + + BEGIN_PROVIDER [ character*(128), qp_run_address ] +&BEGIN_PROVIDER [ integer, zmq_port_start ] + use f77_zmq + implicit none + BEGIN_DOC + ! Address of the qp_run socket + ! Example : tcp://130.120.229.139:12345 + END_DOC + character*(128) :: buffer + call getenv('QP_RUN_ADDRESS',buffer) + if (trim(buffer) == '') then + print *, 'This run should be started with the qp_run command' + stop -1 + endif + + integer :: i + do i=len(buffer),1,-1 + if ( buffer(i:i) == ':') then + qp_run_address = trim(buffer(1:i-1)) + read(buffer(i+1:), *) zmq_port_start + exit + endif + enddo +END_PROVIDER + + BEGIN_PROVIDER [ character*(128), zmq_socket_pull_tcp_address ] +&BEGIN_PROVIDER [ character*(128), zmq_socket_pair_inproc_address ] +&BEGIN_PROVIDER [ character*(128), zmq_socket_push_tcp_address ] +&BEGIN_PROVIDER [ character*(128), zmq_socket_pull_inproc_address ] +&BEGIN_PROVIDER [ character*(128), zmq_socket_push_inproc_address ] + use f77_zmq + implicit none + BEGIN_DOC + ! Socket which pulls the results (2) + END_DOC + + character*(8), external :: zmq_port + zmq_socket_pull_tcp_address = 'tcp://*:'//zmq_port(1)//' ' + zmq_socket_push_tcp_address = trim(qp_run_address)//':'//zmq_port(1)//' ' + zmq_socket_pull_inproc_address = 'inproc://'//zmq_port(1)//' ' + zmq_socket_push_inproc_address = zmq_socket_pull_inproc_address + zmq_socket_pair_inproc_address = 'inproc://'//zmq_port(2)//' ' +END_PROVIDER + +subroutine reset_zmq_addresses + use f77_zmq + implicit none + character*(8), external :: zmq_port + + zmq_socket_pull_tcp_address = 'tcp://*:'//zmq_port(1)//' ' + zmq_socket_push_tcp_address = trim(qp_run_address)//':'//zmq_port(1)//' ' + zmq_socket_pull_inproc_address = 'inproc://'//zmq_port(1)//' ' + zmq_socket_push_inproc_address = zmq_socket_pull_inproc_address + zmq_socket_pair_inproc_address = 'inproc://'//zmq_port(2)//' ' +end + + +subroutine switch_qp_run_to_master + use f77_zmq + implicit none + BEGIN_DOC + ! Address of the master qp_run socket + ! Example : tcp://130.120.229.139:12345 + END_DOC + character*(128) :: buffer + call getenv('QP_RUN_ADDRESS_MASTER',buffer) + if (trim(buffer) == '') then + print *, 'This run should be started with the qp_run command' + stop -1 + endif + qp_run_address = trim(buffer) + + integer :: i + do i=len(buffer),1,-1 + if ( buffer(i:i) == ':') then + qp_run_address = trim(buffer(1:i-1)) + read(buffer(i+1:), *) zmq_port_start + exit + endif + enddo + + call reset_zmq_addresses + +end + + +function zmq_port(ishift) + use f77_zmq + implicit none + BEGIN_DOC + ! Return the value of the ZMQ port from the corresponding integer + END_DOC + integer, intent(in) :: ishift + character*(8) :: zmq_port + write(zmq_port,'(I8)') zmq_port_start+ishift + zmq_port = adjustl(trim(zmq_port)) +end + + +function new_zmq_to_qp_run_socket() + use f77_zmq + implicit none + BEGIN_DOC + ! Socket on which the qp_run process replies + END_DOC + integer :: rc + character*(8), external :: zmq_port + integer(ZMQ_PTR) :: new_zmq_to_qp_run_socket + + call omp_set_lock(zmq_lock) + new_zmq_to_qp_run_socket = f77_zmq_socket(zmq_context, ZMQ_REQ) + call omp_unset_lock(zmq_lock) + if (new_zmq_to_qp_run_socket == 0_ZMQ_PTR) then + stop 'Unable to create zmq req socket' + endif + + rc = f77_zmq_connect(new_zmq_to_qp_run_socket, trim(qp_run_address)//':'//trim(zmq_port(0))) + if (rc /= 0) then + stop 'Unable to connect new_zmq_to_qp_run_socket' + endif + + rc = f77_zmq_setsockopt(new_zmq_to_qp_run_socket, ZMQ_SNDTIMEO, 120000, 4) + if (rc /= 0) then + stop 'Unable to set send timout in new_zmq_to_qp_run_socket' + endif + + rc = f77_zmq_setsockopt(new_zmq_to_qp_run_socket, ZMQ_RCVTIMEO, 120000, 4) + if (rc /= 0) then + stop 'Unable to set recv timout in new_zmq_to_qp_run_socket' + endif + +end + + +function new_zmq_pair_socket(bind) + use f77_zmq + implicit none + BEGIN_DOC + ! Socket on which the collector and the main communicate + END_DOC + logical :: bind + integer :: rc + character*(8), external :: zmq_port + integer(ZMQ_PTR) :: new_zmq_pair_socket + + call omp_set_lock(zmq_lock) + new_zmq_pair_socket = f77_zmq_socket(zmq_context, ZMQ_PAIR) + call omp_unset_lock(zmq_lock) + if (new_zmq_pair_socket == 0_ZMQ_PTR) then + stop 'Unable to create zmq pair socket' + endif + + if (bind) then + rc = f77_zmq_bind(new_zmq_pair_socket,zmq_socket_pair_inproc_address) + if (rc /= 0) then + print *, 'f77_zmq_bind(new_zmq_pair_socket, zmq_socket_pair_inproc_address)' + stop 'error' + endif + else + rc = f77_zmq_connect(new_zmq_pair_socket,zmq_socket_pair_inproc_address) + if (rc /= 0) then + stop 'Unable to connect new_zmq_pair_socket' + endif + endif + + rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_SNDHWM, 0, 4) + if (rc /= 0) then + stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_SNDHWM, 0, 4)' + endif + + rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_RCVHWM, 0, 4) + if (rc /= 0) then + stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_RCVHWM, 0, 4)' + endif + + rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_IMMEDIATE, 1, 4) + if (rc /= 0) then + stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_IMMEDIATE, 1, 4)' + endif + + rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_LINGER, 600000, 4) + if (rc /= 0) then + stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_LINGER, 60000, 4)' + endif + +end + + + + +function new_zmq_pull_socket() + use f77_zmq + implicit none + BEGIN_DOC + ! Socket on which the results are sent. If thread is 1, use inproc + END_DOC + integer :: rc + character*(8), external :: zmq_port + integer(ZMQ_PTR) :: new_zmq_pull_socket + + call omp_set_lock(zmq_lock) + new_zmq_pull_socket = f77_zmq_socket(zmq_context, ZMQ_PULL) +! new_zmq_pull_socket = f77_zmq_socket(zmq_context, ZMQ_REP) + call omp_unset_lock(zmq_lock) + if (new_zmq_pull_socket == 0_ZMQ_PTR) then + stop 'Unable to create zmq pull socket' + endif + + rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_LINGER,300000,4) + if (rc /= 0) then + stop 'Unable to set ZMQ_LINGER on pull socket' + endif + + rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_RCVHWM,100000,4) + if (rc /= 0) then + stop 'Unable to set ZMQ_RCVHWM on pull socket' + endif + + rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_IMMEDIATE,1,4) + if (rc /= 0) then + stop 'Unable to set ZMQ_IMMEDIATE on pull socket' + endif + + rc = f77_zmq_bind(new_zmq_pull_socket, zmq_socket_pull_tcp_address) + if (rc /= 0) then + print *, 'Unable to bind new_zmq_pull_socket (tcp)', zmq_socket_pull_tcp_address + stop + endif + + rc = f77_zmq_bind(new_zmq_pull_socket, zmq_socket_pull_inproc_address) + if (rc /= 0) then + stop 'Unable to bind new_zmq_pull_socket (inproc)' + endif + +end + + + + +function new_zmq_push_socket(thread) + use f77_zmq + implicit none + BEGIN_DOC + ! Socket on which the results are sent. If thread is 1, use inproc + END_DOC + integer, intent(in) :: thread + integer :: rc + character*(8), external :: zmq_port + integer(ZMQ_PTR) :: new_zmq_push_socket + + call omp_set_lock(zmq_lock) + new_zmq_push_socket = f77_zmq_socket(zmq_context, ZMQ_PUSH) +! new_zmq_push_socket = f77_zmq_socket(zmq_context, ZMQ_REQ) + call omp_unset_lock(zmq_lock) + if (new_zmq_push_socket == 0_ZMQ_PTR) then + stop 'Unable to create zmq push socket' + endif + + rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_LINGER,300000,4) + if (rc /= 0) then + stop 'Unable to set ZMQ_LINGER on push socket' + endif + + rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_SNDHWM,100,4) + if (rc /= 0) then + stop 'Unable to set ZMQ_SNDHWM on push socket' + endif + + rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_IMMEDIATE,1,4) + if (rc /= 0) then + stop 'Unable to set ZMQ_IMMEDIATE on push socket' + endif + + rc = f77_zmq_setsockopt(new_zmq_push_socket, ZMQ_SNDTIMEO, 100000, 4) + if (rc /= 0) then + stop 'Unable to set send timout in new_zmq_push_socket' + endif + + if (thread == 1) then + rc = f77_zmq_connect(new_zmq_push_socket, zmq_socket_push_inproc_address) + else + rc = f77_zmq_connect(new_zmq_push_socket, zmq_socket_push_tcp_address) + endif + if (rc /= 0) then + stop 'Unable to connect new_zmq_push_socket' + endif + +end + + + +subroutine end_zmq_pair_socket(zmq_socket_pair) + use f77_zmq + implicit none + BEGIN_DOC + ! Terminate socket on which the results are sent. + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_socket_pair + integer :: rc + character*(8), external :: zmq_port + + rc = f77_zmq_unbind(zmq_socket_pair,zmq_socket_pair_inproc_address) +! if (rc /= 0) then +! print *, rc +! print *, irp_here, 'f77_zmq_unbind(zmq_socket_pair,zmq_socket_pair_inproc_address)' +! stop 'error' +! endif + + rc = f77_zmq_setsockopt(zmq_socket_pair,ZMQ_LINGER,0,4) + if (rc /= 0) then + stop 'Unable to set ZMQ_LINGER on zmq_socket_pair' + endif + + rc = f77_zmq_close(zmq_socket_pair) + if (rc /= 0) then + print *, 'f77_zmq_close(zmq_socket_pair)' + stop 'error' + endif + +end + +subroutine end_zmq_pull_socket(zmq_socket_pull) + use f77_zmq + implicit none + BEGIN_DOC + ! Terminate socket on which the results are sent. + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_socket_pull + integer :: rc + character*(8), external :: zmq_port + + rc = f77_zmq_unbind(zmq_socket_pull,zmq_socket_pull_inproc_address) +! if (rc /= 0) then +! print *, rc +! print *, irp_here, 'f77_zmq_unbind(zmq_socket_pull,zmq_socket_pull_inproc_address)' +! stop 'error' +! endif + + rc = f77_zmq_unbind(zmq_socket_pull,zmq_socket_pull_tcp_address) + if (rc /= 0) then + print *, rc + print *, irp_here, 'f77_zmq_unbind(zmq_socket_pull,zmq_socket_pull_tcp_address)' + stop 'error' + endif + + rc = f77_zmq_setsockopt(zmq_socket_pull,ZMQ_LINGER,0,4) + if (rc /= 0) then + stop 'Unable to set ZMQ_LINGER on zmq_socket_pull' + endif + + rc = f77_zmq_close(zmq_socket_pull) + if (rc /= 0) then + print *, 'f77_zmq_close(zmq_socket_pull)' + stop 'error' + endif + +end + + +subroutine end_zmq_push_socket(zmq_socket_push,thread) + implicit none + use f77_zmq + BEGIN_DOC + ! Terminate socket on which the results are sent. + END_DOC + integer, intent(in) :: thread + integer(ZMQ_PTR), intent(in) :: zmq_socket_push + integer :: rc + character*(8), external :: zmq_port + + if (thread == 1) then + rc = f77_zmq_disconnect(zmq_socket_push,zmq_socket_push_inproc_address) +! if (rc /= 0) then +! print *, 'f77_zmq_disconnect(zmq_socket_push,zmq_socket_push_inproc_address)' +! stop 'error' +! endif + else + rc = f77_zmq_disconnect(zmq_socket_push,zmq_socket_push_tcp_address) + if (rc /= 0) then + print *, 'f77_zmq_disconnect(zmq_socket_push,zmq_socket_push_tcp_address)' + stop 'error' + endif + endif + + + rc = f77_zmq_setsockopt(zmq_socket_push,ZMQ_LINGER,0,4) + if (rc /= 0) then + stop 'Unable to set ZMQ_LINGER on push socket' + endif + + rc = f77_zmq_close(zmq_socket_push) + if (rc /= 0) then + print *, 'f77_zmq_close(zmq_socket_push)' + stop 'error' + endif + +end + + + +BEGIN_PROVIDER [ character*(128), zmq_state ] + implicit none + BEGIN_DOC + ! Threads executing work through the ZeroMQ interface + END_DOC + zmq_state = 'No_state' +END_PROVIDER + +subroutine new_parallel_job(zmq_to_qp_run_socket,name_in) + use f77_zmq + implicit none + BEGIN_DOC + ! Start a new parallel job with name 'name'. The slave tasks execute subroutine 'slave' + END_DOC + character*(*), intent(in) :: name_in + + character*(512) :: message, name + integer :: rc, sze + integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR), intent(out) :: zmq_to_qp_run_socket + + zmq_context = f77_zmq_ctx_new () + if (zmq_context == 0_ZMQ_PTR) then + stop 'ZMQ_PTR is null' + endif + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + name = name_in + sze = len(trim(name)) + call lowercase(name,sze) + message = 'new_job '//trim(name)//' '//zmq_socket_push_tcp_address//' '//zmq_socket_pull_inproc_address + sze = len(trim(message)) + rc = f77_zmq_send(zmq_to_qp_run_socket,message,sze,0) + if (rc /= sze) then + print *, irp_here, ':f77_zmq_send(zmq_to_qp_run_socket,message,sze,0)' + stop 'error' + endif + rc = f77_zmq_recv(zmq_to_qp_run_socket,message,510,0) + message = trim(message(1:rc)) + if (message(1:2) /= 'ok') then + print *, message + print *, 'Unable to start parallel job : '//name + stop 1 + endif + + zmq_state = trim(name) + +end + + +subroutine end_parallel_job(zmq_to_qp_run_socket,name_in) + use f77_zmq + implicit none + BEGIN_DOC + ! End a new parallel job with name 'name'. The slave tasks execute subroutine 'slave' + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + character*(*), intent(in) :: name_in + + character*(512) :: message, name + integer :: i,rc, sze + + name = name_in + sze = len(trim(name)) + call lowercase(name,sze) + if (name /= zmq_state) then + stop 'Wrong end of job' + endif + + rc = f77_zmq_send(zmq_to_qp_run_socket, 'end_job '//trim(zmq_state),8+len(trim(zmq_state)),0) + rc = f77_zmq_recv(zmq_to_qp_run_socket, zmq_state, 2, 0) + if (rc /= 2) then + print *, 'f77_zmq_recv(zmq_to_qp_run_socket, zmq_state, 2, 0)' + stop 'error' + endif + zmq_state = 'No_state' + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + + rc = f77_zmq_ctx_term(zmq_context) + if (rc /= 0) then + print *, 'Unable to terminate ZMQ context' + stop 'error' + endif +end + +subroutine connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) + use f77_zmq + implicit none + BEGIN_DOC + ! Connect to the task server and obtain the worker ID + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + integer, intent(out) :: worker_id + integer, intent(in) :: thread + + character*(512) :: message + character*(128) :: reply, state, address + integer :: rc + + if (thread == 1) then + rc = f77_zmq_send(zmq_to_qp_run_socket, "connect inproc", 14, 0) + if (rc /= 14) then + print *, 'f77_zmq_send(zmq_to_qp_run_socket, "connect inproc", 14, 0)' + stop 'error' + endif + else + rc = f77_zmq_send(zmq_to_qp_run_socket, "connect tcp", 11, 0) + if (rc /= 11) then + print *, 'f77_zmq_send(zmq_to_qp_run_socket, "connect tcp", 11, 0)' + stop 'error' + endif + endif + + rc = f77_zmq_recv(zmq_to_qp_run_socket, message, 510, 0) + message = trim(message(1:rc)) + read(message,*) reply, state, worker_id, address + if ( (trim(reply) /= 'connect_reply') .and. & + (trim(state) /= trim(zmq_state)) ) then + print *, 'Reply: ', trim(reply) + print *, 'State: ', trim(state), '/', trim(zmq_state) + print *, 'Address: ', trim(address) + stop -1 + endif + +end + +subroutine disconnect_from_taskserver(zmq_to_qp_run_socket, & + zmq_socket_push, worker_id) + use f77_zmq + implicit none + BEGIN_DOC + ! Disconnect from the task server + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + integer(ZMQ_PTR), intent(in) :: zmq_socket_push + integer, intent(in) :: worker_id + + integer :: rc, sze + character*(64) :: message, reply, state + write(message,*) 'disconnect '//trim(zmq_state), worker_id + + sze = len(trim(message)) + rc = f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0) + if (rc /= sze) then + print *, rc, sze + print *, irp_here, 'f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0)' + stop 'error' + endif + + rc = f77_zmq_recv(zmq_to_qp_run_socket, message, 510, 0) + message = trim(message(1:rc)) + + read(message,*) reply, state + if ( (trim(reply) /= 'disconnect_reply').or. & + (trim(state) /= zmq_state) ) then + print *, 'Unable to disconnect : ', zmq_state + print *, trim(message) + stop -1 + endif + +end + +subroutine add_task_to_taskserver(zmq_to_qp_run_socket,task) + use f77_zmq + implicit none + BEGIN_DOC + ! Get a task from the task server + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + character*(*), intent(in) :: task + + integer :: rc, sze + character*(512) :: message + write(message,*) 'add_task '//trim(zmq_state)//' '//trim(task) + + sze = len(trim(message)) + rc = f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0) + if (rc /= sze) then + print *, rc, sze + print *, irp_here,': f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0)' + stop 'error' + endif + + rc = f77_zmq_recv(zmq_to_qp_run_socket, message, 510, 0) + message = trim(message(1:rc)) + if (trim(message) /= 'ok') then + print *, trim(task) + print *, 'Unable to add the next task' + stop -1 + endif + +end + +subroutine task_done_to_taskserver(zmq_to_qp_run_socket,worker_id, task_id) + use f77_zmq + implicit none + BEGIN_DOC + ! Get a task from the task server + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + integer, intent(in) :: worker_id, task_id + + integer :: rc, sze + character*(512) :: message + write(message,*) 'task_done '//trim(zmq_state), worker_id, task_id + + sze = len(trim(message)) + rc = f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0) + if (rc /= sze) then + print *, irp_here, 'f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0)' + stop 'error' + endif + + rc = f77_zmq_recv(zmq_to_qp_run_socket, message, 510, 0) + message = trim(message(1:rc)) + if (trim(message) /= 'ok') then + print *, 'Unable to send task_done message' + stop -1 + endif + +end + +subroutine get_task_from_taskserver(zmq_to_qp_run_socket,worker_id,task_id,task) + use f77_zmq + implicit none + BEGIN_DOC + ! Get a task from the task server + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + integer, intent(in) :: worker_id + integer, intent(out) :: task_id + character*(512), intent(out) :: task + + character*(512) :: message + character*(64) :: reply + integer :: rc, sze + + write(message,*) 'get_task '//trim(zmq_state), worker_id + + sze = len(trim(message)) + rc = f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0) + if (rc /= sze) then + print *, irp_here, ':f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0)' + stop 'error' + endif + + rc = f77_zmq_recv(zmq_to_qp_run_socket, message, 510, 0) + message = trim(message(1:rc)) + read(message,*) reply + if (trim(reply) == 'get_task_reply') then + read(message,*) reply, task_id + rc = 15 + do while (message(rc:rc) == ' ') + rc += 1 + enddo + do while (message(rc:rc) /= ' ') + rc += 1 + enddo + rc += 1 + task = message(rc:) + else if (trim(reply) == 'terminate') then + task_id = 0 + task = 'terminate' + else + print *, 'Unable to get the next task' + print *, trim(message) + stop -1 + endif + +end + + +subroutine end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + use f77_zmq + implicit none + BEGIN_DOC +! Terminate the socket from the application to qp_run + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + character*(8), external :: zmq_port + integer :: rc + + rc = f77_zmq_disconnect(zmq_to_qp_run_socket, trim(qp_run_address)//':'//trim(zmq_port(0))) +! if (rc /= 0) then +! print *, 'f77_zmq_disconnect(zmq_to_qp_run_socket, trim(qp_run_address)//'':''//trim(zmq_port(0)))' +! stop 'error' +! endif + + rc = f77_zmq_setsockopt(zmq_to_qp_run_socket,ZMQ_LINGER,0,4) + if (rc /= 0) then + stop 'Unable to set ZMQ_LINGER on zmq_to_qp_run_socket' + endif + + rc = f77_zmq_close(zmq_to_qp_run_socket) + if (rc /= 0) then + print *, 'f77_zmq_close(zmq_to_qp_run_socket)' + stop 'error' + endif + +end + +subroutine zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more) + use f77_zmq + implicit none + BEGIN_DOC +! When a task is done, it has to be removed from the list of tasks on the qp_run +! queue. This guarantees that the results have been received in the pull. + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_socket_pull + integer, intent(in) :: task_id + integer, intent(out) :: more + integer :: rc + character*(512) :: msg + + write(msg,*) 'del_task ', zmq_state, task_id + rc = f77_zmq_send(zmq_to_qp_run_socket,msg,512,0) + if (rc /= 512) then + print *, 'f77_zmq_send(zmq_to_qp_run_socket,task_id,4,0)' + stop 'error' + endif + + character*(64) :: reply + reply = '' + rc = f77_zmq_recv(zmq_to_qp_run_socket,reply,64,0) + + if (reply(16:19) == 'more') then + more = 1 + else if (reply(16:19) == 'done') then + more = 0 + rc = f77_zmq_setsockopt(zmq_socket_pull, ZMQ_RCVTIMEO, 1000, 4) + if (rc /= 0) then + print *, 'f77_zmq_setsockopt(zmq_socket_pull, ZMQ_RCVTIMEO, 3000, 4)' + stop 'error' + endif + else + print *, reply + print *, 'f77_zmq_recv(zmq_to_qp_run_socket,reply,64,0)' + stop 'error' + endif +end + 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 ae385fe8..de0cd1c8 100644 --- a/tests/bats/qp.bats +++ b/tests/bats/qp.bats @@ -24,8 +24,6 @@ function eq() { } - - # ___ # | ._ o _|_ # _|_ | | | |_ @@ -59,31 +57,59 @@ 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)" eq $energy_pt2 $4 $thresh } +function run_all_1h_1p() { + thresh=1.e-6 + test_exe all_1h_1p || skip + ezfio set_file $1 + ezfio set determinants n_det_max $2 + ezfio set perturbation pt2_max $3 + ezfio set determinants threshold_davidson 1.e-10 + + qp_run all_1h_1p $1 | tee $1.F1h1p.out + energy="$(ezfio get all_singles energy)" + eq $energy $4 $thresh +} + # ___ # | _ _ _|_ # | (/_ _> |_ # + +#=== DHNO +@test "init DHNO chipman-dzp" { + run_init dhno.xyz "-b chipman-dzp -m 2" dhno.ezfio +} + +@test "SCF DHNO chipman-dzp" { + run_HF dhno.ezfio -130.4278777822 +} + +@test "all_1h_1p DHNO chipman-dzp" { + qp_set_mo_class -inact "[1-8]" -act "[9]" -virt "[10-64]" dhno.ezfio + run_all_1h_1p dhno.ezfio 10000 0.0000000001 -130.4466283766202 +} + #=== HBO @test "init HBO STO-3G" { run_init HBO.xyz "-b STO-3G" hbo.ezfio @@ -104,7 +130,8 @@ function run_FCI() { } @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" { @@ -113,8 +140,8 @@ function run_FCI() { 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 } @@ -126,7 +153,7 @@ function run_FCI() { 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 @@ -143,7 +170,8 @@ function run_FCI() { } @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 @@ -151,7 +179,7 @@ function run_FCI() { 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 @@ -161,7 +189,7 @@ function run_FCI() { 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/input/dhno.xyz b/tests/input/dhno.xyz new file mode 100644 index 00000000..367a2fa7 --- /dev/null +++ b/tests/input/dhno.xyz @@ -0,0 +1,7 @@ +4 +XYZ file: coordinates in Angstrom +H -0.877367 -1.047049 0.000000 +N 0.000000 -0.544985 0.000000 +O 0.000000 0.738624 0.000000 +H 0.877367 -1.047049 0.000000 + 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