diff --git a/.gitignore b/.gitignore index 9d9c4fdb..ccf29a14 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,5 @@ quantum_package.rc +config/ifort.cfg quantum_package_static.tar.gz build.ninja .ninja_log diff --git a/.travis.yml b/.travis.yml index 18a13949..5e032609 100644 --- a/.travis.yml +++ b/.travis.yml @@ -9,6 +9,8 @@ sudo: false addons: apt: packages: + - zlib1g-dev + - libgmp3-dev - gfortran - gcc - liblapack-dev @@ -24,7 +26,7 @@ python: script: - ./configure --production ./config/gfortran.cfg - - source ./quantum_package.rc ; qp_module.py install Full_CI Hartree_Fock CAS_SD MRCC_CASSD All_singles + - source ./quantum_package.rc ; qp_module.py install Full_CI Full_CI_ZMQ Hartree_Fock CAS_SD mrcepa0 All_singles - source ./quantum_package.rc ; ninja - source ./quantum_package.rc ; cd ocaml ; make ; cd - - source ./quantum_package.rc ; cd tests ; ./run_tests.sh #-v diff --git a/README.md b/README.md index e313f444..bb63b691 100644 --- a/README.md +++ b/README.md @@ -1,21 +1,20 @@ -Quantum package -=============== - +![QP](https://raw.githubusercontent.com/LCPQ/quantum_package/master/data/qp.png) [![Build Status](https://travis-ci.org/LCPQ/quantum_package.svg?branch=master)](https://travis-ci.org/LCPQ/quantum_package) - [![Gitter](https://badges.gitter.im/Join%20Chat.svg)](https://gitter.im/LCPQ/quantum_package?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) - Set of quantum chemistry programs and libraries. (under GNU GENERAL PUBLIC LICENSE v2) For more information, you can visit the [wiki of the project](http://github.com/LCPQ/quantum_package/wiki>), or below for the installation instructions. + + Demo ==== [![Full-CI energy of C2 in 2 minutes](https://i.vimeocdn.com/video/555047954_295x166.jpg)](https://vimeo.com/scemama/quantum_package_demo "Quantum Package Demo") +[![Frozen-core Full-CI energy of Ti](https://raw.githubusercontent.com/LCPQ/quantum_package/master/data/Titanium.png)](https://raw.githubusercontent.com/LCPQ/quantum_package/master/data/Titanium.png "Convergence of Ti in cc-pv{DTQ}Z") # Installation @@ -159,7 +158,7 @@ Program exited with code 139. #### Why ? -It's caused when we call the DGEM routine of LAPACK. +It's caused when we call the DGEMM routine of LAPACK. ##### Fix diff --git a/config/gfortran.cfg b/config/gfortran.cfg index 694ef0df..c0aa875f 100644 --- a/config/gfortran.cfg +++ b/config/gfortran.cfg @@ -35,7 +35,7 @@ OPENMP : 1 ; Append OpenMP flags # -ffast-math and the Fortran-specific # -fno-protect-parens and -fstack-arrays. [OPT] -FCFLAGS : -Ofast +FCFLAGS : -Ofast # Profiling flags ################# diff --git a/config/gfortran_avx.cfg b/config/gfortran_avx.cfg index 6672bca1..80bbbec9 100644 --- a/config/gfortran_avx.cfg +++ b/config/gfortran_avx.cfg @@ -10,7 +10,7 @@ # # [COMMON] -FC : gfortran -ffree-line-length-none -I . -mavx +FC : gfortran -ffree-line-length-none -I . -mavx -g LAPACK_LIB : -llapack -lblas IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=32 diff --git a/config/gfortran_debug.cfg b/config/gfortran_debug.cfg index 72084241..03663eea 100644 --- a/config/gfortran_debug.cfg +++ b/config/gfortran_debug.cfg @@ -51,7 +51,7 @@ FCFLAGS : -Ofast # -g : Extra debugging information # [DEBUG] -FCFLAGS : -g -pedantic -msse4.2 +FCFLAGS : -g -msse4.2 # OpenMP flags ################# diff --git a/config/ifort.cfg b/config/ifort.cfg index c1d7e968..843e887b 100644 --- a/config/ifort.cfg +++ b/config/ifort.cfg @@ -31,14 +31,15 @@ OPENMP : 1 ; Append OpenMP flags # -ftz : Flushes denormal results to zero # [OPT] -FCFLAGS : -xSSE4.2 -O2 -ip -opt-prefetch -ftz -g +FC : -traceback +FCFLAGS : -xSSE4.2 -O2 -ip -ftz -g # Profiling flags ################# # [PROFILE] FC : -p -g -FCFLAGS : -xSSE4.2 -O2 -ip -opt-prefetch -ftz +FCFLAGS : -xSSE4.2 -O2 -ip -ftz # Debugging flags ################# @@ -51,12 +52,12 @@ FCFLAGS : -xSSE4.2 -O2 -ip -opt-prefetch -ftz # [DEBUG] FC : -g -traceback -FCFLAGS : -xSSE2 -C -fpe0 +FCFLAGS : -xSSE2 -C -fpe0 # OpenMP flags ################# # [OPENMP] -FC : -openmp +FC : -qopenmp IRPF90_FLAGS : --openmp diff --git a/config/sse4_avx2.cfg b/config/sse4_avx2.cfg new file mode 100644 index 00000000..eabf75a3 --- /dev/null +++ b/config/sse4_avx2.cfg @@ -0,0 +1,62 @@ +# Common flags +############## +# +# -mkl=[parallel|sequential] : Use the MKL library +# --ninja : Allow the utilisation of ninja. It is mandatory ! +# --align=32 : Align all provided arrays on a 32-byte boundary +# +[COMMON] +FC : ifort +LAPACK_LIB : -mkl=parallel +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 +#################### +# +# -xHost : Compile a binary optimized for the current architecture +# -O2 : O3 not better than O2. +# -ip : Inter-procedural optimizations +# -ftz : Flushes denormal results to zero +# +[OPT] +FCFLAGS : -axSSE4.2,AVX,CORE-AVX2 -O2 -ip -ftz -g -traceback + +# Profiling flags +################# +# +[PROFILE] +FC : -p -g +FCFLAGS : -xSSE4.2 -O2 -ip -ftz + +# Debugging flags +################# +# +# -traceback : Activate backtrace on runtime +# -fpe0 : All floating point exaceptions +# -C : Checks uninitialized variables, array subscripts, etc... +# -g : Extra debugging information +# -xSSE2 : Valgrind needs a very simple x86 executable +# +[DEBUG] +FC : -g -traceback +FCFLAGS : -xSSE2 -C -fpe0 + +# OpenMP flags +################# +# +[OPENMP] +FC : -openmp +IRPF90_FLAGS : --openmp + diff --git a/configure b/configure index b217cbea..8cb02608 100755 --- a/configure +++ b/configure @@ -46,7 +46,12 @@ if len(sys.argv) != 3: # \_| |_ (_) |_) (_| | | | | | (_) # -QP_ROOT = os.getcwd() +try: + QP_ROOT = os.environ["QP_ROOT"] +except KeyError: + QP_ROOT = os.getcwd() + os.environ["QP_ROOT"] = QP_ROOT + QP_ROOT_BIN = join(QP_ROOT, "bin") QP_ROOT_LIB = join(QP_ROOT, "lib") QP_ROOT_INSTALL = join(QP_ROOT, "install") @@ -137,7 +142,7 @@ ezfio = Info( default_path=join(QP_ROOT_INSTALL, "EZFIO")) zeromq = Info( - url='http://download.zeromq.org/zeromq-4.0.7.tar.gz', + url='https://github.com/zeromq/zeromq4-1/releases/download/v4.1.5/zeromq-4.1.5.tar.gz', description=' ZeroMQ', default_path=join(QP_ROOT_LIB, "libzmq.a")) @@ -482,7 +487,6 @@ 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}")), @@ -493,6 +497,10 @@ def create_ninja_and_rc(l_installed): 'export LIBRARY_PATH="${QP_ROOT}"/lib:"${LIBRARY_PATH}"', "", 'source ${QP_ROOT}/install/EZFIO/Bash/ezfio.sh', "", 'source ${HOME}/.opam/opam-init/init.sh > /dev/null 2> /dev/null || true', + '', + '# Choose the correct network interface', + '# export QP_NIC=ib0', + '# export QP_NIC=eth0', "" ] @@ -538,7 +546,6 @@ def recommendation(): print "" print "Finally :" print " ninja" - print " make -C ocaml" print "" print "You can install more plugin with the qp_module.py install command" print "PS : For more info on compiling the code, read the README.md" diff --git a/data/Titanium.png b/data/Titanium.png new file mode 100644 index 00000000..871babd4 Binary files /dev/null and b/data/Titanium.png differ diff --git a/data/basis/aug-cc-pcv5z b/data/basis/aug-cc-pcv5z index b2f69a7f..e7690eda 100644 --- a/data/basis/aug-cc-pcv5z +++ b/data/basis/aug-cc-pcv5z @@ -705,3 +705,5 @@ H 1 1 21.1040000 1.0000000 H 1 1 0.7420000 1.0000000 + + diff --git a/data/basis/aug-cc-pcvdz b/data/basis/aug-cc-pcvdz index 91e05234..21e387d3 100644 --- a/data/basis/aug-cc-pcvdz +++ b/data/basis/aug-cc-pcvdz @@ -893,3 +893,5 @@ D 1 1 11.4590000 1.0000000 D 1 1 0.2400000 1.0000000 + + diff --git a/data/basis/aug-cc-pcvqz b/data/basis/aug-cc-pcvqz index b51cdb26..ccffc20e 100644 --- a/data/basis/aug-cc-pcvqz +++ b/data/basis/aug-cc-pcvqz @@ -1594,3 +1594,5 @@ G 1 1 17.2430000 1.0000000 G 1 1 0.4590000 1.0000000 + + diff --git a/data/basis/aug-cc-pcvtz b/data/basis/aug-cc-pcvtz index 0d918bdb..bab856a3 100644 --- a/data/basis/aug-cc-pcvtz +++ b/data/basis/aug-cc-pcvtz @@ -1224,3 +1224,5 @@ F 1 1 13.6740000 1.0000000 F 1 1 0.4060000 1.0000000 + + diff --git a/data/basis/aug-cc-pv5z b/data/basis/aug-cc-pv5z index 50d2cab2..f069ed87 100644 --- a/data/basis/aug-cc-pv5z +++ b/data/basis/aug-cc-pv5z @@ -7065,3 +7065,5 @@ H 1 1 0.9303000 1.0000000 H 1 1 0.5800000 1.0000000 + + diff --git a/data/basis/aug-cc-pv6z b/data/basis/aug-cc-pv6z index b041e85e..7b1ae494 100644 --- a/data/basis/aug-cc-pv6z +++ b/data/basis/aug-cc-pv6z @@ -1515,3 +1515,5 @@ I 1 1 1.5066000 1.0000000 I 1 1 0.9926000 1.0000000 + + diff --git a/data/basis/aug-cc-pvdz b/data/basis/aug-cc-pvdz index 9ea395a2..6ba22f17 100644 --- a/data/basis/aug-cc-pvdz +++ b/data/basis/aug-cc-pvdz @@ -3485,3 +3485,5 @@ D 1 1 0.5030000 1.0000000 D 1 1 0.2155000 1.0000000 + + diff --git a/data/basis/aug-cc-pvqz b/data/basis/aug-cc-pvqz index ee6500f7..5539c11d 100644 --- a/data/basis/aug-cc-pvqz +++ b/data/basis/aug-cc-pvqz @@ -5685,3 +5685,5 @@ G 1 1 0.7395000 1.0000000 G 1 1 0.3590000 1.0000000 + + diff --git a/data/basis/aug-cc-pvtz b/data/basis/aug-cc-pvtz index 347d7acd..b9d1788f 100644 --- a/data/basis/aug-cc-pvtz +++ b/data/basis/aug-cc-pvtz @@ -4421,3 +4421,5 @@ F 1 1 0.6622000 1.0000000 F 1 1 0.3280000 1.0000000 + + diff --git a/data/basis/cc-pcv5z b/data/basis/cc-pcv5z index 268ec7b1..b46f1e0e 100644 --- a/data/basis/cc-pcv5z +++ b/data/basis/cc-pcv5z @@ -1614,3 +1614,5 @@ G 1 1 0.3023000 1.0000000 H 1 1 0.2534000 1.0000000 + + diff --git a/data/basis/cc-pcv6z b/data/basis/cc-pcv6z index 24be7b59..73d5f29f 100644 --- a/data/basis/cc-pcv6z +++ b/data/basis/cc-pcv6z @@ -1515,3 +1515,5 @@ I 1 1 1.5066000 1.0000000 I 1 1 24.5369000 1.0000000 + + diff --git a/data/basis/cc-pcvdz b/data/basis/cc-pcvdz index aee98b83..9c28d870 100644 --- a/data/basis/cc-pcvdz +++ b/data/basis/cc-pcvdz @@ -905,3 +905,5 @@ D 1 1 0.0537000 1.0000000 D 1 1 1.3743000 1.0000000 + + diff --git a/data/basis/cc-pcvqz b/data/basis/cc-pcvqz index 4534ab01..da85c7f1 100644 --- a/data/basis/cc-pcvqz +++ b/data/basis/cc-pcvqz @@ -1611,3 +1611,5 @@ G 1 1 0.1466000 1.0000000 G 1 1 1.5908000 1.0000000 + + diff --git a/data/basis/cc-pcvtz b/data/basis/cc-pcvtz index 3338e531..650c3962 100644 --- a/data/basis/cc-pcvtz +++ b/data/basis/cc-pcvtz @@ -1246,3 +1246,5 @@ F 1 1 0.1509000 1.0000000 F 1 1 1.3909000 1.0000000 + + diff --git a/data/basis/cc-pv5z b/data/basis/cc-pv5z index 39869ff5..6900f274 100644 --- a/data/basis/cc-pv5z +++ b/data/basis/cc-pv5z @@ -7212,3 +7212,5 @@ G 1 1 1.1040000 1.0000000 H 1 1 0.9303000 1.0000000 + + diff --git a/data/basis/cc-pv6z b/data/basis/cc-pv6z index f850752f..53f322ca 100644 --- a/data/basis/cc-pv6z +++ b/data/basis/cc-pv6z @@ -1323,3 +1323,5 @@ H 1 1 0.8871000 1.0000000 I 1 1 1.5066000 1.0000000 + + diff --git a/data/basis/cc-pvdz b/data/basis/cc-pvdz index 18eea48d..1685d42d 100644 --- a/data/basis/cc-pvdz +++ b/data/basis/cc-pvdz @@ -3367,3 +3367,5 @@ D 5 5 1.5075240 0.2667560 D 1 1 0.5030000 1.0000000 + + diff --git a/data/basis/cc-pvqz b/data/basis/cc-pvqz index 2fff4854..f7575ab7 100644 --- a/data/basis/cc-pvqz +++ b/data/basis/cc-pvqz @@ -5482,3 +5482,5 @@ F 1 1 0.9557000 1.0000000 G 1 1 0.7395000 1.0000000 + + diff --git a/data/basis/cc-pvtz b/data/basis/cc-pvtz index 332a7ec8..6e4c326c 100644 --- a/data/basis/cc-pvtz +++ b/data/basis/cc-pvtz @@ -4269,3 +4269,5 @@ D 1 1 0.3006000 1.0000000 F 1 1 0.6622000 1.0000000 + + diff --git a/data/basis/chipman-dzp b/data/basis/chipman-dzp index b0178ef4..f7410dd8 100644 --- a/data/basis/chipman-dzp +++ b/data/basis/chipman-dzp @@ -166,3 +166,5 @@ D 1 1 0.6650000 1.0000000 D 1 1 2.6600000 1.0000000 + + diff --git a/data/basis/v5z-bfd b/data/basis/v5z-bfd index c7533e9b..0afd2bfc 100644 --- a/data/basis/v5z-bfd +++ b/data/basis/v5z-bfd @@ -1017,3 +1017,5 @@ F 1 G 1 1 0.623669 1.000000 + + diff --git a/data/basis/vdz-ano-bfd b/data/basis/vdz-ano-bfd index 1adef6a1..f43040af 100644 --- a/data/basis/vdz-ano-bfd +++ b/data/basis/vdz-ano-bfd @@ -586,3 +586,5 @@ S 1 P 1 1 1.275000 1.000000 + + diff --git a/data/basis/vdz-bfd b/data/basis/vdz-bfd index 7d3ebb94..8ec29ffe 100644 --- a/data/basis/vdz-bfd +++ b/data/basis/vdz-bfd @@ -997,3 +997,5 @@ P 8 7 9.063386 -0.224631 8 16.737180 0.098422 + + diff --git a/data/basis/vqz-ano-bfd b/data/basis/vqz-ano-bfd index 3b38b145..ea1f38b9 100644 --- a/data/basis/vqz-ano-bfd +++ b/data/basis/vqz-ano-bfd @@ -2409,3 +2409,5 @@ G 1 H 1 1 3.164456 1.000000 + + diff --git a/data/basis/vqz-bfd b/data/basis/vqz-bfd index 5e1dd1f8..b0fc8d65 100644 --- a/data/basis/vqz-bfd +++ b/data/basis/vqz-bfd @@ -809,3 +809,5 @@ D 1 F 1 1 1.021427 1.000000 + + diff --git a/data/basis/vtz-ano-bfd b/data/basis/vtz-ano-bfd index a0e873c3..f6916f58 100644 --- a/data/basis/vtz-ano-bfd +++ b/data/basis/vtz-ano-bfd @@ -1850,3 +1850,5 @@ F 1 G 1 1 2.775762 1.000000 + + diff --git a/data/basis/vtz-bfd b/data/basis/vtz-bfd index 0b6bb3f4..2091118e 100644 --- a/data/basis/vtz-bfd +++ b/data/basis/vtz-bfd @@ -1279,3 +1279,5 @@ P 1 D 1 1 1.913792 1.000000 + + diff --git a/data/pseudo/tm b/data/pseudo/tm new file mode 100644 index 00000000..531445f8 --- /dev/null +++ b/data/pseudo/tm @@ -0,0 +1,32 @@ +Ag GEN 36 2 +4 +11.074 1 1.712 +-166.201 2 1.391 +255.676 2 1.194 +-91.757 2 1.033 +3 +11.074 1 0.897 +-22.6472 2 1.226 +16.8557 2 0.9789 +4 +9.524 1 12.668 +227.659 2 1.662 +-363.576 2 1.4 +150.286 2 1.205 + +Au GEN 68 2 +4 +10.881 1 2.286 +-97.386 2 1.088 +270.134 2 1.267 +-171.733 2 1.499 +3 +10.721 1 1.38 +-63.222 2 1.111 +60.634 2 0.987 +4 +9.383 1 11. +225.822 2 1.66 +286.233 2 1.342 +-497.561 2 1.437 + diff --git a/data/pseudo/tn_df b/data/pseudo/tn_df new file mode 100644 index 00000000..79ebf8f5 --- /dev/null +++ b/data/pseudo/tn_df @@ -0,0 +1,806 @@ +H GEN 0 2 +6 + 1.00000000 1 34.44662515 + -0.89096601 2 40.13885591 + -4.35250792 2 24.66307521 + -11.58011743 2 20.49225491 + 12.58011743 2 30.23909011 + 34.44662515 3 22.28419700 +6 + -262.22422461 2 17.87367530 + 258.22981252 2 28.75598991 + 5613.63467960 2 19.10096571 + -4192.30569417 2 18.88256059 + -1341.04802395 2 20.95302325 + -79.28421640 2 34.10653707 +6 + -199.48848662 2 37.85954681 + 197.31066276 2 28.79454664 + 4870247.22276531 2 40.22839783 + -5277181.77014563 2 40.34690459 + -196566.81095176 2 39.13989706 + 603502.35555458 2 40.91315002 + +He GEN 0 2 +6 + 2.00000000 1 22.64777484 + -0.00700692 2 23.54196640 + -8.90169316 2 18.71556903 + 113.56926776 2 15.15150658 + -112.56926776 2 13.80465850 + 45.29554968 3 12.54192267 +6 + 747.63794984 2 13.33611411 + -753.70091072 2 23.45392111 + -397.08293819 2 12.23651194 + 10.35341837 2 14.87987639 + -1430.53848568 2 18.32138342 + 1818.26602949 2 21.24054054 +6 + 305.67933642 2 21.32319132 + -307.98355807 2 12.22370696 + 5957.66379729 2 14.11720170 + -6099.62872267 2 14.41269814 + 523.59639310 2 17.66028106 + -380.63505659 2 21.52626637 + +Li GEN 2 2 +6 + 1.00000000 1 0.78732101 + -2.23999912 2 0.79224763 + 0.10376190 2 1.79622268 + 4.27489122 2 1.83637465 + -3.27489122 2 1.91213904 + 0.78732101 3 0.79291624 +6 + 256.80790655 2 1.78312879 + -255.81956741 2 0.95553059 + 90.30361668 2 0.87617279 + 272.13155048 2 1.09621549 + -180.73373018 2 1.43900642 + -180.70146573 2 1.83085147 +6 + -4.80714862 2 1.53942961 + 3.36281864 2 0.84742021 + -305.38012622 2 0.78976831 + -509.40184487 2 0.98031681 + 436.16121675 2 0.81548364 + 379.61797456 2 1.02582853 + +Be GEN 2 2 +6 + 2.00000000 1 1.20639978 + -5.40313229 2 1.18425537 + 1.72394027 2 2.81826911 + 2.83884922 2 2.37513515 + -1.83884922 2 2.82920954 + 2.41279956 3 1.18219335 +6 + -1045.63679908 2 2.59240356 + 1047.85482764 2 1.41685787 + -1899.15859219 2 1.48536566 + 1398.06780686 2 1.70076501 + -696.13481389 2 2.03898674 + 1198.22571139 2 2.57766211 +6 + 630.90931326 2 1.84421403 + -632.78437074 2 1.13419132 + 441.35012255 2 1.13393716 + 435.97021325 2 1.22419150 + -353.63284449 2 1.39760436 + -522.69065435 2 1.88595068 + +B GEN 2 2 +6 + 3.00000000 1 2.72292969 + -11.78419674 2 2.41356794 + 5.22993640 2 4.60628004 + 0.42834165 2 3.81569642 + 0.57165835 2 4.75281449 + 8.16878907 3 2.42655010 +6 + -260.26050710 2 2.55536939 + 265.37594882 2 4.54575013 + 76.89512909 2 2.14992133 + -57.25691791 2 2.71845869 + 4293.37943873 2 3.54567059 + -4312.01708538 2 3.65811356 +6 + 236.98381086 2 3.86703012 + -239.59777090 2 2.15409783 + 4347.09682018 2 2.51320631 + -4637.07702775 2 2.58243237 + 786.10765740 2 3.15459528 + -495.13181880 2 3.69673537 + +C GEN 2 2 +6 + 4.00000000 1 6.85914037 + -69.31783111 2 7.66877502 + 58.73619595 2 8.89164866 + -5.11066199 2 4.63398124 + 6.11066199 2 5.40104250 + 27.43656147 3 6.79273179 +6 + 430.61454744 2 8.62389774 + -421.35054055 2 5.03244470 + -33212.40034531 2 6.89861917 + 44.12655159 2 3.96628687 + 96.39927700 2 5.01313881 + 33072.87650778 2 6.85964729 +6 + -104389.58452246 2 4.75057662 + 104386.03365951 2 8.95366858 + 690570.92310077 2 7.84605551 + 105067.78650436 2 4.75435948 + -142604.06718444 2 8.80450514 + -653033.64724842 2 7.81116996 + +N GEN 2 2 +6 + 5.00000000 1 11.01983025 + -747.65378590 2 7.70260962 + 731.28815439 2 7.83791198 + -3.54162255 2 8.41784728 + 4.54162255 2 12.53426384 + 55.09915125 3 6.76845507 +6 + 189.29450948 2 10.95064006 + -174.81483163 2 7.48980682 + 148422.74289741 2 6.18035270 + -167161.90534269 2 6.21695388 + 34280.43140051 2 6.81408633 + -15540.26812247 2 7.23413705 +6 + -5338.70218681 2 6.15987128 + 5334.35386770 2 7.49726635 + -1839.21100223 2 8.80963870 + 16010.85000728 2 6.52067091 + -16722.95522386 2 6.97790252 + 2552.31199840 2 8.37871646 + +O GEN 2 2 +6 + 6.00000000 1 8.86932353 + -28.04199287 2 6.05326172 + 11.15704031 2 5.51480979 + 180.82432510 2 10.77878397 + -179.82432510 2 10.23693413 + 53.21594115 3 7.90462675 +6 + -9212.20980516 2 7.28893859 + 9226.86567950 2 6.05971190 + 58203.26727502 2 10.83143357 + -5120.48607364 2 5.75281092 + -93321.50266843 2 10.51155711 + 40239.72318888 2 9.72227746 +6 + 10001.55649464 2 7.43321349 + -10012.86801601 2 5.85047476 + 8554.95973537 2 5.79011164 + -20342.33136146 2 8.08750969 + 11739.44079236 2 8.43229920 + 48.92837040 2 4.71055456 + +F GEN 2 2 +6 + 7.00000000 1 16.52048840 + -10.46754024 2 13.26693551 + -11.21567917 2 18.77563836 + -32.41582195 2 10.96778594 + 33.41582195 2 21.09729680 + 115.64341877 3 13.46927525 +6 + 1201.43391413 2 19.92490215 + -1182.60889584 2 11.77163137 + -8770.99026936 2 12.30043337 + 5336.21358848 2 11.63810105 + 8729.77565724 2 14.12189391 + -5293.99672165 2 16.53091209 +6 + 92.58757506 2 8.66992000 + -108.46085404 2 9.40009036 + -319.30686222 2 9.08633595 + 524.57586653 2 9.90194004 + -443.63347077 2 13.57164540 + 239.36118945 2 16.47995554 + +Ne GEN 2 2 +6 + 8.00000000 1 21.64664513 + 1794.02959527 2 14.45731213 + -1828.03241002 2 14.11697591 + 23.90491418 2 14.10774236 + -22.90491418 2 20.42359560 + 173.17316107 3 11.93940404 +6 + -5911.13460210 2 12.24993716 + 5941.26076308 2 20.24332306 + 2840.09993994 2 12.20646543 + 1742.40556167 2 11.50431394 + 8834.09207695 2 16.82066882 + -13415.59681607 2 18.72208419 +6 + 53626.32637171 2 20.56468824 + -53639.90888359 2 19.92390926 + -576.65341012 2 13.02834964 + 1907.80575476 2 15.43385134 + 5623.71426075 2 18.06950435 + -6953.86800222 2 22.66963993 + +K GEN 18 2 +6 + 1.00000000 1 0.50008727 + 1416.76952428 2 0.63134777 + -1419.89095139 2 0.60241926 + -302.74307268 2 0.68724573 + 303.74307268 2 0.55624069 + 0.50008727 3 0.50008691 +6 + -854959.33457742 2 0.55297829 + 854960.96236303 2 0.59508099 + -2735051.37932036 2 0.55136787 + -797902.82136562 2 0.59254779 + -90621.33409241 2 0.60683509 + 3623576.53510235 2 0.55188848 +6 + 5366450.44923246 2 0.56834617 + -5366449.39460951 2 0.57395202 + 506392.75510780 2 0.65188562 + 1065012.45735119 2 0.60395254 + -764583.36396565 2 0.55451976 + -806820.84832728 2 0.64359720 + +Ca GEN 18 2 +6 + 2.00000000 1 0.74758765 + 308735.40641498 2 0.72269274 + -308740.90975833 2 0.72197603 + 7202.81432103 2 0.70435779 + -7201.81432103 2 0.73462875 + 1.49517531 3 0.98521314 +6 + 3358.40551562 2 0.85820603 + -3354.33378202 2 0.50055931 + 645.82930380 2 0.77593512 + -4032.30085432 2 0.85197466 + 3315.68514964 2 0.50005881 + 71.78714429 2 1.01826143 +6 + 3797.10880911 2 0.54666026 + -3794.15970380 2 0.55760964 + 1988.78457523 2 0.66771019 + 13912.48066729 2 0.71662858 + -408.96685813 2 0.50701325 + -15491.29677996 2 0.71335086 + +Sc GEN 18 2 +6 + 3.00000000 1 6.99258598 + -124.50237230 2 4.24128187 + 97.21802227 2 1.68870852 + -87.09390293 2 1.51321231 + 88.09390293 2 5.62659050 + 20.97775795 3 2.67617421 +6 + 375.73920548 2 5.45654024 + -350.54708476 2 5.82486421 + -11.58800164 2 0.51173797 + 12.31935173 2 0.56805032 + 20.80334597 2 0.78399590 + -20.53480959 2 1.25273408 +6 + 6092.78689761 2 1.30970450 + -6068.65474455 2 6.97688197 + 6074.16548241 2 6.96312742 + -2.71306889 2 0.50000000 + 562.44223581 2 1.09627007 + -6632.89448781 2 1.28901234 + +Ti GEN 18 2 +6 + 4.00000000 1 4.58962911 + 29.78882355 2 12.99080675 + -64.03604684 2 6.47044482 + 4.09908827 2 7.32890448 + -3.09908827 2 0.86508310 + 18.35851644 3 11.66884823 +6 + 204.54741131 2 6.98984163 + -173.26765359 2 1.14387234 + -179.62280834 2 7.98041969 + 81.98571631 2 1.30274954 + -105.23530836 2 0.79373704 + 203.87378660 2 0.87617820 +6 + 47.21398743 2 4.46327869 + -17.03315162 2 12.03758238 + -1.80345968 2 1.82986618 + -67.65022794 2 0.85432599 + 83.23157126 2 0.75234069 + -12.77614240 2 0.56466795 + +V GEN 18 2 +6 + 5.00000000 1 4.80344323 + 22.35774108 2 18.78787979 + -64.07198704 2 7.13216682 + 4.33388926 2 9.27213879 + -3.33388926 2 0.97989891 + 24.01721615 3 16.08839186 +6 + 180.61077610 2 8.25076842 + -142.94184574 2 0.97905818 + -150.64642751 2 9.92043295 + -6.71407277 2 0.62363714 + 176.09329684 2 0.95148528 + -17.73131270 2 1.07801133 +6 + 57.45110361 2 5.32960287 + -20.81111514 2 14.24980571 + -8.29286428 2 1.85925508 + -5.73287020 2 0.58593750 + 29.10022105 2 0.79878530 + -14.07269455 2 1.00225258 + +Cr GEN 18 2 +6 + 6.00000000 1 12.84308988 + -3.09604991 2 0.99382054 + -44.89504234 2 7.58819115 + -170.55613293 2 14.51774012 + 171.55613293 2 16.43682827 + 77.05853926 3 12.82491986 +6 + -18202.34922306 2 1.98782159 + 18244.42867028 2 31.32646602 + 30868.09979612 2 30.37846452 + 17868.98085600 2 1.97809129 + -49114.96837018 2 30.73273877 + 378.88775116 2 2.67913288 +6 + 29.20236180 2 19.25203633 + 12.37319603 2 0.97567458 + 4072.48148684 2 17.43196546 + -17623.52674725 2 16.30880219 + 0.00000000 2 1.00000000 + 13552.04578438 2 15.92770430 + +Mn GEN 18 2 +6 + 7.00000000 1 15.05016398 + 76.06668034 2 15.84783194 + -134.18719488 2 9.80426007 + 5.15310013 2 22.40715541 + -4.15310013 2 1.28870598 + 105.35114786 3 9.24698903 +6 + 5.29793560 2 36.81344701 + 46.23395617 2 10.22325416 + -60.32817992 2 19.40077237 + 47.36691946 2 10.31192728 + -593.48022661 2 0.82035751 + 607.44155846 2 0.82499832 +6 + 43.56050065 2 39.11191097 + 6.67450664 2 5.89010993 + 273.74198710 2 12.39309544 + -27.45450618 2 46.10455298 + -256.40166892 2 15.13448958 + 11.11513392 2 0.96513012 + +Fe GEN 18 2 +6 + 8.00000000 1 15.22430826 + 44.74166498 2 23.61492800 + -111.48295214 2 10.92989564 + 4.87905385 2 34.25190536 + -3.87905385 2 1.33822720 + 121.79446608 3 12.33553803 +6 + -19.50464924 2 30.77395752 + 78.13974335 2 10.21396062 + -93.51149367 2 7.16717891 + -5331.00729306 2 2.86167947 + 2973.12062964 2 2.65030718 + 2452.39961633 2 3.20024669 +6 + 24692.89537881 2 35.68878072 + -24635.37117467 2 1.90446408 + 67.20321584 2 9.50100295 + -24719.85685234 2 35.67756831 + 155.45498669 2 2.48480944 + 24498.19947049 2 1.90126047 + +Co GEN 18 2 +6 + 9.00000000 1 16.99448342 + 49.13807967 2 27.18614115 + -125.28324533 2 12.21218102 + 5.11388765 2 39.14513799 + -4.11388765 2 1.47717612 + 152.95035078 3 13.67966454 +6 + -14.42629264 2 42.14707531 + 80.80701231 2 9.38147677 + -241.37463154 2 5.80599555 + -2375.49390008 2 3.20236619 + 1470.87516654 2 3.85735739 + 1146.99509265 2 2.77670509 +6 + 136.98013925 2 35.88691706 + -71.59603354 2 2.32679268 + 69.29537053 2 14.47120857 + -182.97334302 2 33.48566094 + 53.73921710 2 5.03596368 + 60.93980797 2 1.71252673 + +Ni GEN 18 2 +6 + 10.00000000 1 22.08639324 + -144.93688782 2 14.51813938 + 58.56151708 2 31.72005545 + 5.46467869 2 46.47610840 + -4.46467869 2 1.64348434 + 220.86393239 3 17.23929992 +6 + -1037.96291767 2 23.63013626 + 1112.68285967 2 22.54579447 + -202.88667032 2 10.67846148 + -1992.46747856 2 2.78611652 + 261.70081349 2 7.26891690 + 1934.65478930 2 2.71695433 +6 + -53.30731307 2 26.78098186 + 127.09013633 2 3.54449677 + -4806.85555998 2 9.97427088 + 4887.04372410 2 10.06368893 + -212.17359382 2 2.46160888 + 132.98697057 2 1.97486742 + +Cu GEN 18 2 +6 + 11.00000000 1 2.82733696 + -34.48196386 2 1.92614044 + -60.25585479 2 16.36117816 + 95.74606505 2 26.07073787 + -94.74606505 2 15.23964803 + 31.10070652 3 2.17204001 +6 + -45.62927216 2 31.69953680 + 125.91417027 2 1.14930323 + -14.54702824 2 1.62190112 + 4.20903863 2 5.04037704 + 108.15433753 2 13.02666762 + -96.81611101 2 1.08245080 +6 + 95.22440516 2 11.30741812 + -15.05535618 2 0.88219501 + 50.51809351 2 1.10244974 + -44.11033096 2 1.38963093 + 24.77977412 2 1.74927941 + -30.18619193 2 36.48037929 + +Zn GEN 18 2 +6 + 12.00000000 1 31.07239014 + -200.01988966 2 17.28158695 + 92.10229536 2 34.39655496 + 5.98135501 2 49.89939973 + -4.98135501 2 1.96865590 + 372.86868168 3 19.34259724 +6 + -36.14038802 2 38.52109994 + 128.37782465 2 12.00212013 + -1.61496737 2 1.07625274 + -1.83786181 2 49.67118376 + 65.46563590 2 2.17772473 + -61.01291439 2 3.24812913 +6 + -65.64354860 2 18.09701361 + 156.02859885 2 36.00255883 + 172.20201747 2 14.96596000 + -192.17040837 2 36.71242576 + 4.39165632 2 5.39429237 + 16.57829500 2 1.49031308 + +Ga GEN 28 2 +6 + 3.00000000 1 1.13608798 + 164.07678897 2 1.26217688 + -167.28328999 2 1.14858151 + -669.79177234 2 1.15353581 + 670.79177234 2 1.12952095 + 3.40826394 3 1.10744970 +6 + 2326.37321481 2 0.75031475 + -2323.38047364 2 0.75000124 + 386.83516033 2 2.39556890 + 3373.92258044 2 1.92296729 + -3444.97340674 2 2.01243025 + -314.78429931 2 1.54022372 +6 + -49.00749762 2 0.97248539 + 49.23559677 2 1.12030491 + 13.15736344 2 1.17799318 + 125.85888665 2 1.43966818 + -194.32447492 2 1.61975153 + 56.31063114 2 1.96345236 + +Ge GEN 28 2 +6 + 4.00000000 1 1.37803409 + 19.62241898 2 1.39153725 + -23.72148814 2 1.27769848 + 2.49161805 2 1.59279926 + -1.49161805 2 0.64699203 + 5.51213636 3 0.92923210 +6 + -2.74466220 2 0.87224298 + 6.62035166 2 1.17293014 + -2420.40847648 2 1.99495027 + -82306.43955717 2 2.42954180 + 6740.23721390 2 2.16484262 + 77987.61073589 2 2.43883104 +6 + -2107.38453991 2 1.16911036 + 2108.21076604 2 1.46731756 + 1481.43044167 2 1.13494844 + -5605.67944848 2 1.57427397 + 1698.46708565 2 1.69705377 + 2426.78290985 2 1.49642085 + +As GEN 28 2 +6 + 5.00000000 1 1.43022249 + -9.34297986 2 1.49610460 + 4.21498088 2 6.47107540 + 10.09813510 2 3.25241162 + -9.09813510 2 5.07144325 + 7.15111245 3 1.33657021 +6 + 13218.94379269 2 1.93743539 + -13214.39886844 2 1.06114866 + -12968.43207956 2 1.94924972 + 13915.97822491 2 1.06566409 + -954.00698285 2 1.23265097 + 7.46088753 2 4.89271387 +6 + 1464.46500602 2 1.99905491 + -1463.07044815 2 1.47578217 + 368.93680276 2 1.30626554 + -20015.22902646 2 1.76510607 + -4931.41969774 2 1.62454622 + 24578.71284776 2 1.71245824 + +Se GEN 28 2 +6 + 6.00000000 1 1.51096144 + 18985.66456772 2 2.92355341 + -18994.15945825 2 2.92032845 + -67662.27071451 2 3.11248219 + 67663.27071451 2 3.11189793 + 9.06576863 3 1.65761092 +6 + 9.98441274 2 1.51889669 + -2.50844675 2 1.97738476 + -180236.05319146 2 2.70806322 + 388717.66809223 2 2.76186155 + -395809.31847294 2 2.85646715 + 187328.70401255 2 2.90992434 +6 + -0.64003892 2 1.60286011 + 4.75615253 2 1.39335643 + -1221.08696720 2 2.09669307 + -10412.15615824 2 2.41527013 + 11345.50935270 2 2.36453165 + 288.73492615 2 3.03391531 + +Br GEN 28 2 +6 + 7.00000000 1 1.41289916 + -7.52651514 2 1.15658370 + -0.55005317 2 2.42725255 + 32.50767838 2 2.88316202 + -31.50767838 2 2.65601102 + 9.89029412 3 1.40346702 +6 + 28526.73706896 2 2.34791729 + -28520.73498833 2 2.45113975 + -99003.29767895 2 2.50553756 + 749850.19071550 2 2.81179865 + -1128475.81390516 2 2.78141408 + 477629.92118992 2 2.68265676 +6 + 17.76908748 2 1.31119911 + -15.01578842 2 1.60289186 + -18723.09651802 2 2.55330648 + -655.15159005 2 2.02749820 + 16349.83148583 2 2.49321553 + 3029.41777740 2 2.76331597 + +Kr GEN 28 2 +6 + 8.00000000 1 8.52108317 + -122698.81335772 2 3.24264497 + 122687.31930993 2 3.40822193 + -118092.31104849 2 3.40804203 + 118093.31104849 2 3.23631062 + 68.16866536 3 4.68396906 +6 + -494.70169718 2 5.76331362 + 503.25343741 2 2.73098609 + -367021.57369848 2 3.66759371 + -1529686.47073208 2 3.83008505 + 1834642.13235417 2 3.78655002 + 62066.91317383 2 4.17980892 +6 + -73.83484449 2 5.20603747 + 79.00632901 2 4.70236432 + 1062.70264892 2 4.15470411 + -40873.21549348 2 3.08586486 + 43280.45283221 2 3.10363880 + -3468.93856436 2 3.63224008 + +Al GEN 10 2 +6 + 3.00000000 1 0.91821413 + -12.79791788 2 1.10715442 + 7.32796626 2 2.03989390 + -52053.92058080 2 2.04204466 + 52054.92058080 2 2.04199047 + 2.75464240 3 0.94029840 +6 + -42.72903905 2 1.99445589 + 47.15203530 2 1.12469986 + 3231.39534748 2 1.72843552 + -398.06113457 2 1.37872018 + 6652.21368423 2 1.92811339 + -9484.54780105 2 1.87995009 +6 + 830.07508675 2 1.87943518 + -827.97758021 2 1.42508183 + -1235.04705829 2 1.80941062 + -21.40768628 2 0.95469299 + 154.21154335 2 1.20079877 + 1103.24388863 2 1.53169350 + +Si GEN 10 2 +6 + 4.00000000 1 1.22418085 + 40.72596063 2 2.05337336 + -48.11509746 2 1.71412850 + -37.28006653 2 2.41395005 + 38.28006653 2 2.32084434 + 4.89672339 3 1.35299631 +6 + -7.68509694 2 1.13070385 + 13.98411213 2 1.16859753 + -116498.38332824 2 2.36994226 + -9121.48068622 2 2.16734100 + 31941.11999828 2 2.44879942 + 93679.74429067 2 2.32322104 +6 + 41248.64599856 2 1.86811003 + -41245.51022334 2 2.10179754 + -60.37864776 2 1.33467919 + 4180.55486914 2 2.29835912 + -142125.41164262 2 1.93345601 + 138006.23630568 2 1.99192523 + +P GEN 10 2 +6 + 5.00000000 1 3.71332384 + -13724.87406260 2 3.31759335 + 13714.20593187 2 3.65850189 + -19470.81568886 2 3.61426447 + 19471.81568886 2 3.37579099 + 18.56661922 3 2.21831587 +6 + -1411.99322697 2 3.20289077 + 1421.31824558 2 2.14807352 + 576236.74902855 2 2.65372234 + -397754.23263905 2 2.69778221 + -194403.08693812 2 2.58386669 + 15921.57087605 2 2.99361065 +6 + 64.03084909 2 2.59482433 + -58.63734715 2 3.43313766 + 365.80442210 2 2.95557705 + -12.13895471 2 1.75387879 + 158.27628825 2 3.69699906 + -510.94109430 2 3.15077203 + +S GEN 10 2 +6 + 6.00000000 1 2.51977085 + -84.83332404 2 3.22007986 + 70.54487302 2 4.71655238 + 3581.56671658 2 4.39998291 + -3580.56671658 2 4.41784559 + 15.11862509 3 2.54586294 +6 + -231.72652822 2 4.61819246 + 244.26248418 2 2.30938314 + -920.53494189 2 2.65072450 + 2410.83323256 2 3.31119070 + -2429.46016726 2 3.80226712 + 940.16251250 2 4.46824294 +6 + 957.88712772 2 4.48874898 + -950.12559451 2 3.37845034 + 6481.05990210 2 3.83307173 + -157.23448173 2 1.92699416 + 186.18956071 2 1.98946862 + -6509.01396292 2 3.99439281 + +Cl GEN 10 2 +6 + 7.00000000 1 6.06473582 + -454.17116717 2 5.57110302 + 436.13184861 2 5.26917938 + -712.97599461 2 4.62455647 + 713.97599461 2 4.94326867 + 42.45315074 3 3.47635853 +6 + 3561.38023524 2 4.48278574 + -3545.84042135 2 3.43372818 + -348465.51723117 2 3.74855830 + 12627.08188052 2 3.20650110 + 404246.19776785 2 3.70673786 + -68406.76197098 2 3.45681590 +6 + 19.30024745 2 3.79400952 + -9.26766424 2 3.06020678 + 508.81151546 2 4.47438492 + -7.59455659 2 2.43219723 + -757.15587217 2 4.97983429 + 256.93953188 2 5.71145786 + +Ar GEN 10 2 +6 + 8.00000000 1 3.61306766 + 326.13269394 2 4.01911273 + -346.66642426 2 5.31624938 + -7083.13498801 2 4.62848435 + 7084.13498801 2 4.70295676 + 28.90454131 3 3.84612203 +6 + 323.59441180 2 3.28236424 + -306.35028843 2 3.72212609 + -6283.46399338 2 4.23452843 + 435312.63926384 2 4.90386840 + 20087.00527001 2 5.30220051 + -449115.17955704 2 4.93088566 +6 + -2470.88386165 2 5.66191962 + 2481.68427537 2 4.62960722 + 48097.69821672 2 2.45115265 + -48060.46858390 2 2.45082141 + -1386.79918148 2 4.23753203 + 1350.57102634 2 6.12344921 + +Ag GEN 36 2 + 6 + 11.00000000 1 7.02317516 + 178.71479273 2 1.36779344 + -206.54166000 2 1.85990342 + 92.80009949 2 2.70385827 + -91.80009949 2 1.21149868 + 77.25492677 3 2.46247055 + 6 + -19159.46923372 2 2.56205947 + 19178.09022506 2 3.28075183 + -19956.12207989 2 3.86486918 + 12405.48540805 2 2.42437953 + -8569.95659418 2 5.14643113 + 16121.59197935 2 4.79642660 + 6 + -1054.66284551 2 1.92427691 + 1072.38275494 2 1.94184452 + -1.15533162 2 27.95704514 + 88.48945385 2 1.25545336 + -0.36033231 2 10.04954095 + -85.97371403 2 1.49011553 + + diff --git a/data/pseudo/tn_df_sc b/data/pseudo/tn_df_sc new file mode 100644 index 00000000..aa3234af --- /dev/null +++ b/data/pseudo/tn_df_sc @@ -0,0 +1,292 @@ +Sc GEN 12 2 +8 + 9.00000000 1 18.44478556 + -28.08765281 2 1.72227091 + 6.39250114 2 38.78217945 + 135.57316128 3 4.25767220 + 30.42990876 3 30.59237471 + 732.69856731 4 3.04901650 + -839.18407578 4 3.26586693 + 306.02608763 4 19.55311974 +8 + -0.66275990 2 28.84167604 + 15.34001225 2 2.35022973 + -2135.70086146 3 2.36887926 + -272.32226474 3 1.53860208 + 2408.02312621 3 2.24659807 + 101.49528202 4 3.20659052 + 2308.19070504 4 1.65816906 + -2392.74854053 4 1.70062176 +8 + 253.56902450 2 1.38158346 + -244.79525414 2 7.79906720 + 613.28437434 3 3.46268859 + -167.40250936 3 1.44953060 + -445.88186498 3 4.19986338 + -558.92885001 4 2.84253773 + -139.52186395 4 8.10103826 + -860.39715397 4 5.29686620 + +Ti GEN 12 2 +8 + 10.00000000 1 22.29649672 + -72305.15340277 2 6.07562013 + 72279.39956641 2 7.08549167 + -5.38004642 3 1.85317121 + 228.34501358 3 11.48488557 + 72347.84359974 4 6.58565089 + -36.31015055 4 10.79509368 + 524.90430538 4 4.36759114 +8 + -1486.27686725 2 1.90199524 + 1504.05739312 2 3.17280244 + -346.63236251 3 7.28185273 + 297.60206194 3 1.60782556 + 49.03030057 3 31.70876802 + 1363.17044217 4 2.57136209 + 173.13661454 4 15.10326471 + 408.87838151 4 10.51280239 +8 + 770.58828172 2 4.79017059 + -760.06500844 2 16.39428027 + 4131.47101858 3 2.73641831 + -2.86068712 3 1.26533109 + -4128.61033146 3 2.75566672 + -4681.55429918 4 13.54811035 + -216.64417046 4 3.18165696 + -3871.27097394 4 7.38011991 + +V GEN 12 2 +8 + 11.00000000 1 7.61152016 + -2254.24090893 2 3.39807975 + 2224.02899636 2 6.97361870 + -110446453.80565737 3 4.55862146 + 110446537.53237911 3 4.55862102 + 3279.23908558 4 3.96488312 + 110445429.80748074 4 5.79893896 + -110440859.60674113 4 5.79892709 +8 + 793493.20383269 2 1.90936932 + -793472.27490442 2 1.96341714 + -208.86387558 3 5.49944355 + 258.48298732 3 4.42141770 + -49.61911175 3 2.27427679 + -42873.55595686 4 1.93670396 + -750668.26686351 4 13.81929388 + 750696.33209725 4 13.81951796 +8 + 563.75098077 2 2.73920868 + -551.25384718 2 8.34159772 + 565.60881231 3 6.86565518 + -552.54712531 3 7.02672916 + -13.06168700 3 1.72160118 + 766.15325384 4 5.21722741 + -1341.96583800 4 3.64504781 + -2478.29367021 4 6.45896159 + +Cr GEN 12 2 +8 + 12.00000000 1 37.30558989 + -31.65683900 2 2.72495980 + -3.82112970 2 82.35078893 + -1340.05228092 3 5.03605834 + 1787.71935961 3 8.49223479 + 1670.38275859 4 5.05934149 + -297.67363866 4 11.22316422 + -1773.64577915 4 12.78798168 +8 + 1321.32584937 2 2.01494487 + -1297.16280545 2 9.11769637 + 172456.79432585 3 2.74640213 + -172130.54143941 3 2.73601029 + -326.25288644 3 8.22966405 + 3318.19479259 4 8.93660753 + -4964.77333719 4 4.18996691 + -7518.15931266 4 8.08712175 +8 + 426.08303476 2 2.13852920 + -410.95463497 2 6.95873057 + -26339.61341213 3 10.51865586 + 27348.01671881 3 10.59655900 + -1008.40330668 3 12.57249470 + -1190.97633771 4 3.81958382 + -242.50982893 4 2.30397730 + -515.04540222 4 8.50147041 + +Mn GEN 12 2 +8 + 13.00000000 1 5.18371402 + -578541.89058487 2 5.06065032 + 578503.38848415 2 6.70792867 + -51913.84692424 3 6.17952209 + 51981.23520653 3 6.17539491 + 363344.02202434 4 6.42176078 + 267112.71548476 4 5.85884127 + 322304.52239107 4 5.30004030 +8 + 1419.16815158 2 2.36735511 + -1393.80593768 2 10.44777616 + 90835.30824196 3 3.38832573 + -87236.54130341 3 3.33976449 + -3598.76693855 3 4.59371397 + -6244.54083570 4 4.53305698 + 1227.60592152 4 6.80451212 + -6185.56255228 4 8.40561309 +8 + 4024.75281098 2 2.94114594 + -4009.68099577 2 7.86104996 + 6036.24229971 3 5.47734943 + 597.55987937 3 7.26632213 + -6633.80217908 3 5.64966653 + -8536.73955532 4 4.35053539 + -2120.81538582 4 3.10976563 + -9025.36229250 4 6.88076377 + +Fe GEN 12 2 +8 + 14.00000000 1 5.12237041 + -40.17016318 2 2.51511645 + -1.31093574 2 68.88205922 + 233.53970769 3 8.04518971 + -161.82652195 3 11.87602774 + -1791.82033120 4 5.09693593 + 1599.45078669 4 4.72210640 + 1.03695301 4 1.70594204 +8 + 26.70612465 2 1.98046097 + 0.57578912 2 129.99498266 + 3039.39666376 3 2.39996246 + -3165.32503397 3 2.43500497 + 125.92837021 3 5.42607639 + -291.65810402 4 8.00515516 + 391.88052787 4 5.38996549 + 27.51771082 4 21.57361672 +8 + 624.99065580 2 2.73200743 + -610.14663705 2 8.14205971 + 1017.89543597 3 6.81776145 + -40.92293045 3 25.88593190 + -976.97250552 3 5.88766735 + -1433.26030940 4 3.94271278 + -167.70300401 4 2.68547503 + -1659.40792313 4 8.24853344 + +Co GEN 12 2 +8 + 15.00000000 1 7.54679164 + 144513.79744165 2 3.67362404 + -144558.25171900 2 4.84501436 + 107.53071842 3 2.40342575 + 5.67115611 3 26.17864786 + -58433.23776581 4 3.80837544 + -86187.09039425 4 4.51680318 + -24877.11683436 4 4.40937071 +8 + 95.23258759 2 2.24610518 + -66.50913381 2 5.03497074 + 5039.10184384 3 3.22714612 + 106438.82887427 3 4.39051698 + -111477.93071810 3 4.34028955 + -3416.23892647 4 3.35420522 + -108155.92422115 4 5.08283495 + 111451.19401338 4 5.04411598 +8 + 595.60664332 2 4.48956443 + -581.05689813 2 7.69628175 + -1377.49199281 3 3.90883087 + 825.53641688 3 4.85597858 + 551.95557593 3 2.42496884 + -403.44284159 4 2.48937518 + 360.79216631 4 7.08237042 + -1755.31252545 4 7.01264199 + +Ni GEN 12 2 +8 + 16.00000000 1 7.69817381 + 1050.11428773 2 7.53303210 + -1144.28791364 2 25.60798551 + 13641.04856576 3 13.90272560 + -13517.87778478 3 14.02243059 + -99.93959073 4 5.40919366 + -14590.22326277 4 19.39187326 + -6702.20081903 4 10.04177364 +8 + -137324.04248861 2 3.00959957 + 137399.59146577 2 2.97820277 + 137895.50489379 3 3.20429852 + -1036.38091066 3 8.22563766 + -136859.12398313 3 3.17346613 + 1370.72380067 4 18.22958633 + -904.80564965 4 6.63637638 + -4552.45338879 4 4.01705177 +8 + -315.28909178 2 15.14825706 + 371.76324185 2 5.57172908 + 471.27416207 3 2.88437623 + 165.43855728 3 3.75784965 + -636.71271936 3 3.41699124 + -172.18113847 4 5.67830819 + -148.24251004 4 2.70288433 + -2384.29249546 4 8.91177457 + +Cu GEN 12 2 +8 + 17.00000000 1 14.72121260 + 0.43564135 2 173.23217215 + -51.26559465 2 2.58024469 + 3.82433122 3 80.09883693 + 246.43628291 3 9.08368916 + 6456.72306266 4 4.49885474 + -6459.98303523 4 4.56436500 + -53.55070822 4 20.14135032 +8 + -7.61322720 2 104.42478595 + 38.51618543 2 3.64199543 + -12.00344193 3 52.46064977 + 288.99573247 3 4.33410703 + -276.99229053 3 8.38373584 + 876.14551285 4 3.01347300 + -1144.52462196 4 3.25680498 + -386.35474053 4 59.52152812 +8 + 142.97388030 2 48.08520852 + -128.80933064 2 49.90034500 + -186.15554307 3 11.18440029 + 180.45159943 3 5.04653753 + 5.70394364 3 85.01391269 + 101.90155258 4 3.06268644 + -238.17133323 4 3.55821337 + 583.56858981 4 22.24622222 + +Zn GEN 12 2 +8 + 18.00000000 1 16.25309578 + -62.06001046 2 3.04359000 + 8.22443626 2 52.31604625 + 284.31836352 3 4.12635237 + 8.23736049 3 129.68855961 + 11442.99692797 4 7.94323624 + -11664.25528103 4 7.74821809 + 462.64311342 4 34.44853266 +8 + 140.30017448 2 3.16683649 + -108.24959569 2 14.80839343 + 88.79372352 3 43.94225321 + 949.52154936 3 3.34122685 + -1038.31527288 3 8.34153430 + 780.81282740 4 18.34782011 + -1958.42831296 4 4.00418064 + 18.92059615 4 597.07325481 +8 + 664.93623774 2 5.16678579 + -651.12455824 2 11.88724380 + 930.96426186 3 7.96788974 + -913.07841414 3 5.27302550 + -17.88584772 3 127.63757255 + 3275.61040524 4 37.54266998 + -3957.43240479 4 9.90068894 + -3622.67126499 4 37.33250038 + + + diff --git a/data/pseudo/tn_hf b/data/pseudo/tn_hf new file mode 100644 index 00000000..a036558a --- /dev/null +++ b/data/pseudo/tn_hf @@ -0,0 +1,785 @@ +H GEN 0 2 +6 + 1.00000000 1 33.97261756 + -5.73227574 2 41.31028903 + -0.09126064 2 25.25940941 + -20.89980944 2 22.55290552 + 21.89980945 2 32.44131356 + 33.97261756 3 21.12884239 +6 + -792.10375913 2 18.05333002 + 788.69064150 2 28.72271273 + 243.76232429 2 17.34000000 + 1971.45741618 2 20.31094085 + -1795.56663560 2 22.08154655 + -418.65661775 2 30.98799599 +6 + 20.17177614 2 43.35000000 + -21.74798121 2 30.58059209 + 81.48044293 2 43.35000000 + -250.69197995 2 42.07548166 + 88.72115024 2 36.90496619 + 81.48044293 2 43.35000000 + +He GEN 0 2 +6 + 2.00000000 1 20.98762121 + -33.61186426 2 22.14709418 + 24.51669349 2 23.61790706 + 130.14113834 2 15.38761786 + -129.14113834 2 14.22621787 + 41.97524242 3 12.59257273 +6 + 1056.41263785 2 13.17618363 + -1062.28560366 2 23.62254131 + -463.87351954 2 12.04168890 + -676.20404915 2 15.14280380 + -595.21618656 2 19.81607243 + 1736.29130578 2 22.34342328 +6 + 428.21432838 2 21.71652417 + -430.31401911 2 12.32378638 + 7327.65357096 2 14.04426129 + -7501.20178041 2 14.34477832 + 827.37705616 2 17.58948890 + -652.83515208 2 21.22706329 + +Li GEN 2 2 +6 + 1.00000000 1 0.78732101 + -2.23995793 2 0.79224763 + 0.10336496 2 1.79622268 + 4.26591073 2 1.83637465 + -3.26591073 2 1.91213904 + 0.78732101 3 0.79291624 +6 + 256.06005883 2 1.78312879 + -255.07112703 2 0.95553059 + 89.99417499 2 0.87617279 + 271.48958394 2 1.09621549 + -180.35430387 2 1.43900642 + -180.12948429 2 1.83085147 +6 + -6.15265886 2 1.51120608 + 4.70876577 2 0.76936375 + -145.31681550 2 0.76874061 + -238.21930857 2 0.99080928 + 219.67347903 2 0.80457655 + 164.85986038 2 1.07164892 + +Be GEN 2 2 +6 + 2.00000000 1 1.20639978 + -5.40210132 2 1.18425537 + 1.72285109 2 2.81826911 + 2.83477794 2 2.37513515 + -1.83477794 2 2.82920954 + 2.41279956 3 1.18219335 +6 + -1045.56923435 2 2.59240549 + 1047.78889524 2 1.41686040 + -1899.02207714 2 1.48536195 + 1398.02036098 2 1.70076266 + -696.17508584 2 2.03898393 + 1198.17691383 2 2.57766021 +6 + 630.77503458 2 1.84421403 + -632.64959849 2 1.13419132 + 441.30858401 2 1.13393716 + 435.76647651 2 1.22419150 + -353.48689426 2 1.39760436 + -522.59133089 2 1.88595068 + +B GEN 2 2 +6 + 3.00000000 1 2.72292969 + -11.77602579 2 2.41356794 + 5.22133296 2 4.60628004 + 0.40709712 2 3.81569642 + 0.59290288 2 4.75281449 + 8.16878906 3 2.42655010 +6 + -259.65579181 2 2.54943794 + 264.77623108 2 4.54559309 + 79.19161122 2 2.15270531 + -59.67150303 2 2.71820746 + 4276.39654293 2 3.54458188 + -4294.91608677 2 3.65732479 +6 + 236.40878048 2 3.85965228 + -239.02058908 2 2.15130911 + 4065.68265375 2 2.50786619 + -4354.92616892 2 2.58144728 + 782.08428825 2 3.14947869 + -491.84514677 2 3.69136935 + +C GEN 2 2 +6 + 4.00000000 1 6.85924392 + -68.83281650 2 7.67473342 + 58.31001518 2 8.89832626 + -5.23010100 2 4.63334409 + 6.23010100 2 5.40036758 + 27.43697568 3 6.78357071 +6 + 15927.37261280 2 7.83879438 + -15918.16480090 2 5.19308059 + 2266.75441213 2 7.53204263 + 199.75030501 2 9.76960112 + 15915.92435302 2 5.19521204 + -18381.42723477 2 7.82847044 +6 + -153360.42295057 2 4.77965478 + 153356.81223147 2 7.75552602 + -369415.66050006 2 7.39994991 + 152547.92039307 2 4.77641318 + -50035.07991665 2 8.01352516 + 266903.80850142 2 7.30461659 + +N GEN 2 2 +6 + 5.00000000 1 11.01983025 + -745.67280403 2 7.70260962 + 729.30210222 2 7.83791198 + -3.61639106 2 8.41784728 + 4.61639106 2 12.53426384 + 55.09915126 3 6.76845507 +6 + 190.73305357 2 10.95092720 + -176.25003778 2 7.48977970 + 138618.50426238 2 6.17989888 + -156031.83911197 2 6.21713643 + 33624.66842989 2 6.84042808 + -16210.33273520 2 7.23938652 +6 + -6963.78021671 2 6.00000000 + 6959.42174113 2 6.82157159 + -1881.92821431 2 8.95497565 + 13576.39988827 2 6.21477468 + -14307.35309373 2 6.69426410 + 2613.87687182 2 8.63240466 + +O GEN 2 2 +6 + 6.00000000 1 8.86965578 + -28.03502457 2 6.05347085 + 11.15565054 2 5.51487970 + 180.73182495 2 10.77996678 + -179.73182495 2 10.23800841 + 53.21793471 3 7.90307811 +6 + -9301.89903913 2 7.28355994 + 9316.57793048 2 6.06026884 + 59864.04331135 2 10.82203807 + -5153.55178109 2 5.75221581 + -94673.29831259 2 10.51025188 + 39963.80850689 2 9.71187643 +6 + 1682.75815189 2 6.93414347 + -1694.05800561 2 5.70161443 + 848.47217112 2 5.90927487 + -8787.11179775 2 8.69956320 + 7632.94108771 2 8.89513889 + 306.69604455 2 4.97067782 + +F GEN 2 2 +6 + 7.00000000 1 16.52363418 + -6.34751135 2 13.25777643 + -15.15415075 2 18.76649923 + -34.29784879 2 10.97564997 + 35.29784879 2 21.10568925 + 115.66543928 3 13.45706123 +6 + 3851.10542697 2 18.85020393 + -3832.40250429 2 12.48878559 + -237433.87385812 2 13.23599298 + 4380.91891820 2 11.79852686 + 240164.95590264 2 13.28196243 + -7110.99868861 2 17.38283172 +6 + -154.12048513 2 8.59949907 + 138.11297468 2 9.44224375 + 90.42851925 2 8.92886754 + 24.83173716 2 10.18592724 + -424.59591732 2 14.47166344 + 310.33244840 2 16.45175456 + +Ne GEN 2 2 +6 + 8.00000000 1 21.65168713 + 1792.30188007 2 14.45374325 + -1826.14661180 2 14.11313946 + 24.26469360 2 14.10779016 + -23.26469360 2 20.42281751 + 173.21349705 3 11.94458523 +6 + -3233.03788910 2 12.39056574 + 3263.09949012 2 20.60119535 + 1065.47298248 2 11.30677784 + 846.05067282 2 12.27737462 + -34052.05079344 2 17.82669542 + 32141.52790433 2 17.34318949 +6 + 64989.42116117 2 20.31242587 + -65003.08394100 2 20.05277414 + -486.55828399 2 12.87396775 + 2895.04182579 2 15.84533388 + -261.91821074 2 19.42277681 + -2145.56672184 2 23.82700477 + +K GEN 18 2 +6 + 1.00000000 1 0.68724959 + 7665.13435390 2 0.62381187 + -7668.26785841 2 0.59278246 + -3877.60874288 2 0.63961163 + 3878.60874288 2 0.57860350 + 0.68724959 3 0.50008691 +6 + 477943.00813868 2 0.60446875 + -477941.36080643 2 0.55281419 + -533027.54468668 2 0.57763214 + 644866.44840953 2 0.56624742 + -347063.87255621 2 0.60823749 + 235225.96911606 2 0.54903924 +6 + 5177368.01138896 2 0.56835236 + -5177366.94506877 2 0.57395949 + 479730.23987439 2 0.65183506 + 1027151.48932830 2 0.60393420 + -737636.25038898 2 0.55451546 + -769244.47868615 2 0.64345811 + +Ca GEN 18 2 +6 + 2.00000000 1 1.02097432 + -10036.20006734 2 0.76570985 + 10030.67757963 2 0.83608195 + -8136.00883920 2 0.84362927 + 8137.00883920 2 0.75729596 + 2.04194863 3 0.94514267 +6 + -34706.02643508 2 0.85912364 + 34710.12533681 2 0.50000000 + 860.68953329 2 0.79227941 + 33806.87817612 2 0.85997136 + -34747.30927870 2 0.50004940 + 80.74228959 2 1.01833438 +6 + 514.89542915 2 0.50045897 + -511.93073005 2 0.57886998 + -1374495660.24999190 2 0.50000000 + 687246875.87136328 2 0.50000000 + 595.96081232 2 0.56402502 + 687248189.41960287 2 0.50000000 + +Sc GEN 18 2 +6 + 3.00000000 1 8.57059896 + 39.59298139 2 7.59719947 + -67.37349200 2 5.06179469 + 3.54689568 2 11.85222547 + -2.54689568 2 0.70815643 + 25.71179688 3 5.04858060 +6 + 414.99811890 2 5.58945823 + -389.30527335 2 5.93611719 + 8.74915776 2 0.56803113 + -23.92388226 2 0.60868170 + 42.12589000 2 0.76957270 + -25.95178014 2 1.21300456 +6 + 87.05758924 2 1.12946939 + -62.19670511 2 8.56362761 + 66.37833241 2 7.27494713 + 16.41391965 2 0.74327556 + 43.70031508 2 2.03252459 + -125.49197853 2 1.19227023 + +Ti GEN 18 2 +6 + 4.00000000 1 4.77516915 + 28.34758957 2 10.86929502 + -63.21363466 2 5.37319310 + 5.17935660 2 6.86168513 + -4.17935660 2 0.95669336 + 19.10067660 3 3.52162434 +6 + 211.66189616 2 7.01854391 + -179.82099411 2 1.03880358 + -185.28466640 2 8.02474194 + 43.44334388 2 1.22490803 + -44.06205312 2 0.73917909 + 186.90335758 2 0.89595855 +6 + 49.26886952 2 4.65596397 + -18.32131307 2 12.03001514 + -5.50633295 2 2.16547114 + -342.25486254 2 0.92182600 + 304.90681508 2 0.90099079 + 43.85505055 2 0.99684289 + +V GEN 18 2 +6 + 5.00000000 1 7.54069430 + 35.58763613 2 13.63949328 + -78.03044429 2 6.35551182 + 6.53716910 2 2.59423528 + -5.53716910 2 1.16176108 + 37.70347150 3 6.00940761 +6 + 194.57815114 2 8.18606241 + -156.25972501 2 0.95585889 + -162.29334861 2 9.81441300 + -7.74379387 2 0.70017858 + 244.84040986 2 0.97854682 + -73.80312462 2 1.14925292 +6 + 58.91069981 2 5.48333809 + -21.55840127 2 14.40777862 + -10.12891199 2 2.12080402 + 2.52953175 2 0.69388688 + 109.28174657 2 1.01378564 + -100.68144081 2 1.02780261 + +Cr GEN 18 2 +6 + 6.00000000 1 5.86829616 + -3.09900314 2 0.98487638 + -44.94655388 2 6.96616660 + 135.46731129 2 13.59887742 + -134.46731129 2 11.34882544 + 35.20977696 3 8.91110617 +6 + -526.12421414 2 1.73784849 + 568.24328209 2 32.55674074 + -4019.88240027 2 29.55364033 + 495.64908693 2 1.64707294 + 3445.48735974 2 29.05037955 + 79.74580069 2 3.85284016 +6 + 31.31844062 2 19.50625909 + 10.30743573 2 0.86978393 + -81.88780266 2 15.20370471 + 461.22634080 2 10.28610919 + 1.00599253 2 29.84121604 + -379.34381792 2 10.93761710 + +Mn GEN 18 2 +6 + 7.00000000 1 15.05016398 + 76.91199595 2 15.84783194 + -135.08366030 2 9.80426007 + 5.12036990 2 21.62193241 + -4.12036990 2 1.26331891 + 105.35114786 3 9.24698903 +6 + 4.45077705 2 37.07900996 + 46.93892122 2 10.09409180 + -59.63952162 2 18.98557107 + 47.25376130 2 10.16267391 + 2270.38024432 2 0.79460121 + -2256.99438460 2 0.79345224 +6 + 43.65884288 2 39.18960573 + 6.58957965 2 5.88646925 + 273.41973132 2 12.35978155 + -27.85882166 2 45.92825074 + -255.64090683 2 15.10051906 + 11.08093098 2 0.96083847 + +Fe GEN 18 2 +6 + 8.00000000 1 20.13246747 + 61.79343671 2 20.09868712 + -128.55600523 2 10.70685691 + 4.84472314 2 28.79726611 + -3.84472314 2 1.31374323 + 161.05973977 3 11.74858936 +6 + -20.21006220 2 30.42214774 + 78.68908034 2 10.18491881 + -104.38370168 2 6.69228251 + 11879.61125830 2 2.98725076 + 4067.63536025 2 2.63900793 + -15841.86182474 2 2.88538957 +6 + 52.35701571 2 38.26448010 + 4.85142656 2 5.90250183 + 2169.08154283 2 14.09502191 + -40.04038813 2 42.65213493 + -2140.34005623 2 14.44188153 + 12.29991314 2 1.06050818 + +Co GEN 18 2 +6 + 9.00000000 1 18.31609159 + 47.84627034 2 26.91264651 + -123.98809879 2 11.91957078 + 5.09540361 2 38.50128360 + -4.09540361 2 1.45636943 + 164.84482431 3 13.41744556 +6 + -22.55314559 2 34.07535172 + 88.75521276 2 10.45260699 + -158.32924566 2 5.91087540 + -53402.80058080 2 3.13684604 + 49767.17959800 2 3.16692544 + 3794.95155282 2 2.81533596 +6 + 61.92019742 2 38.11279103 + 2.85881103 2 5.82898971 + -387.27158530 2 15.59733227 + -64.65478412 2 38.57519906 + 439.30094674 2 13.98109833 + 13.62664636 2 1.17046441 + +Ni GEN 18 2 +6 + 10.00000000 1 19.84291404 + -195.32353012 2 16.02128656 + 108.98533897 2 26.59513762 + 6.08469364 2 39.39261550 + -5.08469364 2 1.73812596 + 198.42914037 3 16.63287860 +6 + 636.14358475 2 21.00974643 + -561.54325704 2 22.88188409 + -146.65571659 2 11.08963477 + 1590.91833845 2 2.66405882 + 203.15470938 2 6.84512029 + -1646.41568069 2 2.74451213 +6 + 67.70992628 2 28.31556957 + 5.37743585 2 4.16521410 + 374.49405320 2 17.37825451 + -389.83846114 2 21.96153313 + 1.91671522 2 49.74424984 + 14.42906054 2 1.27579002 + +Cu GEN 18 2 +6 + 11.00000000 1 35.47715926 + -18105.91023962 2 21.73013363 + 18011.23386368 2 21.83870561 + 6.01228206 2 18.42008793 + -5.01228206 2 1.78198604 + 390.24875182 3 20.58922180 +6 + -51.41016015 2 31.92243640 + 131.47547623 2 14.07215286 + -100490.54220540 2 4.21909683 + 20675.75763691 2 3.56801887 + 263590.56712535 2 4.06536588 + -183774.78117039 2 3.92650866 +6 + 68.62159615 2 31.47726702 + 10.70810140 2 4.95987737 + 233.01753836 2 17.95562228 + -258.78181256 2 26.97191776 + 12.01106739 2 46.85069031 + 14.75422657 2 1.35614623 + +Zn GEN 18 2 +6 + 12.00000000 1 26.60492300 + -196.98442222 2 17.93401272 + 89.18558790 2 36.25784521 + 6.19159911 2 49.96784160 + -5.19159911 2 1.99109193 + 319.25907600 3 19.77027094 +6 + -177.37971474 2 32.01501166 + 269.42130045 2 23.08836163 + 60361.29701582 2 4.67975974 + 1343973.13568915 2 5.29114502 + -619902.07009680 2 5.11539109 + -784431.36064381 2 5.38368747 +6 + 46.22045015 2 19.08371294 + 43.98275320 2 50.00000000 + 103.59052598 2 16.88459979 + -129.86700605 2 37.83300205 + 11.83058445 2 5.11918008 + 15.44716451 2 1.45112568 + +Ga GEN 28 2 +6 + 3.00000000 1 1.29464779 + 1852.96920182 2 1.20541500 + -1856.15440251 2 1.17879070 + -513.51787928 2 1.21964580 + 514.51787928 2 1.12868888 + 3.88394338 3 1.06946118 +6 + -10.41248284 2 0.75266853 + 13.44253658 2 0.82344143 + -163070.82529640 2 1.96346903 + 118782.06261627 2 1.90761481 + 72439.51450979 2 2.00432013 + -28149.75180125 2 1.83309310 +6 + -55.43707314 2 0.98715132 + 55.68679311 2 1.18143237 + 95.35935510 2 1.24163917 + -111.55606197 2 1.48647971 + 6.22134153 2 1.87957113 + 10.97737885 2 2.24689865 + +Ge GEN 28 2 +6 + 4.00000000 1 0.64699203 + 1042.65966555 2 1.17600365 + -1045.50742663 2 1.40672708 + -522.21837337 2 1.06148136 + 523.21837337 2 1.52689039 + 2.58796812 3 0.70634661 +6 + 298.52031462 2 1.37488700 + -295.91758286 2 3.05395101 + -65778.83466330 2 1.99750874 + 253302.61962618 2 2.10159773 + 25864.29161720 2 2.35028323 + -213387.07659768 2 2.16152517 +6 + -1416.87913796 2 1.43279054 + 1416.49405157 2 1.27947333 + -4677.12774504 2 1.39756889 + 6758.57740664 2 1.50728327 + -2630.12555402 2 1.70834188 + 549.67778384 2 1.92912262 + +As GEN 28 2 +6 + 5.00000000 1 1.90897798 + -8.55267316 2 1.59326524 + 3.44617934 2 1.10844459 + -8.94709126 2 1.02625257 + 9.94709126 2 1.90897549 + 9.54488990 3 1.18318262 +6 + -299.57003383 2 1.31601774 + 303.89084920 2 0.88992491 + 34018.91875930 2 0.82417957 + -44808.38727678 2 0.87058735 + 19528.43031171 2 0.91644709 + -8737.95845690 2 0.77833472 +6 + 46094.50987530 2 1.90902784 + -46093.10097169 2 1.56895782 + -1934.82978262 2 1.41134047 + -240427.05172601 2 1.84187044 + 36043.17172862 2 1.53235052 + 206319.71069040 2 1.81590910 + +Se GEN 28 2 +6 + 6.00000000 1 1.73885845 + -4868.76631948 2 3.10952817 + 4860.07291481 2 2.76656612 + 247376.94576273 2 2.93723435 + -247375.94576273 2 2.93039894 + 10.43315069 3 1.80783830 +6 + 43.48906338 2 1.54256367 + -36.07303722 2 1.99876644 + -1338.16209913 2 2.22244851 + 88855.15492433 2 3.01653570 + -93322.17292948 2 3.00370283 + 5806.18068397 2 2.62760372 +6 + 101.24952978 2 1.51703915 + -96.89194467 2 1.50669503 + -561.81915381 2 2.17759706 + 1474.30831735 2 2.47900419 + -87533.83638244 2 3.02701983 + 86622.34849171 2 3.03071493 + +Br GEN 28 2 +6 + 7.00000000 1 1.29861066 + -8.22129971 2 1.15959643 + 0.21335410 2 2.29768788 + -14617.16154553 2 2.88622041 + 14618.16154553 2 2.88664159 + 9.09027461 3 1.38987227 +6 + 1993.56030565 2 1.99554365 + -1988.14839885 2 2.18330258 + 62338.94920254 2 2.78298975 + 91516.94063906 2 2.50252605 + -109846.25447802 2 2.70576408 + -44008.63516555 2 2.38434210 +6 + 17.36412726 2 1.29580803 + -14.67327121 2 1.60078690 + -6128.76923065 2 2.16344915 + 12563.02678529 2 2.26961184 + 757.63553722 2 2.83383736 + -7190.89195704 2 2.41971949 + +Kr GEN 28 2 +6 + 8.00000000 1 6.82429532 + 2245.94610147 2 4.82301962 + -2257.24927570 2 3.38163452 + 1889.52842356 2 3.29088128 + -1888.52842356 2 4.98656184 + 54.59436254 3 3.01373570 +6 + -2003.10975854 2 6.01573226 + 2010.79212346 2 4.07497664 + 13467772.94730707 2 4.47273823 + -18464141.82809087 2 4.45030979 + -2607955.84552628 2 4.28291762 + 7604325.72641131 2 4.35368575 +6 + -6512.57971257 2 5.33963561 + 6517.54562224 2 4.41831473 + 55170.14413687 2 3.66247372 + -35314.20447418 2 3.56293692 + -27094.88743738 2 3.99199621 + 7239.94695795 2 5.23539786 + +Al GEN 10 2 +6 + 3.00000000 1 0.90167530 + -12.07740634 2 1.08338853 + 6.60507677 2 2.07851308 + -13877404.00590185 2 2.08053590 + 13877405.00590186 2 2.08053570 + 2.70502591 3 0.92748596 +6 + -41.26842670 2 2.04866185 + 45.70193781 2 1.11866688 + 2946.69575922 2 1.71721106 + -376.01922297 2 1.36753958 + 4331.41613799 2 1.93292012 + -6901.09265568 2 1.86705782 +6 + 504.79904464 2 1.88548919 + -502.69536383 2 1.42616967 + -769.46860271 2 1.80548694 + -17.66088618 2 0.95520911 + 101.43853505 2 1.20112583 + 686.69150206 2 1.52824179 + +Si GEN 10 2 +6 + 4.00000000 1 2.54461774 + -2902.58084906 2 2.24978528 + 2895.18838752 2 2.53789008 + 7161.72254279 2 2.34887222 + -7160.72254279 2 2.46336277 + 10.17847098 3 1.52421025 +6 + 4.24352962 2 1.08064949 + 2.05989979 2 1.33341749 + 88608.14855737 2 2.39993059 + -849.93508619 2 1.92845396 + -1434647.87047626 2 2.35634772 + 1346890.65714548 2 2.35320332 +6 + -15264.86061936 2 1.82998100 + 15267.99758945 2 1.91566514 + -0.49522434 2 1.35066217 + 2807.17037795 2 2.16756956 + 6912.45723497 2 1.79762600 + -9718.13169060 2 2.03990309 + +P GEN 10 2 +6 + 5.00000000 1 2.20104239 + -14571.76154266 2 3.30954781 + 14561.08785293 2 3.65491917 + -21023.88213100 2 3.60582863 + 21024.88213100 2 3.36814532 + 11.00521195 3 2.06883762 +6 + -214.99423753 2 3.00175595 + 224.31212541 2 1.90508764 + -1320.42895216 2 2.23252373 + 2262.27394007 2 2.56842585 + -5217.11058123 2 3.22957222 + 4276.26614237 2 3.32169865 +6 + -4655.41288683 2 1.51251059 + 4660.80718311 2 1.51289861 + -994.25816078 2 3.31761981 + -19.30793578 2 2.04639527 + 311.57919748 2 3.70626860 + 702.98798215 2 3.09154453 + +S GEN 10 2 +6 + 6.00000000 1 3.76431332 + 518.21506704 2 2.91975646 + -532.35656437 2 2.26777538 + 14394.84387811 2 2.49556645 + -14393.84387811 2 2.51698479 + 22.58587994 3 2.71241239 +6 + -104.19902150 2 4.55895180 + 116.57081427 2 2.10503756 + -994.81335242 2 2.63814508 + 2203.13414043 2 3.11140569 + -1617.61176296 2 3.62963239 + 410.29160018 2 4.55921172 +6 + 723.09548214 2 4.48128068 + -715.46568241 2 3.35956681 + 9063.41201304 2 3.83857196 + -16.38228027 2 1.92699416 + 44.06704522 2 2.30670170 + -9090.09577098 2 3.92706305 + +Cl GEN 10 2 +6 + 7.00000000 1 4.77392870 + 719885.76609499 2 4.74019033 + -719903.82223984 2 4.74189768 + -37102.89380181 2 4.67979490 + 37103.89380181 2 4.71510215 + 33.41750090 3 3.29732864 +6 + 959.05010082 2 5.01134618 + -943.54843009 2 3.64529189 + -6456.16063099 2 4.20510279 + 637.70704529 2 2.74283267 + -1479.66774202 2 3.00605599 + 7299.12201388 2 3.90198120 +6 + -121.63220275 2 3.86324469 + 131.70125226 2 3.08695111 + 5447.27282828 2 5.92092153 + -52.94814165 2 2.63467524 + 559.83762330 2 5.08437179 + -5953.16139883 2 5.86183616 + +Ar GEN 10 2 +6 + 8.00000000 1 5.17746158 + -76.72264736 2 5.90884243 + 56.16280755 2 3.53735685 + -660.63282107 2 4.53072721 + 661.63282107 2 4.90879705 + 41.41969264 3 3.95156133 +6 + 496.48392385 2 3.21092458 + -479.29969508 2 3.39224537 + -12086.26924659 2 4.28061928 + 37151.97923364 2 4.62803105 + 496310.90908097 2 5.10487541 + -521375.61810527 2 5.08995306 +6 + -1901.02320099 2 5.53714820 + 1911.87432982 2 4.52372637 + -127.53875733 2 2.45115265 + 198.78501467 2 2.62001527 + -976.26297293 2 3.97593759 + 906.01814260 2 6.12659776 + + + + diff --git a/data/qp.png b/data/qp.png new file mode 100644 index 00000000..777e5ac0 Binary files /dev/null and b/data/qp.png differ diff --git a/doc/source/conf.py b/doc/source/conf.py index c77267ea..e461323a 100644 --- a/doc/source/conf.py +++ b/doc/source/conf.py @@ -25,7 +25,7 @@ import sys, os # Add any Sphinx extension module names here, as strings. They can be extensions # coming with Sphinx (named 'sphinx.ext.*') or your custom ones. -extensions = ['sphinx.ext.autodoc', 'sphinx.ext.doctest', 'sphinx.ext.todo', 'sphinx.ext.pngmath', 'sphinx.ext.mathjax', 'sphinx.ext.viewcode'] +extensions = ['sphinx.ext.autodoc', 'sphinx.ext.doctest', 'sphinx.ext.todo', 'sphinx.ext.mathjax', 'sphinx.ext.viewcode'] # Add any paths that contain templates here, relative to this directory. templates_path = ['_templates'] diff --git a/install/scripts/install_ocaml.sh b/install/scripts/install_ocaml.sh index 86e4e8b7..913ae75d 100755 --- a/install/scripts/install_ocaml.sh +++ b/install/scripts/install_ocaml.sh @@ -5,7 +5,8 @@ QP_ROOT=$PWD cd - # Normal installation -PACKAGES="core cryptokit ocamlfind sexplib ZMQ" +PACKAGES="core cryptokit zarith ocamlfind sexplib ZMQ" +#ppx_sexp_conv # Needed for ZeroMQ export C_INCLUDE_PATH="${QP_ROOT}"/lib:"${C_INCLUDE_PATH}" diff --git a/install/scripts/install_zeromq.sh b/install/scripts/install_zeromq.sh index 73b59019..3bf2a715 100755 --- a/install/scripts/install_zeromq.sh +++ b/install/scripts/install_zeromq.sh @@ -15,14 +15,14 @@ function _install() ./configure --without-libsodium || exit 1 make -j 8 || exit 1 rm -f -- "${QP_ROOT}"/lib/libzmq.a "${QP_ROOT}"/lib/libzmq.so "${QP_ROOT}"/lib/libzmq.so.? -# cp .libs/libzmq.a "${QP_ROOT}"/lib -# cp .libs/libzmq.so "${QP_ROOT}"/lib/libzmq.so.5 - cp src/.libs/libzmq.a "${QP_ROOT}"/lib - cp src/.libs/libzmq.so "${QP_ROOT}"/lib/libzmq.so.4 + cp .libs/libzmq.a "${QP_ROOT}"/lib + cp .libs/libzmq.so "${QP_ROOT}"/lib/libzmq.so.5 +# cp src/.libs/libzmq.a "${QP_ROOT}"/lib +# cp src/.libs/libzmq.so "${QP_ROOT}"/lib/libzmq.so.4 cp include/{zmq.h,zmq_utils.h} "${QP_ROOT}"/lib cd "${QP_ROOT}"/lib -# ln -s libzmq.so.5 libzmq.so - ln -s libzmq.so.4 libzmq.so + ln -s libzmq.so.5 libzmq.so +# ln -s libzmq.so.4 libzmq.so cd ${ORIG} return 0 } diff --git a/ocaml/Address.ml b/ocaml/Address.ml index e107cf0c..47eb3fd6 100644 --- a/ocaml/Address.ml +++ b/ocaml/Address.ml @@ -42,7 +42,7 @@ end = struct assert (String.is_prefix ~prefix:"inproc://" x); x let create name = - Printf.sprintf "ipc://%s" name + Printf.sprintf "inproc://%s" name let to_string x = x end diff --git a/ocaml/Atom.ml b/ocaml/Atom.ml index 832cfa5b..72932b1f 100644 --- a/ocaml/Atom.ml +++ b/ocaml/Atom.ml @@ -1,4 +1,4 @@ -open Core.Std;; +open Core.Std exception AtomError of string @@ -27,12 +27,18 @@ let of_string ~units s = coord = Point3d.of_string ~units (String.concat [x; y; z] ~sep:" ") } | _ -> raise (AtomError s) -;; + let to_string ~units a = [ Element.to_string a.element ; Charge.to_string a.charge ; Point3d.to_string ~units a.coord ] |> String.concat ~sep:" " -;; + + +let to_xyz a = + Printf.sprintf "%-3s %s" + (Element.to_string a.element) + (Point3d.to_string ~units:Units.Angstrom a.coord) + diff --git a/ocaml/Atom.mli b/ocaml/Atom.mli index 28915993..4b1963d5 100644 --- a/ocaml/Atom.mli +++ b/ocaml/Atom.mli @@ -7,3 +7,4 @@ val sexp_of_t : t -> Sexplib.Sexp.t val of_string : units:Units.units -> string -> t val to_string : units:Units.units -> t -> string +val to_xyz : t -> string diff --git a/ocaml/Basis.ml b/ocaml/Basis.ml index 237e5547..869fb132 100644 --- a/ocaml/Basis.ml +++ b/ocaml/Basis.ml @@ -35,11 +35,11 @@ let read_element in_channel at_number element = read in_channel at_number -let to_string b = + +let to_string_general ~fmt ~atom_sep b = let new_nucleus n = Printf.sprintf "Atom %d" n in - let rec do_work accu current_nucleus = function | [] -> List.rev accu | (g,n)::tail -> @@ -47,15 +47,27 @@ let to_string b = in let accu = if (n <> current_nucleus) then - (new_nucleus n)::""::accu + (new_nucleus n)::atom_sep::accu else accu in - do_work ((Gto.to_string g)::accu) n tail + do_work ((Gto.to_string ~fmt g)::accu) n tail in do_work [new_nucleus 1] 1 b |> String.concat ~sep:"\n" +let to_string_gamess = + to_string_general ~fmt:Gto.Gamess ~atom_sep:"" + +let to_string_gaussian b = + String.concat ~sep:"\n" + [ to_string_general ~fmt:Gto.Gaussian ~atom_sep:"****" b ; "****" ] + +let to_string ?(fmt=Gto.Gamess) = + match fmt with + | Gto.Gamess -> to_string_gamess + | Gto.Gaussian -> to_string_gaussian + include To_md5 let to_md5 = to_md5 sexp_of_t diff --git a/ocaml/Basis.mli b/ocaml/Basis.mli index 4da99266..249c14f9 100644 --- a/ocaml/Basis.mli +++ b/ocaml/Basis.mli @@ -14,7 +14,7 @@ val read_element : in_channel -> Nucl_number.t -> Element.t -> (Gto.t * Nucl_number.t) list (** Convert the basis to a string *) -val to_string : (Gto.t * Nucl_number.t) list -> string +val to_string : ?fmt:Gto.fmt -> (Gto.t * Nucl_number.t) list -> string (** Convert the basis to an MD5 hash *) val to_md5 : (Gto.t * Nucl_number.t) list -> MD5.t diff --git a/ocaml/Element.ml b/ocaml/Element.ml index 6bc2de4e..df85663f 100644 --- a/ocaml/Element.ml +++ b/ocaml/Element.ml @@ -9,6 +9,7 @@ type t = |Li|Be |B |C |N |O |F |Ne |Na|Mg |Al|Si|P |S |Cl|Ar |K |Ca|Sc|Ti|V |Cr|Mn|Fe|Co|Ni|Cu|Zn|Ga|Ge|As|Se|Br|Kr +|Rb|Sr|Y |Zr|Nb|Mo|Tc|Ru|Rh|Pd|Ag|Cd|In|Sn|Sb|Te|I |Xe with sexp let of_string x = @@ -50,6 +51,24 @@ let of_string x = | "Se" | "Selenium" -> Se | "Br" | "Bromine" -> Br | "Kr" | "Krypton" -> Kr +| "Rb" | "Rubidium" -> Rb +| "Sr" | "Strontium" -> Sr +| "Y" | "Yttrium" -> Y +| "Zr" | "Zirconium" -> Zr +| "Nb" | "Niobium" -> Nb +| "Mo" | "Molybdenum" -> Mo +| "Tc" | "Technetium" -> Tc +| "Ru" | "Ruthenium" -> Ru +| "Rh" | "Rhodium" -> Rh +| "Pd" | "Palladium" -> Pd +| "Ag" | "Silver" -> Ag +| "Cd" | "Cadmium" -> Cd +| "In" | "Indium" -> In +| "Sn" | "Tin" -> Sn +| "Sb" | "Antimony" -> Sb +| "Te" | "Tellurium" -> Te +| "I" | "Iodine" -> I +| "Xe" | "Xenon" -> Xe | x -> raise (ElementError ("Element "^x^" unknown")) @@ -91,6 +110,24 @@ let to_string = function | Se -> "Se" | Br -> "Br" | Kr -> "Kr" +| Rb -> "Rb" +| Sr -> "Sr" +| Y -> "Y" +| Zr -> "Zr" +| Nb -> "Nb" +| Mo -> "Mo" +| Tc -> "Tc" +| Ru -> "Ru" +| Rh -> "Rh" +| Pd -> "Pd" +| Ag -> "Ag" +| Cd -> "Cd" +| In -> "In" +| Sn -> "Sn" +| Sb -> "Sb" +| Te -> "Te" +| I -> "I" +| Xe -> "Xe" let to_long_string = function @@ -131,6 +168,24 @@ let to_long_string = function | Se -> "Selenium" | Br -> "Bromine" | Kr -> "Krypton" +| Rb -> "Rubidium" +| Sr -> "Strontium" +| Y -> "Yttrium" +| Zr -> "Zirconium" +| Nb -> "Niobium" +| Mo -> "Molybdenum" +| Tc -> "Technetium" +| Ru -> "Ruthenium" +| Rh -> "Rhodium" +| Pd -> "Palladium" +| Ag -> "Silver" +| Cd -> "Cadmium" +| In -> "Indium" +| Sn -> "Tin" +| Sb -> "Antimony" +| Te -> "Tellurium" +| I -> "Iodine" +| Xe -> "Xenon" let to_charge c = @@ -172,47 +227,83 @@ let to_charge c = | Se -> 34 | Br -> 35 | Kr -> 36 + | Rb -> 37 + | Sr -> 38 + | Y -> 39 + | Zr -> 40 + | Nb -> 41 + | Mo -> 42 + | Tc -> 43 + | Ru -> 44 + | Rh -> 45 + | Pd -> 46 + | Ag -> 47 + | Cd -> 48 + | In -> 49 + | Sn -> 50 + | Sb -> 51 + | Te -> 52 + | I -> 53 + | Xe -> 54 in Charge.of_int result let of_charge c = match (Charge.to_int c) with -| 0 -> X -| 1 -> H -| 2 -> He -| 3 -> Li -| 4 -> Be -| 5 -> B -| 6 -> C -| 7 -> N -| 8 -> O -| 9 -> F -| 10 -> Ne -| 11 -> Na -| 12 -> Mg -| 13 -> Al -| 14 -> Si -| 15 -> P -| 16 -> S -| 17 -> Cl -| 18 -> Ar -| 19 -> K -| 20 -> Ca -| 21 -> Sc -| 22 -> Ti -| 23 -> V -| 24 -> Cr -| 25 -> Mn -| 26 -> Fe -| 27 -> Co -| 28 -> Ni -| 29 -> Cu -| 30 -> Zn -| 31 -> Ga -| 32 -> Ge -| 33 -> As -| 34 -> Se -| 35 -> Br -| 36 -> Kr +| 0 -> X +| 1 -> H +| 2 -> He +| 3 -> Li +| 4 -> Be +| 5 -> B +| 6 -> C +| 7 -> N +| 8 -> O +| 9 -> F +| 10 -> Ne +| 11 -> Na +| 12 -> Mg +| 13 -> Al +| 14 -> Si +| 15 -> P +| 16 -> S +| 17 -> Cl +| 18 -> Ar +| 19 -> K +| 20 -> Ca +| 21 -> Sc +| 22 -> Ti +| 23 -> V +| 24 -> Cr +| 25 -> Mn +| 26 -> Fe +| 27 -> Co +| 28 -> Ni +| 29 -> Cu +| 30 -> Zn +| 31 -> Ga +| 32 -> Ge +| 33 -> As +| 34 -> Se +| 35 -> Br +| 36 -> Kr +| 37 -> Rb +| 38 -> Sr +| 39 -> Y +| 40 -> Zr +| 41 -> Nb +| 42 -> Mo +| 43 -> Tc +| 44 -> Ru +| 45 -> Rh +| 46 -> Pd +| 47 -> Ag +| 48 -> Cd +| 49 -> In +| 50 -> Sn +| 51 -> Sb +| 52 -> Te +| 53 -> I +| 54 -> Xe | x -> raise (ElementError ("Element of charge "^(string_of_int x)^" unknown")) @@ -255,6 +346,24 @@ let covalent_radius x = | Se -> 0.70 | Br -> 1.24 | Kr -> 1.91 + | Rb -> 2.20 + | Sr -> 1.95 + | Y -> 1.90 + | Zr -> 1.75 + | Nb -> 1.64 + | Mo -> 1.54 + | Tc -> 1.47 + | Ru -> 1.46 + | Rh -> 1.42 + | Pd -> 1.39 + | Ag -> 1.45 + | Cd -> 1.44 + | In -> 1.42 + | Sn -> 1.39 + | Sb -> 1.39 + | Te -> 1.38 + | I -> 1.39 + | Xe -> 1.40 in Units.angstrom_to_bohr *. (result x) |> Positive_float.of_float @@ -298,6 +407,24 @@ let vdw_radius x = | Se -> 1.70 | Br -> 2.10 | Kr -> 1.70 + | Rb -> 3.03 + | Sr -> 2.49 + | Y -> 0. + | Zr -> 0. + | Nb -> 0. + | Mo -> 0. + | Tc -> 0. + | Ru -> 0. + | Rh -> 0. + | Pd -> 1.63 + | Ag -> 1.72 + | Cd -> 1.58 + | In -> 1.93 + | Sn -> 2.17 + | Sb -> 2.06 + | Te -> 2.06 + | I -> 1.98 + | Xe -> 2.16 in Units.angstrom_to_bohr *. (result x) |> Positive_float.of_float @@ -341,6 +468,24 @@ let mass x = | Se -> 78.96 | Br -> 79.904 | Kr -> 83.80 + | Rb -> 85.4678 + | Sr -> 87.62 + | Y -> 88.90584 + | Zr -> 91.224 + | Nb -> 92.90637 + | Mo -> 95.95 + | Tc -> 98. + | Ru -> 101.07 + | Rh -> 102.90550 + | Pd -> 106.42 + | Ag -> 107.8682 + | Cd -> 112.414 + | In -> 114.818 + | Sn -> 118.710 + | Sb -> 121.760 + | Te -> 127.60 + | I -> 126.90447 + | Xe -> 131.293 in result x |> Positive_float.of_float diff --git a/ocaml/Element.mli b/ocaml/Element.mli index 8d9862c9..2c899b3b 100644 --- a/ocaml/Element.mli +++ b/ocaml/Element.mli @@ -6,6 +6,7 @@ type t = |Li|Be |B |C |N |O |F |Ne |Na|Mg |Al|Si|P |S |Cl|Ar |K |Ca|Sc|Ti|V |Cr|Mn|Fe|Co|Ni|Cu|Zn|Ga|Ge|As|Se|Br|Kr +|Rb|Sr|Y |Zr|Nb|Mo|Tc|Ru|Rh|Pd|Ag|Cd|In|Sn|Sb|Te|I |Xe with sexp (** String conversion functions *) @@ -18,3 +19,4 @@ val to_charge : t -> Charge.t val of_charge : Charge.t -> t val covalent_radius : t -> Qptypes.Positive_float.t val vdw_radius : t -> Qptypes.Positive_float.t +val mass : t -> Qptypes.Positive_float.t diff --git a/ocaml/Gto.ml b/ocaml/Gto.ml index 69aeba37..fb576ee7 100644 --- a/ocaml/Gto.ml +++ b/ocaml/Gto.ml @@ -4,6 +4,10 @@ open Qptypes exception GTO_Read_Failure of string exception End_Of_Basis +type fmt = +| Gamess +| Gaussian + type t = { sym : Symmetry.t ; lc : ((Primitive.t * AO_coef.t) list) @@ -68,8 +72,8 @@ let read_one in_channel = -(** Transform the gto to a string *) -let to_string { sym = sym ; lc = lc } = +(** Write the GTO in Gamess format *) +let to_string_gamess { sym = sym ; lc = lc } = let result = Printf.sprintf "%s %3d" (Symmetry.to_string sym) (List.length lc) in @@ -88,3 +92,30 @@ let to_string { sym = sym ; lc = lc } = |> String.concat ~sep:"\n" +(** Write the GTO in Gaussian format *) +let to_string_gaussian { sym = sym ; lc = lc } = + let result = + Printf.sprintf "%s %3d 1.00" (Symmetry.to_string sym) (List.length lc) + in + let rec do_work accu i = function + | [] -> List.rev accu + | (p,c)::tail -> + let p = AO_expo.to_float p.Primitive.expo + and c = AO_coef.to_float c + in + let result = + Printf.sprintf "%15.7f %15.7f" p c + in + do_work (result::accu) (i+1) tail + in + (do_work [result] 1 lc) + |> String.concat ~sep:"\n" + + +(** Transform the gto to a string *) +let to_string ?(fmt=Gamess) = + match fmt with + | Gamess -> to_string_gamess + | Gaussian -> to_string_gaussian + + diff --git a/ocaml/Gto.mli b/ocaml/Gto.mli index fad133a3..753cd81a 100644 --- a/ocaml/Gto.mli +++ b/ocaml/Gto.mli @@ -1,5 +1,9 @@ exception GTO_Read_Failure of string exception End_Of_Basis +type fmt = +| Gamess +| Gaussian + type t = { sym : Symmetry.t ; lc : (Primitive.t * Qptypes.AO_coef.t) list; @@ -13,4 +17,4 @@ val of_prim_coef_list : val read_one : in_channel -> t (** Convert to string for printing *) -val to_string : t -> string +val to_string : ?fmt:fmt -> t -> string diff --git a/ocaml/Id.ml b/ocaml/Id.ml index 660c3452..3e616922 100644 --- a/ocaml/Id.ml +++ b/ocaml/Id.ml @@ -1,26 +1,22 @@ -open Core.Std - -module Id : sig - type t - val of_int : int -> t - val to_int : t -> int - val of_string : string -> t - val to_string : t -> string - val increment : t -> t - val decrement : t -> t -end -= struct +module Id = struct type t = int + let of_int x = assert (x>0); x + let to_int x = x + let of_string x = - Int.of_string x + int_of_string x |> of_int + let to_string x = - Int.to_string x + string_of_int x + let increment x = x + 1 let decrement x = x - 1 + + let compare = compare end module Task = struct diff --git a/ocaml/Id.mli b/ocaml/Id.mli new file mode 100644 index 00000000..02d1efca --- /dev/null +++ b/ocaml/Id.mli @@ -0,0 +1,23 @@ +module Id : + sig + type t + val of_int : int -> t + val to_int : t -> int + val of_string : string -> t + val to_string : t -> string + val increment : t -> t + val decrement : t -> t + val compare : t -> t -> int + end + + +module Task : + sig + include (module type of Id) + end + + +module Client : + sig + include (module type of Id) + end diff --git a/ocaml/Input_ao_basis.ml b/ocaml/Input_ao_basis.ml index 82bc4964..88e277ee 100644 --- a/ocaml/Input_ao_basis.ml +++ b/ocaml/Input_ao_basis.ml @@ -17,6 +17,7 @@ module Ao_basis : sig ;; val read : unit -> t option val to_string : t -> string + val to_basis : t -> Basis.t val write : t -> unit val to_md5 : t -> MD5.t val to_rst : t -> Rst_string.t diff --git a/ocaml/Input_determinants_by_hand.ml b/ocaml/Input_determinants_by_hand.ml index c69c8ad9..76080b02 100644 --- a/ocaml/Input_determinants_by_hand.ml +++ b/ocaml/Input_determinants_by_hand.ml @@ -93,23 +93,6 @@ end = struct ;; - let read_n_states_diag () = - if not (Ezfio.has_determinants_n_states_diag ()) then - read_n_states () - |> States_number.to_int - |> Ezfio.set_determinants_n_states_diag - ; - Ezfio.get_determinants_n_states_diag () - |> States_number.of_int - ;; - - let write_n_states_diag ~n_states n = - let n_states = States_number.to_int n_states - and n = States_number.to_int n - in - Ezfio.set_determinants_n_states_diag (max n_states n) - ;; - let read_expected_s2 () = if not (Ezfio.has_determinants_expected_s2 ()) then begin diff --git a/ocaml/Input_nuclei.ml b/ocaml/Input_nuclei.ml index d050ded9..ca81629e 100644 --- a/ocaml/Input_nuclei.ml +++ b/ocaml/Input_nuclei.ml @@ -13,6 +13,7 @@ module Nuclei : sig val read : unit -> t option val write : t -> unit val to_string : t -> string + val to_atom_list : t -> Atom.t list val to_rst : t -> Rst_string.t val of_rst : Rst_string.t -> t option end = struct @@ -134,6 +135,22 @@ end = struct ;; + let to_atom_list b = + let rec loop accu (coord, charge, label) = function + | -1 -> accu + | i -> + let atom = + { Atom.element = label.(i) ; + Atom.charge = charge.(i) ; + Atom.coord = coord.(i) ; + } + in + loop (atom::accu) (coord, charge, label) (i-1) + in + loop [] (b.nucl_coord, b.nucl_charge, b.nucl_label) + ( (Nucl_number.to_int b.nucl_num) - 1) + ;; + let to_string b = Printf.sprintf " nucl_num = %s diff --git a/ocaml/Makefile b/ocaml/Makefile index 31330c66..7d51986f 100644 --- a/ocaml/Makefile +++ b/ocaml/Makefile @@ -79,7 +79,7 @@ git: ${QP_ROOT}/install/EZFIO/Ocaml/ezfio.ml: $(NINJA) -C ${QP_ROOT}/install/EZFIO -Input_auto_generated.ml qp_edit.ml: +Input_auto_generated.ml qp_edit.ml: $(filter-out Input_auto_generated.ml, $(wildcard Input_*.ml)) ei_handler.py ocaml_global clean: diff --git a/ocaml/Message.ml b/ocaml/Message.ml index 505f9789..68b866d5 100644 --- a/ocaml/Message.ml +++ b/ocaml/Message.ml @@ -248,16 +248,20 @@ end (** GetTaskReply : Reply to the GetTask message *) module GetTaskReply_msg : sig type t - val create : task_id:Id.Task.t -> task:string -> t + val create : task_id:Id.Task.t option -> task:string option -> t val to_string : t -> string end = struct type t = - { task_id: Id.Task.t ; - task : string ; + { task_id: Id.Task.t option ; + task : string option ; } let create ~task_id ~task = { task_id ; task } let to_string x = - Printf.sprintf "get_task_reply %d %s" (Id.Task.to_int x.task_id) x.task + match x.task_id, x.task with + | Some task_id, Some task -> + Printf.sprintf "get_task_reply %d %s" (Id.Task.to_int task_id) task + | _ -> + Printf.sprintf "get_task_reply 0" end (** GetPsi : get the current variational wave function *) @@ -288,13 +292,14 @@ module Psi : sig n_det_selectors : Strictly_positive_int.t option; psi_det : string ; psi_coef : string ; + energy : 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 + -> psi_det:string -> psi_coef:string -> energy:string -> t end = struct type t = { @@ -305,14 +310,16 @@ end = struct n_det_selectors : Strictly_positive_int.t option; psi_det : string ; psi_coef : string ; + energy : string ; } let create ~n_state ~n_det ~psi_det_size - ~n_det_generators ~n_det_selectors ~psi_det ~psi_coef = + ~n_det_generators ~n_det_selectors ~psi_det ~psi_coef + ~energy = 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 } + psi_det ; psi_coef ; energy } end (** GetPsiReply_msg : Reply to the GetPsi message *) @@ -329,19 +336,6 @@ end = struct 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 @@ -354,6 +348,9 @@ end = struct (Strictly_positive_int.to_int x.psi.Psi.n_det) (Strictly_positive_int.to_int x.psi.Psi.psi_det_size) g s + let to_string_list x = + [ to_string x ; + x.psi.Psi.psi_det ; x.psi.Psi.psi_coef ; x.psi.Psi.energy ] end @@ -375,7 +372,8 @@ module PutPsi_msg : sig psi_det:string option -> psi_coef:string option -> n_det_generators: string option -> - n_det_selectors:string option -> t + n_det_selectors:string option -> + energy:string option -> t val to_string_list : t -> string list val to_string : t -> string end = struct @@ -388,7 +386,7 @@ end = struct 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 = + ~n_det_generators ~n_det_selectors ~energy = let n_state, n_det, psi_det_size = Int.of_string n_state |> Strictly_positive_int.of_int , @@ -407,45 +405,19 @@ end = struct | _ -> None, None in let psi = - match (psi_det, psi_coef) with - | (Some psi_det, Some psi_coef) -> + match (psi_det, psi_coef, energy) with + | (Some psi_det, Some psi_coef, Some energy) -> Some (Psi.create ~n_state ~n_det ~psi_det_size ~psi_det - ~psi_coef ~n_det_generators ~n_det_selectors) + ~psi_coef ~n_det_generators ~n_det_selectors ~energy) | _ -> 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 -> + match x.n_det_generators, x.n_det_selectors with + | Some g, Some 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) @@ -453,21 +425,20 @@ end = struct (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) + + let to_string_list x = + match x.psi with + | Some psi -> + [ to_string x ; psi.Psi.psi_det ; psi.Psi.psi_coef ; psi.Psi.energy ] + | None -> + [ to_string x ; "None" ; "None" ; "None" ] end (** PutPsiReply_msg : Reply to the PutPsi message *) @@ -574,6 +545,9 @@ type t = | Terminate of Terminate_msg.t | Ok of Ok_msg.t | Error of Error_msg.t +| SetStopped +| SetWaiting +| SetRunning let of_string s = @@ -606,14 +580,15 @@ let of_string s = | "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 ) + ~psi_det:None ~psi_coef:None ~energy: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 -> - Error (Error_msg.create (String.concat ~sep:" " rest)) + ~n_det_selectors:None ~psi_det:None ~psi_coef:None ~energy:None) + | "ok" :: [] -> Ok (Ok_msg.create ()) + | "error" :: rest -> Error (Error_msg.create (String.concat ~sep:" " rest)) + | "set_stopped" :: [] -> SetStopped + | "set_running" :: [] -> SetRunning + | "set_waiting" :: [] -> SetWaiting | _ -> failwith "Message not understood" @@ -638,6 +613,9 @@ let to_string = function | Error x -> Error_msg.to_string x | PutPsi x -> PutPsi_msg.to_string x | GetPsiReply x -> GetPsiReply_msg.to_string x +| SetStopped -> "set_stopped" +| SetRunning -> "set_running" +| SetWaiting -> "set_waiting" let to_string_list = function diff --git a/ocaml/Molecule.ml b/ocaml/Molecule.ml index f0800f7f..a26e23b5 100644 --- a/ocaml/Molecule.ml +++ b/ocaml/Molecule.ml @@ -85,7 +85,7 @@ let name m = String.concat (result) -let to_string m = +let to_string_general ~f m = let { nuclei ; elec_alpha ; elec_beta } = m in let n = @@ -94,10 +94,15 @@ let to_string m = let title = name m in - [ Int.to_string n ; title ] @ - (List.map ~f:(fun x -> Atom.to_string Units.Angstrom x) nuclei) + [ Int.to_string n ; title ] @ (List.map ~f nuclei) |> String.concat ~sep:"\n" +let to_string = + to_string_general ~f:(fun x -> Atom.to_string Units.Angstrom x) + +let to_xyz = + to_string_general ~f:Atom.to_xyz + let of_xyz_string ?(charge=(Charge.of_int 0)) ?(multiplicity=(Multiplicity.of_int 1)) @@ -142,10 +147,28 @@ let of_xyz_file let (_,buffer) = In_channel.read_all filename |> String.lsplit2_exn ~on:'\n' in let (_,buffer) = String.lsplit2_exn buffer ~on:'\n' in - of_xyz_string ~charge:charge ~multiplicity:multiplicity - ~units:units buffer + of_xyz_string ~charge ~multiplicity ~units buffer +let of_zmt_file + ?(charge=(Charge.of_int 0)) ?(multiplicity=(Multiplicity.of_int 1)) + ?(units=Units.Angstrom) + filename = + In_channel.read_all filename + |> Zmatrix.of_string + |> Zmatrix.to_xyz_string + |> of_xyz_string ~charge ~multiplicity ~units + + +let of_file + ?(charge=(Charge.of_int 0)) ?(multiplicity=(Multiplicity.of_int 1)) + ?(units=Units.Angstrom) + filename = + try + of_xyz_file ~charge ~multiplicity ~units filename + with _ -> + of_zmt_file ~charge ~multiplicity ~units filename + let distance_matrix molecule = let coord = diff --git a/ocaml/Molecule.mli b/ocaml/Molecule.mli index 1a3d9715..f6201b18 100644 --- a/ocaml/Molecule.mli +++ b/ocaml/Molecule.mli @@ -20,6 +20,7 @@ val name : t -> string (** Conversion for printing *) val to_string : t -> string +val to_xyz : t -> string (** Creates a molecule from an xyz file *) @@ -28,6 +29,18 @@ val of_xyz_file : ?multiplicity:Multiplicity.t -> ?units:Units.units -> string -> t +(** Creates a molecule from a zmt file *) +val of_zmt_file : + ?charge:Charge.t -> + ?multiplicity:Multiplicity.t -> + ?units:Units.units -> string -> t + +(** Creates a molecule from a file (xyz or zmt) *) +val of_file : + ?charge:Charge.t -> + ?multiplicity:Multiplicity.t -> + ?units:Units.units -> string -> t + (** Creates a molecule from an xyz file in a string *) val of_xyz_string : ?charge:Charge.t -> diff --git a/ocaml/Progress_bar.ml b/ocaml/Progress_bar.ml index 2ca8bd00..b8e97a59 100644 --- a/ocaml/Progress_bar.ml +++ b/ocaml/Progress_bar.ml @@ -14,13 +14,13 @@ type 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 () } + init_time= Time.now () ; dirty = false ; 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 } + { bar with end_value=(bar.end_value +. 1.) ; dirty=false } let increment_cur bar = { bar with cur_value=(bar.cur_value +. 1.) ; dirty=true } diff --git a/ocaml/Qpackage.ml b/ocaml/Qpackage.ml index bd0d34fc..8011b23b 100644 --- a/ocaml/Qpackage.ml +++ b/ocaml/Qpackage.ml @@ -127,3 +127,14 @@ let get_ezfio_default directory data = |> aux ;; +let ezfio_work ezfio_file = + let result = + Filename.concat ezfio_file "work" + in + begin + match Sys.is_directory result with + | `Yes -> () + | _ -> Unix.mkdir result + end; + result +;; diff --git a/ocaml/Queuing_system.ml b/ocaml/Queuing_system.ml index acdfd439..0c668e16 100644 --- a/ocaml/Queuing_system.ml +++ b/ocaml/Queuing_system.ml @@ -1,25 +1,35 @@ -open Core.Std -open Qptypes - +module RunningMap = Map.Make (Id.Task) +module TasksMap = Map.Make (Id.Task) +module ClientsSet = Set.Make (Id.Client) type t = -{ queued : Id.Task.t list ; - running : (Id.Task.t, Id.Client.t) Map.Poly.t ; - tasks : (Id.Task.t, string) Map.Poly.t; - clients : Id.Client.t Set.Poly.t; +{ queued_front : Id.Task.t list ; + queued_back : Id.Task.t list ; + running : Id.Client.t RunningMap.t; + tasks : string TasksMap.t; + clients : ClientsSet.t; next_client_id : Id.Client.t; next_task_id : Id.Task.t; + number_of_queued : int; + number_of_running : int; + number_of_tasks : int; + number_of_clients : int; } let create () = - { queued = [] ; - running = Map.Poly.empty ; - tasks = Map.Poly.empty; - clients = Set.Poly.empty; + { queued_front = [] ; + queued_back = [] ; + running = RunningMap.empty ; + tasks = TasksMap.empty; + clients = ClientsSet.empty; next_client_id = Id.Client.of_int 1; next_task_id = Id.Task.of_int 1; + number_of_queued = 0; + number_of_running = 0; + number_of_tasks = 0; + number_of_clients = 0; } @@ -30,9 +40,11 @@ let add_task ~task q = q.next_task_id in { q with - queued = task_id :: q.queued ; - tasks = Map.add q.tasks ~key:task_id ~data:task ; + queued_front = task_id :: q.queued_front ; + tasks = TasksMap.add task_id task q.tasks; next_task_id = Id.Task.increment task_id ; + number_of_queued = q.number_of_queued + 1; + number_of_tasks = q.number_of_tasks + 1; } @@ -43,55 +55,73 @@ let add_client q = q.next_client_id in { q with - clients = Set.add q.clients client_id; + clients = ClientsSet.add client_id q.clients; next_client_id = Id.Client.increment client_id; + number_of_clients = q.number_of_clients + 1; }, client_id let pop_task ~client_id q = - let { queued ; running ; _ } = + let { queued_front ; queued_back ; running ; _ } = q in - assert (Set.mem q.clients client_id); - match queued with + assert (ClientsSet.mem client_id q.clients); + let queued_front', queued_back' = + match queued_front, queued_back with + | (l, []) -> ( [], List.rev l) + | t -> t + in + match queued_back' with | task_id :: new_queue -> let new_q = { q with - queued = new_queue ; - running = Map.add running ~key:task_id ~data:client_id ; + queued_front= queued_front' ; + queued_back = new_queue ; + running = RunningMap.add task_id client_id running; + number_of_queued = q.number_of_queued - 1; + number_of_running = q.number_of_running + 1; } - in new_q, Some task_id, (Map.find q.tasks task_id) + and found = + try Some (TasksMap.find task_id q.tasks) + with Not_found -> None + in new_q, Some task_id, found | [] -> q, None, None let del_client ~client_id q = - assert (Set.mem q.clients client_id); + assert (ClientsSet.mem client_id q.clients); { q with - clients = Set.remove q.clients client_id } + clients = ClientsSet.remove client_id q.clients; + number_of_clients = q.number_of_clients - 1 + } let end_task ~task_id ~client_id q = let { running ; tasks ; _ } = q in - assert (Set.mem q.clients client_id); - let () = - match Map.Poly.find running task_id with - | None -> failwith "Task already finished" - | Some client_id_check -> assert (client_id_check = client_id) + assert (ClientsSet.mem client_id q.clients); + let () = + let client_id_check = + try RunningMap.find task_id running with + Not_found -> failwith "Task already finished" + in + assert (client_id_check = client_id) in { q with - running = Map.remove running task_id ; + running = RunningMap.remove task_id running ; + number_of_running = q.number_of_running - 1 } - + let del_task ~task_id q = let { tasks ; _ } = q in - if (Map.mem tasks task_id) then + if (TasksMap.mem task_id tasks) then { q with - tasks = Map.remove tasks task_id ; + tasks = TasksMap.remove task_id tasks; + number_of_tasks = q.number_of_tasks - 1; } else Printf.sprintf "Task %d is already deleted" (Id.Task.to_int task_id) @@ -99,33 +129,81 @@ let del_task ~task_id q = +let number_of_tasks q = + assert (q.number_of_tasks >= 0); + q.number_of_tasks + let number_of_queued q = - Map.length q.tasks + assert (q.number_of_queued >= 0); + q.number_of_queued let number_of_running q = - Map.length q.running + assert (q.number_of_running >= 0); + q.number_of_running + +let number_of_clients q = + assert (q.number_of_clients >= 0); + q.number_of_clients -let to_string { queued ; running ; tasks ; _ } = +let to_string qs = + let { queued_back ; queued_front ; running ; tasks ; _ } = qs in let q = - List.map ~f:Id.Task.to_string queued - |> String.concat ~sep:" ; " + (List.map Id.Task.to_string queued_front) @ + (List.map Id.Task.to_string @@ List.rev queued_back) + |> String.concat " ; " and r = - Map.Poly.to_alist running - |> List.map ~f:(fun (t,c) -> "("^(Id.Task.to_string t)^", " + RunningMap.bindings running + |> List.map (fun (t,c) -> "("^(Id.Task.to_string t)^", " ^(Id.Client.to_string c)^")") - |> String.concat ~sep:" ; " + |> String.concat " ; " and t = - Map.Poly.to_alist tasks - |> List.map ~f:(fun (t,c) -> "("^(Id.Task.to_string t)^", \"" + TasksMap.bindings tasks + |> List.map (fun (t,c) -> "("^(Id.Task.to_string t)^", \"" ^c^"\")") - |> String.concat ~sep:" ; " + |> String.concat " ; " in Printf.sprintf "{ +Tasks : %d Queued : %d Running : %d Clients : %d queued : { %s } running : { %s } tasks : [ %s ] -}" q r t +}" +(number_of_tasks qs) (number_of_queued qs) (number_of_running qs) (number_of_clients qs) +q r t + +let test () = + let q = + create () + |> add_task ~task:"First Task" + |> add_task ~task:"Second Task" + in + let q, client_id = + add_client q + in + let q, task_id, task_content = + match pop_task ~client_id q with + | q, Some x, Some y -> q, Id.Task.to_int x, y + | _ -> assert false + in + Printf.printf "Task_id : %d \t\t Task : %s\n" task_id task_content; + to_string q |> print_endline ; + let q, task_id, task_content = + match pop_task ~client_id q with + | q, Some x, Some y -> q, Id.Task.to_int x, y + | _ -> assert false + in + Printf.printf "Task_id : %d \t\t Task : %s\n" task_id task_content; + let q, task_id, task_content = + match pop_task ~client_id q with + | q, None, None -> q, 0, "None" + | _ -> assert false + in + Printf.printf "Task_id : %d \t\t Task : %s\n" task_id task_content; + q + |> to_string + |> print_endline + diff --git a/ocaml/Queuing_system.mli b/ocaml/Queuing_system.mli new file mode 100644 index 00000000..dc6836d2 --- /dev/null +++ b/ocaml/Queuing_system.mli @@ -0,0 +1,63 @@ +module RunningMap : Map.S with type key = Id.Task.t +module TasksMap : Map.S with type key = Id.Task.t +module ClientsSet : Set.S with type elt = Id.Client.t + +type t = { + queued_front : Id.Task.t list ; + queued_back : Id.Task.t list ; + running : Id.Client.t RunningMap.t ; + tasks : string TasksMap.t ; + clients : ClientsSet.t ; + next_client_id : Id.Client.t ; + next_task_id : Id.Task.t ; + number_of_queued : int ; + number_of_running : int ; + number_of_tasks : int ; + number_of_clients : int ; +} + +(** Creates a new queuing system. Returns the new queue. *) +val create : unit -> t + +(** Add a new task represented as a string. Returns the queue with the added task. *) +val add_task : task:string -> t -> t + +(** Add a new client. Returns the queue and a new client_id. *) +val add_client : t -> t * Id.Client.t + +(** Pops a task from the queue. The task is set as running on client client_id. + Returns the queue, a task_id and the content of the task. If the queue contains + no task, the task_id and the task content are None. *) +val pop_task : + client_id:ClientsSet.elt -> t -> t * Id.Task.t option * string option + +(** Deletes a client from the queuing system *) +val del_client : client_id:ClientsSet.elt -> t -> t + +(** Deletes a client from the queuing system. The client is assumed to be a member + of the set of clients. Returns the queue without the removed client. *) +val end_task : task_id:RunningMap.key -> client_id:ClientsSet.elt -> t -> t + +(** Deletes a task from the queuing system. The task is assumed to be a member + of the map of tasks. Returns the queue without the removed task. *) +val del_task : task_id:TasksMap.key -> t -> t + +(** Returns the number of tasks, assumed >= 0 *) +val number_of_tasks : t -> int + +(** Returns the number of queued tasks, assumed >= 0 *) +val number_of_queued : t -> int + +(** Returns the number of running tasks, assumed >= 0 *) +val number_of_running : t -> int + +(** Returns the number of connected clients, assumed >= 0 *) +val number_of_clients : t -> int + +(** Prints the content of the queue *) +val to_string : t -> string + +(** Test function for debug *) +val test : unit -> unit + + diff --git a/ocaml/TaskServer.ml b/ocaml/TaskServer.ml index 67d5bb07..6edc8122 100644 --- a/ocaml/TaskServer.ml +++ b/ocaml/TaskServer.ml @@ -2,6 +2,23 @@ open Core.Std open Qptypes +type pub_state = +| Waiting +| Running of string +| Stopped + +let pub_state_of_string = function +| "Waiting" -> Waiting +| "Stopped" -> Stopped +| s -> Running s + +let string_of_pub_state = function +| Waiting -> "Waiting" +| Stopped -> "Stopped" +| Running s -> s + + + type t = { queue : Queuing_system.t ; @@ -31,20 +48,21 @@ let zmq_context = ZMQ.Context.create () -let bind_socket ~socket_type ~socket ~address = +let bind_socket ~socket_type ~socket ~port = let rec loop = function | 0 -> failwith @@ Printf.sprintf - "Unable to bind the %s socket : %s " - socket_type address + "Unable to bind the %s socket to port : %d " + socket_type port | -1 -> () | i -> try - ZMQ.Socket.bind socket address; + ZMQ.Socket.bind socket @@ Printf.sprintf "tcp://*:%d" port; loop (-1) with | Unix.Unix_error _ -> (Time.pause @@ Time.Span.of_float 1. ; loop (i-1) ) | other_exception -> raise other_exception - in loop 10 + in loop 60; + ZMQ.Socket.bind socket @@ Printf.sprintf "ipc:///tmp/qp_run:%d" port let hostname = lazy ( @@ -98,7 +116,7 @@ let stop ~port = let req_socket = ZMQ.Socket.create zmq_context ZMQ.Socket.req and address = - Printf.sprintf "tcp://%s:%d" (Lazy.force ip_address) port + Printf.sprintf "ipc:///tmp/qp_run:%d" port in ZMQ.Socket.set_linger_period req_socket 1_000_000; ZMQ.Socket.connect req_socket address; @@ -120,7 +138,7 @@ let stop ~port = ZMQ.Socket.close req_socket -let new_job msg program_state rep_socket = +let new_job msg program_state rep_socket pair_socket = let state = msg.Message.Newjob_msg.state @@ -143,10 +161,32 @@ let new_job msg program_state rep_socket = } in reply_ok rep_socket; + string_of_pub_state Waiting + |> ZMQ.Socket.send pair_socket ; result +let change_pub_state msg program_state rep_socket pair_socket = + let msg = + match msg with + | `Waiting -> Waiting + | `Stopped -> Stopped + | `Running -> + begin + let state = + match program_state.state with + | Some x -> x + | None -> failwith "Trying to change pub state while no job is ready" + in + Running (Message.State.to_string state) + end + in + reply_ok rep_socket; + string_of_pub_state msg + |> ZMQ.Socket.send pair_socket ; -let end_job msg program_state rep_socket = + program_state + +let end_job msg program_state rep_socket pair_socket = let failure () = reply_wrong_state rep_socket; @@ -165,7 +205,11 @@ let end_job msg program_state rep_socket = | Some state -> begin if (msg.Message.Endjob_msg.state = state) then - success state + begin + string_of_pub_state Waiting + |> ZMQ.Socket.send pair_socket ; + success state + end else failure () end @@ -262,8 +306,7 @@ let del_task msg program_state rep_socket = } in let more = - (Queuing_system.number_of_queued new_program_state.queue + - Queuing_system.number_of_running new_program_state.queue) > 0 + (Queuing_system.number_of_tasks new_program_state.queue > 0) in Message.DelTaskReply (Message.DelTaskReply_msg.create ~task_id ~more) |> Message.to_string @@ -355,7 +398,7 @@ let add_task msg program_state rep_socket = -let get_task msg program_state rep_socket = +let get_task msg program_state rep_socket pair_socket = let state, client_id = msg.Message.GetTask_msg.state, @@ -371,6 +414,12 @@ let get_task msg program_state rep_socket = let new_queue, task_id, task = Queuing_system.pop_task ~client_id program_state.queue in + if (Queuing_system.number_of_queued new_queue = 0) then + string_of_pub_state Waiting + |> ZMQ.Socket.send pair_socket + else + string_of_pub_state (Running (Message.State.to_string state)) + |> ZMQ.Socket.send pair_socket; let new_program_state = { program_state with @@ -378,21 +427,10 @@ let get_task msg program_state rep_socket = } in - match (task, task_id) with - | Some task, Some task_id -> - begin - Message.GetTaskReply (Message.GetTaskReply_msg.create ~task ~task_id) - |> Message.to_string - |> ZMQ.Socket.send rep_socket ; - new_program_state - end - | _ -> - begin - Message.Terminate (Message.Terminate_msg.create ()) - |> Message.to_string - |> ZMQ.Socket.send rep_socket ; - program_state - end + Message.GetTaskReply (Message.GetTaskReply_msg.create ~task ~task_id) + |> Message.to_string + |> ZMQ.Socket.send rep_socket ; + new_program_state in @@ -454,9 +492,9 @@ let put_psi msg rest_of_msg program_state rep_socket = | Some x -> x | None -> begin - let psi_det, psi_coef = + let psi_det, psi_coef, energy = match rest_of_msg with - | [ x ; y ] -> x, y + | [ x ; y ; e ] -> x, y, e | _ -> failwith "Badly formed put_psi message" in Message.Psi.create @@ -467,6 +505,7 @@ let put_psi msg rest_of_msg program_state rep_socket = ~n_det_selectors:msg.Message.PutPsi_msg.n_det_selectors ~psi_det ~psi_coef + ~energy end in let new_program_state = @@ -501,29 +540,85 @@ let get_psi msg program_state rep_socket = let terminate program_state rep_socket = reply_ok rep_socket; { program_state with + psi = None; + address_tcp = None; + address_inproc = None; 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 start_pub_thread ~port = + Thread.create (fun () -> + let timeout = + 1000 + in + let pair_socket = + ZMQ.Socket.create zmq_context ZMQ.Socket.pair + and address = + "inproc://pair" + in + ZMQ.Socket.connect pair_socket address; + + let pub_socket = + ZMQ.Socket.create zmq_context ZMQ.Socket.pub + in + bind_socket ~socket_type:"PUB" ~socket:pub_socket ~port; + + let pollitem = + ZMQ.Poll.mask_of + [| (pair_socket, ZMQ.Poll.In) |] + in + + let rec run state = + let new_state = + let polling = + ZMQ.Poll.poll ~timeout pollitem + in + if (polling.(0) = Some ZMQ.Poll.In) then + ZMQ.Socket.recv ~block:false pair_socket + |> pub_state_of_string + else + state + in + ZMQ.Socket.send pub_socket @@ string_of_pub_state new_state; + match state with + | Stopped -> () + | _ -> run new_state + in + run Waiting; + ZMQ.Socket.set_linger_period pair_socket 1000 ; + ZMQ.Socket.close pair_socket; + ZMQ.Socket.set_linger_period pub_socket 1000 ; + ZMQ.Socket.close pub_socket; + ) let run ~port = + (** Bind inproc socket for changing state of pub *) + let pair_socket = + ZMQ.Socket.create zmq_context ZMQ.Socket.pair + and address = + "inproc://pair" + in + ZMQ.Socket.bind pair_socket address; + + let pub_thread = + start_pub_thread ~port:(port+1) () + in + (** 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; + bind_socket "REP" rep_socket port; let initial_program_state = { queue = Queuing_system.create () ; @@ -542,6 +637,9 @@ let run ~port = [| (rep_socket, ZMQ.Poll.In) |] in + let address = + Printf.sprintf "tcp://%s:%d" (Lazy.force ip_address) port + in Printf.printf "Task server running : %s\n%!" address; @@ -579,9 +677,10 @@ let run ~port = in (** Debug input *) - Printf.sprintf "%d %d : %s\n%!" + Printf.sprintf "q:%d r:%d n:%d : %s\n%!" (Queuing_system.number_of_queued program_state.queue) (Queuing_system.number_of_running program_state.queue) + (Queuing_system.number_of_tasks program_state.queue) (Message.to_string message) |> debug; @@ -591,15 +690,18 @@ let run ~port = | _ , 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 + | None , Message.Newjob x -> new_job x program_state rep_socket pair_socket | _ , Message.Newjob _ -> error "A job is already running" program_state rep_socket - | Some _, Message.Endjob x -> end_job x program_state rep_socket + | Some _, Message.Endjob x -> end_job x program_state rep_socket pair_socket + | Some _, Message.SetRunning -> change_pub_state `Running program_state rep_socket pair_socket + | _, Message.SetWaiting -> change_pub_state `Waiting program_state rep_socket pair_socket + | _, Message.SetStopped -> change_pub_state `Stopped program_state rep_socket pair_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.GetTask x -> get_task x program_state rep_socket pair_socket | Some _, Message.TaskDone x -> task_done x program_state rep_socket | _ , _ -> error ("Invalid message : "^(Message.to_string message)) program_state rep_socket @@ -614,6 +716,11 @@ let run ~port = end in main_loop initial_program_state true; + ZMQ.Socket.send pair_socket @@ string_of_pub_state Stopped; + Thread.join pub_thread; + ZMQ.Socket.close rep_socket + + diff --git a/ocaml/TaskServer.mli b/ocaml/TaskServer.mli new file mode 100644 index 00000000..e1baab12 --- /dev/null +++ b/ocaml/TaskServer.mli @@ -0,0 +1,84 @@ +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; +} + + +(** {1} Debugging *) + +(** Fetch the QP_TASK_DEBUG environment variable *) +val debug_env : bool + +(** Print a debug message *) +val debug : string -> unit + +(** {1} ZMQ *) + +(** ZeroMQ context *) +val zmq_context : ZMQ.Context.t + +(** Bind a ZMQ socket to a TCP port and to an IPC file /tmp/qp_run. *) +val bind_socket : + socket_type:string -> socket:'a ZMQ.Socket.t -> port:int -> unit + +(** Name of the host on which the server runs *) +val hostname : string lazy_t + +(** IP address of the current host *) +val ip_address : string lazy_t + +(** Standard messages *) +val reply_ok : [> `Req ] ZMQ.Socket.t -> unit +val reply_wrong_state : [> `Req ] ZMQ.Socket.t -> unit + +(** Stop server *) +val stop : port:int -> unit + +(** {1} Server functions *) + +(** Create a new job *) +val new_job : Message.Newjob_msg.t -> t -> [> `Req ] ZMQ.Socket.t -> [> `Pair] ZMQ.Socket.t -> t + +(** Finish a running job *) +val end_job : Message.Endjob_msg.t -> t -> [> `Req ] ZMQ.Socket.t -> [> `Pair] ZMQ.Socket.t -> t + +(** Connect a client *) +val connect: Message.Connect_msg.t -> t -> [> `Req ] ZMQ.Socket.t -> t + +(** Disconnect a client *) +val disconnect: Message.Disconnect_msg.t -> t -> [> `Req ] ZMQ.Socket.t -> t + +(** Add a task to the pool *) +val add_task: Message.AddTask_msg.t -> t -> [> `Req ] ZMQ.Socket.t -> t + +(** Mark the task as done by the client *) +val task_done: Message.TaskDone_msg.t -> t -> [> `Req ] ZMQ.Socket.t -> t + +(** Delete a task when it has been pulled by the collector *) +val del_task: Message.DelTask_msg.t -> t -> [> `Req ] ZMQ.Socket.t -> t + +(** The client get a new task to execute *) +val get_task: Message.GetTask_msg.t -> t -> [> `Req ] ZMQ.Socket.t -> [> `Pair] ZMQ.Socket.t -> t + +(** Terminate server *) +val terminate : t -> [> `Req ] ZMQ.Socket.t -> t + +(** Put a wave function in the task server *) +val put_psi : + Message.PutPsi_msg.t -> string list -> t -> [> `Req ] ZMQ.Socket.t -> t + +(** Get the wave function stored in the task server *) +val get_psi : Message.GetPsi_msg.t -> t -> [> `Req ] ZMQ.Socket.t -> t + +(** Reply an Error message *) +val error : string -> t -> [> `Req ] ZMQ.Socket.t -> t + +(** Run server *) +val run : port:int -> unit + diff --git a/ocaml/Zmatrix.ml b/ocaml/Zmatrix.ml new file mode 100644 index 00000000..0aae3441 --- /dev/null +++ b/ocaml/Zmatrix.ml @@ -0,0 +1,326 @@ +open Qptypes + +module StringMap = Map.Make(String) + +type atom_id = int +type angle = Label of string | Value of float +type distance = Label of string | Value of float +type dihedral = Label of string | Value of float + +let pi = acos (-1.) +let to_radian = pi /. 180. + +let rec in_range (xmin, xmax) x = + if (x <= xmin) then + in_range (xmin, xmax) (x -. xmin +. xmax ) + else if (x > xmax) then + in_range (xmin, xmax) (x -. xmax +. xmin ) + else + x + +let atom_id_of_int : int -> atom_id = + fun x -> ( assert (x>0) ; x) + +let distance_of_float : float -> distance = + fun x -> ( assert (x>=0.) ; Value x) + +let angle_of_float : float -> angle = + fun x -> Value (in_range (-180., 180.) x) + +let dihedral_of_float : float -> dihedral = + fun x -> Value (in_range (-360., 360.) x) + + +let atom_id_of_string : string -> atom_id = + fun i -> atom_id_of_int @@ int_of_string i + +let distance_of_string : string -> distance = + fun s -> + try + distance_of_float @@ float_of_string s + with _ -> Label s + +let angle_of_string : string -> angle = + fun s -> + try + angle_of_float @@ float_of_string s + with _ -> Label s + +let dihedral_of_string : string -> dihedral = + fun s -> + try + dihedral_of_float @@ float_of_string s + with _ -> Label s + + +let int_of_atom_id : atom_id -> int = fun x -> x + +let float_of_distance : float StringMap.t -> distance -> float = + fun map -> function + | Value x -> x + | Label s -> StringMap.find s map + +let float_of_angle : float StringMap.t -> angle -> float = + fun map -> function + | Value x -> x + | Label s -> StringMap.find s map + +let float_of_dihedral : float StringMap.t -> dihedral -> float = + fun map -> function + | Value x -> x + | Label s -> StringMap.find s map + + +type line = +| First of Element.t +| Second of (Element.t * distance) +| Third of (Element.t * atom_id * distance * atom_id * angle) +| Other of (Element.t * atom_id * distance * atom_id * angle * atom_id * dihedral ) +| Coord of (string * float) + + +let string_of_line map = + let f_r = float_of_distance map + and f_a = float_of_angle map + and f_d = float_of_dihedral map + and i_i = int_of_atom_id + in function +| First e -> Printf.sprintf "%-3s" (Element.to_string e) +| Second (e, r) -> Printf.sprintf "%-3s %5d %f" (Element.to_string e) 1 (f_r r) +| Third (e, i, r, j, a) -> Printf.sprintf "%-3s %5d %f %5d %f" (Element.to_string e) (i_i i) (f_r r) (i_i j) (f_a a) +| Other (e, i, r, j, a, k, d) -> Printf.sprintf "%-3s %5d %f %5d %f %5d %f" (Element.to_string e) (i_i i) (f_r r) (i_i j) (f_a a) (i_i k) (f_d d) +| Coord (c, f) -> Printf.sprintf "%s %f" c f + + +let line_of_string l = + let line_clean = + Str.split (Str.regexp " ") l + |> List.filter (fun x -> x <> "") + in + match line_clean with + | e :: [] -> First (Element.of_string e) + | e :: i :: r :: [] -> Second + (Element.of_string e, + distance_of_string r) + | e :: i :: r :: j :: a :: [] -> Third + (Element.of_string e, + atom_id_of_string i, + distance_of_string r, + atom_id_of_string j, + angle_of_string a) + | e :: i :: r :: j :: a :: k :: d :: [] -> Other + (Element.of_string e, + atom_id_of_string i, + distance_of_string r, + atom_id_of_string j, + angle_of_string a, + atom_id_of_string k, + dihedral_of_string d) + | c :: f :: [] -> Coord (c, float_of_string f) + | _ -> failwith ("Syntax error: "^l) + + +type t = (line array * float StringMap.t) + +let of_string t = + let l = + Str.split (Str.regexp "\n") t + |> List.map String.trim + |> List.filter (fun x -> x <> "") + |> List.map line_of_string + in + + let l = + match l with + | First _ :: Second _ :: Third _ :: _ + | First _ :: Second _ :: Coord _ :: [] + | First _ :: Second _ :: [] + | First _ :: [] -> l + | _ -> failwith "Syntax error" + in + + let (l, m) = + let rec work lst map = function + | (First _ as x) :: rest + | (Second _ as x) :: rest + | (Third _ as x) :: rest + | (Other _ as x) :: rest -> work (x::lst) map rest + | (Coord (c,f)) :: rest -> work lst (StringMap.add c f map) rest + | [] -> (List.rev lst, map) + in + work [] (StringMap.empty) l + in + (Array.of_list l, m) + + +(** Linear algebra *) + +let (|-) (x,y,z) (x',y',z') = + ( x-.x', y-.y', z-.z' ) + +let (|+) (x,y,z) (x',y',z') = + ( x+.x', y+.y', z+.z' ) + +let (|.) s (x,y,z) = + ( s*.x, s*.y, s*.z ) + +let dot (x,y,z) (x',y',z') = + x*.x' +. y*.y' +. z*.z' + +let norm u = + sqrt @@ dot u u + +let normalized u = + 1. /. (norm u) |. u + +let cross (x,y,z) (x',y',z') = + ((y *. z' -. z *. y'), -. (x *. z' -. z *. x'), (x *. y' -. y *. x')) + +let rotation_matrix axis angle = + (* Euler-Rodrigues formula for rotation matrix, taken from + https://github.com/jevandezande/zmatrix/blob/master/converter.py + *) + let a = + (cos (angle *. to_radian *. 0.5)) + in + let (b, c, d) = + (-. sin (angle *. to_radian *. 0.5)) |. (normalized axis) + in + Array.of_list @@ + [(a *. a +. b *. b -. c *. c -. d *. d, + 2. *. (b *. c -. a *. d), + 2. *. (b *. d +. a *. c)); + (2. *. (b *. c +. a *. d), + a *. a +. c *. c -.b *. b -. d *. d, + 2. *. (c *. d -. a *. b)); + (2. *. (b *. d -. a *. c), + 2. *. (c *. d +. a *. b), + a *. a +. d *. d -. b *. b -. c *. c)] +(* + [(a *. a +. b *. b -. c *. c -. d *. d, + 2. *. (b *. c +. a *. d), + 2. *. (b *. d -. a *. c)); + (2. *. (b *. c -. a *. d), + a *. a +. c *. c -.b *. b -. d *. d, + 2. *. (c *. d +. a *. b)); + (2. *. (b *. d +. a *. c), + 2. *. (c *. d -. a *. b), + a *. a +. d *. d -. b *. b -. c *. c)] +*) + + + +let apply_rotation_matrix rot u = + (dot rot.(0) u, dot rot.(1) u, dot rot.(2) u) + +let center_of_mass l = +let (x,y,z) = + let sum_mass, com = + Array.fold_left (fun (s,com) (e,x,y,z) -> + let mass = + Positive_float.to_float @@ Element.mass e + in + (s +. mass, ( mass |. (x,y,z) ) |+ com) ) + (0., (0.,0.,0.)) l + in + (1. /. sum_mass) |. com +in +Printf.printf "%f %f %f\n" x y z ; (x,y,z) + +let to_xyz (z,map) = + let result = + Array.make (Array.length z) None + in + + let get_cartesian_coord i = + match result.(i-1) with + | None -> failwith @@ Printf.sprintf "Atom %d is defined in the future" i + | Some (_, x, y, z) -> (x, y, z) + in + + + let append_line i' = + match z.(i') with + | First e -> + result.(i') <- Some (e, 0., 0., 0.) + | Second (e, r) -> + let r = + float_of_distance map r + in + result.(i') <- Some (e, 0., 0., r) + | Third (e, i, r, j, a) -> + begin + let i, r, j, a = + int_of_atom_id i, + float_of_distance map r, + int_of_atom_id j, + float_of_angle map a + in + let ui, uj = + get_cartesian_coord i, + get_cartesian_coord j + in + let u_ij = + (uj |- ui) + in + let rot = + rotation_matrix (0., 1., 0.) a + in + let new_vec = + apply_rotation_matrix rot ( r |. (normalized u_ij)) + in + let (x, y, z) = + new_vec |+ ui + in + result.(i') <- Some (e, x, y, z) + end + | Other (e, i, r, j, a, k, d) -> + begin + let i, r, j, a, k, d = + int_of_atom_id i, + float_of_distance map r, + int_of_atom_id j, + float_of_angle map a, + int_of_atom_id k, + float_of_dihedral map d + in + let ui, uj, uk = + get_cartesian_coord i, + get_cartesian_coord j, + get_cartesian_coord k + in + let u_ij, u_kj = + (uj |- ui) , (uj |- uk) + in + let normal = + cross u_ij u_kj + in + let new_vec = + r |. (normalized u_ij) + |> apply_rotation_matrix (rotation_matrix normal a) + |> apply_rotation_matrix (rotation_matrix u_ij d) + in + let (x, y, z) = + new_vec |+ ui + in + result.(i') <- Some (e, x, y, z) + end + | Coord _ -> () + in + Array.iteri (fun i _ -> append_line i) z; + let result = + Array.map (function + | Some x -> x + | None -> failwith "Some atoms were not defined" ) result + in + Array.to_list result + + +let to_xyz_string (l,map) = + String.concat "\n" + ( to_xyz (l,map) + |> List.map (fun (e,x,y,z) -> + Printf.sprintf "%s %f %f %f\n" (Element.to_string e) x y z) ) + + + diff --git a/ocaml/_tags b/ocaml/_tags index fd4c4804..0935c0bb 100644 --- a/ocaml/_tags +++ b/ocaml/_tags @@ -1,3 +1,3 @@ -true: package(core,sexplib.syntax,cryptokit,ZMQ) +true: package(core,cryptokit,ZMQ,sexplib.syntax,str) true: thread false: profile diff --git a/ocaml/qp_create_ezfio_from_xyz.ml b/ocaml/qp_create_ezfio_from_xyz.ml index 710523e4..c79bf550 100644 --- a/ocaml/qp_create_ezfio_from_xyz.ml +++ b/ocaml/qp_create_ezfio_from_xyz.ml @@ -19,7 +19,7 @@ let spec = ~doc:"string Name of the pseudopotential" +> flag "cart" no_arg ~doc:" Compute AOs in the Cartesian basis set (6d, 10f, ...)" - +> anon ("xyz_file" %: file ) + +> anon ("(xyz_file|zmt_file)" %: file ) (** Handle dummy atoms placed on bonds *) @@ -93,7 +93,7 @@ let run ?o b c d m p cart xyz_file = (* Read molecule *) let molecule = - (Molecule.of_xyz_file xyz_file ~charge:(Charge.of_int c) + (Molecule.of_file xyz_file ~charge:(Charge.of_int c) ~multiplicity:(Multiplicity.of_int m) ) in let dummy = @@ -309,7 +309,8 @@ let run ?o b c d m p cart xyz_file = | None -> begin match String.rsplit2 ~on:'.' xyz_file with - | Some (x,"xyz") -> x^".ezfio" + | Some (x,"xyz") + | Some (x,"zmt") -> x^".ezfio" | _ -> xyz_file^".ezfio" end in @@ -640,9 +641,10 @@ let command = ============================ -Creates an EZFIO directory from a standard xyz file. The basis set is defined -as a single string if all the atoms are taken from the same basis set, -otherwise specific elements can be defined as follows: +Creates an EZFIO directory from a standard xyz file or from a z-matrix file +in Gaussian format. The basis set is defined as a single string if all the +atoms are taken from the same basis set, otherwise specific elements can be +defined as follows: -b \"cc-pcvdz | H:cc-pvdz | C:6-31g\" diff --git a/ocaml/qp_create_guess.ml b/ocaml/qp_create_guess.ml new file mode 100644 index 00000000..62af57de --- /dev/null +++ b/ocaml/qp_create_guess.ml @@ -0,0 +1,141 @@ +open Qputils +open Qptypes +open Core.Std + +let run ~multiplicity ezfio_file = + if (not (Sys.file_exists_exn ezfio_file)) then + failwith ("EZFIO directory "^ezfio_file^" not found"); + Ezfio.set_file ezfio_file; + let d = + Input.Determinants_by_hand.read () + in + let m = + Multiplicity.of_int multiplicity + in + let ne = + Ezfio.get_electrons_elec_alpha_num () + + Ezfio.get_electrons_elec_beta_num () + |> Elec_number.of_int + in + let alpha, beta = + let (a,b) = + Multiplicity.to_alpha_beta ne m + in + (Elec_alpha_number.to_int a, Elec_beta_number.to_int b) + in + let n_open_shells = + alpha - beta + in + let mo_tot_num = + Ezfio.get_mo_basis_mo_tot_num () + in + let build_list_of_dets ne n_closed n_open = + let init = + Array.create ~len:n_closed Bit.One + |> Array.to_list + in + let rec set_electron accu = function + | 1 -> [ Bit.One :: accu ] + | i -> + assert (i>1); + let rest = + set_electron (Bit.Zero :: accu) (i-1) + in + (Bit.One::accu) :: rest + in + let rec extend accu = function + | 0 -> List.rev accu + | i -> extend (Bit.Zero::accu) (i-1) + in + let rec set_n_electrons accu imax = function + | 0 -> [] + | 1 -> set_electron accu imax + | i -> + assert (i>1); + let l = + set_electron accu (imax-1) + in + List.map ~f:(fun x -> set_n_electrons x (imax-1) (i-1)) l + |> List.concat + in + set_n_electrons init n_open ne + |> List.filter ~f:(fun x -> List.length x <= n_closed+n_open) + |> List.map ~f:(fun x -> extend x (((mo_tot_num-1)/64+1)*64 - List.length x)) + in + + let alpha_new = + (Elec_number.to_int ne + 1)/2 + and beta_new = + Elec_number.to_int ne/2 + in + let l_alpha = + build_list_of_dets ((alpha-beta+1)/2) beta n_open_shells + in + let l_beta = + if alpha_new = beta_new then + l_alpha + else + build_list_of_dets ((alpha-beta)/2)beta n_open_shells + in + + let n_int = + Bitlist.n_int_of_mo_tot_num mo_tot_num + in + let determinants = + List.map l_alpha ~f:(fun x -> List.map l_beta ~f:(fun y -> (x,y) )) + |> List.concat + |> List.map ~f:(fun pair -> Determinant.of_bitlist_couple ~n_int + ~alpha:(Elec_alpha_number.of_int alpha_new) + ~beta:(Elec_beta_number.of_int beta_new) pair ) + in + let c = + Array.create ~len:(List.length determinants) (Det_coef.of_float 1.) + in + + determinants + |> List.map ~f:(fun x -> Determinant.to_string ~mo_tot_num:(MO_number.of_int mo_tot_num) x) + |> List.iter ~f:(fun x -> Printf.printf "%s\n\n%!" x); + + let l = + List.length determinants + in + if l > 0 then + begin + let d = + let s = (Float.of_int (alpha - beta)) *. 0.5 in + let open Input.Determinants_by_hand in + { d with n_int ; + n_det = Det_number.of_int ~min:1 ~max:l l; + expected_s2 = Positive_float.of_float (s *. (s +. 1.)) ; + psi_coef = c; + psi_det = Array.of_list determinants; + } + in + Input.Determinants_by_hand.write d; + Ezfio.set_determinants_read_wf true + end + else + Ezfio.set_determinants_read_wf false + + + +let spec = + let open Command.Spec in + empty + +> flag "m" (required int) + ~doc:"int Spin multiplicity" + +> anon ("ezfio_file" %: string) + +let () = + Command.basic + ~summary: "Quantum Package command" + ~readme:( fun () -> " +Creates an open-shell multiplet initial guess\n\n" ) + spec + (fun multiplicity ezfio_file () -> + run ~multiplicity ezfio_file + ) + |> Command.run ~version: Git.sha1 ~build_info: Git.message + + + diff --git a/ocaml/qp_overlap_of_wf.ml b/ocaml/qp_overlap_of_wf.ml new file mode 100644 index 00000000..816256fa --- /dev/null +++ b/ocaml/qp_overlap_of_wf.ml @@ -0,0 +1,66 @@ +open Input_determinants_by_hand +open Qptypes + +let () = + let ezfio, ezfio' = + try + Sys.argv.(1), Sys.argv.(2) + with Invalid_argument _ -> + raise (Invalid_argument (Printf.sprintf + "Syntax : %s EZFIO1 EZFIO2" Sys.argv.(0))) + in + + let fetch_wf filename = + Ezfio.set_file filename; + let mo_tot_num = + Ezfio.get_mo_basis_mo_tot_num () + |> MO_number.of_int + in + let d = + Determinants_by_hand.read () + in + let n_det = + Det_number.to_int d.Determinants_by_hand.n_det + in + let keys = + Array.map (Determinant.to_string ~mo_tot_num) + d.Determinants_by_hand.psi_det + and values = + Array.map Det_coef.to_float + d.Determinants_by_hand.psi_coef + in + let hash = + Hashtbl.create n_det + in + for i=0 to n_det-1 + do + Hashtbl.add hash keys.(i) values.(i); + done; + hash + in + + let overlap wf wf' = + let result, norm, norm' = + Hashtbl.fold (fun k c (accu,norm,norm') -> + let c' = + try Hashtbl.find wf' k + with Not_found -> 0. + in + (accu +. c *. c' , + norm +. c *. c , + norm'+. c'*. c' ) + ) wf (0.,0.,0.) + in + result /. (norm *. norm') + in + + let wf, wf' = + fetch_wf ezfio, + fetch_wf ezfio' + in + + let o = + overlap wf wf' + in + print_float (abs_float o) + diff --git a/ocaml/qp_run.ml b/ocaml/qp_run.ml index 1d44f35f..e8c8d05a 100644 --- a/ocaml/qp_run.ml +++ b/ocaml/qp_run.ml @@ -15,7 +15,7 @@ let print_list () = let () = Random.self_init () -let run ~master exe ezfio_file = +let run slave exe ezfio_file = (** Check availability of the ports *) @@ -28,7 +28,7 @@ let run ~master exe ezfio_file = in let rec try_new_port port_number = try - List.iter [ 0;1;2;3;4 ] ~f:(fun i -> + List.iter [ 0;1;2;3;4;5;6;7;8;9 ] ~f:(fun i -> let address = Printf.sprintf "tcp://%s:%d" (Lazy.force TaskServer.ip_address) (port_number+i) in @@ -43,6 +43,7 @@ let run ~master exe ezfio_file = try_new_port 41279 in ZMQ.Socket.close dummy_socket; + ZMQ.Context.terminate zmq_context; result in let time_start = @@ -74,16 +75,23 @@ let run ~master exe ezfio_file = | 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 address = - Printf.sprintf "tcp://%s:%d" (Lazy.force TaskServer.ip_address) port_number + let qp_run_address_filename = + Filename.concat (Qpackage.ezfio_work ezfio_file) "qp_run_address" in + + let () = + if slave then + try + let address = + In_channel.read_all qp_run_address_filename + |> String.strip + in + Unix.putenv ~key:"QP_RUN_ADDRESS_MASTER" ~data:address + with Sys_error _ -> failwith "No master is not running" + in + + (** Start task server *) let task_thread = let thread = Thread.create ( fun () -> @@ -91,7 +99,16 @@ let run ~master exe ezfio_file = in thread (); in + let address = + Printf.sprintf "tcp://%s:%d" (Lazy.force TaskServer.ip_address) port_number + in Unix.putenv ~key:"QP_RUN_ADDRESS" ~data:address; + let () = + if (not slave) then + Out_channel.with_file qp_run_address_filename ~f:( + fun oc -> Out_channel.output_lines oc [address]) + in + (** Run executable *) let prefix = @@ -110,6 +127,8 @@ let run ~master exe ezfio_file = TaskServer.stop ~port:port_number; Thread.join task_thread; + if (not slave) then + Sys.remove qp_run_address_filename; let duration = Time.diff (Time.now()) time_start |> Core.Span.to_string in @@ -118,8 +137,8 @@ let run ~master exe ezfio_file = let spec = let open Command.Spec in empty - +> flag "master" (optional string) - ~doc:("address Address of the master process") + +> flag "slave" no_arg + ~doc:(" Needed for slave tasks") +> anon ("executable" %: string) +> anon ("ezfio_file" %: string) ;; @@ -137,8 +156,8 @@ Executes a Quantum Package binary file among these:\n\n" ) ) spec - (fun master exe ezfio_file () -> - run ~master exe ezfio_file + (fun slave exe ezfio_file () -> + run slave exe ezfio_file ) |> Command.run ~version: Git.sha1 ~build_info: Git.message diff --git a/ocaml/qp_set_mo_class.ml b/ocaml/qp_set_mo_class.ml index f5555c9c..aaf11422 100644 --- a/ocaml/qp_set_mo_class.ml +++ b/ocaml/qp_set_mo_class.ml @@ -49,20 +49,20 @@ let t_to_string = function | None -> assert false ;; -let run ?(core="[]") ?(inact="[]") ?(act="[]") ?(virt="[]") ?(del="[]") ezfio_filename = +let set ~core ~inact ~act ~virt ~del = - Ezfio.set_file ezfio_filename ; - if not (Ezfio.has_mo_basis_mo_tot_num ()) then - failwith "mo_basis/mo_tot_num not found" ; - - let mo_tot_num = Ezfio.get_mo_basis_mo_tot_num () in + let mo_tot_num = + Ezfio.get_mo_basis_mo_tot_num () + in let n_int = try N_int_number.of_int (Ezfio.get_determinants_n_int ()) with _ -> Bitlist.n_int_of_mo_tot_num mo_tot_num in - let mo_class = Array.init mo_tot_num ~f:(fun i -> None) in + let mo_class = + Array.init mo_tot_num ~f:(fun i -> None) + in (* Check input data *) let apply_class l = @@ -196,6 +196,49 @@ let run ?(core="[]") ?(inact="[]") ?(act="[]") ?(virt="[]") ?(del="[]") ezfio_fi |> Ezfio.set_bitmasks_cas; ;; +let get () = + + let mo_tot_num = + Ezfio.get_mo_basis_mo_tot_num () + in + let n_int = + try N_int_number.of_int (Ezfio.get_determinants_n_int ()) + with _ -> Bitlist.n_int_of_mo_tot_num mo_tot_num + in + + let bitmasks = + match Input.Bitmasks.read () with + | Some x -> x + | None -> failwith "No data to print" + in + assert (bitmasks.Input.Bitmasks.n_mask_gen |> Bitmask_number.to_int = 1); + assert (bitmasks.Input.Bitmasks.n_mask_cas |> Bitmask_number.to_int = 1); + + let (generators,cas) = + Bitlist.of_int64_array bitmasks.Input.Bitmasks.generators, + Bitlist.of_int64_array bitmasks.Input.Bitmasks.cas + in + + Printf.printf "MO : %d\n" mo_tot_num; + Printf.printf "n_int: %d\n" (N_int_number.to_int n_int); + Printf.printf "Gen : %s\nCAS : %s\n" + (Bitlist.to_string generators) + (Bitlist.to_string cas) + +;; + +let run ~print ?(core="[]") ?(inact="[]") ?(act="[]") ?(virt="[]") ?(del="[]") ezfio_filename = + + Ezfio.set_file ezfio_filename ; + if not (Ezfio.has_mo_basis_mo_tot_num ()) then + failwith "mo_basis/mo_tot_num not found" ; + + if print then + get () + else + set ~core ~inact ~act ~virt ~del +;; + let ezfio_file = let failure filename = eprintf "'%s' is not an EZFIO file.\n%!" filename; @@ -240,6 +283,7 @@ let spec = +> flag "act" (optional string) ~doc:"range Range of active orbitals" +> flag "virt" (optional string) ~doc:"range Range of virtual orbitals" +> flag "del" (optional string) ~doc:"range Range of deleted orbitals" + +> flag "print" no_arg ~doc:" Print the current masks" +> anon ("ezfio_filename" %: ezfio_file) ;; @@ -251,7 +295,7 @@ let command = The range of MOs has the form : \"[36-53,72-107,126-131]\" ") spec - (fun core inact act virt del ezfio_filename () -> run ?core ?inact ?act ?virt ?del ezfio_filename ) + (fun core inact act virt del print ezfio_filename () -> run ~print ?core ?inact ?act ?virt ?del ezfio_filename ) ;; let () = diff --git a/ocaml/qptypes_generator.ml b/ocaml/qptypes_generator.ml index d04d6629..ee988ccb 100644 --- a/ocaml/qptypes_generator.ml +++ b/ocaml/qptypes_generator.ml @@ -47,12 +47,8 @@ let input_data = " * States_number : int assert (x > 0) ; - if (x > 100) then - warning \"More than 100 states\"; - if (Ezfio.has_determinants_n_states_diag ()) then - assert (x <= (Ezfio.get_determinants_n_states_diag ())) - else if (Ezfio.has_determinants_n_states ()) then - assert (x <= (Ezfio.get_determinants_n_states ())); + if (x > 1000) then + warning \"More than 1000 states\"; * Bit_kind_size : int begin match x with diff --git a/plugins/All_singles/NEEDED_CHILDREN_MODULES b/plugins/All_singles/NEEDED_CHILDREN_MODULES index bb97ddb9..ee0ff040 100644 --- a/plugins/All_singles/NEEDED_CHILDREN_MODULES +++ b/plugins/All_singles/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Generators_restart Perturbation Properties Selectors_no_sorted Utils +Generators_restart Perturbation Properties Selectors_no_sorted Utils Davidson diff --git a/plugins/All_singles/README.rst b/plugins/All_singles/README.rst index b4b3f517..d3888edc 100644 --- a/plugins/All_singles/README.rst +++ b/plugins/All_singles/README.rst @@ -6,7 +6,77 @@ Needed Modules ============== .. Do not edit this section It was auto-generated .. by the `update_README.py` script. + + +.. image:: tree_dependency.png + +* `Generators_restart `_ +* `Perturbation `_ +* `Properties `_ +* `Selectors_no_sorted `_ +* `Utils `_ + Documentation ============= .. Do not edit this section It was auto-generated .. by the `update_README.py` script. + + +h_apply_just_1h_1p + 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. + + +h_apply_just_1h_1p_diexc + Undocumented + + +h_apply_just_1h_1p_diexcorg + Generate all double excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_just_1h_1p_diexcp + Undocumented + + +h_apply_just_1h_1p_monoexc + Generate all single excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_just_mono + 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. + + +h_apply_just_mono_diexc + Undocumented + + +h_apply_just_mono_diexcorg + Generate all double excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_just_mono_diexcp + Undocumented + + +h_apply_just_mono_monoexc + Generate all single excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +`restart_more_singles `_ + Generates and select single excitations + on the top of a given restart wave function + + +`routine `_ + Undocumented + diff --git a/plugins/CAS_SD/.gitignore b/plugins/CAS_SD/.gitignore index b8827b3b..380d6cbf 100644 --- a/plugins/CAS_SD/.gitignore +++ b/plugins/CAS_SD/.gitignore @@ -22,6 +22,9 @@ Properties Pseudo Selectors_full Utils +ZMQ +cas_s +cas_s_selected cas_sd cas_sd_selected ezfio_interface.irp.f diff --git a/plugins/CAS_SD/H_apply.irp.f b/plugins/CAS_SD/H_apply.irp.f index 35c45fb6..f1d0c66b 100644 --- a/plugins/CAS_SD/H_apply.irp.f +++ b/plugins/CAS_SD/H_apply.irp.f @@ -3,6 +3,7 @@ BEGIN_SHELL [ /usr/bin/env python ] from generate_h_apply import * s = H_apply("CAS_SD") +s.unset_skip() print s s = H_apply("CAS_SD_selected_no_skip") @@ -12,6 +13,7 @@ print s s = H_apply("CAS_SD_selected") s.set_selection_pt2("epstein_nesbet_2x2") +s.unset_skip() print s s = H_apply("CAS_SD_PT2") @@ -22,13 +24,9 @@ print s s = H_apply("CAS_S",do_double_exc=False) print s -s = H_apply("CAS_S_selected_no_skip",do_double_exc=False) -s.set_selection_pt2("epstein_nesbet_2x2") -s.unset_skip() -print s - s = H_apply("CAS_S_selected",do_double_exc=False) s.set_selection_pt2("epstein_nesbet_2x2") +s.unset_skip() print s s = H_apply("CAS_S_PT2",do_double_exc=False) diff --git a/plugins/CAS_SD/NEEDED_CHILDREN_MODULES b/plugins/CAS_SD/NEEDED_CHILDREN_MODULES index f7264a0f..0b7ce8a9 100644 --- a/plugins/CAS_SD/NEEDED_CHILDREN_MODULES +++ b/plugins/CAS_SD/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Selectors_full Generators_CAS +Perturbation Selectors_full Generators_CAS Davidson diff --git a/plugins/CAS_SD/README.rst b/plugins/CAS_SD/README.rst index f2d76615..11f5d4cc 100644 --- a/plugins/CAS_SD/README.rst +++ b/plugins/CAS_SD/README.rst @@ -118,6 +118,106 @@ Documentation Undocumented +h_apply_cas_s + 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. + + +h_apply_cas_s_diexc + Undocumented + + +h_apply_cas_s_diexcorg + Generate all double excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_cas_s_diexcp + Undocumented + + +h_apply_cas_s_monoexc + Generate all single excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_cas_s_pt2 + 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. + + +h_apply_cas_s_pt2_diexc + Undocumented + + +h_apply_cas_s_pt2_diexcorg + Generate all double excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_cas_s_pt2_diexcp + Undocumented + + +h_apply_cas_s_pt2_monoexc + Generate all single excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_cas_s_selected + 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. + + +h_apply_cas_s_selected_diexc + Undocumented + + +h_apply_cas_s_selected_diexcorg + Generate all double excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_cas_s_selected_diexcp + Undocumented + + +h_apply_cas_s_selected_monoexc + Generate all single excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_cas_s_selected_no_skip + 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. + + +h_apply_cas_s_selected_no_skip_diexc + Undocumented + + +h_apply_cas_s_selected_no_skip_diexcorg + Generate all double excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_cas_s_selected_no_skip_diexcp + Undocumented + + +h_apply_cas_s_selected_no_skip_monoexc + Generate all single excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + h_apply_cas_sd 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. diff --git a/plugins/CAS_SD/cas_s_selected.irp.f b/plugins/CAS_SD/cas_s_selected.irp.f index 802de171..7c77b529 100644 --- a/plugins/CAS_SD/cas_s_selected.irp.f +++ b/plugins/CAS_SD/cas_s_selected.irp.f @@ -12,6 +12,7 @@ program full_ci pt2 = 1.d0 diag_algorithm = "Lapack" + if (N_det > N_det_max) then call diagonalize_CI call save_wavefunction @@ -28,49 +29,84 @@ program full_ci print *, 'E+PT2 = ', CI_energy+pt2 print *, '-----' endif + double precision :: i_H_psi_array(N_states),diag_H_mat_elem,h,i_O1_psi_array(N_states) + double precision :: E_CI_before(N_states) + if(read_wf)then + call i_H_psi(psi_det(1,1,N_det),psi_det,psi_coef,N_int,N_det,psi_det_size,N_states,i_H_psi_array) + h = diag_H_mat_elem(psi_det(1,1,N_det),N_int) + selection_criterion = dabs(psi_coef(N_det,1) * (i_H_psi_array(1) - h * psi_coef(N_det,1))) * 0.1d0 + soft_touch selection_criterion + endif + + integer :: n_det_before + print*,'Beginning the selection ...' + E_CI_before(1:N_states) = CI_energy(1:N_states) do while (N_det < N_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max) - call H_apply_CAS_S_selected_no_skip(pt2, norm_pert, H_pert_diag, N_st) + n_det_before = N_det + call H_apply_CAS_SD_selected(pt2, norm_pert, H_pert_diag, N_st) PROVIDE psi_coef PROVIDE psi_det PROVIDE psi_det_sorted - if (N_det > N_det_max) then - psi_det = psi_det_sorted - psi_coef = psi_coef_sorted - N_det = N_det_max - soft_touch N_det psi_det psi_coef - endif call diagonalize_CI + + if (N_det > N_det_max) then + N_det = N_det_max + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + touch N_det psi_det psi_coef psi_det_sorted psi_coef_sorted psi_average_norm_contrib_sorted + endif + + call save_wavefunction - print *, 'N_det = ', N_det - print *, 'N_states = ', N_states - print *, 'PT2 = ', pt2 - print *, 'E = ', CI_energy - print *, 'E+PT2 = ', CI_energy+pt2 + if(n_det_before == N_det)then + selection_criterion = selection_criterion * 0.5d0 + endif + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + 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 *, '-----' + 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(1:N_states) = CI_energy(1:N_states) call ezfio_set_cas_sd_energy(CI_energy(1)) enddo - call diagonalize_CI - + N_det = min(N_det_max,N_det) + touch N_det psi_det psi_coef + call diagonalize_CI if(do_pt2_end)then print*,'Last iteration only to compute the PT2' threshold_selectors = 1.d0 threshold_generators = 0.999d0 - call H_apply_CAS_S_PT2(pt2, norm_pert, H_pert_diag, N_st) + call H_apply_CAS_SD_PT2(pt2, norm_pert, H_pert_diag, N_st) print *, 'Final step' print *, 'N_det = ', N_det print *, 'N_states = ', N_states print *, 'PT2 = ', pt2 - print *, 'E = ', CI_energy - print *, 'E+PT2 = ', CI_energy+pt2 + print *, 'E = ', CI_energy(1:N_states) + print *, 'E+PT2 = ', CI_energy(1:N_states)+pt2(1:N_states) print *, '-----' call ezfio_set_cas_sd_energy_pt2(CI_energy(1)+pt2(1)) endif - integer :: exc_max, degree_min exc_max = 0 print *, 'CAS determinants : ', N_det_cas @@ -79,6 +115,7 @@ program full_ci call get_excitation_degree(psi_cas(1,1,k),psi_cas(1,1,i),degree,N_int) exc_max = max(exc_max,degree) enddo + print *, psi_coef_cas_diagonalized(i,:) call debug_det(psi_cas(1,1,i),N_int) print *, '' enddo diff --git a/plugins/CAS_SD/cas_sd.irp.f b/plugins/CAS_SD/cas_sd.irp.f index a5fc39b2..e2e8cb1f 100644 --- a/plugins/CAS_SD/cas_sd.irp.f +++ b/plugins/CAS_SD/cas_sd.irp.f @@ -1,7 +1,6 @@ program full_ci implicit none integer :: i,k - integer :: N_det_old double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:) @@ -11,9 +10,9 @@ program full_ci character*(64) :: perturbation PROVIDE N_det_cas - N_det_old = 0 pt2 = 1.d0 diag_algorithm = "Lapack" + if (N_det > N_det_max) then call diagonalize_CI call save_wavefunction @@ -30,36 +29,68 @@ program full_ci print *, 'E+PT2 = ', CI_energy+pt2 print *, '-----' endif + double precision :: i_H_psi_array(N_states),diag_H_mat_elem,h,i_O1_psi_array(N_states) + double precision :: E_CI_before(N_states) + if(read_wf)then + call i_H_psi(psi_det(1,1,N_det),psi_det,psi_coef,N_int,N_det,psi_det_size,N_states,i_H_psi_array) + h = diag_H_mat_elem(psi_det(1,1,N_det),N_int) + selection_criterion = dabs(psi_coef(N_det,1) * (i_H_psi_array(1) - h * psi_coef(N_det,1))) * 0.1d0 + soft_touch selection_criterion + endif + + integer :: n_det_before + print*,'Beginning the selection ...' + E_CI_before(1:N_states) = CI_energy(1:N_states) do while (N_det < N_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max) - N_det_old = N_det + n_det_before = N_det call H_apply_CAS_SD(pt2, norm_pert, H_pert_diag, N_st) PROVIDE psi_coef PROVIDE psi_det PROVIDE psi_det_sorted - if (N_det > N_det_max) then - psi_det = psi_det_sorted - psi_coef = psi_coef_sorted - N_det = N_det_max - soft_touch N_det psi_det psi_coef - endif call diagonalize_CI - call save_wavefunction - print *, 'N_det = ', N_det - print *, 'N_states = ', N_states - print *, 'PT2 = ', pt2 - print *, 'E = ', CI_energy - print *, 'E+PT2 = ', CI_energy+pt2 - print *, '-----' - call ezfio_set_cas_sd_energy(CI_energy(1)) - if (N_det == N_det_old) then - exit - endif - enddo - call diagonalize_CI + if (N_det > N_det_max) then + N_det = N_det_max + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + touch N_det psi_det psi_coef psi_det_sorted psi_coef_sorted psi_average_norm_contrib_sorted + endif + + + call save_wavefunction + if(n_det_before == N_det)then + selection_criterion = selection_criterion * 0.5d0 + endif + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + 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 *, '-----' + 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(1:N_states) = CI_energy(1:N_states) + call ezfio_set_cas_sd_energy(CI_energy(1)) + enddo + N_det = min(N_det_max,N_det) + touch N_det psi_det psi_coef + call diagonalize_CI if(do_pt2_end)then print*,'Last iteration only to compute the PT2' threshold_selectors = 1.d0 @@ -70,13 +101,12 @@ program full_ci print *, 'N_det = ', N_det print *, 'N_states = ', N_states print *, 'PT2 = ', pt2 - print *, 'E = ', CI_energy - print *, 'E+PT2 = ', CI_energy+pt2 + print *, 'E = ', CI_energy(1:N_states) + print *, 'E+PT2 = ', CI_energy(1:N_states)+pt2(1:N_states) print *, '-----' call ezfio_set_cas_sd_energy_pt2(CI_energy(1)+pt2(1)) endif - integer :: exc_max, degree_min exc_max = 0 print *, 'CAS determinants : ', N_det_cas @@ -85,6 +115,7 @@ program full_ci call get_excitation_degree(psi_cas(1,1,k),psi_cas(1,1,i),degree,N_int) exc_max = max(exc_max,degree) enddo + print *, psi_coef_cas_diagonalized(i,:) call debug_det(psi_cas(1,1,i),N_int) print *, '' enddo diff --git a/plugins/CAS_SD/cas_sd_selected.irp.f b/plugins/CAS_SD/cas_sd_selected.irp.f index caed690c..d12e8430 100644 --- a/plugins/CAS_SD/cas_sd_selected.irp.f +++ b/plugins/CAS_SD/cas_sd_selected.irp.f @@ -12,6 +12,7 @@ program full_ci pt2 = 1.d0 diag_algorithm = "Lapack" + if (N_det > N_det_max) then call diagonalize_CI call save_wavefunction @@ -28,32 +29,68 @@ program full_ci print *, 'E+PT2 = ', CI_energy+pt2 print *, '-----' endif + double precision :: i_H_psi_array(N_states),diag_H_mat_elem,h,i_O1_psi_array(N_states) + double precision :: E_CI_before(N_states) + if(read_wf)then + call i_H_psi(psi_det(1,1,N_det),psi_det,psi_coef,N_int,N_det,psi_det_size,N_states,i_H_psi_array) + h = diag_H_mat_elem(psi_det(1,1,N_det),N_int) + selection_criterion = dabs(psi_coef(N_det,1) * (i_H_psi_array(1) - h * psi_coef(N_det,1))) * 0.1d0 + soft_touch selection_criterion + endif + + integer :: n_det_before + print*,'Beginning the selection ...' + E_CI_before(1:N_states) = CI_energy(1:N_states) do while (N_det < N_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max) + n_det_before = N_det call H_apply_CAS_SD_selected(pt2, norm_pert, H_pert_diag, N_st) PROVIDE psi_coef PROVIDE psi_det PROVIDE psi_det_sorted - if (N_det > N_det_max) then - psi_det = psi_det_sorted - psi_coef = psi_coef_sorted - N_det = N_det_max - soft_touch N_det psi_det psi_coef - endif call diagonalize_CI + + if (N_det > N_det_max) then + N_det = N_det_max + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + touch N_det psi_det psi_coef psi_det_sorted psi_coef_sorted psi_average_norm_contrib_sorted + endif + + call save_wavefunction - print *, 'N_det = ', N_det - print *, 'N_states = ', N_states - print *, 'PT2 = ', pt2 - print *, 'E = ', CI_energy - print *, 'E+PT2 = ', CI_energy+pt2 + if(n_det_before == N_det)then + selection_criterion = selection_criterion * 0.5d0 + endif + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + 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 *, '-----' + 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(1:N_states) = CI_energy(1:N_states) call ezfio_set_cas_sd_energy(CI_energy(1)) enddo - call diagonalize_CI - + N_det = min(N_det_max,N_det) + touch N_det psi_det psi_coef + call diagonalize_CI if(do_pt2_end)then print*,'Last iteration only to compute the PT2' threshold_selectors = 1.d0 @@ -64,13 +101,12 @@ program full_ci print *, 'N_det = ', N_det print *, 'N_states = ', N_states print *, 'PT2 = ', pt2 - print *, 'E = ', CI_energy - print *, 'E+PT2 = ', CI_energy+pt2 + print *, 'E = ', CI_energy(1:N_states) + print *, 'E+PT2 = ', CI_energy(1:N_states)+pt2(1:N_states) print *, '-----' call ezfio_set_cas_sd_energy_pt2(CI_energy(1)+pt2(1)) endif - integer :: exc_max, degree_min exc_max = 0 print *, 'CAS determinants : ', N_det_cas @@ -79,6 +115,7 @@ program full_ci call get_excitation_degree(psi_cas(1,1,k),psi_cas(1,1,i),degree,N_int) exc_max = max(exc_max,degree) enddo + print *, psi_cas_coef(i,:) call debug_det(psi_cas(1,1,i),N_int) print *, '' enddo diff --git a/plugins/CAS_SD/tree_dependency.png b/plugins/CAS_SD/tree_dependency.png index 185c2b27..e53499c9 100644 Binary files a/plugins/CAS_SD/tree_dependency.png and b/plugins/CAS_SD/tree_dependency.png differ diff --git a/plugins/CID/NEEDED_CHILDREN_MODULES b/plugins/CID/NEEDED_CHILDREN_MODULES index afc8cfd4..1632a44d 100644 --- a/plugins/CID/NEEDED_CHILDREN_MODULES +++ b/plugins/CID/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Selectors_full SingleRefMethod +Selectors_full SingleRefMethod Davidson diff --git a/plugins/CIS/NEEDED_CHILDREN_MODULES b/plugins/CIS/NEEDED_CHILDREN_MODULES index afc8cfd4..1632a44d 100644 --- a/plugins/CIS/NEEDED_CHILDREN_MODULES +++ b/plugins/CIS/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Selectors_full SingleRefMethod +Selectors_full SingleRefMethod Davidson diff --git a/plugins/CISD/NEEDED_CHILDREN_MODULES b/plugins/CISD/NEEDED_CHILDREN_MODULES index afc8cfd4..1632a44d 100644 --- a/plugins/CISD/NEEDED_CHILDREN_MODULES +++ b/plugins/CISD/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Selectors_full SingleRefMethod +Selectors_full SingleRefMethod Davidson diff --git a/plugins/Casino/NEEDED_CHILDREN_MODULES b/plugins/Casino/NEEDED_CHILDREN_MODULES index aae89501..34de8ddb 100644 --- a/plugins/Casino/NEEDED_CHILDREN_MODULES +++ b/plugins/Casino/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Determinants +Determinants Davidson diff --git a/plugins/DDCI_selected/NEEDED_CHILDREN_MODULES b/plugins/DDCI_selected/NEEDED_CHILDREN_MODULES index f7264a0f..0b7ce8a9 100644 --- a/plugins/DDCI_selected/NEEDED_CHILDREN_MODULES +++ b/plugins/DDCI_selected/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Selectors_full Generators_CAS +Perturbation Selectors_full Generators_CAS Davidson diff --git a/plugins/FCIdump/NEEDED_CHILDREN_MODULES b/plugins/FCIdump/NEEDED_CHILDREN_MODULES index aae89501..34de8ddb 100644 --- a/plugins/FCIdump/NEEDED_CHILDREN_MODULES +++ b/plugins/FCIdump/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Determinants +Determinants Davidson diff --git a/plugins/FOBOCI/H_apply_dressed_autonom.irp.f b/plugins/FOBOCI/H_apply_dressed_autonom.irp.f index 9d076dc1..abe6ef2e 100644 --- a/plugins/FOBOCI/H_apply_dressed_autonom.irp.f +++ b/plugins/FOBOCI/H_apply_dressed_autonom.irp.f @@ -273,7 +273,8 @@ subroutine H_apply_dressed_pert_monoexc(key_in, hole_1,particl_1,i_generator,ipr integer,parameter :: size_max = 3072 integer, intent(in) :: Ndet_generators - double precision, intent(in) :: delta_ij_generators_(Ndet_generators,Ndet_generators),E_ref + double precision, intent(inout) :: E_ref + double precision, intent(inout) :: delta_ij_generators_(Ndet_generators,Ndet_generators) integer(bit_kind), intent(in) :: psi_det_generators_input(N_int,2,Ndet_generators) integer ,intent(in) :: i_generator @@ -437,8 +438,9 @@ subroutine H_apply_dressed_pert(delta_ij_generators_, Ndet_generators,psi_det_g integer, intent(in) :: Ndet_generators + double precision, intent(inout) :: E_ref + double precision, intent(inout) :: delta_ij_generators_(Ndet_generators,Ndet_generators) integer(bit_kind), intent(in) :: psi_det_generators_input(N_int,2,Ndet_generators) - double precision, intent(in) :: delta_ij_generators_(Ndet_generators,Ndet_generators),E_ref integer :: i_generator, nmax diff --git a/plugins/FOBOCI/NEEDED_CHILDREN_MODULES b/plugins/FOBOCI/NEEDED_CHILDREN_MODULES index f6c0c1c4..16fce081 100644 --- a/plugins/FOBOCI/NEEDED_CHILDREN_MODULES +++ b/plugins/FOBOCI/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Selectors_no_sorted Hartree_Fock +Perturbation Selectors_no_sorted Hartree_Fock Davidson CISD diff --git a/plugins/FOBOCI/SC2_1h1p.irp.f b/plugins/FOBOCI/SC2_1h1p.irp.f index 6f6156f4..b9378575 100644 --- a/plugins/FOBOCI/SC2_1h1p.irp.f +++ b/plugins/FOBOCI/SC2_1h1p.irp.f @@ -40,7 +40,7 @@ subroutine dressing_1h1p(dets_in,u_in,diag_H_elements,dim_in,sze,N_st,Nint,conve double precision :: phase integer(bit_kind) :: key_tmp(N_int,2) integer :: i_ok - double precision :: phase_single_double,phase_double_hf,get_mo_bielec_integral_schwartz + double precision :: phase_single_double,phase_double_hf,get_mo_bielec_integral double precision :: hij,c_ref,contrib integer :: iorb @@ -231,7 +231,7 @@ subroutine dressing_1h1p_by_2h2p(dets_in,u_in,diag_H_elements,dim_in,sze,N_st,Ni double precision :: phase integer(bit_kind) :: key_tmp(N_int,2) integer :: i_ok - double precision :: phase_single_double,phase_double_hf,get_mo_bielec_integral_schwartz + double precision :: phase_single_double,phase_double_hf,get_mo_bielec_integral double precision :: hij,c_ref,contrib integer :: iorb @@ -409,7 +409,7 @@ subroutine dressing_1h1p_full(dets_in,u_in,H_matrix,dim_in,sze,N_st,Nint,converg double precision :: phase integer(bit_kind) :: key_tmp(N_int,2) integer :: i_ok - double precision :: phase_single_double,phase_double_hf,get_mo_bielec_integral_schwartz + double precision :: phase_single_double,phase_double_hf,get_mo_bielec_integral double precision :: hij,c_ref,contrib integer :: iorb @@ -603,6 +603,7 @@ subroutine SC2_1h1p_full(dets_in,u_in,energies,H_matrix,dim_in,sze,N_st,Nint,con double precision, intent(in) :: convergence integer :: i,j,iter print*,'sze = ',sze + H_matrix = 0.d0 do iter = 1, 1 ! if(sze<=N_det_max_jacobi)then double precision, allocatable :: eigenvectors(:,:), eigenvalues(:),H_matrix_tmp(:,:) @@ -662,6 +663,7 @@ subroutine SC2_1h1p(dets_in,u_in,energies,diag_H_elements,dim_in,sze,N_st,Nint,c double precision :: extra_diag_H_elements(dim_in) double precision, intent(in) :: convergence integer :: i,j,iter + DIAG_H_ELEMENTS = 0.d0 do iter = 1, 1 ! call dressing_1h1p(dets_in,u_in,diag_H_elements,dim_in,sze,N_st,Nint,convergence) call dressing_1h1p_by_2h2p(dets_in,u_in,extra_diag_H_elements,dim_in,sze,N_st,Nint,convergence) @@ -740,7 +742,7 @@ subroutine density_matrix_1h1p(dets_in,u_in,density_matrix_alpha,density_matrix_ double precision :: phase integer(bit_kind) :: key_tmp(N_int,2) integer :: i_ok - double precision :: phase_single_double,phase_double_hf,get_mo_bielec_integral_schwartz + double precision :: phase_single_double,phase_double_hf,get_mo_bielec_integral double precision :: hij,c_ref,contrib integer :: iorb diff --git a/plugins/FOBOCI/all_singles.irp.f b/plugins/FOBOCI/all_singles.irp.f index 2968ab90..65d81e07 100644 --- a/plugins/FOBOCI/all_singles.irp.f +++ b/plugins/FOBOCI/all_singles.irp.f @@ -30,7 +30,7 @@ subroutine all_single(e_pt2) print*,'N_det_generators = ',N_det_generators pt2=-1.d0 print*, 'ref_bitmask_energy =',ref_bitmask_energy - print*, 'CI_expectation_value =',CI_expectation_value(1) + print*, 'CI_expectation_value =',psi_energy(1) E_before = ref_bitmask_energy print*,'Initial Step ' diff --git a/plugins/FOBOCI/corr_energy_2h2p.irp.f b/plugins/FOBOCI/corr_energy_2h2p.irp.f index ada46bf2..40bfa5aa 100644 --- a/plugins/FOBOCI/corr_energy_2h2p.irp.f +++ b/plugins/FOBOCI/corr_energy_2h2p.irp.f @@ -15,7 +15,7 @@ integer(bit_kind) :: key_tmp(N_int,2) integer :: i,j,k,l integer :: i_hole,j_hole,k_part,l_part - double precision :: get_mo_bielec_integral_schwartz,hij,delta_e,exc,contrib + double precision :: get_mo_bielec_integral,hij,delta_e,exc,contrib double precision :: diag_H_mat_elem integer :: i_ok,ispin ! Alpha - Beta correlation energy @@ -46,7 +46,7 @@ if(i_ok .ne.1)cycle delta_e = (ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int)) - hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map) + hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map) contrib = hij*hij/delta_e total_corr_e_2h2p += contrib ! Single orbital contribution @@ -81,8 +81,8 @@ k_part = list_virt(k) do l = k+1,n_virt_orb l_part = list_virt(l) - hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map) - exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map) + hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map) + exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map) key_tmp = ref_bitmask ispin = 1 call do_mono_excitation(key_tmp,i_hole,k_part,ispin,i_ok) @@ -114,8 +114,8 @@ k_part = list_virt(k) do l = k+1,n_virt_orb l_part = list_virt(l) - hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map) - exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map) + hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map) + exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map) key_tmp = ref_bitmask ispin = 2 call do_mono_excitation(key_tmp,i_hole,k_part,ispin,i_ok) @@ -161,7 +161,7 @@ END_PROVIDER integer(bit_kind) :: key_tmp(N_int,2) integer :: i,j,k,l integer :: i_hole,j_hole,k_part,l_part - double precision :: get_mo_bielec_integral_schwartz,hij,delta_e,exc,contrib + double precision :: get_mo_bielec_integral,hij,delta_e,exc,contrib double precision :: diag_H_mat_elem integer :: i_ok,ispin ! Alpha - Beta correlation energy @@ -191,7 +191,7 @@ END_PROVIDER if(i_ok .ne.1)cycle delta_e = -(ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int)) - hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map) + hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map) contrib = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * hij*hij)) total_corr_e_2h1p += contrib corr_energy_2h1p_ab_bb_per_2_orb(i_hole,j_hole) += contrib @@ -211,8 +211,8 @@ END_PROVIDER k_part = list_act(k) do l = 1,n_virt_orb l_part = list_virt(l) - hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map) - exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map) + hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map) + exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map) key_tmp = ref_bitmask ispin = 1 call do_mono_excitation(key_tmp,i_hole,k_part,ispin,i_ok) @@ -241,8 +241,8 @@ END_PROVIDER k_part = list_act(k) do l = 1,n_virt_orb l_part = list_virt(l) - hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map) - exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map) + hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map) + exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map) key_tmp = ref_bitmask ispin = 2 call do_mono_excitation(key_tmp,i_hole,k_part,ispin,i_ok) @@ -276,7 +276,7 @@ END_PROVIDER integer(bit_kind) :: key_tmp(N_int,2) integer :: i,j,k,l integer :: i_hole,j_hole,k_part,l_part - double precision :: get_mo_bielec_integral_schwartz,hij,delta_e,exc,contrib + double precision :: get_mo_bielec_integral,hij,delta_e,exc,contrib double precision :: diag_H_mat_elem integer :: i_ok,ispin ! Alpha - Beta correlation energy @@ -302,7 +302,7 @@ END_PROVIDER if(i_ok .ne.1)cycle delta_e = -(ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int)) - hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map) + hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map) contrib = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * hij*hij)) total_corr_e_1h2p += contrib @@ -324,8 +324,8 @@ END_PROVIDER k_part = list_act(k) do l = i+1,n_virt_orb l_part = list_virt(l) - hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map) - exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map) + hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map) + exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map) key_tmp = ref_bitmask ispin = 1 @@ -356,8 +356,8 @@ END_PROVIDER k_part = list_act(k) do l = i+1,n_virt_orb l_part = list_virt(l) - hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map) - exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map) + hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map) + exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map) key_tmp = ref_bitmask ispin = 2 @@ -388,7 +388,7 @@ END_PROVIDER integer(bit_kind) :: key_tmp(N_int,2) integer :: i,j,k,l integer :: i_hole,j_hole,k_part,l_part - double precision :: get_mo_bielec_integral_schwartz,hij,delta_e,exc,contrib + double precision :: get_mo_bielec_integral,hij,delta_e,exc,contrib double precision :: diag_H_mat_elem integer :: i_ok,ispin ! Alpha - Beta correlation energy @@ -412,7 +412,7 @@ END_PROVIDER if(i_ok .ne.1)cycle delta_e = -(ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int)) - hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map) + hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map) contrib = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * hij*hij)) total_corr_e_1h1p_spin_flip += contrib diff --git a/plugins/FOBOCI/diag_fock_inactiv_virt.irp.f b/plugins/FOBOCI/diag_fock_inactiv_virt.irp.f index 83955e61..40d75fc4 100644 --- a/plugins/FOBOCI/diag_fock_inactiv_virt.irp.f +++ b/plugins/FOBOCI/diag_fock_inactiv_virt.irp.f @@ -38,7 +38,7 @@ end subroutine diag_inactive_virt_new_and_update_mos implicit none integer :: i,j,i_inact,j_inact,i_virt,j_virt,k,k_act - double precision :: tmp(mo_tot_num_align,mo_tot_num),accu,get_mo_bielec_integral_schwartz + double precision :: tmp(mo_tot_num_align,mo_tot_num),accu,get_mo_bielec_integral character*(64) :: label tmp = 0.d0 do i = 1, mo_tot_num @@ -52,8 +52,8 @@ subroutine diag_inactive_virt_new_and_update_mos accu =0.d0 do k = 1, n_act_orb k_act = list_act(k) - accu += get_mo_bielec_integral_schwartz(i_inact,k_act,j_inact,k_act,mo_integrals_map) - accu -= get_mo_bielec_integral_schwartz(i_inact,k_act,k_act,j_inact,mo_integrals_map) + accu += get_mo_bielec_integral(i_inact,k_act,j_inact,k_act,mo_integrals_map) + accu -= get_mo_bielec_integral(i_inact,k_act,k_act,j_inact,mo_integrals_map) enddo tmp(i_inact,j_inact) = Fock_matrix_mo(i_inact,j_inact) + accu tmp(j_inact,i_inact) = Fock_matrix_mo(j_inact,i_inact) + accu @@ -67,7 +67,7 @@ subroutine diag_inactive_virt_new_and_update_mos accu =0.d0 do k = 1, n_act_orb k_act = list_act(k) - accu += get_mo_bielec_integral_schwartz(i_virt,k_act,j_virt,k_act,mo_integrals_map) + accu += get_mo_bielec_integral(i_virt,k_act,j_virt,k_act,mo_integrals_map) enddo tmp(i_virt,j_virt) = Fock_matrix_mo(i_virt,j_virt) - accu tmp(j_virt,i_virt) = Fock_matrix_mo(j_virt,i_virt) - accu diff --git a/plugins/FOBOCI/dress_simple.irp.f b/plugins/FOBOCI/dress_simple.irp.f index e6521c76..dd1ed221 100644 --- a/plugins/FOBOCI/dress_simple.irp.f +++ b/plugins/FOBOCI/dress_simple.irp.f @@ -212,16 +212,16 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener call lapack_diagd(eigvalues,eigvectors,dressed_H_matrix,Ndet_generators,Ndet_generators) ! Diagonalize the Dressed_H_matrix - double precision :: s2,E_ref(N_states) + double precision :: s2(N_det_generators),E_ref(N_states) integer :: i_state(N_states) integer :: n_state_good n_state_good = 0 if(s2_eig)then + call u_0_S2_u_0(s2,eigvectors,Ndet_generators,psi_det_generators_input,N_int,N_det_generators,size(eigvectors,1)) 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 + print*,'s2 = ',s2(i) + print*,dabs(s2(i)-expected_s2) + if(dabs(s2(i)-expected_s2).le.0.3d0)then n_state_good +=1 i_state(n_state_good) = i E_ref(n_state_good) = eigvalues(i) @@ -279,7 +279,6 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener 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 @@ -387,7 +386,7 @@ subroutine fill_H_apply_buffer_no_selection_first_order_coef(n_selected,det_buff call i_H_psi(det_buffer(1,1,i),psi_selectors,psi_selectors_coef,N_int,N_det_selectors,psi_selectors_size,N_states,i_H_psi_array) call i_H_j(det_buffer(1,1,i),det_buffer(1,1,i),N_int,h) do j=1,N_states - delta_e = -1.d0 /(h - CI_expectation_value(j)) + delta_e = -1.d0 /(h - psi_energy(j)) H_apply_buffer(iproc)%coef(i+H_apply_buffer(iproc)%N_det,j) = i_H_psi_array(j) * delta_e enddo enddo diff --git a/plugins/FOBOCI/hcc_1h1p.irp.f b/plugins/FOBOCI/hcc_1h1p.irp.f deleted file mode 100644 index ffad686f..00000000 --- a/plugins/FOBOCI/hcc_1h1p.irp.f +++ /dev/null @@ -1,83 +0,0 @@ -program test_sc2 - implicit none - read_wf = .True. - touch read_wf - call routine - - -end - -subroutine routine - implicit none - double precision, allocatable :: energies(:),diag_H_elements(:) - double precision, allocatable :: H_matrix(:,:) - allocate(energies(N_states),diag_H_elements(N_det)) - call diagonalize_CI - call test_hcc - call test_mulliken - call SC2_1h1p(psi_det,psi_coef,energies, & - diag_H_elements,size(psi_coef,1),N_det,N_states_diag,N_int,threshold_convergence_SC2) -! allocate(H_matrix(N_det,N_det)) -! call SC2_1h1p_full(psi_det,psi_coef,energies, & -! H_matrix,size(psi_coef,1),N_det,N_states_diag,N_int,threshold_convergence_SC2) -! deallocate(H_matrix) - integer :: i,j - double precision :: accu,coef_hf -! coef_hf = 1.d0/psi_coef(1,1) -! do i = 1, N_det -! psi_coef(i,1) *= coef_hf -! enddo - touch psi_coef - call pouet -end - -subroutine pouet - implicit none - double precision :: accu,coef_hf - provide one_body_dm_mo_alpha one_body_dm_mo_beta -! call density_matrix_1h1p(psi_det,psi_coef,one_body_dm_mo_alpha,one_body_dm_mo_beta,accu,size(psi_coef,1),N_det,N_states_diag,N_int) -! touch one_body_dm_mo_alpha one_body_dm_mo_beta - call test_hcc - call test_mulliken - call save_wavefunction - -end - -subroutine test_hcc - 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 - -subroutine test_mulliken - 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/FOBOCI/routines_foboci.irp.f b/plugins/FOBOCI/routines_foboci.irp.f index b3dfca52..7d194a54 100644 --- a/plugins/FOBOCI/routines_foboci.irp.f +++ b/plugins/FOBOCI/routines_foboci.irp.f @@ -841,7 +841,7 @@ end call dress_diag_elem_2h2p(dressing_H_mat_elem,N_det) call dress_diag_elem_2h1p(dressing_H_mat_elem,N_det,lmct,i_hole) call dress_diag_elem_1h2p(dressing_H_mat_elem,N_det,lmct,i_hole) - call davidson_diag_hjj(psi_det,psi_coef,dressing_H_mat_elem,energies,size(psi_coef,1),N_det,N_states_diag,N_int,output_determinants) + call davidson_diag_hjj(psi_det,psi_coef,dressing_H_mat_elem,energies,size(psi_coef,1),N_det,N_states,N_states_diag,N_int,output_determinants) do i = 1, 2 print*,'psi_coef = ',psi_coef(i,1) enddo diff --git a/plugins/Full_CI/.gitignore b/plugins/Full_CI/.gitignore index fe4ea27b..674f56da 100644 --- a/plugins/Full_CI/.gitignore +++ b/plugins/Full_CI/.gitignore @@ -28,6 +28,7 @@ full_ci full_ci_no_skip irpf90.make irpf90_entities +micro_pt2 tags target_pt2 var_pt2_ratio \ No newline at end of file diff --git a/plugins/Full_CI/H_apply.irp.f b/plugins/Full_CI/H_apply.irp.f index 921b9a1a..79599065 100644 --- a/plugins/Full_CI/H_apply.irp.f +++ b/plugins/Full_CI/H_apply.irp.f @@ -2,8 +2,13 @@ use bitmasks BEGIN_SHELL [ /usr/bin/env python ] from generate_h_apply import * -s = H_apply_zmq("FCI") +s = H_apply("FCI") s.set_selection_pt2("epstein_nesbet_2x2") +#s.unset_openmp() +print s + +s = H_apply("FCI_PT2") +s.set_perturbation("epstein_nesbet_2x2") s.unset_openmp() print s @@ -12,15 +17,16 @@ s.set_perturbation("decontracted") s.unset_openmp() print s -s = H_apply("FCI_PT2") -s.set_perturbation("epstein_nesbet_2x2") -s.unset_openmp() -print s -s = H_apply_zmq("FCI_no_skip") +s = H_apply("FCI_no_skip") s.set_selection_pt2("epstein_nesbet_2x2") s.unset_skip() -s.unset_openmp() +#s.unset_openmp() +print s + +s = H_apply("FCI_no_selection") +s.set_selection_pt2("dummy") +s.unset_skip() print s s = H_apply("FCI_mono") @@ -30,28 +36,6 @@ 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 - END_SHELL diff --git a/plugins/Full_CI/NEEDED_CHILDREN_MODULES b/plugins/Full_CI/NEEDED_CHILDREN_MODULES index 58203ca4..ad5f053f 100644 --- a/plugins/Full_CI/NEEDED_CHILDREN_MODULES +++ b/plugins/Full_CI/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Selectors_full Generators_full +Perturbation Selectors_full Generators_full Davidson diff --git a/plugins/Full_CI/README.rst b/plugins/Full_CI/README.rst index 08a0d1ea..750db44c 100644 --- a/plugins/Full_CI/README.rst +++ b/plugins/Full_CI/README.rst @@ -107,6 +107,10 @@ h_apply_fci_pt2 excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. +h_apply_fci_pt2_collector + Collects results from the selection in an array of generators + + h_apply_fci_pt2_diexc Undocumented @@ -127,6 +131,19 @@ h_apply_fci_pt2_monoexc Assume N_int is already provided. +h_apply_fci_pt2_slave + 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. + + +h_apply_fci_pt2_slave_inproc + Computes a buffer using threads + + +h_apply_fci_pt2_slave_tcp + Computes a buffer over the network + + h_apply_pt2_mono_delta_rho 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. @@ -227,6 +244,18 @@ h_apply_select_mono_di_delta_rho_monoexc Assume N_int is already provided. +`micro_pt2 `_ + Helper program to compute the PT2 in distributed mode. + + +`provide_everything `_ + Undocumented + + +`run_wf `_ + Undocumented + + `var_pt2_ratio_run `_ Undocumented diff --git a/plugins/Full_CI/full_ci.irp.f b/plugins/Full_CI/full_ci.irp.f index ff599870..a53064b4 100644 --- a/plugins/Full_CI/full_ci.irp.f +++ b/plugins/Full_CI/full_ci.irp.f @@ -11,7 +11,7 @@ program full_ci pt2 = 1.d0 diag_algorithm = "Lapack" - + if (N_det > N_det_max) then call diagonalize_CI call save_wavefunction @@ -40,7 +40,7 @@ program full_ci integer :: n_det_before print*,'Beginning the selection ...' - E_CI_before = CI_energy + E_CI_before(1:N_states) = CI_energy(1:N_states) do while (N_det < N_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max) n_det_before = N_det call H_apply_FCI(pt2, norm_pert, H_pert_diag, N_st) @@ -49,13 +49,16 @@ program full_ci PROVIDE psi_det PROVIDE psi_det_sorted - if (N_det > N_det_max) then - psi_det = psi_det_sorted - psi_coef = psi_coef_sorted - N_det = N_det_max - soft_touch N_det psi_det psi_coef - endif call diagonalize_CI + + if (N_det > N_det_max) then + N_det = N_det_max + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + touch N_det psi_det psi_coef psi_det_sorted psi_coef_sorted psi_average_norm_contrib_sorted + endif + + call save_wavefunction if(n_det_before == N_det)then selection_criterion = selection_criterion * 0.5d0 @@ -69,7 +72,6 @@ program full_ci print *, 'E(before)+PT2 = ', E_CI_before(k)+pt2(k) enddo print *, '-----' - E_CI_before = CI_energy if(N_states.gt.1)then print*,'Variational Energy difference' do i = 2, N_states @@ -82,8 +84,8 @@ program full_ci 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) + E_CI_before(1:N_states) = CI_energy(1:N_states) + call ezfio_set_full_ci_energy(CI_energy(1)) enddo N_det = min(N_det_max,N_det) touch N_det psi_det psi_coef @@ -99,10 +101,10 @@ program full_ci print *, 'N_det = ', N_det print *, 'N_states = ', N_states print *, 'PT2 = ', pt2 - print *, 'E = ', CI_energy - print *, 'E+PT2 = ', CI_energy+pt2 + print *, 'E = ', CI_energy(1:N_states) + print *, 'E+PT2 = ', CI_energy(1:N_states)+pt2(1:N_states) print *, '-----' - call ezfio_set_full_ci_energy_pt2(CI_energy+pt2) + call ezfio_set_full_ci_energy_pt2(CI_energy(1)+pt2(1)) endif call save_wavefunction deallocate(pt2,norm_pert) diff --git a/plugins/Full_CI/tree_dependency.png b/plugins/Full_CI/tree_dependency.png index caedb2e0..158a3945 100644 Binary files a/plugins/Full_CI/tree_dependency.png and b/plugins/Full_CI/tree_dependency.png differ diff --git a/plugins/Full_CI/var_pt2_ratio.irp.f b/plugins/Full_CI/var_pt2_ratio.irp.f index 3d942a30..1ea52dda 100644 --- a/plugins/Full_CI/var_pt2_ratio.irp.f +++ b/plugins/Full_CI/var_pt2_ratio.irp.f @@ -11,7 +11,7 @@ program var_pt2_ratio_run double precision, allocatable :: psi_det_save(:,:,:), psi_coef_save(:,:) - double precision :: E_fci, E_var, ratio, E_ref + double precision :: E_fci, E_var, ratio, E_ref, selection_criterion_save integer :: Nmin, Nmax pt2 = 1.d0 @@ -30,6 +30,7 @@ program var_pt2_ratio_run threshold_selectors = 1.d0 threshold_generators = 0.999d0 + selection_criterion_save = selection_criterion call diagonalize_CI call H_apply_FCI_PT2(pt2, norm_pert, H_pert_diag, N_st) E_ref = CI_energy(1) + pt2(1) @@ -46,6 +47,8 @@ program var_pt2_ratio_run Nmax = max(Nmax,Nmin+10) ! Select new determinants call H_apply_FCI(pt2, norm_pert, H_pert_diag, N_st) + selection_criterion = selection_criterion_save + SOFT_TOUCH selection_criterion selection_criterion_min selection_criterion_factor else Nmax = N_det N_det = Nmin + (Nmax-Nmin)/2 diff --git a/plugins/Full_CI_ZMQ/NEEDED_CHILDREN_MODULES b/plugins/Full_CI_ZMQ/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..cb6ff46e --- /dev/null +++ b/plugins/Full_CI_ZMQ/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Perturbation Selectors_full Generators_full ZMQ Full_CI diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f new file mode 100644 index 00000000..964edf62 --- /dev/null +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -0,0 +1,221 @@ +program fci_zmq + implicit none + integer :: i,j,k + logical, external :: detEq + + double precision, allocatable :: pt2(:) + integer :: degree + + allocate (pt2(N_states)) + + pt2 = 1.d0 + diag_algorithm = "Lapack" + + if (N_det > N_det_max) then + call diagonalize_CI + call save_wavefunction + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + N_det = N_det_max + soft_touch N_det psi_det psi_coef + call diagonalize_CI + call save_wavefunction + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + do k=1,N_states + print*,'State ',k + print *, 'PT2 = ', pt2(k) + print *, 'E = ', CI_energy(k) + print *, 'E+PT2 = ', CI_energy(k) + pt2(k) + print *, '-----' + enddo + endif + double precision :: E_CI_before(N_states) + + + integer :: n_det_before + print*,'Beginning the selection ...' + E_CI_before(1:N_states) = CI_energy(1:N_states) + + do while ( (N_det < N_det_max) .and. (maxval(abs(pt2(1:N_states))) > pt2_max) ) + n_det_before = N_det + call ZMQ_selection(max(1024-N_det, N_det), pt2) + + PROVIDE psi_coef + PROVIDE psi_det + PROVIDE psi_det_sorted + + call diagonalize_CI + call save_wavefunction + + if (N_det > N_det_max) then + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + N_det = N_det_max + soft_touch N_det psi_det psi_coef + call diagonalize_CI + call save_wavefunction + endif + + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + 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 *, '-----' + 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(1:N_states) = CI_energy(1:N_states) + call ezfio_set_full_ci_energy(CI_energy) + enddo + + if(do_pt2_end)then + print*,'Last iteration only to compute the PT2' + threshold_selectors = threshold_selectors_pt2 + threshold_generators = threshold_generators_pt2 + TOUCH threshold_selectors threshold_generators + E_CI_before(1:N_states) = CI_energy(1:N_states) + call ZMQ_selection(0, pt2) + print *, 'Final step' + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + do k=1,N_states + print *, 'State', k + print *, 'PT2 = ', pt2 + print *, 'E = ', E_CI_before + print *, 'E+PT2 = ', E_CI_before+pt2 + print *, '-----' + enddo + call ezfio_set_full_ci_energy_pt2(E_CI_before+pt2) + endif + call save_wavefunction +end + + + + +subroutine ZMQ_selection(N_in, pt2) + use f77_zmq + use selection_types + + implicit none + + character*(512) :: task + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + integer, intent(in) :: N_in + type(selection_buffer) :: b + integer :: i, N + integer, external :: omp_get_thread_num + double precision, intent(out) :: pt2(N_states) + + + N = max(N_in,1) + provide nproc + provide ci_electronic_energy + call new_parallel_job(zmq_to_qp_run_socket,"selection") + call zmq_put_psi(zmq_to_qp_run_socket,1,ci_electronic_energy,size(ci_electronic_energy)) + call zmq_set_running(zmq_to_qp_run_socket) + call create_selection_buffer(N, N*2, b) + + integer :: i_generator, i_generator_start, i_generator_max, step +! step = int(max(1.,10*elec_num/mo_tot_num) + + step = int(5000000.d0 / dble(N_int * N_states * elec_num * elec_num * mo_tot_num * mo_tot_num )) + step = max(1,step) + do i= N_det_generators, 1, -step + i_generator_start = max(i-step+1,1) + i_generator_max = i + write(task,*) i_generator_start, i_generator_max, 1, N + call add_task_to_taskserver(zmq_to_qp_run_socket,task) + end do + + !$OMP PARALLEL DEFAULT(none) SHARED(b, pt2) PRIVATE(i) NUM_THREADS(nproc+1) shared(ci_electronic_energy_is_built, n_det_generators_is_built, n_states_is_built, n_int_is_built, nproc_is_built) + i = omp_get_thread_num() + if (i==0) then + call selection_collector(b, pt2) + else + call selection_slave_inproc(i) + endif + !$OMP END PARALLEL + call end_parallel_job(zmq_to_qp_run_socket, 'selection') + if (N_in > 0) then + call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0) !!! PAS DE ROBIN + call copy_H_apply_buffer_to_wf() + endif +end subroutine + + +subroutine selection_slave_inproc(i) + implicit none + integer, intent(in) :: i + + call run_selection_slave(1,i,ci_electronic_energy) +end + +subroutine selection_collector(b, pt2) + use f77_zmq + use selection_types + use bitmasks + implicit none + + + type(selection_buffer), intent(inout) :: b + double precision, intent(out) :: pt2(N_states) + double precision :: pt2_mwen(N_states) + 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 :: msg_size, rc, more + integer :: acc, i, j, robin, N, ntask + double precision, allocatable :: val(:) + integer(bit_kind), allocatable :: det(:,:,:) + integer, allocatable :: task_id(:) + integer :: done + real :: time, time0 + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + zmq_socket_pull = new_zmq_pull_socket() + allocate(val(b%N), det(N_int, 2, b%N), task_id(N_det)) + done = 0 + more = 1 + pt2(:) = 0d0 + call CPU_TIME(time0) + do while (more == 1) + call pull_selection_results(zmq_socket_pull, pt2_mwen, val(1), det(1,1,1), N, task_id, ntask) + pt2 += pt2_mwen + do i=1, N + call add_to_selection_buffer(b, det(1,1,i), val(i)) + end do + + do i=1, ntask + if(task_id(i) == 0) then + print *, "Error in collector" + endif + call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id(i),more) + end do + done += ntask + call CPU_TIME(time) +! print *, "DONE" , done, time - time0 + end do + + + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + call end_zmq_pull_socket(zmq_socket_pull) + call sort_selection_buffer(b) +end subroutine + diff --git a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f new file mode 100644 index 00000000..36550116 --- /dev/null +++ b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f @@ -0,0 +1,156 @@ + +subroutine run_selection_slave(thread,iproc,energy) + use f77_zmq + use selection_types + implicit none + + double precision, intent(in) :: energy(N_states_diag) + integer, intent(in) :: thread, iproc + integer :: rc, i + + integer :: worker_id, task_id(1), ctask, ltask + 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 + + type(selection_buffer) :: buf, buf2 + logical :: done + double precision :: pt2(N_states) + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + zmq_socket_push = new_zmq_push_socket(thread) + call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) + if(worker_id == -1) then + print *, "WORKER -1" + !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) + return + end if + buf%N = 0 + ctask = 1 + pt2 = 0d0 + + do + call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id(ctask), task) + done = task_id(ctask) == 0 + if (done) then + ctask = ctask - 1 + else + integer :: i_generator, i_generator_start, i_generator_max, step, N + read (task,*) i_generator_start, i_generator_max, step, N + if(buf%N == 0) then + ! Only first time + call create_selection_buffer(N, N*2, buf) + call create_selection_buffer(N, N*3, buf2) + else + if(N /= buf%N) stop "N changed... wtf man??" + end if + !print *, "psi_selectors_coef ", psi_selectors_coef(N_det_selectors-5:N_det_selectors, 1) + !call debug_det(psi_selectors(1,1,N_det_selectors), N_int) + do i_generator=i_generator_start,i_generator_max,step + call select_connected(i_generator,energy,pt2,buf) + enddo + endif + + if(done .or. ctask == size(task_id)) then + if(buf%N == 0 .and. ctask > 0) stop "uninitialized selection_buffer" + do i=1, ctask + call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i)) + end do + if(ctask > 0) then + call push_selection_results(zmq_socket_push, pt2, buf, task_id(1), ctask) + do i=1,buf%cur + call add_to_selection_buffer(buf2, buf%det(1,1,i), buf%val(i)) + enddo + call sort_selection_buffer(buf2) + buf%mini = buf2%mini + pt2 = 0d0 + buf%cur = 0 + end if + ctask = 0 + end if + + if(done) exit + ctask = ctask + 1 + end do + call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + call end_zmq_push_socket(zmq_socket_push,thread) +end subroutine + + +subroutine push_selection_results(zmq_socket_push, pt2, b, task_id, ntask) + use f77_zmq + use selection_types + implicit none + + integer(ZMQ_PTR), intent(in) :: zmq_socket_push + double precision, intent(in) :: pt2(N_states) + type(selection_buffer), intent(inout) :: b + integer, intent(in) :: ntask, task_id(*) + integer :: rc + + call sort_selection_buffer(b) + + rc = f77_zmq_send( zmq_socket_push, b%cur, 4, ZMQ_SNDMORE) + if(rc /= 4) stop "push" + rc = f77_zmq_send( zmq_socket_push, pt2, 8*N_states, ZMQ_SNDMORE) + if(rc /= 8*N_states) stop "push" + + rc = f77_zmq_send( zmq_socket_push, b%val(1), 8*b%cur, ZMQ_SNDMORE) + if(rc /= 8*b%cur) stop "push" + + rc = f77_zmq_send( zmq_socket_push, b%det(1,1,1), bit_kind*N_int*2*b%cur, ZMQ_SNDMORE) + if(rc /= bit_kind*N_int*2*b%cur) stop "push" + + rc = f77_zmq_send( zmq_socket_push, ntask, 4, ZMQ_SNDMORE) + if(rc /= 4) stop "push" + + rc = f77_zmq_send( zmq_socket_push, task_id(1), ntask*4, 0) + if(rc /= 4*ntask) stop "push" + +! Activate is zmq_socket_push is a REQ +! rc = f77_zmq_recv( zmq_socket_push, task_id(1), ntask*4, 0) +end subroutine + + +subroutine pull_selection_results(zmq_socket_pull, pt2, val, det, N, task_id, ntask) + use f77_zmq + use selection_types + implicit none + integer(ZMQ_PTR), intent(in) :: zmq_socket_pull + double precision, intent(inout) :: pt2(N_states) + double precision, intent(out) :: val(*) + integer(bit_kind), intent(out) :: det(N_int, 2, *) + integer, intent(out) :: N, ntask, task_id(*) + integer :: rc, rn, i + + rc = f77_zmq_recv( zmq_socket_pull, N, 4, 0) + if(rc /= 4) stop "pull" + + rc = f77_zmq_recv( zmq_socket_pull, pt2, N_states*8, 0) + if(rc /= 8*N_states) stop "pull" + + rc = f77_zmq_recv( zmq_socket_pull, val(1), 8*N, 0) + if(rc /= 8*N) stop "pull" + + rc = f77_zmq_recv( zmq_socket_pull, det(1,1,1), bit_kind*N_int*2*N, 0) + if(rc /= bit_kind*N_int*2*N) stop "pull" + + rc = f77_zmq_recv( zmq_socket_pull, ntask, 4, 0) + if(rc /= 4) stop "pull" + + rc = f77_zmq_recv( zmq_socket_pull, task_id(1), ntask*4, 0) + if(rc /= 4*ntask) stop "pull" + +! Activate is zmq_socket_pull is a REP +! rc = f77_zmq_send( zmq_socket_pull, task_id(1), ntask*4, 0) +end subroutine + + + diff --git a/plugins/Full_CI_ZMQ/selection.irp.f b/plugins/Full_CI_ZMQ/selection.irp.f new file mode 100644 index 00000000..a0209cc5 --- /dev/null +++ b/plugins/Full_CI_ZMQ/selection.irp.f @@ -0,0 +1,106 @@ +use bitmasks + + +double precision function integral8(i,j,k,l) + implicit none + + integer, intent(in) :: i,j,k,l + double precision, external :: get_mo_bielec_integral + + integral8 = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) +end function + + +BEGIN_PROVIDER [ integer(1), psi_phasemask, (N_int*bit_kind_size, 2, N_det)] + use bitmasks + implicit none + + integer :: i + do i=1, N_det + call get_mask_phase(psi_det_sorted(1,1,i), psi_phasemask(1,1,i)) + end do +END_PROVIDER + + +subroutine assert(cond, msg) + character(*), intent(in) :: msg + logical, intent(in) :: cond + + if(.not. cond) then + print *, "assert fail: "//msg + stop + end if +end subroutine + + +subroutine get_mask_phase(det, phasemask) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: det(N_int, 2) + integer(1), intent(out) :: phasemask(N_int*bit_kind_size, 2) + integer :: s, ni, i + logical :: change + + phasemask = 0_1 + do s=1,2 + change = .false. + do ni=1,N_int + do i=0,bit_kind_size-1 + if(BTEST(det(ni, s), i)) change = .not. change + if(change) phasemask((ni-1)*bit_kind_size + i + 1, s) = 1_1 + end do + end do + end do +end subroutine + + +subroutine select_connected(i_generator,E0,pt2,b) + use bitmasks + use selection_types + implicit none + integer, intent(in) :: i_generator + type(selection_buffer), intent(inout) :: b + double precision, intent(inout) :: pt2(N_states) + integer :: k,l + double precision, intent(in) :: E0(N_states) + + integer(bit_kind) :: hole_mask(N_int,2), particle_mask(N_int,2) + double precision :: fock_diag_tmp(2,mo_tot_num+1) + + call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int) + + do l=1,N_generators_bitmask + do k=1,N_int + hole_mask(k,1) = iand(generators_bitmask(k,1,s_hole,l), psi_det_generators(k,1,i_generator)) + hole_mask(k,2) = iand(generators_bitmask(k,2,s_hole,l), psi_det_generators(k,2,i_generator)) + particle_mask(k,1) = iand(generators_bitmask(k,1,s_part,l), not(psi_det_generators(k,1,i_generator)) ) + particle_mask(k,2) = iand(generators_bitmask(k,2,s_part,l), not(psi_det_generators(k,2,i_generator)) ) + + enddo + call select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b) + call select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b) + enddo +end subroutine + + +double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2) + use bitmasks + implicit none + + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + integer, intent(in) :: s1, s2, h1, h2, p1, p2 + logical :: change + integer(1) :: np + double precision, parameter :: res(0:1) = (/1d0, -1d0/) + + np = phasemask(h1,s1) + phasemask(p1,s1) + phasemask(h2,s2) + phasemask(p2,s2) + if(p1 < h1) np = np + 1_1 + if(p2 < h2) np = np + 1_1 + + if(s1 == s2 .and. max(h1, p1) > min(h2, p2)) np = np + 1_1 + get_phase_bi = res(iand(np,1_1)) +end subroutine + + + diff --git a/plugins/Full_CI_ZMQ/selection_buffer.irp.f b/plugins/Full_CI_ZMQ/selection_buffer.irp.f new file mode 100644 index 00000000..2bcb11d3 --- /dev/null +++ b/plugins/Full_CI_ZMQ/selection_buffer.irp.f @@ -0,0 +1,70 @@ + +subroutine create_selection_buffer(N, siz, res) + use selection_types + implicit none + + integer, intent(in) :: N, siz + type(selection_buffer), intent(out) :: res + + allocate(res%det(N_int, 2, siz), res%val(siz)) + + res%val = 0d0 + res%det = 0_8 + res%N = N + res%mini = 0d0 + res%cur = 0 +end subroutine + + +subroutine add_to_selection_buffer(b, det, val) + use selection_types + implicit none + + type(selection_buffer), intent(inout) :: b + integer(bit_kind), intent(in) :: det(N_int, 2) + double precision, intent(in) :: val + integer :: i + + if(dabs(val) >= b%mini) then + b%cur += 1 + b%det(:,:,b%cur) = det(:,:) + b%val(b%cur) = val + if(b%cur == size(b%val)) then + call sort_selection_buffer(b) + end if + end if +end subroutine + + +subroutine sort_selection_buffer(b) + use selection_types + implicit none + + type(selection_buffer), intent(inout) :: b + double precision, allocatable :: vals(:), absval(:) + integer, allocatable :: iorder(:) + integer(bit_kind), allocatable :: detmp(:,:,:) + integer :: i, nmwen + logical, external :: detEq + nmwen = min(b%N, b%cur) + + + allocate(iorder(b%cur), detmp(N_int, 2, nmwen), absval(b%cur), vals(nmwen)) + absval = -dabs(b%val(:b%cur)) + do i=1,b%cur + iorder(i) = i + end do + call dsort(absval, iorder, b%cur) + + do i=1, nmwen + detmp(:,:,i) = b%det(:,:,iorder(i)) + vals(i) = b%val(iorder(i)) + end do + b%det(:,:,:nmwen) = detmp(:,:,:) + b%det(:,:,nmwen+1:) = 0_bit_kind + b%val(:nmwen) = vals(:) + b%val(nmwen+1:) = 0d0 + b%mini = max(b%mini,dabs(b%val(b%N))) + b%cur = nmwen +end subroutine + diff --git a/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f b/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f new file mode 100644 index 00000000..6e4cf44f --- /dev/null +++ b/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f @@ -0,0 +1,107 @@ +program selection_slave + 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 mo_mono_elec_integral +! PROVIDE ci_electronic_energy mo_tot_num N_int +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 + double precision :: energy(N_states_diag) + character*(64) :: states(2) + integer :: rc, i + + call provide_everything + + zmq_context = f77_zmq_ctx_new () + states(1) = 'selection' + states(2) = 'davidson' + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + + do + + call wait_for_states(states,zmq_state,2) + + if(trim(zmq_state) == 'Stopped') then + + exit + + else if (trim(zmq_state) == 'selection') then + + ! Selection + ! --------- + + print *, 'Selection' + call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states_diag) + + !$OMP PARALLEL PRIVATE(i) + i = omp_get_thread_num() + call selection_slave_tcp(i, energy) + !$OMP END PARALLEL + print *, 'Selection done' + + else if (trim(zmq_state) == 'davidson') then + + ! Davidson + ! -------- + + print *, 'Davidson' + call davidson_miniserver_get() + !$OMP PARALLEL PRIVATE(i) + i = omp_get_thread_num() + call davidson_slave_tcp(i) + !$OMP END PARALLEL + print *, 'Davidson done' + + endif + + end do +end + +subroutine update_energy(energy) + implicit none + double precision, intent(in) :: energy(N_states_diag) + BEGIN_DOC +! Update energy when it is received from ZMQ + END_DOC + integer :: j,k + do j=1,N_states + do k=1,N_det + CI_eigenvectors(k,j) = psi_coef(k,j) + enddo + enddo + call u_0_S2_u_0(CI_eigenvectors_s2,CI_eigenvectors,N_det,psi_det,N_int) + if (.True.) then + do k=1,size(ci_electronic_energy) + ci_electronic_energy(k) = energy(k) + enddo + TOUCH ci_electronic_energy CI_eigenvectors_s2 CI_eigenvectors + endif + + call write_double(6,ci_energy,'Energy') +end + +subroutine selection_slave_tcp(i,energy) + implicit none + double precision, intent(in) :: energy(N_states_diag) + integer, intent(in) :: i + + call run_selection_slave(0,i,energy) +end + diff --git a/plugins/Full_CI_ZMQ/selection_double.irp.f b/plugins/Full_CI_ZMQ/selection_double.irp.f new file mode 100644 index 00000000..977622fd --- /dev/null +++ b/plugins/Full_CI_ZMQ/selection_double.irp.f @@ -0,0 +1,726 @@ + +subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator + integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + + double precision :: mat(N_states, mo_tot_num, mo_tot_num) + integer :: h1,h2,s1,s2,s3,i1,i2,ib,sp,k,i,j,nt,ii + integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2), pmask(N_int, 2) + logical :: fullMatch, ok + + integer(bit_kind) :: mobMask(N_int, 2), negMask(N_int, 2) + integer,allocatable :: preinteresting(:), prefullinteresting(:), interesting(:), fullinteresting(:) + integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :) + + allocate(minilist(N_int, 2, N_det_selectors), fullminilist(N_int, 2, N_det)) + allocate(preinteresting(0:N_det_selectors), prefullinteresting(0:N_det), interesting(0:N_det_selectors), fullinteresting(0:N_det)) + + do k=1,N_int + hole (k,1) = iand(psi_det_generators(k,1,i_generator), hole_mask(k,1)) + hole (k,2) = iand(psi_det_generators(k,2,i_generator), hole_mask(k,2)) + particle(k,1) = iand(not(psi_det_generators(k,1,i_generator)), particle_mask(k,1)) + particle(k,2) = iand(not(psi_det_generators(k,2,i_generator)), particle_mask(k,2)) + enddo + + integer :: N_holes(2), N_particles(2) + integer :: hole_list(N_int*bit_kind_size,2) + integer :: particle_list(N_int*bit_kind_size,2) + + call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) + call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) + + + preinteresting(0) = 0 + prefullinteresting(0) = 0 + + do i=1,N_int + negMask(i,1) = not(psi_det_generators(i,1,i_generator)) + negMask(i,2) = not(psi_det_generators(i,2,i_generator)) + end do + + do i=1,N_det + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 4) then + if(i <= N_det_selectors) then + preinteresting(0) += 1 + preinteresting(preinteresting(0)) = i + else if(nt <= 2) then + prefullinteresting(0) += 1 + prefullinteresting(prefullinteresting(0)) = i + end if + end if + end do + + + do s1=1,2 + do i1=N_holes(s1),1,-1 ! Generate low excitations first + h1 = hole_list(i1,s1) + call apply_hole(psi_det_generators(1,1,i_generator), s1,h1, pmask, ok, N_int) + + do i=1,N_int + negMask(i,1) = not(pmask(i,1)) + negMask(i,2) = not(pmask(i,2)) + end do + + interesting(0) = 0 + fullinteresting(0) = 0 + + do ii=1,preinteresting(0) + i = preinteresting(ii) + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 4) then + interesting(0) += 1 + interesting(interesting(0)) = i + minilist(:,:,interesting(0)) = psi_det_sorted(:,:,i) + if(nt <= 2) then + fullinteresting(0) += 1 + fullinteresting(fullinteresting(0)) = i + fullminilist(:,:,fullinteresting(0)) = psi_det_sorted(:,:,i) + end if + end if + end do + + do ii=1,prefullinteresting(0) + i = prefullinteresting(ii) + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 2) then + fullinteresting(0) += 1 + fullinteresting(fullinteresting(0)) = i + fullminilist(:,:,fullinteresting(0)) = psi_det_sorted(:,:,i) + end if + end do + + do s2=s1,2 + sp = s1 + if(s1 /= s2) sp = 3 + + ib = 1 + if(s1 == s2) ib = i1+1 + do i2=N_holes(s2),ib,-1 ! Generate low excitations first + + h2 = hole_list(i2,s2) + call apply_hole(pmask, s2,h2, mask, ok, N_int) + + logical :: banned(mo_tot_num, mo_tot_num,2) + logical :: bannedOrb(mo_tot_num, 2) + + banned = .false. + + call spot_isinwf(mask, fullminilist, i_generator, fullinteresting(0), banned, fullMatch, fullinteresting) + + if(fullMatch) cycle + + bannedOrb(1:mo_tot_num, 1:2) = .true. + do s3=1,2 + do i=1,N_particles(s3) + bannedOrb(particle_list(i,s3), s3) = .false. + enddo + enddo + + mat = 0d0 + call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting) + call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) + enddo + enddo + enddo + enddo +end subroutine + + +subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator, sp, h1, h2 + double precision, intent(in) :: mat(N_states, mo_tot_num, mo_tot_num) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + logical :: ok + integer :: s1, s2, p1, p2, ib, j, istate + integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) + double precision :: e_pert, delta_E, val, Hii, max_e_pert + double precision, external :: diag_H_mat_elem_fock + + logical, external :: detEq + + + if(sp == 3) then + s1 = 1 + s2 = 2 + else + s1 = sp + s2 = sp + end if + + call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int) + + do p1=1,mo_tot_num + if(bannedOrb(p1, s1)) cycle + ib = 1 + if(sp /= 3) ib = p1+1 + do p2=ib,mo_tot_num + if(bannedOrb(p2, s2)) cycle + if(banned(p1,p2)) cycle + if(mat(1, p1, p2) == 0d0) cycle + call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + + + Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) + max_e_pert = 0d0 + + do istate=1,N_states + delta_E = E0(istate) - Hii + val = mat(istate, p1, p2) + if (delta_E < 0.d0) then + e_pert = 0.5d0 * (-dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) + else + e_pert = 0.5d0 * ( dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) + endif + pt2(istate) += e_pert + if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert + end do + + if(dabs(max_e_pert) > buf%mini) then + call add_to_selection_buffer(buf, det, max_e_pert) + end if + end do + end do +end subroutine + + +subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, interesting) + use bitmasks + implicit none + + integer, intent(in) :: interesting(0:N_sel) + + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N_sel) + integer, intent(in) :: sp, i_gen, N_sel + logical, intent(inout) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num, 2) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + + integer :: i, ii, j, k, l, h(0:2,2), p(0:4,2), nt + integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) +! logical :: bandon +! +! bandon = .false. + mat = 0d0 + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + do i=1, N_sel ! interesting(0) + !i = interesting(ii) + + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt > 4) cycle + + do j=1,N_int + perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) + perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) + end do + + call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int) + call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int) + + call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) + call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) + + if(interesting(i) < i_gen) then + if(nt == 4) call past_d2(banned, p, sp) + if(nt == 3) call past_d1(bannedOrb, p) + else + if(interesting(i) == i_gen) then +! bandon = .true. + if(sp == 3) then + banned(:,:,2) = transpose(banned(:,:,1)) + else + do k=1,mo_tot_num + do l=k+1,mo_tot_num + banned(l,k,1) = banned(k,l,1) + end do + end do + end if + end if + if(nt == 4) then + call get_d2(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + else if(nt == 3) then + call get_d1(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + else + call get_d0(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + end if + end if + end do +end subroutine + + +subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + double precision, external :: get_phase_bi, integral8 + + integer :: i, j, tip, ma, mi, puti, putj + integer :: h1, h2, p1, p2, i1, i2 + double precision :: hij, phase + + integer, parameter:: turn2d(2,3,4) = reshape((/0,0, 0,0, 0,0, 3,4, 0,0, 0,0, 2,4, 1,4, 0,0, 2,3, 1,3, 1,2 /), (/2,3,4/)) + integer, parameter :: turn2(2) = (/2, 1/) + integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + + integer :: bant + bant = 1 + + tip = p(0,1) * p(0,2) + + ma = sp + if(p(0,1) > p(0,2)) ma = 1 + if(p(0,1) < p(0,2)) ma = 2 + mi = mod(ma, 2) + 1 + + if(sp == 3) then + if(ma == 2) bant = 2 + + if(tip == 3) then + puti = p(1, mi) + do i = 1, 3 + putj = p(i, ma) + if(banned(putj,puti,bant)) cycle + i1 = turn3(1,i) + i2 = turn3(2,i) + p1 = p(i1, ma) + p2 = p(i2, ma) + h1 = h(1, ma) + h2 = h(2, ma) + + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) + if(ma == 1) then + mat(:, putj, puti) += coefs * hij + else + mat(:, puti, putj) += coefs * hij + end if + end do + else + do i = 1,2 + do j = 1,2 + puti = p(i, 1) + putj = p(j, 2) + + if(banned(puti,putj,bant)) cycle + p1 = p(turn2(i), 1) + p2 = p(turn2(j), 2) + h1 = h(1,1) + h2 = h(1,2) + + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end do + end do + end if + + else + if(tip == 0) then + h1 = h(1, ma) + h2 = h(2, ma) + do i=1,3 + puti = p(i, ma) + do j=i+1,4 + putj = p(j, ma) + if(banned(puti,putj,1)) cycle + + i1 = turn2d(1, i, j) + i2 = turn2d(2, i, j) + p1 = p(i1, ma) + p2 = p(i2, ma) + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end do + end do + else if(tip == 3) then + h1 = h(1, mi) + h2 = h(1, ma) + p1 = p(1, mi) + do i=1,3 + puti = p(turn3(1,i), ma) + putj = p(turn3(2,i), ma) + if(banned(puti,putj,1)) cycle + p2 = p(i, ma) + + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2) + mat(:, min(puti, putj), max(puti, putj)) += coefs * hij + end do + else ! tip == 4 + puti = p(1, sp) + putj = p(2, sp) + if(.not. banned(puti,putj,1)) then + p1 = p(1, mi) + p2 = p(2, mi) + h1 = h(1, mi) + h2 = h(2, mi) + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end if + end if + end if +end subroutine + + +subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) + integer(1),intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + double precision :: hij, tmp_row(N_states, mo_tot_num), tmp_row2(N_states, mo_tot_num) + double precision, external :: get_phase_bi, integral8 + + logical :: lbanned(mo_tot_num, 2), ok + integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j, hfix, pfix, h1, h2, p1, p2, ib + + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + integer, parameter :: turn2(2) = (/2,1/) + integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + + integer :: bant + + + lbanned = bannedOrb + + do i=1, p(0,1) + lbanned(p(i,1), 1) = .true. + end do + do i=1, p(0,2) + lbanned(p(i,2), 2) = .true. + end do + + ma = 1 + if(p(0,2) >= 2) ma = 2 + mi = turn2(ma) + + bant = 1 + + if(sp == 3) then + !move MA + if(ma == 2) bant = 2 + puti = p(1,mi) + hfix = h(1,ma) + p1 = p(1,ma) + p2 = p(2,ma) + if(.not. bannedOrb(puti, mi)) then + tmp_row = 0d0 + do putj=1, hfix-1 + if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle + hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) + tmp_row(1:N_states,putj) += hij * coefs(1:N_states) + end do + do putj=hfix+1, mo_tot_num + if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle + hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) + tmp_row(1:N_states,putj) += hij * coefs(1:N_states) + end do + + if(ma == 1) then + mat(1:N_states,1:mo_tot_num,puti) += tmp_row(1:N_states,1:mo_tot_num) + else + mat(1:N_states,puti,1:mo_tot_num) += tmp_row(1:N_states,1:mo_tot_num) + end if + end if + + !MOVE MI + pfix = p(1,mi) + tmp_row = 0d0 + tmp_row2 = 0d0 + do puti=1,mo_tot_num + if(lbanned(puti,mi)) cycle + !p1 fixed + putj = p1 + if(.not. banned(putj,puti,bant)) then + hij = integral8(p2,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix) + tmp_row(:,puti) += hij * coefs + end if + + putj = p2 + if(.not. banned(putj,puti,bant)) then + hij = integral8(p1,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix) + tmp_row2(:,puti) += hij * coefs + end if + end do + + if(mi == 1) then + mat(:,:,p1) += tmp_row(:,:) + mat(:,:,p2) += tmp_row2(:,:) + else + mat(:,p1,:) += tmp_row(:,:) + mat(:,p2,:) += tmp_row2(:,:) + end if + else + if(p(0,ma) == 3) then + do i=1,3 + hfix = h(1,ma) + puti = p(i, ma) + p1 = p(turn3(1,i), ma) + p2 = p(turn3(2,i), ma) + tmp_row = 0d0 + do putj=1,hfix-1 + if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle + hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) + tmp_row(:,putj) += hij * coefs + end do + do putj=hfix+1,mo_tot_num + if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle + hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) + tmp_row(:,putj) += hij * coefs + end do + + mat(:, :puti-1, puti) += tmp_row(:,:puti-1) + mat(:, puti, puti:) += tmp_row(:,puti:) + end do + else + hfix = h(1,mi) + pfix = p(1,mi) + p1 = p(1,ma) + p2 = p(2,ma) + tmp_row = 0d0 + tmp_row2 = 0d0 + do puti=1,mo_tot_num + if(lbanned(puti,ma)) cycle + putj = p2 + if(.not. banned(puti,putj,1)) then + hij = integral8(pfix, p1, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1) + tmp_row(:,puti) += hij * coefs + end if + + putj = p1 + if(.not. banned(puti,putj,1)) then + hij = integral8(pfix, p2, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2) + tmp_row2(:,puti) += hij * coefs + end if + end do + mat(:,:p2-1,p2) += tmp_row(:,:p2-1) + mat(:,p2,p2:) += tmp_row(:,p2:) + mat(:,:p1-1,p1) += tmp_row2(:,:p1-1) + mat(:,p1,p1:) += tmp_row2(:,p1:) + end if + end if + + !! MONO + if(sp == 3) then + s1 = 1 + s2 = 2 + else + s1 = sp + s2 = sp + end if + + do i1=1,p(0,s1) + ib = 1 + if(s1 == s2) ib = i1+1 + do i2=ib,p(0,s2) + p1 = p(i1,s1) + p2 = p(i2,s2) + if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2) .or. banned(p1, p2, 1)) cycle + call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + mat(:, p1, p2) += coefs * hij + end do + end do +end subroutine + + + + +subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + integer :: i, j, s, h1, h2, p1, p2, puti, putj + double precision :: hij, phase + double precision, external :: get_phase_bi, integral8 + logical :: ok + + integer :: bant + bant = 1 + + + if(sp == 3) then ! AB + h1 = p(1,1) + h2 = p(1,2) + do p1=1, mo_tot_num + if(bannedOrb(p1, 1)) cycle + do p2=1, mo_tot_num + if(bannedOrb(p2,2)) cycle + if(banned(p1, p2, bant)) cycle ! rentable? + if(p1 == h1 .or. p2 == h2) then + call apply_particles(mask, 1,p1,2,p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + else + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + end if + mat(:, p1, p2) += coefs(:) * hij + end do + end do + else ! AA BB + p1 = p(1,sp) + p2 = p(2,sp) + do puti=1, mo_tot_num + if(bannedOrb(puti, sp)) cycle + do putj=puti+1, mo_tot_num + if(bannedOrb(putj, sp)) cycle + if(banned(puti, putj, bant)) cycle ! rentable? + if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then + call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + else + hij = (integral8(p1, p2, puti, putj) - integral8(p2, p1, puti, putj))* get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2) + end if + mat(:, puti, putj) += coefs(:) * hij + end do + end do + end if +end subroutine + + +subroutine past_d1(bannedOrb, p) + use bitmasks + implicit none + + logical, intent(inout) :: bannedOrb(mo_tot_num, 2) + integer, intent(in) :: p(0:4, 2) + integer :: i,s + + do s = 1, 2 + do i = 1, p(0, s) + bannedOrb(p(i, s), s) = .true. + end do + end do +end subroutine + + +subroutine past_d2(banned, p, sp) + use bitmasks + implicit none + + logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) + integer, intent(in) :: p(0:4, 2), sp + integer :: i,j + + if(sp == 3) then + do i=1,p(0,1) + do j=1,p(0,2) + banned(p(i,1), p(j,2)) = .true. + end do + end do + else + do i=1,p(0, sp) + do j=1,i-1 + banned(p(j,sp), p(i,sp)) = .true. + banned(p(i,sp), p(j,sp)) = .true. + end do + end do + end if +end subroutine + + + +subroutine spot_isinwf(mask, det, i_gen, N, banned, fullMatch, interesting) + use bitmasks + implicit none + + integer, intent(in) :: interesting(0:N) + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) + integer, intent(in) :: i_gen, N + logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) + logical, intent(out) :: fullMatch + + + integer :: i, j, na, nb, list(3) + integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) + + fullMatch = .false. + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + genl : do i=1, N + do j=1, N_int + if(iand(det(j,1,i), mask(j,1)) /= mask(j, 1)) cycle genl + if(iand(det(j,2,i), mask(j,2)) /= mask(j, 2)) cycle genl + end do + + if(interesting(i) < i_gen) then + fullMatch = .true. + return + end if + + do j=1, N_int + myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) + myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) + end do + + call bitstring_to_list(myMask(1,1), list(1), na, N_int) + call bitstring_to_list(myMask(1,2), list(na+1), nb, N_int) + banned(list(1), list(2)) = .true. + end do genl +end subroutine + diff --git a/plugins/Full_CI_ZMQ/selection_single.irp.f b/plugins/Full_CI_ZMQ/selection_single.irp.f new file mode 100644 index 00000000..f107db11 --- /dev/null +++ b/plugins/Full_CI_ZMQ/selection_single.irp.f @@ -0,0 +1,354 @@ + + +subroutine select_singles(i_gen,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) + use bitmasks + use selection_types + implicit none + BEGIN_DOC +! Select determinants connected to i_det by H + END_DOC + integer, intent(in) :: i_gen + integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + + double precision :: vect(N_states, mo_tot_num) + logical :: bannedOrb(mo_tot_num) + integer :: i, j, k + integer :: h1,h2,s1,s2,i1,i2,ib,sp + integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2) + logical :: fullMatch, ok + + + do k=1,N_int + hole (k,1) = iand(psi_det_generators(k,1,i_gen), hole_mask(k,1)) + hole (k,2) = iand(psi_det_generators(k,2,i_gen), hole_mask(k,2)) + particle(k,1) = iand(not(psi_det_generators(k,1,i_gen)), particle_mask(k,1)) + particle(k,2) = iand(not(psi_det_generators(k,2,i_gen)), particle_mask(k,2)) + enddo + + ! Create lists of holes and particles + ! ----------------------------------- + + integer :: N_holes(2), N_particles(2) + integer :: hole_list(N_int*bit_kind_size,2) + integer :: particle_list(N_int*bit_kind_size,2) + + call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) + call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) + + do sp=1,2 + do i=1, N_holes(sp) + h1 = hole_list(i,sp) + call apply_hole(psi_det_generators(1,1,i_gen), sp, h1, mask, ok, N_int) + bannedOrb = .true. + do j=1,N_particles(sp) + bannedOrb(particle_list(j, sp)) = .false. + end do + call spot_hasBeen(mask, sp, psi_det_sorted, i_gen, N_det, bannedOrb, fullMatch) + if(fullMatch) cycle + vect = 0d0 + call splash_p(mask, sp, psi_selectors(1,1,i_gen), psi_phasemask(1,1,i_gen), psi_selectors_coef_transp(1,i_gen), N_det_selectors - i_gen + 1, bannedOrb, vect) + call fill_buffer_single(i_gen, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf) + end do + enddo +end subroutine + + +subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator, sp, h1 + double precision, intent(in) :: vect(N_states, mo_tot_num) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + logical :: ok + integer :: s1, s2, p1, p2, ib, istate + integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) + double precision :: e_pert, delta_E, val, Hii, max_e_pert + double precision, external :: diag_H_mat_elem_fock + + + call apply_hole(psi_det_generators(1,1,i_generator), sp, h1, mask, ok, N_int) + + do p1=1,mo_tot_num + if(bannedOrb(p1)) cycle + if(vect(1, p1) == 0d0) cycle + call apply_particle(mask, sp, p1, det, ok, N_int) + + + Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) + max_e_pert = 0d0 + + do istate=1,N_states + val = vect(istate, p1) + delta_E = E0(istate) - Hii + if (delta_E < 0.d0) then + e_pert = 0.5d0 * (-dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) + else + e_pert = 0.5d0 * ( dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) + endif + pt2(istate) += e_pert + if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert + end do + + if(dabs(max_e_pert) > buf%mini) call add_to_selection_buffer(buf, det, max_e_pert) + end do +end subroutine + + +subroutine splash_p(mask, sp, det, phasemask, coefs, N_sel, bannedOrb, vect) + use bitmasks + implicit none + + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int,2,N_sel) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2, N_sel) + double precision, intent(in) :: coefs(N_states, N_sel) + integer, intent(in) :: sp, N_sel + logical, intent(inout) :: bannedOrb(mo_tot_num) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + + integer :: i, j, h(0:2,2), p(0:3,2), nt + integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + do i=1, N_sel + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt > 3) cycle + + do j=1,N_int + perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) + perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) + end do + + call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int) + call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int) + + call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) + call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) + + if(nt == 3) then + call get_m2(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) + else if(nt == 2) then + call get_m1(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) + else + call get_m0(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) + end if + end do +end subroutine + + +subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i, j, h1, h2, p1, p2, sfix, hfix, pfix, hmob, pmob, puti + double precision :: hij + double precision, external :: get_phase_bi, integral8 + + integer, parameter :: turn3_2(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + integer, parameter :: turn2(2) = (/2,1/) + + if(h(0,sp) == 2) then + h1 = h(1, sp) + h2 = h(2, sp) + do i=1,3 + puti = p(i, sp) + if(bannedOrb(puti)) cycle + p1 = p(turn3_2(1,i), sp) + p2 = p(turn3_2(2,i), sp) + hij = integral8(p1, p2, h1, h2) - integral8(p2, p1, h1, h2) + hij *= get_phase_bi(phasemask, sp, sp, h1, p1, h2, p2) + vect(:, puti) += hij * coefs + end do + else if(h(0,sp) == 1) then + sfix = turn2(sp) + hfix = h(1,sfix) + pfix = p(1,sfix) + hmob = h(1,sp) + do j=1,2 + puti = p(j, sp) + if(bannedOrb(puti)) cycle + pmob = p(turn2(j), sp) + hij = integral8(pfix, pmob, hfix, hmob) + hij *= get_phase_bi(phasemask, sp, sfix, hmob, pmob, hfix, pfix) + vect(:, puti) += hij * coefs + end do + else + puti = p(1,sp) + if(.not. bannedOrb(puti)) then + sfix = turn2(sp) + p1 = p(1,sfix) + p2 = p(2,sfix) + h1 = h(1,sfix) + h2 = h(2,sfix) + hij = (integral8(p1,p2,h1,h2) - integral8(p2,p1,h1,h2)) + hij *= get_phase_bi(phasemask, sfix, sfix, h1, p1, h2, p2) + vect(:, puti) += hij * coefs + end if + end if +end subroutine + + + +subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i, hole, p1, p2, sh + logical :: ok, lbanned(mo_tot_num) + integer(bit_kind) :: det(N_int, 2) + double precision :: hij + double precision, external :: get_phase_bi, integral8 + + lbanned = bannedOrb + sh = 1 + if(h(0,2) == 1) sh = 2 + hole = h(1, sh) + lbanned(p(1,sp)) = .true. + if(p(0,sp) == 2) lbanned(p(2,sp)) = .true. + !print *, "SPm1", sp, sh + + p1 = p(1, sp) + + if(sp == sh) then + p2 = p(2, sp) + lbanned(p2) = .true. + + do i=1,hole-1 + if(lbanned(i)) cycle + hij = (integral8(p1, p2, i, hole) - integral8(p2, p1, i, hole)) + hij *= get_phase_bi(phasemask, sp, sp, i, p1, hole, p2) + vect(:,i) += hij * coefs + end do + do i=hole+1,mo_tot_num + if(lbanned(i)) cycle + hij = (integral8(p1, p2, hole, i) - integral8(p2, p1, hole, i)) + hij *= get_phase_bi(phasemask, sp, sp, hole, p1, i, p2) + vect(:,i) += hij * coefs + end do + + call apply_particle(mask, sp, p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(:, p2) += hij * coefs + else + p2 = p(1, sh) + do i=1,mo_tot_num + if(lbanned(i)) cycle + hij = integral8(p1, p2, i, hole) + hij *= get_phase_bi(phasemask, sp, sh, i, p1, hole, p2) + vect(:,i) += hij * coefs + end do + end if + + call apply_particle(mask, sp, p1, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(:, p1) += hij * coefs +end subroutine + + +subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i + logical :: ok, lbanned(mo_tot_num) + integer(bit_kind) :: det(N_int, 2) + double precision :: hij + + lbanned = bannedOrb + lbanned(p(1,sp)) = .true. + do i=1,mo_tot_num + if(lbanned(i)) cycle + call apply_particle(mask, sp, i, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(:, i) += hij * coefs + end do +end subroutine + + +subroutine spot_hasBeen(mask, sp, det, i_gen, N, banned, fullMatch) + use bitmasks + implicit none + + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) + integer, intent(in) :: i_gen, N, sp + logical, intent(inout) :: banned(mo_tot_num) + logical, intent(out) :: fullMatch + + + integer :: i, j, na, nb, list(3), nt + integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) + + fullMatch = .false. + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + genl : do i=1, N + nt = 0 + + do j=1, N_int + myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) + myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) + nt += popcnt(myMask(j, 1)) + popcnt(myMask(j, 2)) + end do + + if(nt > 3) cycle + + if(nt <= 2 .and. i < i_gen) then + fullMatch = .true. + return + end if + + call bitstring_to_list(myMask(1,sp), list(1), na, N_int) + + if(nt == 3 .and. i < i_gen) then + do j=1,na + banned(list(j)) = .true. + end do + else if(nt == 1 .and. na == 1) then + banned(list(1)) = .true. + end if + end do genl +end subroutine + + + diff --git a/plugins/Full_CI_ZMQ/selection_slave.irp.f b/plugins/Full_CI_ZMQ/selection_slave.irp.f new file mode 100644 index 00000000..06bcf533 --- /dev/null +++ b/plugins/Full_CI_ZMQ/selection_slave.irp.f @@ -0,0 +1,93 @@ +program selection_slave + 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 +! PROVIDE ci_electronic_energy mo_tot_num N_int +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 + double precision :: energy(N_states_diag) + character*(64) :: states(1) + integer :: rc, i + + call provide_everything + + zmq_context = f77_zmq_ctx_new () + states(1) = 'selection' + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + + do + + call wait_for_states(states,zmq_state,1) + + if(trim(zmq_state) == 'Stopped') then + + exit + + else if (trim(zmq_state) == 'selection') then + + ! Selection + ! --------- + + print *, 'Selection' + call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states_diag) + + !$OMP PARALLEL PRIVATE(i) + i = omp_get_thread_num() + call selection_slave_tcp(i, energy) + !$OMP END PARALLEL + print *, 'Selection done' + + endif + + end do +end + +subroutine update_energy(energy) + implicit none + double precision, intent(in) :: energy(N_states_diag) + BEGIN_DOC +! Update energy when it is received from ZMQ + END_DOC + integer :: j,k + do j=1,N_states + do k=1,N_det + CI_eigenvectors(k,j) = psi_coef(k,j) + enddo + enddo + call u_0_S2_u_0(CI_eigenvectors_s2,CI_eigenvectors,N_det,psi_det,N_int) + if (.True.) then + do k=1,size(ci_electronic_energy) + ci_electronic_energy(k) = energy(k) + enddo + TOUCH ci_electronic_energy CI_eigenvectors_s2 CI_eigenvectors + endif + + call write_double(6,ci_energy,'Energy') +end + +subroutine selection_slave_tcp(i,energy) + implicit none + double precision, intent(in) :: energy(N_states_diag) + integer, intent(in) :: i + + call run_selection_slave(0,i,energy) +end + diff --git a/plugins/Full_CI_ZMQ/selection_types.f90 b/plugins/Full_CI_ZMQ/selection_types.f90 new file mode 100644 index 00000000..9506629c --- /dev/null +++ b/plugins/Full_CI_ZMQ/selection_types.f90 @@ -0,0 +1,9 @@ +module selection_types + type selection_buffer + integer :: N, cur + integer(8), allocatable :: det(:,:,:) + double precision, allocatable :: val(:) + double precision :: mini + endtype +end module + diff --git a/plugins/Generators_CAS/tree_dependency.png b/plugins/Generators_CAS/tree_dependency.png index 5bbc55d0..749ec258 100644 Binary files a/plugins/Generators_CAS/tree_dependency.png and b/plugins/Generators_CAS/tree_dependency.png differ diff --git a/plugins/Generators_full/generators.irp.f b/plugins/Generators_full/generators.irp.f index a61fc5c5..eea5821b 100644 --- a/plugins/Generators_full/generators.irp.f +++ b/plugins/Generators_full/generators.irp.f @@ -30,7 +30,9 @@ END_PROVIDER ! Hartree-Fock determinant END_DOC integer :: i, k - do i=1,N_det + psi_coef_generators = 0.d0 + psi_det_generators = 0_bit_kind + do i=1,N_det_generators do k=1,N_int psi_det_generators(k,1,i) = psi_det_sorted(k,1,i) psi_det_generators(k,2,i) = psi_det_sorted(k,2,i) diff --git a/plugins/Generators_full/tree_dependency.png b/plugins/Generators_full/tree_dependency.png index 94ad6358..eed76866 100644 Binary files a/plugins/Generators_full/tree_dependency.png and b/plugins/Generators_full/tree_dependency.png differ diff --git a/plugins/Generators_restart/README.rst b/plugins/Generators_restart/README.rst index e7ab7045..09b4769c 100644 --- a/plugins/Generators_restart/README.rst +++ b/plugins/Generators_restart/README.rst @@ -2,3 +2,40 @@ Generators_restart Module ========================= +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + + +.. image:: tree_dependency.png + +* `Determinants `_ + +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + + +`n_det_generators `_ + Read the wave function + + +`psi_coef_generators `_ + read wf + .br + + +`psi_det_generators `_ + read wf + .br + + +`select_max `_ + Memo to skip useless selectors + + +`size_select_max `_ + Size of the select_max array + diff --git a/plugins/Hartree_Fock/.gitignore b/plugins/Hartree_Fock/.gitignore index f1a4ff4f..9f1c0929 100644 --- a/plugins/Hartree_Fock/.gitignore +++ b/plugins/Hartree_Fock/.gitignore @@ -5,6 +5,7 @@ AO_Basis Bitmask Electrons Ezfio_files +Huckel_guess IRPF90_man IRPF90_temp Integrals_Bielec @@ -15,6 +16,7 @@ Makefile Makefile.depend Nuclei Pseudo +SCF Utils ZMQ ezfio_interface.irp.f diff --git a/plugins/Hartree_Fock/Fock_matrix.irp.f b/plugins/Hartree_Fock/Fock_matrix.irp.f index 397f8f83..af9255c8 100644 --- a/plugins/Hartree_Fock/Fock_matrix.irp.f +++ b/plugins/Hartree_Fock/Fock_matrix.irp.f @@ -223,6 +223,7 @@ END_PROVIDER ao_bi_elec_integral_beta_tmp = 0.d0 !$OMP DO SCHEDULE(dynamic) + !DIR$ NOVECTOR do i8=0_8,ao_integrals_map%map_size n_elements = n_elements_max call get_cache_map(ao_integrals_map,i8,keys,values,n_elements) diff --git a/plugins/Hartree_Fock/README.rst b/plugins/Hartree_Fock/README.rst index aad4fd56..77521b94 100644 --- a/plugins/Hartree_Fock/README.rst +++ b/plugins/Hartree_Fock/README.rst @@ -25,6 +25,7 @@ Needed Modules * `Integrals_Bielec `_ * `MOGuess `_ +* `Bitmask `_ Documentation ============= @@ -32,11 +33,11 @@ Documentation .. by the `update_README.py` script. -`ao_bi_elec_integral_alpha `_ +`ao_bi_elec_integral_alpha `_ Alpha Fock matrix in AO basis set -`ao_bi_elec_integral_beta `_ +`ao_bi_elec_integral_beta `_ Alpha Fock matrix in AO basis set @@ -52,7 +53,7 @@ Documentation Diagonal Fock matrix in the MO basis -`diagonal_fock_matrix_mo_sum `_ +`diagonal_fock_matrix_mo_sum `_ diagonal element of the fock matrix calculated as the sum over all the interactions with all the electrons in the RHF determinant diagonal_Fock_matrix_mo_sum(i) = sum_{j=1, N_elec} 2 J_ij -K_ij @@ -62,23 +63,23 @@ Documentation Diagonal Fock matrix in the MO basis -`fock_matrix_alpha_ao `_ +`fock_matrix_alpha_ao `_ Alpha Fock matrix in AO basis set -`fock_matrix_alpha_mo `_ +`fock_matrix_alpha_mo `_ Fock matrix on the MO basis -`fock_matrix_ao `_ +`fock_matrix_ao `_ Fock matrix in AO basis set -`fock_matrix_beta_ao `_ +`fock_matrix_beta_ao `_ Alpha Fock matrix in AO basis set -`fock_matrix_beta_mo `_ +`fock_matrix_beta_mo `_ Fock matrix on the MO basis @@ -114,7 +115,7 @@ Documentation .br -`fock_mo_to_ao `_ +`fock_mo_to_ao `_ Undocumented @@ -134,7 +135,7 @@ Documentation S^-1 Beta density matrix in the AO basis x S^-1 -`hf_energy `_ +`hf_energy `_ Hartree-Fock energy @@ -142,18 +143,22 @@ Documentation Build the MOs using the extended Huckel model -`level_shift `_ +`level_shift `_ Energy shift on the virtual MOs to improve SCF convergence -`mo_guess_type `_ +`mo_guess_type `_ Initial MO guess. Can be [ Huckel | HCore ] -`n_it_scf_max `_ +`n_it_scf_max `_ Maximum number of SCF iterations +`no_oa_or_av_opt `_ + If true, skip the (inactive+core) --> (active) and the (active) --> (virtual) orbital rotations within the SCF procedure + + `run `_ Run SCF calculation @@ -165,6 +170,6 @@ Documentation optional: mo_basis.mo_coef -`thresh_scf `_ +`thresh_scf `_ Threshold on the convergence of the Hartree Fock energy diff --git a/plugins/Hartree_Fock/damping_SCF.irp.f b/plugins/Hartree_Fock/damping_SCF.irp.f index d383eb74..aa6f02b0 100644 --- a/plugins/Hartree_Fock/damping_SCF.irp.f +++ b/plugins/Hartree_Fock/damping_SCF.irp.f @@ -96,7 +96,7 @@ subroutine damping_SCF a = (E_new + E - 2.d0*E_half)*2.d0 b = -E_new - 3.d0*E + 4.d0*E_half - lambda = -lambda*b/a + lambda = -lambda*b/(a+1.d-16) D_alpha = (1.d0-lambda) * D_alpha + lambda * D_new_alpha D_beta = (1.d0-lambda) * D_beta + lambda * D_new_beta delta_E = HF_energy - E diff --git a/plugins/Hartree_Fock/tree_dependency.png b/plugins/Hartree_Fock/tree_dependency.png index cb1d9738..67de2eee 100644 Binary files a/plugins/Hartree_Fock/tree_dependency.png and b/plugins/Hartree_Fock/tree_dependency.png differ diff --git a/plugins/MRCC_CASSD/.gitignore b/plugins/MRCC_CASSD/.gitignore deleted file mode 100644 index d81ca7b8..00000000 --- a/plugins/MRCC_CASSD/.gitignore +++ /dev/null @@ -1,32 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Determinants -Electrons -Ezfio_files -Generators_full -Hartree_Fock -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -MRCC_Utils -Makefile -Makefile.depend -Nuclei -Perturbation -Properties -Pseudo -Psiref_CAS -Psiref_Utils -Selectors_full -Utils -ezfio_interface.irp.f -irpf90.make -irpf90_entities -mrcc_cassd -tags \ No newline at end of file diff --git a/plugins/MRCC_CASSD/EZFIO.cfg b/plugins/MRCC_CASSD/EZFIO.cfg deleted file mode 100644 index 21cc5b98..00000000 --- a/plugins/MRCC_CASSD/EZFIO.cfg +++ /dev/null @@ -1,4 +0,0 @@ -[energy] -type: double precision -doc: Calculated energy -interface: ezfio diff --git a/plugins/MRCC_CASSD/README.rst b/plugins/MRCC_CASSD/README.rst deleted file mode 100644 index b2713b43..00000000 --- a/plugins/MRCC_CASSD/README.rst +++ /dev/null @@ -1,60 +0,0 @@ -=========== -MRCC Module -=========== - -MRCC as a coupled cluster on a CAS+SD wave function. - -Needed Modules -============== - -.. Do not edit this section. It was auto-generated from the -.. by the `update_README.py` script. - -.. image:: tree_dependency.png - -* `Perturbation `_ -* `Selectors_full `_ -* `Generators_full `_ -* `Psiref_CAS `_ -* `MRCC_Utils `_ - -Documentation -============= - -.. Do not edit this section. It was auto-generated from the -.. by the `update_README.py` script. - -`mrcc `_ - Undocumented - - -`print_cas_coefs `_ - Undocumented - -Needed Modules -============== -.. Do not edit this section It was auto-generated -.. by the `update_README.py` script. - - -.. image:: tree_dependency.png - -* `Perturbation `_ -* `Selectors_full `_ -* `Generators_full `_ -* `Psiref_CAS `_ -* `MRCC_Utils `_ - -Documentation -============= -.. Do not edit this section It was auto-generated -.. by the `update_README.py` script. - - -`mrcc `_ - Undocumented - - -`print_cas_coefs `_ - Undocumented - diff --git a/plugins/MRCC_CASSD/mrcc_cassd.irp.f b/plugins/MRCC_CASSD/mrcc_cassd.irp.f deleted file mode 100644 index e784a167..00000000 --- a/plugins/MRCC_CASSD/mrcc_cassd.irp.f +++ /dev/null @@ -1,24 +0,0 @@ -program mrcc - implicit none - if (.not.read_wf) then - print *, 'read_wf has to be true.' - stop 1 - endif - call print_cas_coefs - call run_mrcc -end - -subroutine print_cas_coefs - implicit none - - integer :: i,j - print *, 'CAS' - print *, '===' - do i=1,N_det_cas - print *, psi_cas_coef(i,:) - call debug_det(psi_cas(1,1,i),N_int) - enddo - - call write_double(6,ci_energy(1),"Initial CI energy") -end - diff --git a/plugins/MRCC_CASSD/tree_dependency.png b/plugins/MRCC_CASSD/tree_dependency.png deleted file mode 100644 index 480c38a8..00000000 Binary files a/plugins/MRCC_CASSD/tree_dependency.png and /dev/null differ diff --git a/plugins/MRCC_Utils/.gitignore b/plugins/MRCC_Utils/.gitignore index e6279f11..4c65ce66 100644 --- a/plugins/MRCC_Utils/.gitignore +++ b/plugins/MRCC_Utils/.gitignore @@ -24,8 +24,9 @@ Psiref_CAS Psiref_Utils Selectors_full Utils +ZMQ ezfio_interface.irp.f irpf90.make irpf90_entities -mrcc_general +mrcc_dummy tags \ No newline at end of file diff --git a/plugins/MRCC_Utils/H_apply.irp.f b/plugins/MRCC_Utils/H_apply.irp.f index 1cafc8de..4d8964bf 100644 --- a/plugins/MRCC_Utils/H_apply.irp.f +++ b/plugins/MRCC_Utils/H_apply.irp.f @@ -3,19 +3,19 @@ BEGIN_SHELL [ /usr/bin/env python ] from generate_h_apply import * s = H_apply("mrcc") -s.data["parameters"] = ", delta_ij_, delta_ii_,Ndet_ref, Ndet_non_ref" +s.data["parameters"] = ", delta_ij_, delta_ii_, Nstates, Ndet_non_ref, Ndet_ref" s.data["declarations"] += """ - integer, intent(in) :: Ndet_ref,Ndet_non_ref - double precision, intent(in) :: delta_ij_(Ndet_ref,Ndet_non_ref,*) - double precision, intent(in) :: delta_ii_(Ndet_ref,*) + integer, intent(in) :: Nstates, Ndet_ref, Ndet_non_ref + double precision, intent(in) :: delta_ij_(Nstates, Ndet_non_ref, Ndet_ref) + double precision, intent(in) :: delta_ii_(Nstates, Ndet_ref) """ -s.data["keys_work"] = "call mrcc_dress(delta_ij_,delta_ii_,Ndet_ref,Ndet_non_ref,i_generator,key_idx,keys_out,N_int,iproc,key_mask)" -s.data["params_post"] += ", delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref" -s.data["params_main"] += "delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref" +s.data["keys_work"] = "call mrcc_dress(delta_ij_,delta_ii_,Nstates,Ndet_non_ref,Ndet_ref,i_generator,key_idx,keys_out,N_int,iproc,key_mask)" +s.data["params_post"] += ", delta_ij_, delta_ii_, Nstates, Ndet_non_ref, Ndet_ref" +s.data["params_main"] += "delta_ij_, delta_ii_, Nstates, Ndet_non_ref, Ndet_ref" s.data["decls_main"] += """ - integer, intent(in) :: Ndet_ref,Ndet_non_ref - double precision, intent(in) :: delta_ij_(Ndet_ref,Ndet_non_ref,*) - double precision, intent(in) :: delta_ii_(Ndet_ref,*) + integer, intent(in) :: Ndet_ref, Ndet_non_ref, Nstates + double precision, intent(in) :: delta_ij_(Nstates,Ndet_non_ref,Ndet_ref) + double precision, intent(in) :: delta_ii_(Nstates,Ndet_ref) """ s.data["finalization"] = "" s.data["copy_buffer"] = "" @@ -24,27 +24,18 @@ s.data["size_max"] = "3072" print s -s = H_apply("mrcepa") -s.data["parameters"] = ", delta_ij_, delta_ii_,Ndet_ref, Ndet_non_ref" -s.data["declarations"] += """ - integer, intent(in) :: Ndet_ref,Ndet_non_ref - double precision, intent(in) :: delta_ij_(Ndet_ref,Ndet_non_ref,*) - double precision, intent(in) :: delta_ii_(Ndet_ref,*) -""" -s.data["keys_work"] = "call mrcepa_dress(delta_ij_,delta_ii_,Ndet_ref,Ndet_non_ref,i_generator,key_idx,keys_out,N_int,iproc,key_mask)" -s.data["params_post"] += ", delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref" -s.data["params_main"] += "delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref" -s.data["decls_main"] += """ - integer, intent(in) :: Ndet_ref,Ndet_non_ref - double precision, intent(in) :: delta_ij_(Ndet_ref,Ndet_non_ref,*) - double precision, intent(in) :: delta_ii_(Ndet_ref,*) -""" -s.data["finalization"] = "" -s.data["copy_buffer"] = "" -s.data["generate_psi_guess"] = "" -s.data["size_max"] = "3072" -# print s +s = H_apply("mrcc_PT2") +s.energy = "ci_electronic_energy_dressed" +s.set_perturbation("epstein_nesbet_2x2") +s.unset_openmp() +print s + +s = H_apply_zmq("mrcepa_PT2") +s.energy = "psi_energy" +s.set_perturbation("epstein_nesbet_2x2") +s.unset_openmp() +print s END_SHELL diff --git a/plugins/MRCC_Utils/NEEDED_CHILDREN_MODULES b/plugins/MRCC_Utils/NEEDED_CHILDREN_MODULES index 7392852a..801d2f51 100644 --- a/plugins/MRCC_Utils/NEEDED_CHILDREN_MODULES +++ b/plugins/MRCC_Utils/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Selectors_full Generators_full Psiref_Utils Psiref_CAS +Perturbation Selectors_full Generators_full Psiref_Utils Psiref_CAS diff --git a/plugins/MRCC_Utils/README.rst b/plugins/MRCC_Utils/README.rst index 8b97bfbe..39b5684c 100644 --- a/plugins/MRCC_Utils/README.rst +++ b/plugins/MRCC_Utils/README.rst @@ -10,6 +10,7 @@ Needed Modules * `Selectors_full `_ * `Generators_full `_ * `Psiref_Utils `_ +* `Psiref_CAS `_ Documentation ============= @@ -21,14 +22,6 @@ Documentation Undocumented -`abort_all `_ - If True, all the calculation is aborted - - -`abort_here `_ - If True, all the calculation is aborted - - `add_poly `_ Add two polynomials D(t) =! D(t) +( B(t)+C(t)) @@ -43,11 +36,11 @@ Documentation Compute 1st dimension such that it is aligned for vectorization. -`apply_rotation `_ +`apply_rotation `_ Apply the rotation found by find_rotation -`approx_dble `_ +`approx_dble `_ Undocumented @@ -70,23 +63,19 @@ Documentation Binomial coefficients -`catch_signal `_ - What to do on Ctrl-C. If two Ctrl-C are pressed within 1 sec, the calculation if aborted. - - -`ci_eigenvectors_dressed `_ +`ci_eigenvectors_dressed `_ Eigenvectors/values of the CI matrix -`ci_eigenvectors_s2_dressed `_ +`ci_eigenvectors_s2_dressed `_ Eigenvectors/values of the CI matrix -`ci_electronic_energy_dressed `_ +`ci_electronic_energy_dressed `_ Eigenvectors/values of the CI matrix -`ci_energy_dressed `_ +`ci_energy_dressed `_ N_states lowest eigenvalues of the dressed CI matrix @@ -150,15 +139,15 @@ Documentation Undocumented -`delta_ii `_ +`delta_ii `_ Dressing matrix in N_det basis -`delta_ij `_ +`delta_ij `_ Dressing matrix in N_det basis -`diagonalize_ci_dressed `_ +`diagonalize_ci_dressed `_ Replace the coefficients of the CI states by the coefficients of the eigenstates of the CI matrix @@ -198,11 +187,15 @@ Documentation 1/n! -`find_rotation `_ +`find_rotation `_ Find A.C = B -`find_triples_and_quadruples `_ +`find_triples_and_quadruples `_ + Undocumented + + +`find_triples_and_quadruples_micro `_ Undocumented @@ -228,23 +221,7 @@ Documentation Undocumented -`gen_det_idx `_ - Undocumented - - -`gen_det_shortcut `_ - Undocumented - - -`gen_det_sorted `_ - Undocumented - - -`gen_det_version `_ - Undocumented - - -`get_pseudo_inverse `_ +`get_pseudo_inverse `_ Find C = A^-1 @@ -304,7 +281,32 @@ h_apply_mrcc_monoexc Assume N_int is already provided. -`h_matrix_dressed `_ +h_apply_mrcc_pt2 + 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. + + +h_apply_mrcc_pt2_diexc + Undocumented + + +h_apply_mrcc_pt2_diexcorg + Generate all double excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_mrcc_pt2_diexcp + Undocumented + + +h_apply_mrcc_pt2_monoexc + Generate all single excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +`h_matrix_dressed `_ Dressed H with Delta_ij @@ -390,7 +392,11 @@ h_apply_mrcc_monoexc Hermite polynomial -`i2radix_sort `_ +`hij_mrcc `_ + < ref | H | Non-ref > matrix + + +`i2radix_sort `_ Sort integer array x(isize) using the radix sort algorithm. iorder in input should be (1,2,3,...,isize), and in output contains the new order of the elements. @@ -415,14 +421,14 @@ h_apply_mrcc_monoexc contains the new order of the elements. -`i8radix_sort `_ +`i8radix_sort `_ Sort integer array x(isize) using the radix sort algorithm. iorder in input should be (1,2,3,...,isize), and in output contains the new order of the elements. iradix should be -1 in input. -`i8radix_sort_big `_ +`i8radix_sort_big `_ Sort integer array x(isize) using the radix sort algorithm. iorder in input should be (1,2,3,...,isize), and in output contains the new order of the elements. @@ -521,14 +527,14 @@ h_apply_mrcc_monoexc 1/i -`iradix_sort `_ +`iradix_sort `_ Sort integer array x(isize) using the radix sort algorithm. iorder in input should be (1,2,3,...,isize), and in output contains the new order of the elements. iradix should be -1 in input. -`iradix_sort_big `_ +`iradix_sort_big `_ Sort integer array x(isize) using the radix sort algorithm. iorder in input should be (1,2,3,...,isize), and in output contains the new order of the elements. @@ -553,19 +559,15 @@ h_apply_mrcc_monoexc contains the new order of the elements. -`lambda_mrcc `_ +`lambda_mrcc `_ cm/ or perturbative 1/Delta_E(m) -`lambda_mrcc_tmp `_ - Undocumented - - -`lambda_pert `_ +`lambda_mrcc_pt2 `_ cm/ or perturbative 1/Delta_E(m) -`lapack_diag `_ +`lapack_diag `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -576,7 +578,7 @@ h_apply_mrcc_monoexc .br -`lapack_diag_s2 `_ +`lapack_diag_s2 `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -587,7 +589,7 @@ h_apply_mrcc_monoexc .br -`lapack_diagd `_ +`lapack_diagd `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -598,7 +600,7 @@ h_apply_mrcc_monoexc .br -`lapack_partial_diag `_ +`lapack_partial_diag `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -613,7 +615,11 @@ h_apply_mrcc_monoexc n! -`mrcc_dress `_ +`lowercase `_ + Transform to lower case + + +`mrcc_dress `_ Undocumented @@ -626,7 +632,7 @@ h_apply_mrcc_monoexc D(t) =! D(t) +( B(t)*C(t)) -`normalize `_ +`normalize `_ Normalizes vector u u is expected to be aligned in memory. @@ -635,8 +641,8 @@ h_apply_mrcc_monoexc Number of current OpenMP threads -`ortho_lowdin `_ - Compute C_new=C_old.S^-1/2 canonical orthogonalization. +`ortho_canonical `_ + Compute C_new=C_old.U.s^-1/2 canonical orthogonalization. .br overlap : overlap matrix .br @@ -653,8 +659,22 @@ h_apply_mrcc_monoexc .br -`oscillations `_ - Undocumented +`ortho_lowdin `_ + Compute C_new=C_old.S^-1/2 orthogonalization. + .br + overlap : overlap matrix + .br + LDA : leftmost dimension of overlap array + .br + N : Overlap matrix is NxN (array is (LDA,N) ) + .br + C : Coefficients of the vectors to orthogonalize. On exit, + orthogonal vectors + .br + LDC : leftmost dimension of C + .br + m : Coefficients matrix is MxN, ( array is (LDC,N) ) + .br `overlap_a_b_c `_ @@ -683,7 +703,7 @@ h_apply_mrcc_monoexc .br -`pert_determinants `_ +`pouet `_ Undocumented @@ -754,7 +774,7 @@ h_apply_mrcc_monoexc Undocumented -`set_generators_bitmasks_as_holes_and_particles `_ +`set_generators_bitmasks_as_holes_and_particles `_ Undocumented @@ -770,7 +790,7 @@ h_apply_mrcc_monoexc to be in integer*8 format -`set_zero_extra_diag `_ +`set_zero_extra_diag `_ Undocumented @@ -788,11 +808,16 @@ h_apply_mrcc_monoexc Stop the progress bar -`trap_signals `_ - What to do when a signal is caught. Here, trap Ctrl-C and call the control_C subroutine. +`svd `_ + Compute A = U.D.Vt + .br + LDx : leftmost dimension of x + .br + Dimsneion of A is m x n + .br -`u_dot_u `_ +`u_dot_u `_ Compute diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index d278ba13..7033ea61 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -1,7 +1,4 @@ - - - -subroutine davidson_diag_mrcc(dets_in,u_in,energies,dim_in,sze,N_st,Nint,iunit,istate) +subroutine davidson_diag_mrcc(dets_in,u_in,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit,istate) use bitmasks implicit none BEGIN_DOC @@ -22,15 +19,16 @@ subroutine davidson_diag_mrcc(dets_in,u_in,energies,dim_in,sze,N_st,Nint,iunit,i ! ! Initial guess vectors are not necessarily orthonormal END_DOC - integer, intent(in) :: dim_in, sze, N_st, Nint, iunit, istate + integer, intent(in) :: dim_in, sze, N_st, Nint, iunit, istate, N_st_diag integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) - double precision, intent(inout) :: u_in(dim_in,N_st) - double precision, intent(out) :: energies(N_st) + double precision, intent(inout) :: u_in(dim_in,N_st_diag) + double precision, intent(out) :: energies(N_st_diag) double precision, allocatable :: H_jj(:) double precision :: diag_h_mat_elem integer :: i ASSERT (N_st > 0) + ASSERT (N_st_diag >= N_st) ASSERT (sze > 0) ASSERT (Nint > 0) ASSERT (Nint == N_int) @@ -47,16 +45,16 @@ subroutine davidson_diag_mrcc(dets_in,u_in,energies,dim_in,sze,N_st,Nint,iunit,i !$OMP END DO !$OMP DO SCHEDULE(guided) do i=1,N_det_ref - H_jj(idx_ref(i)) += delta_ii(i,istate) + H_jj(idx_ref(i)) += delta_ii(istate,i) enddo !$OMP END DO !$OMP END PARALLEL - call davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nint,iunit,istate) + call davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit,istate) deallocate (H_jj) end -subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nint,iunit,istate) +subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit,istate) use bitmasks implicit none BEGIN_DOC @@ -74,38 +72,44 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nin ! sze : Number of determinants ! ! N_st : Number of eigenstates + ! + ! N_st_diag : Number of states in which H is diagonalized ! ! iunit : Unit for the I/O ! ! Initial guess vectors are not necessarily orthonormal END_DOC - integer, intent(in) :: dim_in, sze, N_st, Nint, istate + integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint, istate integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) double precision, intent(in) :: H_jj(sze) integer, intent(in) :: iunit - double precision, intent(inout) :: u_in(dim_in,N_st) - double precision, intent(out) :: energies(N_st) + double precision, intent(inout) :: u_in(dim_in,N_st_diag) + double precision, intent(out) :: energies(N_st_diag) + integer :: sze_8 integer :: iter integer :: i,j,k,l,m logical :: converged - double precision :: overlap(N_st,N_st) + double precision, allocatable :: overlap(:,:) double precision :: u_dot_v, u_dot_u - integer, allocatable :: kl_pairs(:,:) integer :: k_pairs, kl integer :: iter2 double precision, allocatable :: W(:,:,:), U(:,:,:), R(:,:) double precision, allocatable :: y(:,:,:,:), h(:,:,:,:), lambda(:) + double precision, allocatable :: c(:), H_small(:,:) double precision :: diag_h_mat_elem - double precision :: residual_norm(N_st) + double precision, allocatable :: residual_norm(:) character*(16384) :: write_buffer double precision :: to_print(2,N_st) double precision :: cpu, wall + include 'constants.include.F' - !PROVIDE det_connections + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, R, y, h, lambda + + PROVIDE nuclear_repulsion call write_time(iunit) call wall_time(wall) @@ -115,7 +119,9 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nin write(iunit,'(A)') '------------------------' write(iunit,'(A)') '' call write_int(iunit,N_st,'Number of states') + call write_int(iunit,N_st_diag,'Number of states in diagonalization') call write_int(iunit,sze,'Number of determinants') + call write_int(iunit,istate,'Using dressing for state ') write(iunit,'(A)') '' write_buffer = '===== ' do i=1,N_st @@ -133,16 +139,23 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nin enddo write(iunit,'(A)') trim(write_buffer) + integer, external :: align_double + sze_8 = align_double(sze) + allocate( & - kl_pairs(2,N_st*(N_st+1)/2), & - W(sze,N_st,davidson_sze_max), & - U(sze,N_st,davidson_sze_max), & - R(sze,N_st), & - h(N_st,davidson_sze_max,N_st,davidson_sze_max), & - y(N_st,davidson_sze_max,N_st,davidson_sze_max), & - lambda(N_st*davidson_sze_max)) + W(sze_8,N_st_diag,davidson_sze_max), & + U(sze_8,N_st_diag,davidson_sze_max), & + R(sze_8,N_st_diag), & + h(N_st_diag,davidson_sze_max,N_st_diag,davidson_sze_max), & + y(N_st_diag,davidson_sze_max,N_st_diag,davidson_sze_max), & + residual_norm(N_st_diag), & + overlap(N_st_diag,N_st_diag), & + c(N_st_diag*davidson_sze_max), & + H_small(N_st_diag,N_st_diag), & + lambda(N_st_diag*davidson_sze_max)) ASSERT (N_st > 0) + ASSERT (N_st_diag >= N_st) ASSERT (sze > 0) ASSERT (Nint > 0) ASSERT (Nint == N_int) @@ -151,134 +164,121 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nin ! ============== - - k_pairs=0 - do l=1,N_st - do k=1,l - k_pairs+=1 - kl_pairs(1,k_pairs) = k - kl_pairs(2,k_pairs) = l - enddo - enddo - - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP SHARED(U,sze,N_st,overlap,kl_pairs,k_pairs, & - !$OMP Nint,dets_in,u_in) & - !$OMP PRIVATE(k,l,kl,i) - - - ! Orthonormalize initial guess - ! ============================ - - !$OMP DO - do kl=1,k_pairs - k = kl_pairs(1,kl) - l = kl_pairs(2,kl) - if (k/=l) then - overlap(k,l) = u_dot_v(U_in(1,k),U_in(1,l),sze) - overlap(l,k) = overlap(k,l) - else - overlap(k,k) = u_dot_u(U_in(1,k),sze) - endif - enddo - !$OMP END DO - !$OMP END PARALLEL + do k=1,N_st_diag + + if (k > N_st) then + do i=1,sze + double precision :: r1, r2 + call random_number(r1) + call random_number(r2) + u_in(i,k) = dsqrt(-2.d0*dlog(r1))*dcos(dtwo_pi*r2) + enddo + endif + + ! Gram-Schmidt + ! ------------ + call dgemv('T',sze,k-1,1.d0,u_in,size(u_in,1), & + u_in(1,k),1,0.d0,c,1) + call dgemv('N',sze,k-1,-1.d0,u_in,size(u_in,1), & + c,1,1.d0,u_in(1,k),1) + call normalize(u_in(1,k),sze) + enddo + - call ortho_lowdin(overlap,size(overlap,1),N_st,U_in,size(U_in,1),sze) - - ! Davidson iterations - ! =================== converged = .False. - do while (.not.converged) - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(k,i) SHARED(U,u_in,sze,N_st) - do k=1,N_st - !$OMP DO + do k=1,N_st_diag do i=1,sze U(i,k,1) = u_in(i,k) enddo - !$OMP END DO enddo - !$OMP END PARALLEL - + do iter=1,davidson_sze_max-1 - ! Compute W_k = H |u_k> - ! ---------------------- + ! Compute |W_k> = \sum_i |i> + ! ----------------------------------------- + + call H_u_0_mrcc_nstates(W(1,1,iter),U(1,1,iter),H_jj,sze,dets_in,Nint,istate,N_st_diag,sze_8) - do k=1,N_st - call H_u_0_mrcc(W(1,k,iter),U(1,k,iter),H_jj,sze,dets_in,Nint,istate) - enddo ! Compute h_kl = = ! ------------------------------------------- - do l=1,N_st - do k=1,N_st - do iter2=1,iter-1 - h(k,iter2,l,iter) = u_dot_v(U(1,k,iter2),W(1,l,iter),sze) - h(k,iter,l,iter2) = h(k,iter2,l,iter) - enddo - enddo - do k=1,l - h(k,iter,l,iter) = u_dot_v(U(1,k,iter),W(1,l,iter),sze) - h(l,iter,k,iter) = h(k,iter,l,iter) - enddo - enddo - !DEBUG H MATRIX - !do i=1,iter - ! print '(10(x,F16.10))', h(1,i,1,1:i) - !enddo - !print *, '' - !END - +! do l=1,N_st_diag +! do k=1,N_st_diag +! do iter2=1,iter-1 +! h(k,iter2,l,iter) = u_dot_v(U(1,k,iter2),W(1,l,iter),sze) +! h(k,iter,l,iter2) = h(k,iter2,l,iter) +! enddo +! enddo +! do k=1,l +! h(k,iter,l,iter) = u_dot_v(U(1,k,iter),W(1,l,iter),sze) +! h(l,iter,k,iter) = h(k,iter,l,iter) +! enddo +! enddo + + call dgemm('T','N', N_st_diag*iter, N_st_diag, sze, & + 1.d0, U, size(U,1), W(1,1,iter), size(W,1), & + 0.d0, h(1,1,1,iter), size(h,1)*size(h,2)) + ! Diagonalize h ! ------------- - call lapack_diag(lambda,y,h,N_st*davidson_sze_max,N_st*iter) + call lapack_diag(lambda,y,h,N_st_diag*davidson_sze_max,N_st_diag*iter) ! Express eigenvectors of h in the determinant basis ! -------------------------------------------------- - do k=1,N_st + do k=1,N_st_diag do i=1,sze U(i,k,iter+1) = 0.d0 W(i,k,iter+1) = 0.d0 - do l=1,N_st - do iter2=1,iter - U(i,k,iter+1) = U(i,k,iter+1) + U(i,l,iter2)*y(l,iter2,k,1) - W(i,k,iter+1) = W(i,k,iter+1) + W(i,l,iter2)*y(l,iter2,k,1) - enddo - enddo enddo enddo - +! do k=1,N_st_diag +! do iter2=1,iter +! do l=1,N_st_diag +! do i=1,sze +! U(i,k,iter+1) = U(i,k,iter+1) + U(i,l,iter2)*y(l,iter2,k,1) +! W(i,k,iter+1) = W(i,k,iter+1) + W(i,l,iter2)*y(l,iter2,k,1) +! enddo +! enddo +! enddo +! enddo +! +! + call dgemm('N','N', sze, N_st_diag, N_st_diag*iter, & + 1.d0, U, size(U,1), y, size(y,1)*size(y,2), 0.d0, U(1,1,iter+1), size(U,1)) + call dgemm('N','N',sze,N_st_diag,N_st_diag*iter, & + 1.d0, W, size(W,1), y, size(y,1)*size(y,2), 0.d0, W(1,1,iter+1), size(W,1)) + + ! Compute residual vector ! ----------------------- - do k=1,N_st + do k=1,N_st_diag do i=1,sze R(i,k) = lambda(k) * U(i,k,iter+1) - W(i,k,iter+1) enddo - residual_norm(k) = u_dot_u(R(1,k),sze) - to_print(1,k) = lambda(k) + nuclear_repulsion - to_print(2,k) = residual_norm(k) + if (k <= N_st) then + residual_norm(k) = u_dot_u(R(1,k),sze) + to_print(1,k) = lambda(k) + nuclear_repulsion + to_print(2,k) = residual_norm(k) + endif 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 endif - ! Davidson step ! ------------- - do k=1,N_st + do k=1,N_st_diag do i=1,sze U(i,k,iter+1) = -1.d0/max(H_jj(i) - lambda(k),1.d-2) * R(i,k) enddo @@ -287,37 +287,36 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nin ! Gram-Schmidt ! ------------ - double precision :: c - do k=1,N_st - do iter2=1,iter - do l=1,N_st - c = u_dot_v(U(1,k,iter+1),U(1,l,iter2),sze) - do i=1,sze - U(i,k,iter+1) -= c * U(i,l,iter2) - enddo - enddo - enddo - do l=1,k-1 - c = u_dot_v(U(1,k,iter+1),U(1,l,iter+1),sze) - do i=1,sze - U(i,k,iter+1) -= c * U(i,l,iter+1) - enddo - enddo + do k=1,N_st_diag + +! do iter2=1,iter +! do l=1,N_st_diag +! c(1) = u_dot_v(U(1,k,iter+1),U(1,l,iter2),sze) +! do i=1,sze +! U(i,k,iter+1) = U(i,k,iter+1) - c(1) * U(i,l,iter2) +! enddo +! enddo +! enddo +! + call dgemv('T',sze,N_st_diag*iter,1.d0,U,size(U,1), & + U(1,k,iter+1),1,0.d0,c,1) + call dgemv('N',sze,N_st_diag*iter,-1.d0,U,size(U,1), & + c,1,1.d0,U(1,k,iter+1),1) +! +! do l=1,k-1 +! c(1) = u_dot_v(U(1,k,iter+1),U(1,l,iter+1),sze) +! do i=1,sze +! U(i,k,iter+1) = U(i,k,iter+1) - c(1) * U(i,l,iter+1) +! enddo +! enddo +! + call dgemv('T',sze,k-1,1.d0,U(1,1,iter+1),size(U,1), & + U(1,k,iter+1),1,0.d0,c,1) + call dgemv('N',sze,k-1,-1.d0,U(1,1,iter+1),size(U,1), & + c,1,1.d0,U(1,k,iter+1),1) + call normalize( U(1,k,iter+1), sze ) enddo - - !DEBUG : CHECK OVERLAP - !print *, '===' - !do k=1,iter+1 - ! do l=1,k - ! c = u_dot_v(U(1,1,k),U(1,1,l),sze) - ! print *, k,l, c - ! enddo - !enddo - !print *, '===' - !pause - !END DEBUG - enddo @@ -328,17 +327,25 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nin ! Re-contract to u_in ! ----------- - do k=1,N_st + do k=1,N_st_diag energies(k) = lambda(k) do i=1,sze u_in(i,k) = 0.d0 - do iter2=1,iter - do l=1,N_st - u_in(i,k) += U(i,l,iter2)*y(l,iter2,k,1) - enddo - enddo enddo enddo +! do k=1,N_st_diag +! do i=1,sze +! do iter2=1,iter +! do l=1,N_st_diag +! u_in(i,k) += U(i,l,iter2)*y(l,iter2,k,1) +! enddo +! enddo +! enddo +! enddo + + call dgemm('N','N', sze, N_st_diag, N_st_diag*iter, 1.d0, & + U, size(U,1), y, N_st_diag*davidson_sze_max, & + 0.d0, u_in, size(u_in,1)) enddo @@ -351,10 +358,9 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nin call write_time(iunit) deallocate ( & - kl_pairs, & - W, & - U, & - R, & + W, residual_norm, & + U, overlap, & + R, c, & h, & y, & lambda & @@ -362,8 +368,42 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nin end +subroutine u_0_H_u_0_mrcc_nstates(e_0,u_0,n,keys_tmp,Nint,istate,N_st,sze_8) + use bitmasks + implicit none + BEGIN_DOC + ! Computes e_0 = / + ! + ! n : number of determinants + ! + END_DOC + integer, intent(in) :: n,Nint,N_st,sze_8 + double precision, intent(out) :: e_0(N_st) + double precision, intent(in) :: u_0(sze_8,N_st) + integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) + integer,intent(in) :: istate + + double precision, allocatable :: v_0(:,:), H_jj(:) + double precision :: u_dot_u,u_dot_v,diag_H_mat_elem + integer :: i,j + allocate(H_jj(n), v_0(sze_8,N_st)) + do i = 1, n + H_jj(i) = diag_H_mat_elem(keys_tmp(1,1,i),Nint) + enddo -subroutine H_u_0_mrcc(v_0,u_0,H_jj,n,keys_tmp,Nint,istate) + do i=1,N_det_ref + H_jj(idx_ref(i)) += delta_ii(istate,i) + enddo + + call H_u_0_mrcc_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,istate,N_st,sze_8) + do i=1,N_st + e_0(i) = u_dot_v(v_0(1,i),u_0(1,i),n)/u_dot_u(u_0(1,i),n) + enddo + deallocate(H_jj, v_0) +end + + +subroutine H_u_0_mrcc_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,istate_in,N_st,sze_8) use bitmasks implicit none BEGIN_DOC @@ -373,130 +413,675 @@ subroutine H_u_0_mrcc(v_0,u_0,H_jj,n,keys_tmp,Nint,istate) ! ! H_jj : array of END_DOC - integer, intent(in) :: n,Nint,istate - double precision, intent(out) :: v_0(n) - double precision, intent(in) :: u_0(n) + integer, intent(in) :: n,Nint,istate_in,N_st,sze_8 + double precision, intent(out) :: v_0(sze_8,N_st) + double precision, intent(in) :: u_0(sze_8,N_st) double precision, intent(in) :: H_jj(n) integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) - integer, allocatable :: idx(:) double precision :: hij - double precision, allocatable :: vt(:) + double precision, allocatable :: vt(:,:) integer :: i,j,k,l, jj,ii integer :: i0, j0 + integer(bit_kind) :: sorted_i(Nint) + - integer :: shortcut(0:n+1), sort_idx(n) - integer(bit_kind) :: sorted(Nint,n), version(Nint,n) + integer,allocatable :: shortcut(:,:), sort_idx(:,:) + integer(bit_kind), allocatable :: sorted(:,:,:), version(:,:,:) - integer :: sh, sh2, ni, exa, ext, org_i, org_j, endi, pass -! - + integer :: sh, sh2, ni, exa, ext, org_i, org_j, endi, pass, istate + + ASSERT (Nint > 0) ASSERT (Nint == N_int) ASSERT (n>0) - PROVIDE ref_bitmask_energy delta_ij - integer, parameter :: block_size = 157 - - - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(i,hij,j,k,idx,jj,vt,ii,sh, sh2, ni, exa, ext, org_i, org_j, endi, pass) & - !$OMP SHARED(n_det_ref,n_det_non_ref,idx_ref,idx_non_ref,n,H_jj,u_0,keys_tmp,Nint,v_0,istate,delta_ij,sorted,shortcut,sort_idx,version) - - - - !$OMP DO SCHEDULE(static) - do i=1,n - v_0(i) = H_jj(i) * u_0(i) - enddo - !$OMP END DO + PROVIDE ref_bitmask_energy + allocate (shortcut(0:n+1,2), sort_idx(n,2), sorted(Nint,n,2), version(Nint,n,2)) + v_0 = 0.d0 - allocate(idx(0:n), vt(n)) + call sort_dets_ab_v(keys_tmp, sorted(1,1,1), sort_idx(1,1), shortcut(0,1), version(1,1,1), n, Nint) + call sort_dets_ba_v(keys_tmp, sorted(1,1,2), sort_idx(1,2), shortcut(0,2), version(1,1,2), n, Nint) + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(i,hij,j,k,jj,vt,ii,sh,sh2,ni,exa,ext,org_i,org_j,endi,sorted_i,istate)& + !$OMP SHARED(n,H_jj,u_0,keys_tmp,Nint,v_0,sorted,shortcut,sort_idx,version,N_st,sze_8,& + !$OMP istate_in,delta_ij,N_det_ref,N_det_non_ref,idx_ref,idx_non_ref) + allocate(vt(sze_8,N_st)) Vt = 0.d0 - - !$OMP SINGLE - call sort_dets_ab_v(keys_tmp, sorted, sort_idx, shortcut, version, n, Nint) - !$OMP END SINGLE - - !$OMP DO SCHEDULE(dynamic) - do sh=1,shortcut(0) - do sh2=1,sh - exa = 0 - do ni=1,Nint - exa += popcnt(xor(version(ni,sh), version(ni,sh2))) - end do - if(exa > 2) then - cycle - end if - - do i=shortcut(sh),shortcut(sh+1)-1 - if(sh==sh2) then - endi = i-1 - else - endi = shortcut(sh2+1)-1 + do sh=1,shortcut(0,1) + do sh2=sh,shortcut(0,1) + exa = 0 + do ni=1,Nint + exa = exa + popcnt(xor(version(ni,sh,1), version(ni,sh2,1))) + end do + if(exa > 2) then + cycle end if - do j=shortcut(sh2),endi - ext = exa - do ni=1,Nint - ext += popcnt(xor(sorted(ni,i), sorted(ni,j))) - end do - if(ext <= 4) then - org_i = sort_idx(i) - org_j = sort_idx(j) - - call i_H_j(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),Nint,hij) - vt (org_i) = vt (org_i) + hij*u_0(org_j) - vt (org_j) = vt (org_j) + hij*u_0(org_i) + do i=shortcut(sh,1),shortcut(sh+1,1)-1 + org_i = sort_idx(i,1) + if(sh==sh2) then + endi = i-1 + else + endi = shortcut(sh2+1,1)-1 end if - end do - end do - end do + do ni=1,Nint + sorted_i(ni) = sorted(ni,i,1) + enddo + + do j=shortcut(sh2,1),endi + org_j = sort_idx(j,1) + ext = exa + do ni=1,Nint + ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) + end do + if(ext <= 4) then + call i_H_j(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),Nint,hij) + do istate=1,N_st + vt (org_i,istate) = vt (org_i,istate) + hij*u_0(org_j,istate) + vt (org_j,istate) = vt (org_j,istate) + hij*u_0(org_i,istate) + enddo + endif + enddo + enddo + enddo enddo - !$OMP END DO + !$OMP END DO NOWAIT - !$OMP SINGLE - call sort_dets_ba_v(keys_tmp, sorted, sort_idx, shortcut, version, n, Nint) - !$OMP END SINGLE - !$OMP DO SCHEDULE(dynamic) - do sh=1,shortcut(0) - do i=shortcut(sh),shortcut(sh+1)-1 - do j=shortcut(sh),i-1 + do sh=1,shortcut(0,2) + do i=shortcut(sh,2),shortcut(sh+1,2)-1 + org_i = sort_idx(i,2) + do j=shortcut(sh,2),i-1 + org_j = sort_idx(j,2) ext = 0 do ni=1,Nint - ext += popcnt(xor(sorted(ni,i), sorted(ni,j))) + ext = ext + popcnt(xor(sorted(ni,i,2), sorted(ni,j,2))) end do if(ext == 4) then - org_i = sort_idx(i) - org_j = sort_idx(j) call i_H_j(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),Nint,hij) - vt (org_i) = vt (org_i) + hij*u_0(org_j) - vt (org_j) = vt (org_j) + hij*u_0(org_i) + do istate=1,N_st + vt (org_i,istate) = vt (org_i,istate) + hij*u_0(org_j,istate) + vt (org_j,istate) = vt (org_j,istate) + hij*u_0(org_i,istate) + enddo end if end do end do enddo - !$OMP END DO + !$OMP END DO NOWAIT - - !$OMP DO SCHEDULE(guided) + !$OMP DO do ii=1,n_det_ref i = idx_ref(ii) do jj = 1, n_det_non_ref j = idx_non_ref(jj) - vt (i) = vt (i) + delta_ij(ii,jj,istate)*u_0(j) - vt (j) = vt (j) + delta_ij(ii,jj,istate)*u_0(i) + do istate=1,N_st + vt (i,istate) = vt (i,istate) + delta_ij(istate_in,jj,ii)*u_0(j,istate) + vt (j,istate) = vt (j,istate) + delta_ij(istate_in,jj,ii)*u_0(i,istate) + enddo enddo enddo !$OMP END DO + !$OMP CRITICAL - do i=1,n - v_0(i) = v_0(i) + vt(i) + do istate=1,N_st + do i=n,1,-1 + v_0(i,istate) = v_0(i,istate) + vt(i,istate) + enddo enddo !$OMP END CRITICAL - deallocate(idx,vt) + + deallocate(vt) !$OMP END PARALLEL + + do istate=1,N_st + do i=1,n + v_0(i,istate) += H_jj(i) * u_0(i,istate) + enddo + enddo + deallocate (shortcut, sort_idx, sorted, version) + +end + + +subroutine davidson_diag_mrcc_hs2(dets_in,u_in,dim_in,energies,sze,N_st,N_st_diag,Nint,iunit,istate) + use bitmasks + implicit none + BEGIN_DOC + ! Davidson diagonalization. + ! + ! dets_in : bitmasks corresponding to determinants + ! + ! u_in : guess coefficients on the various states. Overwritten + ! on exit + ! + ! dim_in : leftmost dimension of u_in + ! + ! sze : Number of determinants + ! + ! N_st : Number of eigenstates + ! + ! iunit : Unit number for the I/O + ! + ! Initial guess vectors are not necessarily orthonormal + END_DOC + integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint, iunit, istate + integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) + double precision, intent(inout) :: u_in(dim_in,N_st_diag) + double precision, intent(out) :: energies(N_st) + double precision, allocatable :: H_jj(:), S2_jj(:) + + double precision :: diag_h_mat_elem + integer :: i + ASSERT (N_st > 0) + ASSERT (sze > 0) + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + PROVIDE mo_bielec_integrals_in_map + allocate(H_jj(sze), S2_jj(sze)) + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP SHARED(sze,H_jj,S2_jj, dets_in,Nint,N_det_ref,delta_ii, & + !$OMP idx_ref, istate) & + !$OMP PRIVATE(i) + !$OMP DO SCHEDULE(guided) + do i=1,sze + H_jj(i) = diag_h_mat_elem(dets_in(1,1,i),Nint) + call get_s2(dets_in(1,1,i),dets_in(1,1,i),Nint,S2_jj(i)) + enddo + !$OMP END DO + !$OMP DO SCHEDULE(guided) + do i=1,N_det_ref + H_jj(idx_ref(i)) += delta_ii(istate,i) + enddo + !$OMP END DO + !$OMP END PARALLEL + + call davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit,istate) + deallocate (H_jj,S2_jj) +end + + +subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit,istate ) + use bitmasks + implicit none + BEGIN_DOC + ! Davidson diagonalization with specific diagonal elements of the H matrix + ! + ! H_jj : specific diagonal H matrix elements to diagonalize de Davidson + ! + ! S2_jj : specific diagonal S^2 matrix elements + ! + ! dets_in : bitmasks corresponding to determinants + ! + ! u_in : guess coefficients on the various states. Overwritten + ! on exit + ! + ! dim_in : leftmost dimension of u_in + ! + ! sze : Number of determinants + ! + ! N_st : Number of eigenstates + ! + ! N_st_diag : Number of states in which H is diagonalized. Assumed > sze + ! + ! iunit : Unit for the I/O + ! + ! Initial guess vectors are not necessarily orthonormal + END_DOC + integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint, istate + integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) + double precision, intent(in) :: H_jj(sze), S2_jj(sze) + integer, intent(in) :: iunit + double precision, intent(inout) :: u_in(dim_in,N_st_diag) + double precision, intent(out) :: energies(N_st_diag) + + integer :: sze_8 + integer :: iter + integer :: i,j,k,l,m + logical :: converged + + double precision :: u_dot_v, u_dot_u + + integer :: k_pairs, kl + + integer :: iter2 + double precision, allocatable :: W(:,:), U(:,:), S(:,:) + double precision, allocatable :: y(:,:), h(:,:), lambda(:), s2(:) + double precision, allocatable :: c(:), s_(:,:), s_tmp(:,:) + double precision :: diag_h_mat_elem + double precision, allocatable :: residual_norm(:) + character*(16384) :: write_buffer + double precision :: to_print(3,N_st) + double precision :: cpu, wall + integer :: shift, shift2, itermax + include 'constants.include.F' + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, S, y, h, lambda + if (N_st_diag > sze) then + stop 'error in Davidson : N_st_diag > sze' + endif + + PROVIDE nuclear_repulsion + + call write_time(iunit) + call wall_time(wall) + call cpu_time(cpu) + write(iunit,'(A)') '' + write(iunit,'(A)') 'Davidson Diagonalization' + write(iunit,'(A)') '------------------------' + write(iunit,'(A)') '' + call write_int(iunit,N_st,'Number of states') + call write_int(iunit,N_st_diag,'Number of states in diagonalization') + call write_int(iunit,sze,'Number of determinants') + call write_int(iunit,istate,'Using dressing for state ') + + write(iunit,'(A)') '' + write_buffer = '===== ' + do i=1,N_st + write_buffer = trim(write_buffer)//' ================ =========== ===========' + enddo + write(iunit,'(A)') trim(write_buffer) + write_buffer = ' Iter' + do i=1,N_st + write_buffer = trim(write_buffer)//' Energy S^2 Residual' + enddo + write(iunit,'(A)') trim(write_buffer) + write_buffer = '===== ' + do i=1,N_st + write_buffer = trim(write_buffer)//' ================ =========== ===========' + enddo + write(iunit,'(A)') trim(write_buffer) + + integer, external :: align_double + sze_8 = align_double(sze) + + double precision :: delta + + if (s2_eig) then + delta = 1.d0 + else + delta = 0.d0 + endif + + itermax = min(davidson_sze_max, sze/N_st_diag) + allocate( & + W(sze_8,N_st_diag*itermax), & + U(sze_8,N_st_diag*itermax), & + S(sze_8,N_st_diag*itermax), & + h(N_st_diag*itermax,N_st_diag*itermax), & + y(N_st_diag*itermax,N_st_diag*itermax), & + s_(N_st_diag*itermax,N_st_diag*itermax), & + s_tmp(N_st_diag*itermax,N_st_diag*itermax), & + residual_norm(N_st_diag), & + c(N_st_diag*itermax), & + s2(N_st_diag*itermax), & + lambda(N_st_diag*itermax)) + + h = 0.d0 + s_ = 0.d0 + s_tmp = 0.d0 + U = 0.d0 + W = 0.d0 + S = 0.d0 + y = 0.d0 + + + ASSERT (N_st > 0) + ASSERT (N_st_diag >= N_st) + ASSERT (sze > 0) + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + + ! Davidson iterations + ! =================== + + converged = .False. + + double precision :: r1, r2 + do k=N_st+1,N_st_diag-2,2 + do i=1,sze + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + u_in(i,k) = r1*dcos(r2) + u_in(i,k+1) = r1*dsin(r2) + enddo + enddo + do k=N_st_diag-1,N_st_diag + do i=1,sze + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + u_in(i,k) = r1*dcos(r2) + enddo + enddo + + + do while (.not.converged) + + do k=1,N_st_diag + do i=1,sze + U(i,k) = u_in(i,k) + enddo + enddo + + do iter=1,davidson_sze_max-1 + + shift = N_st_diag*(iter-1) + shift2 = N_st_diag*iter + + call ortho_qr(U,size(U,1),sze,shift2) + + ! Compute |W_k> = \sum_i |i> + ! ----------------------------------------- + + call H_S2_u_0_mrcc_nstates(W(1,shift+1),S(1,shift+1),U(1,shift+1),H_jj,S2_jj,sze,dets_in,Nint,& + istate,N_st_diag,sze_8) + + + ! Compute h_kl = = + ! ------------------------------------------- + + + call dgemm('T','N', shift2, N_st_diag, sze, & + 1.d0, U, size(U,1), W(1,shift+1), size(W,1), & + 0.d0, h(1,shift+1), size(h,1)) + + call dgemm('T','N', shift2, N_st_diag, sze, & + 1.d0, U, size(U,1), S(1,shift+1), size(S,1), & + 0.d0, s_(1,shift+1), size(s_,1)) + + ! Diagonalize h + ! ------------- + call lapack_diag(lambda,y,h,size(h,1),shift2) + + ! Compute S2 for each eigenvector + ! ------------------------------- + + call dgemm('N','N',shift2,shift2,shift2, & + 1.d0, s_, size(s_,1), y, size(y,1), & + 0.d0, s_tmp, size(s_tmp,1)) + + call dgemm('T','N',shift2,shift2,shift2, & + 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), & + 0.d0, s_, size(s_,1)) + + do k=1,shift2 + s2(k) = s_(k,k) + S_z2_Sz + enddo + + if (s2_eig) then + logical :: state_ok(N_st_diag*davidson_sze_max) + do k=1,shift2 + state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0) + enddo + do k=1,shift2 + if (.not. state_ok(k)) then + do l=k+1,shift2 + if (state_ok(l)) then + call dswap(shift2, y(1,k), 1, y(1,l), 1) + call dswap(1, s2(k), 1, s2(l), 1) + call dswap(1, lambda(k), 1, lambda(l), 1) + state_ok(k) = .True. + state_ok(l) = .False. + exit + endif + enddo + endif + enddo + endif + + + ! Express eigenvectors of h in the determinant basis + ! -------------------------------------------------- + + call dgemm('N','N', sze, N_st_diag, shift2, & + 1.d0, U, size(U,1), y, size(y,1), 0.d0, U(1,shift2+1), size(U,1)) + call dgemm('N','N', sze, N_st_diag, shift2, & + 1.d0, W, size(W,1), y, size(y,1), 0.d0, W(1,shift2+1), size(W,1)) + call dgemm('N','N', sze, N_st_diag, shift2, & + 1.d0, S, size(S,1), y, size(y,1), 0.d0, S(1,shift2+1), size(S,1)) + + ! Compute residual vector + ! ----------------------- + + do k=1,N_st_diag + do i=1,sze + U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & + * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz & + )/max(H_jj(i) - lambda (k),1.d-2) + enddo + if (k <= N_st) then + residual_norm(k) = u_dot_u(U(1,shift2+k),sze) + to_print(1,k) = lambda(k) + nuclear_repulsion + to_print(2,k) = s2(k) + to_print(3,k) = residual_norm(k) + endif + enddo + + write(iunit,'(X,I3,X,100(X,F16.10,X,F11.6,X,E11.3))') iter, to_print(1:3,1:N_st) + call davidson_converged(lambda,residual_norm,wall,iter,cpu,N_st,converged) + do k=1,N_st + if (residual_norm(k) > 1.e8) then + print *, '' + stop 'Davidson failed' + endif + enddo + if (converged) then + exit + endif + + enddo + + if (.not.converged) then + iter = itermax-1 + endif + + ! Re-contract to u_in + ! ----------- + + do k=1,N_st_diag + energies(k) = lambda(k) + enddo + + call dgemm('N','N', sze, N_st_diag, N_st_diag*iter, 1.d0, & + U, size(U,1), y, size(y,1), 0.d0, u_in, size(u_in,1)) + + enddo + + write_buffer = '===== ' + do i=1,N_st + write_buffer = trim(write_buffer)//' ================ =========== ===========' + enddo + write(iunit,'(A)') trim(write_buffer) + write(iunit,'(A)') '' + call write_time(iunit) + + deallocate ( & + W, residual_norm, & + U, & + c, S, & + h, & + y, s_, s_tmp, & + lambda & + ) +end + + +subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_in,N_st,sze_8) + use bitmasks + implicit none + BEGIN_DOC + ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> + ! + ! n : number of determinants + ! + ! H_jj : array of + ! + ! S2_jj : array of + END_DOC + integer, intent(in) :: N_st,n,Nint, sze_8, istate_in + double precision, intent(out) :: v_0(sze_8,N_st), s_0(sze_8,N_st) + double precision, intent(in) :: u_0(sze_8,N_st) + double precision, intent(in) :: H_jj(n), S2_jj(n) + integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) + double precision :: hij,s2 + double precision, allocatable :: vt(:,:), ut(:,:), st(:,:) + integer :: i,j,k,l, jj,ii + integer :: i0, j0 + + integer, allocatable :: shortcut(:,:), sort_idx(:,:) + integer(bit_kind), allocatable :: sorted(:,:,:), version(:,:,:) + integer(bit_kind) :: sorted_i(Nint) + + integer :: sh, sh2, ni, exa, ext, org_i, org_j, endi, istate + integer :: N_st_8 + + integer, external :: align_double + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: vt, ut + + N_st_8 = align_double(N_st) + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + ASSERT (n>0) + PROVIDE ref_bitmask_energy + + allocate (shortcut(0:n+1,2), sort_idx(n,2), sorted(Nint,n,2), version(Nint,n,2)) + allocate(ut(N_st_8,n)) + + v_0 = 0.d0 + s_0 = 0.d0 + + do i=1,n + do istate=1,N_st + ut(istate,i) = u_0(i,istate) + enddo + enddo + + call sort_dets_ab_v(keys_tmp, sorted(1,1,1), sort_idx(1,1), shortcut(0,1), version(1,1,1), n, Nint) + call sort_dets_ba_v(keys_tmp, sorted(1,1,2), sort_idx(1,2), shortcut(0,2), version(1,1,2), n, Nint) + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(i,hij,s2,j,k,jj,vt,st,ii,sh,sh2,ni,exa,ext,org_i,org_j,endi,sorted_i,istate)& + !$OMP SHARED(n,keys_tmp,ut,Nint,v_0,s_0,sorted,shortcut,sort_idx,version,N_st,N_st_8, & + !$OMP N_det_ref, idx_ref, N_det_non_ref, idx_non_ref, delta_ij,istate_in) + allocate(vt(N_st_8,n),st(N_st_8,n)) + Vt = 0.d0 + St = 0.d0 + + !$OMP DO SCHEDULE(dynamic) + do sh=1,shortcut(0,1) + do sh2=sh,shortcut(0,1) + exa = 0 + do ni=1,Nint + exa = exa + popcnt(xor(version(ni,sh,1), version(ni,sh2,1))) + end do + if(exa > 2) then + cycle + end if + + do i=shortcut(sh,1),shortcut(sh+1,1)-1 + org_i = sort_idx(i,1) + if(sh==sh2) then + endi = i-1 + else + endi = shortcut(sh2+1,1)-1 + end if + do ni=1,Nint + sorted_i(ni) = sorted(ni,i,1) + enddo + + do j=shortcut(sh2,1),endi + org_j = sort_idx(j,1) + ext = exa + do ni=1,Nint + ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) + end do + if(ext <= 4) then + call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) + call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) + do istate=1,n_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,org_j) + vt (istate,org_j) = vt (istate,org_j) + hij*ut(istate,org_i) + st (istate,org_i) = st (istate,org_i) + s2*ut(istate,org_j) + st (istate,org_j) = st (istate,org_j) + s2*ut(istate,org_i) + enddo + endif + enddo + enddo + enddo + enddo + !$OMP END DO NOWAIT + !$OMP DO SCHEDULE(dynamic) + do sh=1,shortcut(0,2) + do i=shortcut(sh,2),shortcut(sh+1,2)-1 + org_i = sort_idx(i,2) + do j=shortcut(sh,2),i-1 + org_j = sort_idx(j,2) + ext = 0 + do ni=1,Nint + ext = ext + popcnt(xor(sorted(ni,i,2), sorted(ni,j,2))) + end do + if(ext == 4) then + call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) + call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) + do istate=1,n_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,org_j) + vt (istate,org_j) = vt (istate,org_j) + hij*ut(istate,org_i) + st (istate,org_i) = st (istate,org_i) + s2*ut(istate,org_j) + st (istate,org_j) = st (istate,org_j) + s2*ut(istate,org_i) + enddo + end if + end do + end do + enddo + !$OMP END DO NOWAIT + +! -------------------------- +! Begin Specific to dressing +! -------------------------- + + !$OMP DO + do ii=1,n_det_ref + i = idx_ref(ii) + do jj = 1, n_det_non_ref + j = idx_non_ref(jj) + do istate=1,N_st + vt (istate,i) = vt (istate,i) + delta_ij(istate_in,jj,ii)*ut(istate,j) + vt (istate,j) = vt (istate,j) + delta_ij(istate_in,jj,ii)*ut(istate,i) + enddo + enddo + enddo + !$OMP END DO + +! ------------------------ +! End Specific to dressing +! ------------------------ + + !$OMP CRITICAL + do istate=1,N_st + do i=n,1,-1 + v_0(i,istate) = v_0(i,istate) + vt(istate,i) + s_0(i,istate) = s_0(i,istate) + st(istate,i) + enddo + enddo + !$OMP END CRITICAL + + deallocate(vt,st) + !$OMP END PARALLEL + + do istate=1,N_st + do i=1,n + v_0(i,istate) = v_0(i,istate) + H_jj(i) * u_0(i,istate) + s_0(i,istate) = s_0(i,istate) + s2_jj(i)* u_0(i,istate) + enddo + enddo + deallocate (shortcut, sort_idx, sorted, version, ut) end diff --git a/plugins/MRCC_Utils/mrcc_dress.irp.f b/plugins/MRCC_Utils/mrcc_dress.irp.f index 5747b174..5c2f5efc 100644 --- a/plugins/MRCC_Utils/mrcc_dress.irp.f +++ b/plugins/MRCC_Utils/mrcc_dress.irp.f @@ -14,17 +14,17 @@ BEGIN_PROVIDER [ integer(omp_lock_kind), psi_ref_lock, (psi_det_size) ] END_PROVIDER -subroutine mrcc_dress(delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref,i_generator,n_selected,det_buffer,Nint,iproc,key_mask) +subroutine mrcc_dress(delta_ij_, delta_ii_, Nstates, Ndet_non_ref, Ndet_ref,i_generator,n_selected,det_buffer,Nint,iproc,key_mask) use bitmasks implicit none integer, intent(in) :: i_generator,n_selected, Nint, iproc - integer, intent(in) :: Ndet_ref, Ndet_non_ref - double precision, intent(inout) :: delta_ij_(Ndet_ref,Ndet_non_ref,*) - double precision, intent(inout) :: delta_ii_(Ndet_ref,*) + integer, intent(in) :: Nstates, Ndet_ref, Ndet_non_ref + double precision, intent(inout) :: delta_ij_(Nstates,Ndet_non_ref,Ndet_ref) + double precision, intent(inout) :: delta_ii_(Nstates,Ndet_ref) integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) - integer :: i,j,k,l + integer :: i,j,k,l,m integer :: degree_alpha(psi_det_size) integer :: idx_alpha(0:psi_det_size) logical :: good, fullMatch @@ -32,10 +32,10 @@ subroutine mrcc_dress(delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref,i_generator,n integer(bit_kind) :: tq(Nint,2,n_selected) integer :: N_tq, c_ref ,degree - double precision :: hIk, hla, hIl, dIk(N_states), dka(N_states), dIa(N_states) + double precision :: hIk, hla, hIl, dIk(Nstates), dka(Nstates), dIa(Nstates) double precision, allocatable :: dIa_hla(:,:) double precision :: haj, phase, phase2 - double precision :: f(N_states), ci_inv(N_states) + double precision :: f(Nstates), ci_inv(Nstates) integer :: exc(0:2,2,2) integer :: h1,h2,p1,p2,s1,s2 integer(bit_kind) :: tmp_det(Nint,2) @@ -46,10 +46,15 @@ subroutine mrcc_dress(delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref,i_generator,n integer(bit_kind),intent(in) :: key_mask(Nint, 2) integer,allocatable :: idx_miniList(:) integer :: N_miniList, ni, leng + double precision, allocatable :: hij_cache(:) + integer(bit_kind), allocatable :: microlist(:,:,:), microlist_zero(:,:,:) + integer, allocatable :: idx_microlist(:), N_microlist(:), ptr_microlist(:), idx_microlist_zero(:) + integer :: mobiles(2), smallerlist + logical, external :: is_generable leng = max(N_det_generators, N_det_non_ref) - allocate(miniList(Nint, 2, leng), idx_miniList(leng)) + allocate(miniList(Nint, 2, leng), idx_minilist(leng), hij_cache(N_det_non_ref)) !create_minilist_find_previous(key_mask, fullList, miniList, N_fullList, N_miniList, fullMatch, Nint) call create_minilist_find_previous(key_mask, psi_det_generators, miniList, i_generator-1, N_miniList, fullMatch, Nint) @@ -58,142 +63,226 @@ subroutine mrcc_dress(delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref,i_generator,n return end if + allocate(ptr_microlist(0:mo_tot_num*2+1), & + N_microlist(0:mo_tot_num*2) ) + allocate( microlist(Nint,2,N_minilist*4), & + idx_microlist(N_minilist*4)) + + if(key_mask(1,1) /= 0_8) then + call create_microlist(miniList, N_minilist, key_mask, microlist, idx_microlist, N_microlist, ptr_microlist, Nint) + call find_triples_and_quadruples_micro(i_generator,n_selected,det_buffer,Nint,tq,N_tq,microlist,ptr_microlist,N_microlist,key_mask) + else + call find_triples_and_quadruples(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist) + end if + + + + deallocate(microlist, idx_microlist) + + allocate (dIa_hla(Nstates,Ndet_non_ref)) - call find_triples_and_quadruples(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist) - - allocate (dIa_hla(N_states,Ndet_non_ref)) - ! |I> - + ! |alpha> - if(N_tq > 0) then - call create_minilist(key_mask, psi_non_ref, miniList, idx_miniList, N_det_non_ref, N_minilist, Nint) - end if - - - do i_alpha=1,N_tq -! call get_excitation_degree_vector(psi_non_ref,tq(1,1,i_alpha),degree_alpha,Nint,N_det_non_ref,idx_alpha) - call get_excitation_degree_vector(miniList,tq(1,1,i_alpha),degree_alpha,Nint,N_minilist,idx_alpha) + if(N_tq > 0) then + + call create_minilist(key_mask, psi_non_ref, miniList, idx_minilist, N_det_non_ref, N_minilist, Nint) + if(N_minilist == 0) return - do j=1,idx_alpha(0) - idx_alpha(j) = idx_miniList(idx_alpha(j)) - end do - + + if(key_mask(1,1) /= 0) then !!!!!!!!!!! PAS GENERAL !!!!!!!!! + allocate(microlist_zero(Nint,2,N_minilist), idx_microlist_zero(N_minilist)) + + allocate( microlist(Nint,2,N_minilist*4), & + idx_microlist(N_minilist*4)) + call create_microlist(miniList, N_minilist, key_mask, microlist, idx_microlist, N_microlist, ptr_microlist, Nint) + + + do i=0,mo_tot_num*2 + do k=ptr_microlist(i),ptr_microlist(i+1)-1 + idx_microlist(k) = idx_minilist(idx_microlist(k)) + end do + end do + + do l=1,N_microlist(0) + do k=1,Nint + microlist_zero(k,1,l) = microlist(k,1,l) + microlist_zero(k,2,l) = microlist(k,2,l) + enddo + idx_microlist_zero(l) = idx_microlist(l) + enddo + end if + end if + + + + do i_alpha=1,N_tq +! ok = .false. +! do i=N_det_generators, 1, -1 +! if(is_generable(psi_det_generators(1,1,i), tq(1,1,i_alpha), Nint)) then +! ok = .true. +! exit +! end if +! end do +! if(.not. ok) then +! cycle +! end if + + if(key_mask(1,1) /= 0) then + call getMobiles(tq(1,1,i_alpha), key_mask, mobiles, Nint) + + if(N_microlist(mobiles(1)) < N_microlist(mobiles(2))) then + smallerlist = mobiles(1) + else + smallerlist = mobiles(2) + end if + + + do l=0,N_microlist(smallerlist)-1 + microlist_zero(:,:,ptr_microlist(1) + l) = microlist(:,:,ptr_microlist(smallerlist) + l) + idx_microlist_zero(ptr_microlist(1) + l) = idx_microlist(ptr_microlist(smallerlist) + l) + end do + + call get_excitation_degree_vector(microlist_zero,tq(1,1,i_alpha),degree_alpha,Nint,N_microlist(smallerlist)+N_microlist(0),idx_alpha) + do j=1,idx_alpha(0) + idx_alpha(j) = idx_microlist_zero(idx_alpha(j)) + end do + else + call get_excitation_degree_vector(miniList,tq(1,1,i_alpha),degree_alpha,Nint,N_minilist,idx_alpha) + do j=1,idx_alpha(0) + idx_alpha(j) = idx_miniList(idx_alpha(j)) + end do + end if + + + do l_sd=1,idx_alpha(0) + k_sd = idx_alpha(l_sd) + call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hij_cache(k_sd)) + enddo + ! |I> do i_I=1,N_det_ref - ! Find triples and quadruple grand parents - call get_excitation_degree(tq(1,1,i_alpha),psi_ref(1,1,i_I),degree,Nint) - if (degree > 4) then - cycle - endif + ! Find triples and quadruple grand parents + call get_excitation_degree(tq(1,1,i_alpha),psi_ref(1,1,i_I),degree,Nint) + if (degree > 4) then + cycle + endif + + do i_state=1,Nstates + dIa(i_state) = 0.d0 + enddo + + ! |alpha> + do k_sd=1,idx_alpha(0) + + ! Loop if lambda == 0 + logical :: loop + loop = .True. + do i_state=1,Nstates + if (lambda_mrcc(i_state,idx_alpha(k_sd)) /= 0.d0) then + loop = .False. + exit + endif + enddo + if (loop) then + cycle + endif + + call get_excitation_degree(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),degree,Nint) + if (degree > 2) then + cycle + endif + + ! + ! + hIk = hij_mrcc(idx_alpha(k_sd),i_I) + ! call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),Nint,hIk) + do i_state=1,Nstates + dIk(i_state) = hIk * lambda_mrcc(i_state,idx_alpha(k_sd)) + enddo + ! |l> = Exc(k -> alpha) |I> + call get_excitation(psi_non_ref(1,1,idx_alpha(k_sd)),tq(1,1,i_alpha),exc,degree,phase,Nint) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + do k=1,N_int + tmp_det(k,1) = psi_ref(k,1,i_I) + tmp_det(k,2) = psi_ref(k,2,i_I) + enddo + + logical :: ok + call apply_excitation(psi_ref(1,1,i_I), exc, tmp_det, ok, Nint) + if(.not. ok) cycle + + ! + do i_state=1,Nstates + dka(i_state) = 0.d0 + enddo + do l_sd=k_sd+1,idx_alpha(0) - do i_state=1,N_states - dIa(i_state) = 0.d0 - enddo + call get_excitation_degree(tmp_det,psi_non_ref(1,1,idx_alpha(l_sd)),degree,Nint) + if (degree == 0) then + + loop = .True. + do i_state=1,Nstates + if (lambda_mrcc(i_state,idx_alpha(l_sd)) /= 0.d0) then + loop = .False. + exit + endif + enddo + if (.not.loop) then + call get_excitation(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),exc,degree,phase2,Nint) + hIl = hij_mrcc(idx_alpha(l_sd),i_I) +! call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hIl) + do i_state=1,Nstates + dka(i_state) = hIl * lambda_mrcc(i_state,idx_alpha(l_sd)) * phase * phase2 + enddo + endif - ! |alpha> - do k_sd=1,idx_alpha(0) - call get_excitation_degree(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),degree,Nint) - if (degree > 2) then - cycle - endif - ! - ! - call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),Nint,hIk) - do i_state=1,N_states - dIk(i_state) = hIk * lambda_mrcc(i_state,idx_alpha(k_sd)) - enddo - ! |l> = Exc(k -> alpha) |I> - call get_excitation(psi_non_ref(1,1,idx_alpha(k_sd)),tq(1,1,i_alpha),exc,degree,phase,Nint) - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - do k=1,N_int - tmp_det(k,1) = psi_ref(k,1,i_I) - tmp_det(k,2) = psi_ref(k,2,i_I) - enddo - ! Hole (see list_to_bitstring) - iint = ishft(h1-1,-bit_kind_shift) + 1 - ipos = h1-ishft((iint-1),bit_kind_shift)-1 - tmp_det(iint,s1) = ibclr(tmp_det(iint,s1),ipos) + exit + endif + enddo + do i_state=1,Nstates + dIa(i_state) = dIa(i_state) + dIk(i_state) * dka(i_state) + enddo + enddo + + do i_state=1,Nstates + ci_inv(i_state) = psi_ref_coef_inv(i_I,i_state) + enddo + do l_sd=1,idx_alpha(0) + k_sd = idx_alpha(l_sd) + hla = hij_cache(k_sd) +! call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hla) + do i_state=1,Nstates + dIa_hla(i_state,k_sd) = dIa(i_state) * hla + enddo + enddo + call omp_set_lock( psi_ref_lock(i_I) ) - ! Particle - iint = ishft(p1-1,-bit_kind_shift) + 1 - ipos = p1-ishft((iint-1),bit_kind_shift)-1 - tmp_det(iint,s1) = ibset(tmp_det(iint,s1),ipos) - if (degree_alpha(k_sd) == 2) then - ! Hole (see list_to_bitstring) - iint = ishft(h2-1,-bit_kind_shift) + 1 - ipos = h2-ishft((iint-1),bit_kind_shift)-1 - tmp_det(iint,s2) = ibclr(tmp_det(iint,s2),ipos) - - ! Particle - iint = ishft(p2-1,-bit_kind_shift) + 1 - ipos = p2-ishft((iint-1),bit_kind_shift)-1 - tmp_det(iint,s2) = ibset(tmp_det(iint,s2),ipos) - endif - - ! - do i_state=1,N_states - dka(i_state) = 0.d0 - enddo - do l_sd=k_sd+1,idx_alpha(0) - call get_excitation_degree(tmp_det,psi_non_ref(1,1,idx_alpha(l_sd)),degree,Nint) - if (degree == 0) then - call get_excitation(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),exc,degree,phase2,Nint) - call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hIl) - do i_state=1,N_states - dka(i_state) = hIl * lambda_mrcc(i_state,idx_alpha(l_sd)) * phase * phase2 - enddo - exit - endif - enddo - do i_state=1,N_states - dIa(i_state) = dIa(i_state) + dIk(i_state) * dka(i_state) - enddo - enddo - - do i_state=1,N_states - ci_inv(i_state) = 1.d0/psi_ref_coef(i_I,i_state) - enddo - do l_sd=1,idx_alpha(0) - k_sd = idx_alpha(l_sd) - call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hla) - do i_state=1,N_states - dIa_hla(i_state,k_sd) = dIa(i_state) * hla - enddo - enddo - call omp_set_lock( psi_ref_lock(i_I) ) - do l_sd=1,idx_alpha(0) - k_sd = idx_alpha(l_sd) - do i_state=1,N_states - delta_ij_(i_I,k_sd,i_state) += dIa_hla(i_state,k_sd) - if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5)then - delta_ii_(i_I,i_state) -= dIa_hla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef(k_sd,i_state) - else - delta_ii_(i_I,i_state) = 0.d0 - endif - enddo - enddo - call omp_unset_lock( psi_ref_lock(i_I) ) + + do i_state=1,Nstates + if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5)then + do l_sd=1,idx_alpha(0) + k_sd = idx_alpha(l_sd) + delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + dIa_hla(i_state,k_sd) + delta_ii_(i_state,i_I) = delta_ii_(i_state,i_I) - dIa_hla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) + enddo + else + !delta_ii_(i_state,i_I) = 0.d0 + do l_sd=1,idx_alpha(0) + k_sd = idx_alpha(l_sd) + delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + 0.5d0 * dIa_hla(i_state,k_sd) + enddo + endif + enddo + call omp_unset_lock( psi_ref_lock(i_I) ) enddo enddo - deallocate (dIa_hla) + deallocate (dIa_hla,hij_cache) deallocate(miniList, idx_miniList) end - - BEGIN_PROVIDER [ integer(bit_kind), gen_det_sorted, (N_int,2,N_det_generators,2) ] -&BEGIN_PROVIDER [ integer, gen_det_shortcut, (0:N_det_generators,2) ] -&BEGIN_PROVIDER [ integer, gen_det_version, (N_int, N_det_generators,2) ] -&BEGIN_PROVIDER [ integer, gen_det_idx, (N_det_generators,2) ] - gen_det_sorted(:,:,:,1) = psi_det_generators(:,:,:N_det_generators) - gen_det_sorted(:,:,:,2) = psi_det_generators(:,:,:N_det_generators) - call sort_dets_ab_v(gen_det_sorted(:,:,:,1), gen_det_idx(:,1), gen_det_shortcut(0:,1), gen_det_version(:,:,1), N_det_generators, N_int) - call sort_dets_ba_v(gen_det_sorted(:,:,:,2), gen_det_idx(:,2), gen_det_shortcut(0:,2), gen_det_version(:,:,2), N_det_generators, N_int) -END_PROVIDER - - subroutine find_triples_and_quadruples(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_miniList) use bitmasks @@ -224,6 +313,7 @@ subroutine find_triples_and_quadruples(i_generator,n_selected,det_buffer,Nint,tq N_tq = 0 + i_loop : do i=1,N_selected if(is_connected_to(det_buffer(1,1,i), miniList, Nint, N_miniList)) then cycle @@ -241,7 +331,84 @@ subroutine find_triples_and_quadruples(i_generator,n_selected,det_buffer,Nint,tq endif enddo if (good) then - if (.not. is_in_wavefunction(det_buffer(1,1,i),Nint,N_det)) then + if (.not. is_in_wavefunction(det_buffer(1,1,i),Nint)) then + N_tq += 1 + do k=1,N_int + tq(k,1,N_tq) = det_buffer(k,1,i) + tq(k,2,N_tq) = det_buffer(k,2,i) + enddo + endif + endif + enddo i_loop +end + + +subroutine find_triples_and_quadruples_micro(i_generator,n_selected,det_buffer,Nint,tq,N_tq,microlist,ptr_microlist,N_microlist,key_mask) + + use bitmasks + implicit none + + integer, intent(in) :: i_generator,n_selected, Nint + + integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) + integer :: i,j,k,m + logical :: is_in_wavefunction + integer :: degree(psi_det_size) + integer :: idx(0:psi_det_size) + logical :: good + + integer(bit_kind), intent(out) :: tq(Nint,2,n_selected) + integer, intent(out) :: N_tq + + + integer :: nt,ni + logical, external :: is_connected_to + + + integer(bit_kind),intent(in) :: microlist(Nint,2,*) + integer,intent(in) :: ptr_microlist(0:*) + integer,intent(in) :: N_microlist(0:*) + integer(bit_kind),intent(in) :: key_mask(Nint, 2) + + integer :: mobiles(2), smallerlist + + N_tq = 0 + + + + i_loop : do i=1,N_selected + call getMobiles(det_buffer(1,1,i), key_mask, mobiles, Nint) + if(N_microlist(mobiles(1)) < N_microlist(mobiles(2))) then + smallerlist = mobiles(1) + else + smallerlist = mobiles(2) + end if + + if(N_microlist(smallerlist) > 0) then + if(is_connected_to(det_buffer(1,1,i), microlist(1,1,ptr_microlist(smallerlist)), Nint, N_microlist(smallerlist))) then + cycle + end if + end if + + if(N_microlist(0) > 0) then + if(is_connected_to(det_buffer(1,1,i), microlist, Nint, N_microlist(0))) then + cycle + end if + end if + + ! Select determinants that are triple or quadruple excitations + ! from the ref + good = .True. + call get_excitation_degree_vector(psi_ref,det_buffer(1,1,i),degree,Nint,N_det_ref,idx) + !good=(idx(0) == 0) tant que degree > 2 pas retourné par get_excitation_degree_vector + do k=1,idx(0) + if (degree(k) < 3) then + good = .False. + exit + endif + enddo + if (good) then + if (.not. is_in_wavefunction(det_buffer(1,1,i),Nint)) then N_tq += 1 do k=1,N_int tq(k,1,N_tq) = det_buffer(k,1,i) @@ -257,4 +424,3 @@ end - diff --git a/plugins/MRCC_Utils/mrcc_general.irp.f b/plugins/MRCC_Utils/mrcc_general.irp.f index c567c76a..d356e4b9 100644 --- a/plugins/MRCC_Utils/mrcc_general.irp.f +++ b/plugins/MRCC_Utils/mrcc_general.irp.f @@ -1,70 +1,3 @@ -subroutine run_mrcc - implicit none - call set_generators_bitmasks_as_holes_and_particles - call mrcc_iterations -end - -subroutine mrcc_iterations - implicit none - - integer :: i,j - - double precision :: E_new, E_old, delta_e - integer :: iteration,i_oscillations - double precision :: E_past(4) - E_new = 0.d0 - delta_E = 1.d0 - iteration = 0 - j = 1 - i_oscillations = 0 - do while (delta_E > 1.d-7) - iteration += 1 - print *, '===========================' - print *, 'MRCC Iteration', iteration - print *, '===========================' - print *, '' - E_old = sum(ci_energy_dressed) - call write_double(6,ci_energy_dressed(1),"MRCC energy") - call diagonalize_ci_dressed - E_new = sum(ci_energy_dressed) - delta_E = dabs(E_new - E_old) - - E_past(j) = E_new - j +=1 - if(j>4)then - j=1 - endif - if(iteration > 4) then - if(delta_E > 1.d-10)then - if(dabs(E_past(1) - E_past(3)) .le. delta_E .and. dabs(E_past(2) - E_past(4)).le. delta_E)then - print*,'OSCILLATIONS !!!' - oscillations = .True. - i_oscillations +=1 - lambda_mrcc_tmp = lambda_mrcc - endif - endif - endif - call save_wavefunction -! if (i_oscillations > 5) then -! exit -! endif - if (iteration > 200) then - exit - endif - print*,'------------' - print*,'VECTOR' - do i = 1, N_det_ref - print*,'' - print*,'psi_ref_coef(i,1) = ',psi_ref_coef(i,1) - print*,'delta_ii(i,1) = ',delta_ii(i,1) - enddo - print*,'------------' - enddo - call write_double(6,ci_energy_dressed(1),"Final MRCC energy") - call ezfio_set_mrcc_cassd_energy(ci_energy_dressed(1)) - call save_wavefunction - -end subroutine set_generators_bitmasks_as_holes_and_particles implicit none @@ -91,7 +24,4 @@ subroutine set_generators_bitmasks_as_holes_and_particles enddo enddo touch generators_bitmask - - - end diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 1e2f974d..48fa2e80 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -1,115 +1,84 @@ - BEGIN_PROVIDER [integer, pert_determinants, (N_states, psi_det_size) ] - END_PROVIDER +use bitmasks - - BEGIN_PROVIDER [ double precision, lambda_mrcc, (N_states,psi_det_size) ] -&BEGIN_PROVIDER [ double precision, lambda_pert, (N_states,psi_det_size) ] - implicit none - BEGIN_DOC - ! cm/ or perturbative 1/Delta_E(m) - END_DOC - integer :: i,k,j - double precision :: ihpsi(N_states), hii,delta_e_eff,ihpsi_current(N_states),hij - integer :: i_ok,i_pert,i_pert_count - i_ok = 0 - - double precision :: phase_restart(N_states),tmp - do k = 1, N_states - phase_restart(k) = dsign(1.d0,psi_ref_coef_restart(1,k)/psi_ref_coef(1,k)) - enddo - i_pert_count = 0 + BEGIN_PROVIDER [ integer, mrmode ] + mrmode = 0 +END_PROVIDER - do i=1,N_det_non_ref - call i_h_psi(psi_non_ref(1,1,i), psi_ref_restart, psi_ref_coef_restart, N_int, N_det_ref,& - size(psi_ref_coef_restart,1), n_states, ihpsi) - call i_H_j(psi_non_ref(1,1,i),psi_non_ref(1,1,i),N_int,hii) -! TODO --- Test perturbatif ------ - do k=1,N_states - lambda_pert(k,i) = 1.d0 / (psi_ref_energy_diagonalized(k)-hii) - ! TODO : i_h_psi peut sortir de la boucle? - call i_h_psi(psi_non_ref(1,1,i), psi_ref, psi_ref_coef, N_int, N_det_ref,size(psi_ref_coef,1), n_states, ihpsi_current) - if (ihpsi_current(k) == 0.d0) then - ihpsi_current(k) = 1.d-32 - endif - tmp = psi_non_ref_coef(i,k)/ihpsi_current(k) - i_pert = 0 - ! Perturbation only if 1st order < 0.5 x second order - if((ihpsi(k) * lambda_pert(k,i)) < 0.5d0 * psi_non_ref_coef_restart(i,k) )then - i_pert = 1 - else - do j = 1, N_det_ref - call i_H_j(psi_non_ref(1,1,i),psi_ref(1,1,j),N_int,hij) - ! Perturbation diverges when hij*tmp > 0.5 - if(dabs(hij * tmp).ge.0.5d0)then - i_pert_count +=1 - i_pert = 1 - exit - endif - enddo - endif - if( i_pert == 1)then - pert_determinants(k,i) = i_pert - endif - if(pert_determinants(k,i) == 1)then - i_ok +=1 - lambda_mrcc(k,i) = lambda_pert(k,i) - else - lambda_mrcc(k,i) = psi_non_ref_coef(i,k)/ihpsi_current(k) - endif - enddo -! TODO --- Fin test perturbatif ------ - enddo -!if(oscillations)then -! print*,'AVERAGING the lambda_mrcc with those of the previous iterations' -! do i = 1, N_det_non_ref -! do k = 1, N_states + + BEGIN_PROVIDER [ double precision, lambda_mrcc, (N_states, N_det_non_ref) ] +&BEGIN_PROVIDER [ integer, lambda_mrcc_pt2, (0:psi_det_size) ] +&BEGIN_PROVIDER [ integer, lambda_mrcc_kept, (0:psi_det_size) ] + implicit none + BEGIN_DOC + ! cm/ or perturbative 1/Delta_E(m) + END_DOC + integer :: i,k + double precision :: ihpsi_current(N_states) + integer :: i_pert_count + double precision :: hii, lambda_pert + integer :: N_lambda_mrcc_pt2, N_lambda_mrcc_pt3 + + i_pert_count = 0 + lambda_mrcc = 0.d0 + N_lambda_mrcc_pt2 = 0 + N_lambda_mrcc_pt3 = 0 + lambda_mrcc_pt2(0) = 0 + lambda_mrcc_kept(0) = 0 -! double precision :: tmp -! tmp = lambda_mrcc(k,i) -! lambda_mrcc(k,i) += lambda_mrcc_tmp(k,i) -! lambda_mrcc(k,i) = lambda_mrcc(k,i) * 0.5d0 -! if(dabs(tmp - lambda_mrcc(k,i)).ge.1.d-9)then -! print*,'' -! print*,'i = ',i -! print*,'psi_non_ref_coef(i,k) = ',psi_non_ref_coef(i,k) -! print*,'lambda_mrcc(k,i) = ',lambda_mrcc(k,i) -! print*,' tmp = ',tmp -! endif -! enddo -! enddo -!endif - print*,'N_det_non_ref = ',N_det_non_ref - print*,'Number of Perturbatively treated determinants = ',i_ok - print*,'i_pert_count = ',i_pert_count - print*,'psi_coef_ref_ratio = ',psi_ref_coef(2,1)/psi_ref_coef(1,1) + do i=1,N_det_non_ref + call i_h_psi(psi_non_ref(1,1,i), psi_ref, psi_ref_coef, N_int, N_det_ref,& + size(psi_ref_coef,1), N_states,ihpsi_current) + call i_H_j(psi_non_ref(1,1,i),psi_non_ref(1,1,i),N_int,hii) + do k=1,N_states + if (ihpsi_current(k) == 0.d0) then + ihpsi_current(k) = 1.d-32 + endif + lambda_mrcc(k,i) = min(-1.d-32,psi_non_ref_coef(i,k)/ihpsi_current(k) ) + lambda_pert = 1.d0 / (psi_ref_energy_diagonalized(k)-hii) + if (lambda_pert / lambda_mrcc(k,i) < 0.5d0) then + ! Ignore lamdba + i_pert_count += 1 + lambda_mrcc(k,i) = 0.d0 + if (lambda_mrcc_pt2(N_lambda_mrcc_pt2) /= i) then + N_lambda_mrcc_pt2 += 1 + lambda_mrcc_pt2(N_lambda_mrcc_pt2) = i + endif + else + ! Keep lamdba + if (lambda_mrcc_kept(N_lambda_mrcc_pt3) /= i) then + N_lambda_mrcc_pt3 += 1 + lambda_mrcc_kept(N_lambda_mrcc_pt3) = i + endif + endif + enddo + enddo + lambda_mrcc_pt2(0) = N_lambda_mrcc_pt2 + lambda_mrcc_kept(0) = N_lambda_mrcc_pt3 + print*,'N_det_non_ref = ',N_det_non_ref + print*,'psi_coef_ref_ratio = ',psi_ref_coef(2,1)/psi_ref_coef(1,1) + print*,'lambda max = ',maxval(dabs(lambda_mrcc)) + print*,'Number of ignored determinants = ',i_pert_count END_PROVIDER -BEGIN_PROVIDER [ double precision, lambda_mrcc_tmp, (N_states,psi_det_size) ] + +BEGIN_PROVIDER [ double precision, hij_mrcc, (N_det_non_ref,N_det_ref) ] implicit none - lambda_mrcc_tmp = 0.d0 -END_PROVIDER + BEGIN_DOC + ! < ref | H | Non-ref > matrix + END_DOC + integer :: i_I, k_sd + do i_I=1,N_det_ref + do k_sd=1,N_det_non_ref + call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,k_sd),N_int,hij_mrcc(k_sd,i_I)) + enddo + enddo -BEGIN_PROVIDER [ logical, oscillations ] - implicit none - oscillations = .False. -END_PROVIDER +END_PROVIDER - - - -!BEGIN_PROVIDER [ double precision, delta_ij_non_ref, (N_det_non_ref, N_det_non_ref,N_states) ] -!implicit none -!BEGIN_DOC -!! Dressing matrix in SD basis -!END_DOC -!delta_ij_non_ref = 0.d0 -!call H_apply_mrcc_simple(delta_ij_non_ref,N_det_non_ref) -!END_PROVIDER - - BEGIN_PROVIDER [ double precision, delta_ij, (N_det_ref,N_det_non_ref,N_states) ] -&BEGIN_PROVIDER [ double precision, delta_ii, (N_det_ref,N_states) ] + BEGIN_PROVIDER [ double precision, delta_ij, (N_states,N_det_non_ref,N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ii, (N_states,N_det_ref) ] implicit none BEGIN_DOC ! Dressing matrix in N_det basis @@ -117,33 +86,10 @@ END_PROVIDER integer :: i,j,m delta_ij = 0.d0 delta_ii = 0.d0 - call H_apply_mrcc(delta_ij,delta_ii,N_det_ref,N_det_non_ref) - double precision :: max_delta - double precision :: accu - integer :: imax,jmax - max_delta = 0.d0 - accu = 0.d0 - do i = 1, N_det_ref - do j = 1, N_det_non_ref - accu += psi_non_ref_coef(j,1) * psi_ref_coef(i,1) * delta_ij(i,j,1) - if(dabs(delta_ij(i,j,1)).gt.max_delta)then - max_delta = dabs(delta_ij(i,j,1)) - imax = i - jmax = j - endif - enddo - enddo - print*,'' - print*,'' - print*,' = ',accu - print*,'MAX VAL OF DRESING = ',delta_ij(imax,jmax,1) - print*,'imax,jmax = ',imax,jmax - print*,'psi_ref_coef(imax,1) = ',psi_ref_coef(imax,1) - print*,'psi_non_ref_coef(jmax,1) = ',psi_non_ref_coef(jmax,1) - do i = 1, N_det_ref - print*,'delta_ii(i,1) = ',delta_ii(i,1) - enddo + call H_apply_mrcc(delta_ij,delta_ii,N_states,N_det_non_ref,N_det_ref) + END_PROVIDER + BEGIN_PROVIDER [ double precision, h_matrix_dressed, (N_det,N_det,N_states) ] implicit none @@ -159,11 +105,11 @@ BEGIN_PROVIDER [ double precision, h_matrix_dressed, (N_det,N_det,N_states) ] enddo do ii = 1, N_det_ref i =idx_ref(ii) - h_matrix_dressed(i,i,istate) += delta_ii(ii,istate) + h_matrix_dressed(i,i,istate) += delta_ii(istate,ii) do jj = 1, N_det_non_ref j =idx_non_ref(jj) - h_matrix_dressed(i,j,istate) += delta_ij(ii,jj,istate) - h_matrix_dressed(j,i,istate) += delta_ij(ii,jj,istate) + h_matrix_dressed(i,j,istate) += delta_ij(istate,jj,ii) + h_matrix_dressed(j,i,istate) += delta_ij(istate,jj,ii) enddo enddo enddo @@ -175,11 +121,26 @@ END_PROVIDER &BEGIN_PROVIDER [ double precision, CI_eigenvectors_s2_dressed, (N_states_diag) ] implicit none BEGIN_DOC - ! Eigenvectors/values of the CI matrix + ! Eigenvectors/values of the dressed CI matrix END_DOC - integer :: i,j + double precision :: ovrlp,u_dot_v + integer :: i_good_state + integer, allocatable :: index_good_state_array(:) + logical, allocatable :: good_state_array(:) + double precision, allocatable :: s2_values_tmp(:) + integer :: i_other_state + double precision, allocatable :: eigenvectors(:,:), eigenvalues(:) + integer :: i_state + double precision :: e_0 + integer :: i,j,k + double precision, allocatable :: s2_eigvalues(:) + double precision, allocatable :: e_array(:) + integer, allocatable :: iorder(:) + + integer :: mrcc_state - do j=1,N_states_diag + mrcc_state = N_states + do j=1,min(N_states,N_det) do i=1,N_det CI_eigenvectors_dressed(i,j) = psi_coef(i,j) enddo @@ -187,54 +148,100 @@ END_PROVIDER if (diag_algorithm == "Davidson") then - integer :: istate - istate = 1 - call davidson_diag_mrcc(psi_det,CI_eigenvectors_dressed,CI_electronic_energy_dressed,& - size(CI_eigenvectors_dressed,1),N_det,N_states_diag,N_int,output_determinants,istate) +! call davidson_diag_mrcc(psi_det,CI_eigenvectors_dressed,CI_electronic_energy_dressed,& +! size(CI_eigenvectors_dressed,1),N_det,N_states,N_states_diag,N_int,output_determinants,mrcc_state) + + call davidson_diag_mrcc_HS2(psi_det,CI_eigenvectors_dressed,& + size(CI_eigenvectors_dressed,1), & + CI_electronic_energy_dressed,N_det,N_states,N_states_diag,N_int, & + output_determinants,mrcc_state) + + call u_0_S2_u_0(CI_eigenvectors_s2_dressed,CI_eigenvectors_dressed,N_det,psi_det,N_int,& + N_states_diag,size(CI_eigenvectors_dressed,1)) + else if (diag_algorithm == "Lapack") then - double precision, allocatable :: eigenvectors(:,:), eigenvalues(:) allocate (eigenvectors(size(H_matrix_dressed,1),N_det)) allocate (eigenvalues(N_det)) call lapack_diag(eigenvalues,eigenvectors, & H_matrix_dressed,size(H_matrix_dressed,1),N_det) CI_electronic_energy_dressed(:) = 0.d0 - do i=1,N_det - CI_eigenvectors_dressed(i,1) = eigenvectors(i,1) - enddo - integer :: i_state - double precision :: s2 - i_state = 0 if (s2_eig) then + i_state = 0 + allocate (s2_eigvalues(N_det)) + allocate(index_good_state_array(N_det),good_state_array(N_det)) + good_state_array = .False. + call u_0_S2_u_0(s2_eigvalues,eigenvectors,N_det,psi_det,N_int,& + N_det,size(eigenvectors,1)) do j=1,N_det - call get_s2_u0(psi_det,eigenvectors(1,j),N_det,N_det,s2) - if(dabs(s2-expected_s2).le.0.3d0)then + ! Select at least n_states states with S^2 values closed to "expected_s2" + if(dabs(s2_eigvalues(j)-expected_s2).le.0.5d0)then i_state += 1 - do i=1,N_det - CI_eigenvectors_dressed(i,i_state) = eigenvectors(i,j) - enddo - CI_electronic_energy_dressed(i_state) = eigenvalues(j) - CI_eigenvectors_s2_dressed(i_state) = s2 + index_good_state_array(i_state) = j + good_state_array(j) = .True. endif - if (i_state.ge.N_states_diag) then + if (i_state==N_states) then exit endif enddo - else - do j=1,N_states_diag - call get_s2_u0(psi_det,eigenvectors(1,j),N_det,N_det,s2) - i_state += 1 - do i=1,N_det - CI_eigenvectors_dressed(i,i_state) = eigenvectors(i,j) + if (i_state /= 0) then + ! Fill the first "i_state" states that have a correct S^2 value + do j = 1, i_state + do i=1,N_det + CI_eigenvectors_dressed(i,j) = eigenvectors(i,index_good_state_array(j)) + enddo + CI_electronic_energy_dressed(j) = eigenvalues(index_good_state_array(j)) + CI_eigenvectors_s2_dressed(j) = s2_eigvalues(index_good_state_array(j)) enddo - CI_electronic_energy_dressed(i_state) = eigenvalues(j) - CI_eigenvectors_s2_dressed(i_state) = s2 + i_other_state = 0 + do j = 1, N_det + if(good_state_array(j))cycle + i_other_state +=1 + if(i_state+i_other_state.gt.n_states_diag)then + exit + endif + do i=1,N_det + CI_eigenvectors_dressed(i,i_state+i_other_state) = eigenvectors(i,j) + enddo + CI_electronic_energy_dressed(i_state+i_other_state) = eigenvalues(j) + CI_eigenvectors_s2_dressed(i_state+i_other_state) = s2_eigvalues(i_state+i_other_state) + enddo + + else + print*,'' + print*,'!!!!!!!! WARNING !!!!!!!!!' + print*,' Within the ',N_det,'determinants selected' + print*,' and the ',N_states_diag,'states requested' + print*,' We did not find any state with S^2 values close to ',expected_s2 + print*,' We will then set the first N_states eigenvectors of the H matrix' + print*,' as the CI_eigenvectors_dressed' + print*,' You should consider more states and maybe ask for s2_eig to be .True. or just enlarge the CI space' + print*,'' + do j=1,min(N_states_diag,N_det) + do i=1,N_det + CI_eigenvectors_dressed(i,j) = eigenvectors(i,j) + enddo + CI_electronic_energy_dressed(j) = eigenvalues(j) + CI_eigenvectors_s2_dressed(j) = s2_eigvalues(j) + enddo + endif + deallocate(index_good_state_array,good_state_array) + deallocate(s2_eigvalues) + else + call u_0_S2_u_0(CI_eigenvectors_s2_dressed,eigenvectors,N_det,psi_det,N_int,& + min(N_det,N_states_diag),size(eigenvectors,1)) + ! Select the "N_states_diag" states of lowest energy + do j=1,min(N_det,N_states_diag) + do i=1,N_det + CI_eigenvectors_dressed(i,j) = eigenvectors(i,j) + enddo + CI_electronic_energy_dressed(j) = eigenvalues(j) enddo endif deallocate(eigenvectors,eigenvalues) endif - + END_PROVIDER BEGIN_PROVIDER [ double precision, CI_energy_dressed, (N_states_diag) ] @@ -246,24 +253,1110 @@ BEGIN_PROVIDER [ double precision, CI_energy_dressed, (N_states_diag) ] integer :: j character*(8) :: st call write_time(output_determinants) - do j=1,N_states_diag + do j=1,min(N_det,N_states) + write(st,'(I4)') j CI_energy_dressed(j) = CI_electronic_energy_dressed(j) + nuclear_repulsion + call write_double(output_determinants,CI_energy_dressed(j),'Energy of state '//trim(st)) + call write_double(output_determinants,CI_eigenvectors_s2_dressed(j),'S^2 of state '//trim(st)) enddo END_PROVIDER -subroutine diagonalize_CI_dressed +subroutine diagonalize_CI_dressed(lambda) implicit none BEGIN_DOC ! Replace the coefficients of the CI states by the coefficients of the ! eigenstates of the CI matrix END_DOC + double precision, intent(in) :: lambda integer :: i,j - do j=1,N_states_diag + do j=1,N_states do i=1,N_det - psi_coef(i,j) = CI_eigenvectors_dressed(i,j) + psi_coef(i,j) = lambda * CI_eigenvectors_dressed(i,j) + (1.d0 - lambda) * psi_coef(i,j) enddo + call normalize(psi_coef(1,j), N_det) enddo SOFT_TOUCH psi_coef end + + +logical function is_generable(det1, det2, Nint) + use bitmasks + implicit none + integer, intent(in) :: Nint + integer(bit_kind) :: det1(Nint, 2), det2(Nint, 2) + integer :: degree, f, exc(0:2, 2, 2), t + integer*2 :: h1, h2, p1, p2, s1, s2 + integer, external :: searchExc + logical, external :: excEq + double precision :: phase + integer*2 :: tmp_array(4) + + is_generable = .false. + call get_excitation(det1, det2, exc, degree, phase, Nint) + if(degree == -1) return + if(degree == 0) then + is_generable = .true. + return + end if + if(degree > 2) stop "?22??" + + call decode_exc_int2(exc,degree,h1,p1,h2,p2,s1,s2) + + if(degree == 1) then + h2 = h1 + p2 = p1 + s2 = s1 + h1 = 0 + p1 = 0 + s1 = 0 + end if + + if(h1 + (s1-1)*mo_tot_num < h2 + (s2-1)*mo_tot_num) then + tmp_array = (/s1, h1, s2, h2/) + else + tmp_array = (/s2, h2, s1, h1/) + end if + f = searchExc(hh_exists(1,1), tmp_array, hh_shortcut(0)) + + if(p1 + (s1-1)*mo_tot_num < p2 + (s2-1)*mo_tot_num) then + tmp_array = (/s1, p1, s2, p2/) + else + tmp_array = (/s2, p2, s1, p1/) + end if + if (f /= -1) then + f = searchExc(pp_exists(1,hh_shortcut(f)), tmp_array, hh_shortcut(f+1)-hh_shortcut(f)) + endif + + is_generable = (f /= -1) +end function + + + +integer function searchDet(dets, det, n, Nint) + implicit none + use bitmasks + + integer(bit_kind),intent(in) :: dets(Nint,2,n), det(Nint,2) + integer, intent(in) :: nint, n + integer :: l, h, c + integer, external :: detCmp + logical, external :: detEq + + l = 1 + h = n + do while(.true.) + searchDet = (l+h)/2 + c = detCmp(dets(1,1,searchDet), det(1,1), Nint) + if(c == 0) then + return + else if(c == 1) then + h = searchDet-1 + else + l = searchDet+1 + end if + if(l > h) then + searchDet = -1 + return + end if + + end do +end function + + +integer function unsortedSearchDet(dets, det, n, Nint) + implicit none + use bitmasks + + integer(bit_kind),intent(in) :: dets(Nint,2,n), det(Nint,2) + integer, intent(in) :: nint, n + integer :: l, h, c + integer, external :: detCmp + logical, external :: detEq + + do l=1, n + if(detEq(det, dets(1,1,l), N_int)) then + unsortedSearchDet = l + return + end if + end do + unsortedSearchDet = -1 +end function + + +integer function searchExc(excs, exc, n) + implicit none + use bitmasks + + integer, intent(in) :: n + integer*2,intent(in) :: excs(4,n), exc(4) + integer :: l, h, c + integer, external :: excCmp + logical, external :: excEq + + l = 1 + h = n + do + searchExc = (l+h)/2 + c = excCmp(excs(1,searchExc), exc(1)) + if(c == 0) return + if(c == 1) then + h = searchExc-1 + else + l = searchExc+1 + end if + if(l > h) then + searchExc = -1 + return + end if + end do +end function + + +subroutine sort_det(key, idx, N_key, Nint) + implicit none + + + integer, intent(in) :: Nint, N_key + integer(8),intent(inout) :: key(Nint,2,N_key) + integer,intent(inout) :: idx(N_key) + integer(8) :: tmp(Nint, 2) + integer :: tmpidx,i,ni + + do i=1,N_key + idx(i) = i + end do + + do i=N_key/2,1,-1 + call tamiser(key, idx, i, N_key, Nint, N_key) + end do + + do i=N_key,2,-1 + do ni=1,Nint + tmp(ni,1) = key(ni,1,i) + tmp(ni,2) = key(ni,2,i) + key(ni,1,i) = key(ni,1,1) + key(ni,2,i) = key(ni,2,1) + key(ni,1,1) = tmp(ni,1) + key(ni,2,1) = tmp(ni,2) + enddo + + tmpidx = idx(i) + idx(i) = idx(1) + idx(1) = tmpidx + call tamiser(key, idx, 1, i-1, Nint, N_key) + end do +end subroutine + + +subroutine sort_exc(key, N_key) + implicit none + + + integer, intent(in) :: N_key + integer*2,intent(inout) :: key(4,N_key) + integer*2 :: tmp(4) + integer :: i,ni + + + do i=N_key/2,1,-1 + call tamise_exc(key, i, N_key, N_key) + end do + + do i=N_key,2,-1 + do ni=1,4 + tmp(ni) = key(ni,i) + key(ni,i) = key(ni,1) + key(ni,1) = tmp(ni) + enddo + + call tamise_exc(key, 1, i-1, N_key) + end do +end subroutine + + +logical function exc_inf(exc1, exc2) + implicit none + integer*2,intent(in) :: exc1(4), exc2(4) + integer :: i + exc_inf = .false. + do i=1,4 + if(exc1(i) < exc2(i)) then + exc_inf = .true. + return + else if(exc1(i) > exc2(i)) then + return + end if + end do +end function + + +subroutine tamise_exc(key, no, n, N_key) + use bitmasks + implicit none + + BEGIN_DOC +! Uncodumented : TODO + END_DOC + integer,intent(in) :: no, n, N_key + integer*2,intent(inout) :: key(4, N_key) + integer :: k,j + integer*2 :: tmp(4) + logical :: exc_inf + integer :: ni + + k = no + j = 2*k + do while(j <= n) + if(j < n) then + if (exc_inf(key(1,j), key(1,j+1))) then + j = j+1 + endif + endif + if(exc_inf(key(1,k), key(1,j))) then + do ni=1,4 + tmp(ni) = key(ni,k) + key(ni,k) = key(ni,j) + key(ni,j) = tmp(ni) + enddo + k = j + j = k+k + else + return + endif + enddo +end subroutine + + +subroutine dec_exc(exc, h1, h2, p1, p2) + implicit none + integer :: exc(0:2,2,2), s1, s2, degree + integer*2, intent(out) :: h1, h2, p1, p2 + + degree = exc(0,1,1) + exc(0,1,2) + + h1 = 0 + h2 = 0 + p1 = 0 + p2 = 0 + + if(degree == 0) return + + call decode_exc_int2(exc, degree, h1, p1, h2, p2, s1, s2) + + h1 += mo_tot_num * (s1-1) + p1 += mo_tot_num * (s1-1) + + if(degree == 2) then + h2 += mo_tot_num * (s2-1) + p2 += mo_tot_num * (s2-1) + if(h1 > h2) then + s1 = h1 + h1 = h2 + h2 = s1 + end if + if(p1 > p2) then + s1 = p1 + p1 = p2 + p2 = s1 + end if + else + h2 = h1 + p2 = p1 + p1 = 0 + h1 = 0 + end if +end subroutine + + + BEGIN_PROVIDER [ integer, N_hh_exists ] +&BEGIN_PROVIDER [ integer, N_pp_exists ] +&BEGIN_PROVIDER [ integer, N_ex_exists ] + implicit none + integer :: exc(0:2, 2, 2), degree, n, on, s, l, i + integer*2 :: h1, h2, p1, p2 + double precision :: phase + logical,allocatable :: hh(:,:) , pp(:,:) + + allocate(hh(0:mo_tot_num*2, 0:mo_tot_num*2)) + allocate(pp(0:mo_tot_num*2, 0:mo_tot_num*2)) + hh = .false. + pp = .false. + N_hh_exists = 0 + N_pp_exists = 0 + N_ex_exists = 0 + + n = 0 + !TODO Openmp + do i=1, N_det_ref + do l=1, N_det_non_ref + call get_excitation(psi_ref(1,1,i), psi_non_ref(1,1,l), exc, degree, phase, N_int) + if(degree == -1) cycle + call dec_exc(exc, h1, h2, p1, p2) + N_ex_exists += 1 + if(.not. hh(h1,h2)) N_hh_exists = N_hh_exists + 1 + if(.not. pp(p1,p2)) N_pp_exists = N_pp_exists + 1 + hh(h1,h2) = .true. + pp(p1,p2) = .true. + end do + end do + N_pp_exists = min(N_ex_exists, N_pp_exists * N_hh_exists) +END_PROVIDER + + + + BEGIN_PROVIDER [ integer(bit_kind), psi_non_ref_sorted, (N_int, 2, N_det_non_ref) ] +&BEGIN_PROVIDER [ integer, psi_non_ref_sorted_idx, (N_det_non_ref) ] + implicit none + psi_non_ref_sorted = psi_non_ref + call sort_det(psi_non_ref_sorted, psi_non_ref_sorted_idx, N_det_non_ref, N_int) +END_PROVIDER + + + BEGIN_PROVIDER [ double precision, dIj_unique, (hh_shortcut(hh_shortcut(0)+1)-1, N_states) ] +&BEGIN_PROVIDER [ double precision, rho_mrcc, (N_det_non_ref, N_states) ] + implicit none + logical :: ok + integer :: i, j, k, s, II, pp, ppp, hh, ind, wk, nex, a_col, at_row + integer, external :: searchDet, unsortedSearchDet + integer(bit_kind) :: myDet(N_int, 2), myMask(N_int, 2) + integer :: N, INFO, AtA_size, r1, r2 + double precision , allocatable :: AtB(:), AtA_val(:), A_val(:,:), x(:), x_new(:), A_val_mwen(:) + double precision :: t, norm, cx, res + integer, allocatable :: A_ind(:,:), lref(:), AtA_ind(:), A_ind_mwen(:), col_shortcut(:), N_col(:) + double precision :: phase + + + integer, allocatable :: pathTo(:), active_hh_idx(:), active_pp_idx(:) + logical, allocatable :: active(:) + double precision, allocatable :: rho_mrcc_init(:,:) + integer :: nactive + + nex = hh_shortcut(hh_shortcut(0)+1)-1 + print *, "TI", nex, N_det_non_ref + + allocate(pathTo(N_det_non_ref), active(nex)) + allocate(active_pp_idx(nex), active_hh_idx(nex)) + allocate(rho_mrcc_init(N_det_non_ref, N_states)) + + pathTo = 0 + active = .false. + nactive = 0 + + + do hh = 1, hh_shortcut(0) + do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 + do II = 1, N_det_ref + call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int) + if(.not. ok) cycle + call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int) + if(.not. ok) cycle + ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int) + if(ind == -1) cycle + ind = psi_non_ref_sorted_idx(ind) + if(pathTo(ind) == 0) then + pathTo(ind) = pp + else + active(pp) = .true. + active(pathTo(ind)) = .true. + end if + end do + end do + end do + + do hh = 1, hh_shortcut(0) + do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 + if(active(pp)) then + nactive = nactive + 1 + active_hh_idx(nactive) = hh + active_pp_idx(nactive) = pp + end if + end do + end do + + print *, nactive, "inact/", size(active) + + allocate(A_ind(0:N_det_ref+1, nactive), A_val(N_det_ref+1, nactive)) + allocate(AtA_ind(N_det_ref * nactive), AtA_val(N_det_ref * nactive)) + allocate(x(nex), AtB(nex)) + allocate(N_col(nactive), col_shortcut(nactive)) + allocate(x_new(nex)) + + + + do s=1, N_states + + A_val = 0d0 + A_ind = 0 + AtA_ind = 0 + AtB = 0d0 + AtA_val = 0d0 + x = 0d0 + N_col = 0 + col_shortcut = 0 + + !$OMP PARALLEL default(none) shared(psi_non_ref, hh_exists, pp_exists, N_int, A_val, A_ind)& + !$OMP shared(s, hh_shortcut, psi_ref_coef, N_det_non_ref, psi_non_ref_sorted, psi_non_ref_sorted_idx, psi_ref, N_det_ref)& + !$OMP shared(active, active_hh_idx, active_pp_idx, nactive) & + !$OMP private(lref, pp, II, ok, myMask, myDet, ind, phase, wk, ppp, hh) + allocate(lref(N_det_non_ref)) + !$OMP DO schedule(static,10) + do ppp=1,nactive + pp = active_pp_idx(ppp) + hh = active_hh_idx(ppp) + lref = 0 + do II = 1, N_det_ref + call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int) + if(.not. ok) cycle + call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int) + if(.not. ok) cycle + ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int) + if(ind /= -1) then + call get_phase(myDet(1,1), psi_ref(1,1,II), phase, N_int) + if (phase > 0.d0) then + lref(psi_non_ref_sorted_idx(ind)) = II + else + lref(psi_non_ref_sorted_idx(ind)) = -II + endif + end if + end do + wk = 0 + do i=1, N_det_non_ref + if(lref(i) > 0) then + wk += 1 + A_val(wk, ppp) = psi_ref_coef(lref(i), s) + A_ind(wk, ppp) = i + else if(lref(i) < 0) then + wk += 1 + A_val(wk, ppp) = -psi_ref_coef(-lref(i), s) + A_ind(wk, ppp) = i + end if + end do + A_ind(0,ppp) = wk + end do + !$OMP END DO + deallocate(lref) + !$OMP END PARALLEL + + + print *, 'Done building A_val, A_ind' + + AtA_size = 0 + col_shortcut = 0 + N_col = 0 + integer :: a_coll, at_roww + + + !$OMP PARALLEL default(none) shared(k, psi_non_ref_coef, A_ind, A_val, x, N_det_ref, nex, N_det_non_ref)& + !$OMP private(at_row, a_col, t, i, j, r1, r2, wk, A_ind_mwen, A_val_mwen, a_coll, at_roww)& + !$OMP shared(col_shortcut, N_col, AtB, AtA_size, AtA_val, AtA_ind, s, nactive, active_pp_idx) + allocate(A_val_mwen(nex), A_ind_mwen(nex)) + + !$OMP DO schedule(dynamic, 100) + do at_roww = 1, nactive ! nex + at_row = active_pp_idx(at_roww) + wk = 0 + if(mod(at_roww, 100) == 0) print *, "AtA", at_row, "/", nex + do i=1,A_ind(0,at_roww) + j = active_pp_idx(i) + AtB(at_row) = AtB(at_row) + psi_non_ref_coef(A_ind(i, at_roww), s) * A_val(i, at_roww) + end do + + do a_coll = 1, nactive + a_col = active_pp_idx(a_coll) + t = 0d0 + r1 = 1 + r2 = 1 + do while ((A_ind(r1, at_roww) /= 0).and.(A_ind(r2, a_coll) /= 0)) + if(A_ind(r1, at_roww) > A_ind(r2, a_coll)) then + r2 = r2+1 + else if(A_ind(r1, at_roww) < A_ind(r2, a_coll)) then + r1 = r1+1 + else + t = t - A_val(r1, at_roww) * A_val(r2, a_coll) + r1 = r1+1 + r2 = r2+1 + end if + end do + + if(a_col == at_row) then + t = t + 1.d0 + end if + if(t /= 0.d0) then + wk += 1 + A_ind_mwen(wk) = a_col + A_val_mwen(wk) = t + end if + end do + + if(wk /= 0) then + !$OMP CRITICAL + col_shortcut(at_roww) = AtA_size+1 + N_col(at_roww) = wk + if (AtA_size+wk > size(AtA_ind,1)) then + print *, AtA_size+wk , size(AtA_ind,1) + stop 'too small' + endif + do i=1,wk + AtA_ind(AtA_size+i) = A_ind_mwen(i) + AtA_val(AtA_size+i) = A_val_mwen(i) + enddo + AtA_size += wk + !$OMP END CRITICAL + end if + end do + !$OMP END DO NOWAIT + deallocate (A_ind_mwen, A_val_mwen) + !$OMP END PARALLEL + + print *, "ATA SIZE", ata_size + x = 0d0 + + + do a_coll = 1, nactive + a_col = active_pp_idx(a_coll) + X(a_col) = AtB(a_col) + end do + + rho_mrcc_init = 0d0 + + !$OMP PARALLEL default(shared) & + !$OMP private(lref, hh, pp, II, myMask, myDet, ok, ind, phase) + allocate(lref(N_det_ref)) + !$OMP DO schedule(static, 1) + do hh = 1, hh_shortcut(0) + do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 + if(active(pp)) cycle + lref = 0 + do II=1,N_det_ref + call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int) + if(.not. ok) cycle + call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int) + if(.not. ok) cycle + ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int) + if(ind == -1) cycle + ind = psi_non_ref_sorted_idx(ind) + call get_phase(myDet(1,1), psi_ref(1,1,II), phase, N_int) + X(pp) += psi_ref_coef(II,s)**2 + AtB(pp) += psi_non_ref_coef(ind, s) * psi_ref_coef(II, s) * phase + lref(II) = ind + if(phase < 0d0) lref(II) = -ind + end do + X(pp) = AtB(pp) / X(pp) + do II=1,N_det_ref + if(lref(II) > 0) then + rho_mrcc_init(lref(II),s) = psi_ref_coef(II,s) * X(pp) + else if(lref(II) < 0) then + rho_mrcc_init(-lref(II),s) = -psi_ref_coef(II,s) * X(pp) + end if + end do + end do + end do + !$OMP END DO + deallocate(lref) + !$OMP END PARALLEL + + x_new = x + + double precision :: factor, resold + factor = 1.d0 + resold = huge(1.d0) + do k=0,100000 + !$OMP PARALLEL default(shared) private(cx, i, j, a_col, a_coll) + + !$OMP DO + do i=1,N_det_non_ref + rho_mrcc(i,s) = rho_mrcc_init(i,s) ! 0d0 + enddo + !$OMP END DO + + !$OMP DO + do a_coll = 1, nactive !: nex + a_col = active_pp_idx(a_coll) + cx = 0d0 + do i=col_shortcut(a_coll), col_shortcut(a_coll) + N_col(a_coll) - 1 + cx = cx + x(AtA_ind(i)) * AtA_val(i) + end do + x_new(a_col) = AtB(a_col) + cx * factor + end do + !$OMP END DO + + !$OMP END PARALLEL + + res = 0.d0 + + + if (res < resold) then + do a_coll=1,nactive ! nex + a_col = active_pp_idx(a_coll) + do j=1,N_det_non_ref + i = A_ind(j,a_coll) + if (i==0) exit + rho_mrcc(i,s) = rho_mrcc(i,s) + A_val(j,a_coll) * X_new(a_col) + enddo + res = res + (X_new(a_col) - X(a_col))*(X_new(a_col) - X(a_col)) + X(a_col) = X_new(a_col) + end do + factor = 1.d0 + else + factor = -factor * 0.5d0 + endif + resold = res + + if(mod(k, 100) == 0) then + print *, "res ", k, res + end if + + if(res < 1d-9) exit + end do + + + + norm = 0.d0 + do i=1,N_det_non_ref + norm = norm + rho_mrcc(i,s)*rho_mrcc(i,s) + enddo + ! Norm now contains the norm of A.X + + do i=1,N_det_ref + norm = norm + psi_ref_coef(i,s)*psi_ref_coef(i,s) + enddo + ! Norm now contains the norm of Psi + A.X + + print *, k, "res : ", res, "norm : ", sqrt(norm) + +!--------------- +! double precision :: e_0, overlap +! double precision, allocatable :: u_0(:) +! integer(bit_kind), allocatable :: keys_tmp(:,:,:) +! allocate (u_0(N_det), keys_tmp(N_int,2,N_det) ) +! k=0 +! overlap = 0.d0 +! do i=1,N_det_ref +! k = k+1 +! u_0(k) = psi_ref_coef(i,1) +! keys_tmp(:,:,k) = psi_ref(:,:,i) +! overlap += u_0(k)*psi_ref_coef(i,1) +! enddo +! norm = 0.d0 +! do i=1,N_det_non_ref +! k = k+1 +! u_0(k) = psi_non_ref_coef(i,1) +! keys_tmp(:,:,k) = psi_non_ref(:,:,i) +! overlap += u_0(k)*psi_non_ref_coef(i,1) +! enddo +! +! call u_0_H_u_0(e_0,u_0,N_det,keys_tmp,N_int,1,N_det) +! print *, 'Energy of |Psi_CASSD> : ', e_0 + nuclear_repulsion, overlap +! +! k=0 +! overlap = 0.d0 +! do i=1,N_det_ref +! k = k+1 +! u_0(k) = psi_ref_coef(i,1) +! keys_tmp(:,:,k) = psi_ref(:,:,i) +! overlap += u_0(k)*psi_ref_coef(i,1) +! enddo +! norm = 0.d0 +! do i=1,N_det_non_ref +! k = k+1 +! ! f is such that f.\tilde{c_i} = c_i +! f = psi_non_ref_coef(i,1) / rho_mrcc(i,1) +! +! ! Avoid numerical instabilities +! f = min(f,2.d0) +! f = max(f,-2.d0) +! +! f = 1.d0 +! +! u_0(k) = rho_mrcc(i,1)*f +! keys_tmp(:,:,k) = psi_non_ref(:,:,i) +! norm += u_0(k)**2 +! overlap += u_0(k)*psi_non_ref_coef(i,1) +! enddo +! +! call u_0_H_u_0(e_0,u_0,N_det,keys_tmp,N_int,1,N_det) +! print *, 'Energy of |(1+T)Psi_0> : ', e_0 + nuclear_repulsion, overlap +! +! f = 1.d0/norm +! norm = 1.d0 +! do i=1,N_det_ref +! norm = norm - psi_ref_coef(i,s)*psi_ref_coef(i,s) +! enddo +! f = dsqrt(f*norm) +! overlap = norm +! do i=1,N_det_non_ref +! u_0(k) = rho_mrcc(i,1)*f +! overlap += u_0(k)*psi_non_ref_coef(i,1) +! enddo +! +! call u_0_H_u_0(e_0,u_0,N_det,keys_tmp,N_int,1,N_det) +! print *, 'Energy of |(1+T)Psi_0> (normalized) : ', e_0 + nuclear_repulsion, overlap +! +! k=0 +! overlap = 0.d0 +! do i=1,N_det_ref +! k = k+1 +! u_0(k) = psi_ref_coef(i,1) +! keys_tmp(:,:,k) = psi_ref(:,:,i) +! overlap += u_0(k)*psi_ref_coef(i,1) +! enddo +! norm = 0.d0 +! do i=1,N_det_non_ref +! k = k+1 +! ! f is such that f.\tilde{c_i} = c_i +! f = psi_non_ref_coef(i,1) / rho_mrcc(i,1) +! +! ! Avoid numerical instabilities +! f = min(f,2.d0) +! f = max(f,-2.d0) +! +! u_0(k) = rho_mrcc(i,1)*f +! keys_tmp(:,:,k) = psi_non_ref(:,:,i) +! norm += u_0(k)**2 +! overlap += u_0(k)*psi_non_ref_coef(i,1) +! enddo +! +! call u_0_H_u_0(e_0,u_0,N_det,keys_tmp,N_int,1,N_det) +! print *, 'Energy of |(1+T)Psi_0> (mu_i): ', e_0 + nuclear_repulsion, overlap +! +! f = 1.d0/norm +! norm = 1.d0 +! do i=1,N_det_ref +! norm = norm - psi_ref_coef(i,s)*psi_ref_coef(i,s) +! enddo +! overlap = norm +! f = dsqrt(f*norm) +! do i=1,N_det_non_ref +! u_0(k) = rho_mrcc(i,1)*f +! overlap += u_0(k)*psi_non_ref_coef(i,1) +! enddo +! +! call u_0_H_u_0(e_0,u_0,N_det,keys_tmp,N_int,1,N_det) +! print *, 'Energy of |(1+T)Psi_0> (normalized mu_i) : ', e_0 + nuclear_repulsion, overlap +! +! deallocate(u_0, keys_tmp) +! +!--------------- + + norm = 0.d0 + double precision :: f + do i=1,N_det_non_ref + if (rho_mrcc(i,s) == 0.d0) then + rho_mrcc(i,s) = 1.d-32 + endif + + ! f is such that f.\tilde{c_i} = c_i + f = psi_non_ref_coef(i,s) / rho_mrcc(i,s) + + ! Avoid numerical instabilities + f = min(f,2.d0) + f = max(f,-2.d0) + + norm = norm + f*f *rho_mrcc(i,s)*rho_mrcc(i,s) + rho_mrcc(i,s) = f + enddo + ! norm now contains the norm of |T.Psi_0> + ! rho_mrcc now contains the f factors + + f = 1.d0/norm + ! f now contains 1/ + + norm = 1.d0 + do i=1,N_det_ref + norm = norm - psi_ref_coef(i,s)*psi_ref_coef(i,s) + enddo + ! norm now contains + f = dsqrt(f*norm) + ! f normalises T.Psi_0 such that (1+T)|Psi> is normalized + + norm = norm*f + print *, 'norm of |T Psi_0> = ', dsqrt(norm) + + do i=1,N_det_ref + norm = norm + psi_ref_coef(i,s)*psi_ref_coef(i,s) + enddo + + do i=1,N_det_non_ref + rho_mrcc(i,s) = rho_mrcc(i,s) * f + enddo + ! rho_mrcc now contains the product of the scaling factors and the + ! normalization constant + + dIj_unique(:size(X), s) = X(:) + end do + +END_PROVIDER + + + + +BEGIN_PROVIDER [ double precision, dij, (N_det_ref, N_det_non_ref, N_states) ] + integer :: s,i,j + double precision, external :: get_dij_index + print *, "computing amplitudes..." + !$OMP PARALLEL DEFAULT(shared) PRIVATE(s,i,j) + do s=1, N_states + !$OMP DO + do i=1, N_det_non_ref + do j=1, N_det_ref + dij(j, i, s) = get_dij_index(j, i, s, N_int) + end do + end do + !$OMP END DO + end do + !$OMP END PARALLEL + print *, "done computing amplitudes" +END_PROVIDER + + + + +double precision function get_dij_index(II, i, s, Nint) + integer, intent(in) :: II, i, s, Nint + double precision, external :: get_dij + double precision :: HIi, phase + + if(lambda_type == 0) then + call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int) + get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase + get_dij_index = get_dij_index * rho_mrcc(i,s) + else + call i_h_j(psi_ref(1,1,II), psi_non_ref(1,1,i), Nint, HIi) + get_dij_index = HIi * lambda_mrcc(s, i) + end if +end function + + +double precision function get_dij(det1, det2, s, Nint) + use bitmasks + implicit none + integer, intent(in) :: s, Nint + integer(bit_kind) :: det1(Nint, 2), det2(Nint, 2) + integer :: degree, f, exc(0:2, 2, 2), t + integer*2 :: h1, h2, p1, p2, s1, s2 + integer, external :: searchExc + logical, external :: excEq + double precision :: phase + integer*2 :: tmp_array(4) + + get_dij = 0d0 + call get_excitation(det1, det2, exc, degree, phase, Nint) + if(degree == -1) return + if(degree == 0) then + stop "get_dij" + end if + + call decode_exc_int2(exc,degree,h1,p1,h2,p2,s1,s2) + + if(degree == 1) then + h2 = h1 + p2 = p1 + s2 = s1 + h1 = 0 + p1 = 0 + s1 = 0 + end if + + if(h1 + (s1-1)*mo_tot_num < h2 + (s2-1)*mo_tot_num) then + tmp_array = (/s1, h1, s2, h2/) + else + tmp_array = (/s2, h2, s1, h1/) + end if + f = searchExc(hh_exists(1,1), tmp_array, hh_shortcut(0)) + + if(f == -1) return + + if(p1 + (s1-1)*mo_tot_num < p2 + (s2-1)*mo_tot_num) then + tmp_array = (/s1, p1, s2, p2/) + else + tmp_array = (/s2, p2, s1, p1/) + end if + t = searchExc(pp_exists(1,hh_shortcut(f)), tmp_array, hh_shortcut(f+1)-hh_shortcut(f)) + + if(t /= -1) then + get_dij = dIj_unique(t - 1 + hh_shortcut(f), s) + end if +end function + + + BEGIN_PROVIDER [ integer*2, hh_exists, (4, N_hh_exists) ] +&BEGIN_PROVIDER [ integer, hh_shortcut, (0:N_hh_exists + 1) ] +&BEGIN_PROVIDER [ integer*2, pp_exists, (4, N_pp_exists) ] + implicit none + integer*2,allocatable :: num(:,:) + integer :: exc(0:2, 2, 2), degree, n, on, s, l, i + integer*2 :: h1, h2, p1, p2 + double precision :: phase + logical, external :: excEq + + allocate(num(4, N_ex_exists+1)) + + hh_shortcut = 0 + hh_exists = 0 + pp_exists = 0 + num = 0 + + n = 0 + do i=1, N_det_ref + do l=1, N_det_non_ref + call get_excitation(psi_ref(1,1,i), psi_non_ref(1,1,l), exc, degree, phase, N_int) + if(degree == -1) cycle + call dec_exc(exc, h1, h2, p1, p2) + n += 1 + num(:, n) = (/h1, h2, p1, p2/) + end do + end do + + call sort_exc(num, n) + + hh_shortcut(0) = 1 + hh_shortcut(1) = 1 + hh_exists(:,1) = (/1_2, num(1,1), 1_2, num(2,1)/) + pp_exists(:,1) = (/1_2, num(3,1), 1_2, num(4,1)/) + s = 1 + do i=2,n + if(.not. excEq(num(1,i), num(1,s))) then + s += 1 + num(:, s) = num(:, i) + pp_exists(:,s) = (/1_2, num(3,s), 1_2, num(4,s)/) + if(hh_exists(2, hh_shortcut(0)) /= num(1,s) .or. & + hh_exists(4, hh_shortcut(0)) /= num(2,s)) then + hh_shortcut(0) += 1 + hh_shortcut(hh_shortcut(0)) = s + hh_exists(:,hh_shortcut(0)) = (/1_2, num(1,s), 1_2, num(2,s)/) + end if + end if + end do + hh_shortcut(hh_shortcut(0)+1) = s+1 + + do s=2,4,2 + do i=1,hh_shortcut(0) + if(hh_exists(s, i) == 0) then + hh_exists(s-1, i) = 0 + else if(hh_exists(s, i) > mo_tot_num) then + hh_exists(s, i) -= mo_tot_num + hh_exists(s-1, i) = 2 + end if + end do + + do i=1,hh_shortcut(hh_shortcut(0)+1)-1 + if(pp_exists(s, i) == 0) then + pp_exists(s-1, i) = 0 + else if(pp_exists(s, i) > mo_tot_num) then + pp_exists(s, i) -= mo_tot_num + pp_exists(s-1, i) = 2 + end if + end do + end do +END_PROVIDER + + +logical function excEq(exc1, exc2) + implicit none + integer*2, intent(in) :: exc1(4), exc2(4) + integer :: i + excEq = .false. + do i=1, 4 + if(exc1(i) /= exc2(i)) return + end do + excEq = .true. +end function + + +integer function excCmp(exc1, exc2) + implicit none + integer*2, intent(in) :: exc1(4), exc2(4) + integer :: i + excCmp = 0 + do i=1, 4 + if(exc1(i) > exc2(i)) then + excCmp = 1 + return + else if(exc1(i) < exc2(i)) then + excCmp = -1 + return + end if + end do +end function + + +subroutine apply_hole_local(det, exc, res, ok, Nint) + use bitmasks + implicit none + integer, intent(in) :: Nint + integer*2, intent(in) :: exc(4) + integer*2 :: s1, s2, h1, h2 + integer(bit_kind),intent(in) :: det(Nint, 2) + integer(bit_kind),intent(out) :: res(Nint, 2) + logical, intent(out) :: ok + integer :: ii, pos + + ok = .false. + s1 = exc(1) + h1 = exc(2) + s2 = exc(3) + h2 = exc(4) + res = det + + if(h1 /= 0) then + ii = (h1-1)/bit_kind_size + 1 + pos = iand(h1-1,bit_kind_size-1) ! mod 64 + if(iand(det(ii, s1), ishft(1_bit_kind, pos)) == 0_8) then + return + endif + res(ii, s1) = ibclr(res(ii, s1), pos) + end if + + ii = (h2-1)/bit_kind_size + 1 + pos = iand(h2-1,bit_kind_size-1) ! mod 64 + if(iand(det(ii, s2), ishft(1_bit_kind, pos)) == 0_8) then + return + endif + res(ii, s2) = ibclr(res(ii, s2), pos) + ok = .true. +end subroutine + + +subroutine apply_particle_local(det, exc, res, ok, Nint) + use bitmasks + implicit none + integer, intent(in) :: Nint + integer*2, intent(in) :: exc(4) + integer*2 :: s1, s2, p1, p2 + integer(bit_kind),intent(in) :: det(Nint, 2) + integer(bit_kind),intent(out) :: res(Nint, 2) + logical, intent(out) :: ok + integer :: ii, pos + + ok = .false. + s1 = exc(1) + p1 = exc(2) + s2 = exc(3) + p2 = exc(4) + res = det + + if(p1 /= 0) then + ii = (p1-1)/bit_kind_size + 1 + pos = iand(p1-1,bit_kind_size-1) + if(iand(det(ii, s1), ishft(1_bit_kind, pos)) /= 0_8) then + return + endif + res(ii, s1) = ibset(res(ii, s1), pos) + end if + + ii = (p2-1)/bit_kind_size + 1 + pos = iand(p2-1,bit_kind_size-1) + if(iand(det(ii, s2), ishft(1_bit_kind, pos)) /= 0_8) then + return + endif + res(ii, s2) = ibset(res(ii, s2), pos) + + + ok = .true. +end subroutine + + + + diff --git a/plugins/MRCC_Utils/mrcepa_dress.irp.f b/plugins/MRCC_Utils/mrcepa_dress.irp.f deleted file mode 100644 index 9789b818..00000000 --- a/plugins/MRCC_Utils/mrcepa_dress.irp.f +++ /dev/null @@ -1,260 +0,0 @@ -use omp_lib -use bitmasks - -subroutine mrcepa_dress(delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref,i_generator,n_selected,det_buffer,Nint,iproc,key_mask) - use bitmasks - implicit none - - integer, intent(in) :: i_generator,n_selected, Nint, iproc - integer, intent(in) :: Ndet_ref, Ndet_non_ref - double precision, intent(inout) :: delta_ij_(Ndet_ref,Ndet_non_ref,*) - double precision, intent(inout) :: delta_ii_(Ndet_ref,*) - - integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) - integer :: i,j,k,l - integer :: degree_alpha(psi_det_size) - integer :: idx_alpha(0:psi_det_size) - logical :: good, fullMatch - - integer(bit_kind) :: tq(Nint,2,n_selected) - integer :: N_tq, c_ref ,degree - - double precision :: hIk, hla, hIl, dIk(N_states), dka(N_states), dIa(N_states) - double precision, allocatable :: dIa_hia(:,:) - double precision :: haj, phase, phase2 - double precision :: f(N_states), ci_inv(N_states) - integer :: exc(0:2,2,2) - integer :: h1,h2,p1,p2,s1,s2 - integer(bit_kind) :: tmp_det(Nint,2) - integer(bit_kind) :: tmp_det_0(Nint,2) - integer :: iint, ipos - integer :: i_state, i_sd, k_sd, l_sd, i_I, i_alpha - - integer(bit_kind),allocatable :: miniList(:,:,:) - integer(bit_kind),intent(in) :: key_mask(Nint, 2) - integer,allocatable :: idx_miniList(:) - integer :: N_miniList, ni, leng - integer(bit_kind) :: isum - - double precision :: hia - integer, allocatable :: index_sorted(:) - - - leng = max(N_det_generators, N_det_non_ref) - allocate(miniList(Nint, 2, leng), idx_miniList(leng), index_sorted(N_det)) - - !create_minilist_find_previous(key_mask, fullList, miniList, N_fullList, N_miniList, fullMatch, Nint) - call create_minilist_find_previous(key_mask, psi_det_generators, miniList, i_generator-1, N_miniList, fullMatch, Nint) - - if(fullMatch) then - return - end if - - - call find_triples_and_quadruples(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist) - - allocate (dIa_hia(N_states,Ndet_non_ref)) - - ! |I> - - ! |alpha> - - if(N_tq > 0) then - call create_minilist(key_mask, psi_non_ref, miniList, idx_miniList, N_det_non_ref, N_minilist, Nint) - end if - - - do i_alpha=1,N_tq - ! call get_excitation_degree_vector(psi_non_ref,tq(1,1,i_alpha),degree_alpha,Nint,N_det_non_ref,idx_alpha) - call get_excitation_degree_vector(miniList,tq(1,1,i_alpha),degree_alpha,Nint,N_minilist,idx_alpha) - - integer, external :: get_index_in_psi_det_sorted_bit - index_sorted = huge(-1) - do j=1,idx_alpha(0) - idx_alpha(j) = idx_miniList(idx_alpha(j)) - index_sorted( get_index_in_psi_det_sorted_bit( psi_non_ref(1,1,idx_alpha(j)), N_int ) ) = idx_alpha(j) - end do - - ! |I> - do i_I=1,N_det_ref - ! Find triples and quadruple grand parents - call get_excitation_degree(tq(1,1,i_alpha),psi_ref(1,1,i_I),degree,Nint) - if (degree > 4) then - cycle - endif - - do i_state=1,N_states - dIa(i_state) = 0.d0 - enddo - - !TODO: MR - do i_sd=1,idx_alpha(0) - call get_excitation_degree(psi_non_ref(1,1,idx_alpha(i_sd)),tq(1,1,i_alpha),degree,Nint) - if (degree > 2) then - cycle - endif - call get_excitation(psi_non_ref(1,1,idx_alpha(i_sd)),tq(1,1,i_alpha),exc,degree,phase,Nint) - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - tmp_det_0 = 0_bit_kind - ! Hole (see list_to_bitstring) - iint = ishft(h1-1,-bit_kind_shift) + 1 - ipos = h1-ishft((iint-1),bit_kind_shift)-1 - tmp_det_0(iint,s1) = ibset(tmp_det_0(iint,s1),ipos) - - ! Particle - iint = ishft(p1-1,-bit_kind_shift) + 1 - ipos = p1-ishft((iint-1),bit_kind_shift)-1 - tmp_det_0(iint,s1) = ibset(tmp_det_0(iint,s1),ipos) - if (degree == 2) then - ! Hole (see list_to_bitstring) - iint = ishft(h2-1,-bit_kind_shift) + 1 - ipos = h2-ishft((iint-1),bit_kind_shift)-1 - tmp_det_0(iint,s2) = ibset(tmp_det_0(iint,s2),ipos) - - ! Particle - iint = ishft(p2-1,-bit_kind_shift) + 1 - ipos = p2-ishft((iint-1),bit_kind_shift)-1 - tmp_det_0(iint,s2) = ibset(tmp_det_0(iint,s2),ipos) - endif - - call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(i_sd)),Nint,hia) - - ! |alpha> - do k_sd=1,idx_alpha(0) - call get_excitation_degree(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),degree,Nint) - if (degree > 2) then - cycle - endif - - call get_excitation(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),exc,degree,phase,Nint) - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - tmp_det = 0_bit_kind - ! Hole (see list_to_bitstring) - iint = ishft(h1-1,-bit_kind_shift) + 1 - ipos = h1-ishft((iint-1),bit_kind_shift)-1 - tmp_det(iint,s1) = ibset(tmp_det(iint,s1),ipos) - - ! Particle - iint = ishft(p1-1,-bit_kind_shift) + 1 - ipos = p1-ishft((iint-1),bit_kind_shift)-1 - tmp_det(iint,s1) = ibset(tmp_det(iint,s1),ipos) - if (degree == 2) then - ! Hole (see list_to_bitstring) - iint = ishft(h2-1,-bit_kind_shift) + 1 - ipos = h2-ishft((iint-1),bit_kind_shift)-1 - tmp_det(iint,s2) = ibset(tmp_det(iint,s2),ipos) - - ! Particle - iint = ishft(p2-1,-bit_kind_shift) + 1 - ipos = p2-ishft((iint-1),bit_kind_shift)-1 - tmp_det(iint,s2) = ibset(tmp_det(iint,s2),ipos) - endif - - isum = 0_bit_kind - do iint = 1,N_int - isum = isum + iand(tmp_det(iint,1), tmp_det_0(iint,1)) & - + iand(tmp_det(iint,2), tmp_det_0(iint,2)) - enddo - - if (isum /= 0_bit_kind) then - cycle - endif - - ! - ! - call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),Nint,hIk) - do i_state=1,N_states - dIk(i_state) = hIk * lambda_mrcc(i_state,idx_alpha(k_sd)) - enddo - ! |l> = Exc(k -> alpha) |I> - call get_excitation(psi_non_ref(1,1,idx_alpha(k_sd)),tq(1,1,i_alpha),exc,degree,phase,Nint) - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - do k=1,N_int - tmp_det(k,1) = psi_ref(k,1,i_I) - tmp_det(k,2) = psi_ref(k,2,i_I) - enddo - ! Hole (see list_to_bitstring) - iint = ishft(h1-1,-bit_kind_shift) + 1 - ipos = h1-ishft((iint-1),bit_kind_shift)-1 - tmp_det(iint,s1) = ibclr(tmp_det(iint,s1),ipos) - - ! Particle - iint = ishft(p1-1,-bit_kind_shift) + 1 - ipos = p1-ishft((iint-1),bit_kind_shift)-1 - tmp_det(iint,s1) = ibset(tmp_det(iint,s1),ipos) - if (degree == 2) then - ! Hole (see list_to_bitstring) - iint = ishft(h2-1,-bit_kind_shift) + 1 - ipos = h2-ishft((iint-1),bit_kind_shift)-1 - tmp_det(iint,s2) = ibclr(tmp_det(iint,s2),ipos) - - ! Particle - iint = ishft(p2-1,-bit_kind_shift) + 1 - ipos = p2-ishft((iint-1),bit_kind_shift)-1 - tmp_det(iint,s2) = ibset(tmp_det(iint,s2),ipos) - endif - - ! - do i_state=1,N_states - dka(i_state) = 0.d0 - enddo - - -! l_sd = index_sorted( get_index_in_psi_det_sorted_bit( tmp_det, N_int ) ) -! call get_excitation(psi_ref(1,1,i_I),psi_non_ref(1,1,l_sd),exc,degree,phase2,Nint) -! call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,l_sd),Nint,hIl) -! do i_state=1,N_states -! dka(i_state) = hIl * lambda_mrcc(i_state,l_sd) * phase * phase2 -! enddo - - do l_sd=1,idx_alpha(0) - call get_excitation_degree(tmp_det,psi_non_ref(1,1,idx_alpha(l_sd)),degree,Nint) - if (degree == 0) then - call get_excitation(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),exc,degree,phase2,Nint) - call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hIl) - do i_state=1,N_states - dka(i_state) = hIl * lambda_mrcc(i_state,idx_alpha(l_sd)) * phase * phase2 - enddo - exit - endif - enddo - do i_state=1,N_states - dIa(i_state) = dIa(i_state) + dIk(i_state) * dka(i_state) - enddo - enddo - - do i_state=1,N_states - ci_inv(i_state) = 1.d0/psi_ref_coef(i_I,i_state) - enddo - - k_sd = idx_alpha(i_sd) - do i_state=1,N_states - dIa_hia(i_state,k_sd) = dIa(i_state) * hia - enddo - - call omp_set_lock( psi_ref_lock(i_I) ) - do i_state=1,N_states - delta_ij_(i_I,k_sd,i_state) += dIa_hia(i_state,k_sd) - - if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5)then - delta_ii_(i_I,i_state) -= dIa_hia(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef(k_sd,i_state) - else - delta_ii_(i_I,i_state) = 0.d0 - endif - enddo - call omp_unset_lock( psi_ref_lock(i_I) ) - enddo - enddo - - enddo - deallocate (dIa_hia,index_sorted) - deallocate(miniList, idx_miniList) -end - - - - - - - - diff --git a/plugins/MRCC_Utils/mrcepa_general.irp.f b/plugins/MRCC_Utils/mrcepa_general.irp.f deleted file mode 100644 index 3479548b..00000000 --- a/plugins/MRCC_Utils/mrcepa_general.irp.f +++ /dev/null @@ -1,97 +0,0 @@ -subroutine run_mrcepa - implicit none - call set_generators_bitmasks_as_holes_and_particles - call mrcepa_iterations -end - -subroutine mrcepa_iterations - implicit none - - integer :: i,j - - double precision :: E_new, E_old, delta_e - integer :: iteration,i_oscillations - double precision :: E_past(4) - E_new = 0.d0 - delta_E = 1.d0 - iteration = 0 - j = 1 - i_oscillations = 0 - do while (delta_E > 1.d-7) - iteration += 1 - print *, '===========================' - print *, 'MRCEPA Iteration', iteration - print *, '===========================' - print *, '' - E_old = sum(ci_energy_dressed) - call write_double(6,ci_energy_dressed(1),"MRCEPA energy") - call diagonalize_ci_dressed - E_new = sum(ci_energy_dressed) - delta_E = dabs(E_new - E_old) - - E_past(j) = E_new - j +=1 - if(j>4)then - j=1 - endif - if(iteration > 4) then - if(delta_E > 1.d-10)then - if(dabs(E_past(1) - E_past(3)) .le. delta_E .and. dabs(E_past(2) - E_past(4)).le. delta_E)then - print*,'OSCILLATIONS !!!' - oscillations = .True. - i_oscillations +=1 - lambda_mrcc_tmp = lambda_mrcc - endif - endif - endif - call save_wavefunction -! if (i_oscillations > 5) then -! exit -! endif - if (iteration > 200) then - exit - endif - print*,'------------' - print*,'VECTOR' - do i = 1, N_det_ref - print*,'' - print*,'psi_ref_coef(i,1) = ',psi_ref_coef(i,1) - print*,'delta_ii(i,1) = ',delta_ii(i,1) - enddo - print*,'------------' - enddo - call write_double(6,ci_energy_dressed(1),"Final MRCEPA energy") - call ezfio_set_mrcc_cassd_energy(ci_energy_dressed(1)) - call save_wavefunction - -end - -subroutine set_generators_bitmasks_as_holes_and_particles - implicit none - integer :: i,k - do k = 1, N_generators_bitmask - do i = 1, N_int - ! Pure single part - generators_bitmask(i,1,1,k) = holes_operators(i,1) ! holes for pure single exc alpha - generators_bitmask(i,1,2,k) = particles_operators(i,1) ! particles for pure single exc alpha - generators_bitmask(i,2,1,k) = holes_operators(i,2) ! holes for pure single exc beta - generators_bitmask(i,2,2,k) = particles_operators(i,2) ! particles for pure single exc beta - - ! Double excitation - generators_bitmask(i,1,3,k) = holes_operators(i,1) ! holes for first single exc alpha - generators_bitmask(i,1,4,k) = particles_operators(i,1) ! particles for first single exc alpha - generators_bitmask(i,2,3,k) = holes_operators(i,2) ! holes for first single exc beta - generators_bitmask(i,2,4,k) = particles_operators(i,2) ! particles for first single exc beta - - generators_bitmask(i,1,5,k) = holes_operators(i,1) ! holes for second single exc alpha - generators_bitmask(i,1,6,k) = particles_operators(i,1) ! particles for second single exc alpha - generators_bitmask(i,2,5,k) = holes_operators(i,2) ! holes for second single exc beta - generators_bitmask(i,2,6,k) = particles_operators(i,2) ! particles for second single exc beta - - enddo - enddo - touch generators_bitmask - - - -end diff --git a/plugins/MRCC_Utils/tree_dependency.png b/plugins/MRCC_Utils/tree_dependency.png index 500e5d43..3c535b5c 100644 Binary files a/plugins/MRCC_Utils/tree_dependency.png and b/plugins/MRCC_Utils/tree_dependency.png differ diff --git a/plugins/MRCC_Utils_new/EZFIO.cfg b/plugins/MRCC_Utils_new/EZFIO.cfg deleted file mode 100644 index 789f30ef..00000000 --- a/plugins/MRCC_Utils_new/EZFIO.cfg +++ /dev/null @@ -1,4 +0,0 @@ -[energy] -type: double precision -doc: Calculated MRCC energy -interface: ezfio \ No newline at end of file diff --git a/plugins/MRCC_Utils_new/NEEDED_CHILDREN_MODULES b/plugins/MRCC_Utils_new/NEEDED_CHILDREN_MODULES deleted file mode 100644 index 5b16423e..00000000 --- a/plugins/MRCC_Utils_new/NEEDED_CHILDREN_MODULES +++ /dev/null @@ -1 +0,0 @@ -Perturbation Selectors_full Generators_full Psiref_Utils diff --git a/plugins/MRCC_Utils_new/README.rst b/plugins/MRCC_Utils_new/README.rst deleted file mode 100644 index 6f070867..00000000 --- a/plugins/MRCC_Utils_new/README.rst +++ /dev/null @@ -1,168 +0,0 @@ -=========== -MRCC Module -=========== - -Multi-Reference Coupled Cluster. - -Needed Modules -============== - -.. Do not edit this section. It was auto-generated from the -.. by the `update_README.py` script. - -.. image:: tree_dependency.png - -* `Perturbation `_ -* `Selectors_full `_ -* `Generators_full `_ -* `Psiref_Utils `_ - -Documentation -============= - -.. Do not edit this section. It was auto-generated from the -.. by the `update_README.py` script. - -`apply_excitation_operator `_ - Undocumented - - -`ci_eigenvectors_dressed `_ - Eigenvectors/values of the CI matrix - - -`ci_eigenvectors_s2_dressed `_ - Eigenvectors/values of the CI matrix - - -`ci_electronic_energy_dressed `_ - Eigenvectors/values of the CI matrix - - -`ci_energy_dressed `_ - N_states lowest eigenvalues of the dressed CI matrix - - -`davidson_diag_hjj_mrcc `_ - Davidson diagonalization with specific diagonal elements of the H matrix - .br - H_jj : specific diagonal H matrix elements to diagonalize de Davidson - .br - dets_in : bitmasks corresponding to determinants - .br - u_in : guess coefficients on the various states. Overwritten - on exit - .br - dim_in : leftmost dimension of u_in - .br - sze : Number of determinants - .br - N_st : Number of eigenstates - .br - iunit : Unit for the I/O - .br - Initial guess vectors are not necessarily orthonormal - - -`davidson_diag_mrcc `_ - Davidson diagonalization. - .br - dets_in : bitmasks corresponding to determinants - .br - u_in : guess coefficients on the various states. Overwritten - on exit - .br - dim_in : leftmost dimension of u_in - .br - sze : Number of determinants - .br - N_st : Number of eigenstates - .br - iunit : Unit number for the I/O - .br - Initial guess vectors are not necessarily orthonormal - - -`delta_ii `_ - Dressing matrix in N_det basis - - -`delta_ij `_ - Dressing matrix in N_det basis - - -`diagonalize_ci_dressed `_ - Replace the coefficients of the CI states by the coefficients of the - eigenstates of the CI matrix - - -`get_excitation_operators_for_one_ref `_ - This subroutine provides all the amplitudes and excitation operators - that one needs to go from the reference to the non reference wave function - you enter with det_ref that is a reference determinant - .br - N_connect_ref is the number of determinants belonging to psi_non_ref - that are connected to det_ref. - .br - amplitudes_phase_less(i) = amplitude phase less t_{I->i} = * lambda_mrcc(i) * phase(I->i) - .br - excitation_operators(:,i) represents the holes and particles that - link the ith connected determinant to det_ref - if :: - excitation_operators(5,i) = 2 :: double excitation alpha - excitation_operators(5,i) = -2 :: double excitation beta - !! excitation_operators(1,i) :: hole 1 - !! excitation_operators(2,i) :: particle 1 - !! excitation_operators(3,i) :: hole 2 - !! excitation_operators(4,i) :: particle 2 - else if :: - excitation_operators(5,i) = 1 :: single excitation alpha - !! excitation_operators(1,i) :: hole 1 - !! excitation_operators(2,i) :: particle 1 - else if :: - excitation_operators(5,i) = -1 :: single excitation beta - !! excitation_operators(3,i) :: hole 1 - !! excitation_operators(4,i) :: particle 1 - else if :: - !! excitation_operators(5,i) = 0 :: double excitation alpha/beta - !! excitation_operators(1,i) :: hole 1 alpha - !! excitation_operators(2,i) :: particle 1 alpha - !! excitation_operators(3,i) :: hole 2 beta - !! excitation_operators(4,i) :: particle 2 beta - - -`h_matrix_dressed `_ - Dressed H with Delta_ij - - -`h_u_0_mrcc `_ - Computes v_0 = H|u_0> - .br - n : number of determinants - .br - H_jj : array of - - -`lambda_mrcc `_ - cm/ or perturbative 1/Delta_E(m) - - -`lambda_pert `_ - cm/ or perturbative 1/Delta_E(m) - - -`mrcc_dress `_ - Undocumented - - -`mrcc_iterations `_ - Undocumented - - -`run_mrcc `_ - Undocumented - - -`set_generators_bitmasks_as_holes_and_particles `_ - Undocumented - diff --git a/plugins/MRCC_Utils_new/davidson.irp.f b/plugins/MRCC_Utils_new/davidson.irp.f deleted file mode 100644 index 0c7bebbd..00000000 --- a/plugins/MRCC_Utils_new/davidson.irp.f +++ /dev/null @@ -1,430 +0,0 @@ -subroutine davidson_diag_mrcc(dets_in,u_in,energies,dim_in,sze,N_st,Nint,iunit,istate) - use bitmasks - implicit none - BEGIN_DOC - ! Davidson diagonalization. - ! - ! dets_in : bitmasks corresponding to determinants - ! - ! u_in : guess coefficients on the various states. Overwritten - ! on exit - ! - ! dim_in : leftmost dimension of u_in - ! - ! sze : Number of determinants - ! - ! N_st : Number of eigenstates - ! - ! iunit : Unit number for the I/O - ! - ! Initial guess vectors are not necessarily orthonormal - END_DOC - integer, intent(in) :: dim_in, sze, N_st, Nint, iunit, istate - integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) - double precision, intent(inout) :: u_in(dim_in,N_st) - double precision, intent(out) :: energies(N_st) - double precision, allocatable :: H_jj(:) - - double precision :: diag_h_mat_elem - integer :: i - ASSERT (N_st > 0) - ASSERT (sze > 0) - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - PROVIDE mo_bielec_integrals_in_map - allocate(H_jj(sze)) - - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP SHARED(sze,H_jj,N_det_ref,dets_in,Nint,istate,delta_ii,idx_ref) & - !$OMP PRIVATE(i) - !$OMP DO SCHEDULE(guided) - do i=1,sze - H_jj(i) = diag_h_mat_elem(dets_in(1,1,i),Nint) - enddo - !$OMP END DO - !$OMP DO SCHEDULE(guided) - do i=1,N_det_ref - H_jj(idx_ref(i)) += delta_ii(i,istate) - enddo - !$OMP END DO - !$OMP END PARALLEL - - call davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nint,iunit,istate) - deallocate (H_jj) -end - -subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nint,iunit,istate) - use bitmasks - implicit none - BEGIN_DOC - ! Davidson diagonalization with specific diagonal elements of the H matrix - ! - ! H_jj : specific diagonal H matrix elements to diagonalize de Davidson - ! - ! dets_in : bitmasks corresponding to determinants - ! - ! u_in : guess coefficients on the various states. Overwritten - ! on exit - ! - ! dim_in : leftmost dimension of u_in - ! - ! sze : Number of determinants - ! - ! N_st : Number of eigenstates - ! - ! iunit : Unit for the I/O - ! - ! Initial guess vectors are not necessarily orthonormal - END_DOC - integer, intent(in) :: dim_in, sze, N_st, Nint, istate - integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) - double precision, intent(in) :: H_jj(sze) - integer, intent(in) :: iunit - double precision, intent(inout) :: u_in(dim_in,N_st) - double precision, intent(out) :: energies(N_st) - - integer :: iter - integer :: i,j,k,l,m - logical :: converged - - double precision :: overlap(N_st,N_st) - double precision :: u_dot_v, u_dot_u - - integer, allocatable :: kl_pairs(:,:) - integer :: k_pairs, kl - - integer :: iter2 - double precision, allocatable :: W(:,:,:), U(:,:,:), R(:,:) - double precision, allocatable :: y(:,:,:,:), h(:,:,:,:), lambda(:) - double precision :: diag_h_mat_elem - double precision :: residual_norm(N_st) - character*(16384) :: write_buffer - double precision :: to_print(2,N_st) - double precision :: cpu, wall - - PROVIDE det_connections - - call write_time(iunit) - call wall_time(wall) - call cpu_time(cpu) - write(iunit,'(A)') '' - write(iunit,'(A)') 'Davidson Diagonalization' - write(iunit,'(A)') '------------------------' - write(iunit,'(A)') '' - call write_int(iunit,N_st,'Number of states') - call write_int(iunit,sze,'Number of determinants') - write(iunit,'(A)') '' - write_buffer = '===== ' - do i=1,N_st - write_buffer = trim(write_buffer)//' ================ ================' - enddo - write(iunit,'(A)') trim(write_buffer) - write_buffer = ' Iter' - do i=1,N_st - write_buffer = trim(write_buffer)//' Energy Residual' - enddo - write(iunit,'(A)') trim(write_buffer) - write_buffer = '===== ' - do i=1,N_st - write_buffer = trim(write_buffer)//' ================ ================' - enddo - write(iunit,'(A)') trim(write_buffer) - - allocate( & - kl_pairs(2,N_st*(N_st+1)/2), & - W(sze,N_st,davidson_sze_max), & - U(sze,N_st,davidson_sze_max), & - R(sze,N_st), & - h(N_st,davidson_sze_max,N_st,davidson_sze_max), & - y(N_st,davidson_sze_max,N_st,davidson_sze_max), & - lambda(N_st*davidson_sze_max)) - - ASSERT (N_st > 0) - ASSERT (sze > 0) - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - - ! Initialization - ! ============== - - k_pairs=0 - do l=1,N_st - do k=1,l - k_pairs+=1 - kl_pairs(1,k_pairs) = k - kl_pairs(2,k_pairs) = l - enddo - enddo - - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP SHARED(U,sze,N_st,overlap,kl_pairs,k_pairs, & - !$OMP Nint,dets_in,u_in) & - !$OMP PRIVATE(k,l,kl,i) - - - ! Orthonormalize initial guess - ! ============================ - - !$OMP DO - do kl=1,k_pairs - k = kl_pairs(1,kl) - l = kl_pairs(2,kl) - if (k/=l) then - overlap(k,l) = u_dot_v(U_in(1,k),U_in(1,l),sze) - overlap(l,k) = overlap(k,l) - else - overlap(k,k) = u_dot_u(U_in(1,k),sze) - endif - enddo - !$OMP END DO - !$OMP END PARALLEL - - call ortho_lowdin(overlap,size(overlap,1),N_st,U_in,size(U_in,1),sze) - - ! Davidson iterations - ! =================== - - converged = .False. - - do while (.not.converged) - - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(k,i) SHARED(U,u_in,sze,N_st) - do k=1,N_st - !$OMP DO - do i=1,sze - U(i,k,1) = u_in(i,k) - enddo - !$OMP END DO - enddo - !$OMP END PARALLEL - - do iter=1,davidson_sze_max-1 - - ! Compute W_k = H |u_k> - ! ---------------------- - - do k=1,N_st - call H_u_0_mrcc(W(1,k,iter),U(1,k,iter),H_jj,sze,dets_in,Nint,istate) - enddo - - ! Compute h_kl = = - ! ------------------------------------------- - - do l=1,N_st - do k=1,N_st - do iter2=1,iter-1 - h(k,iter2,l,iter) = u_dot_v(U(1,k,iter2),W(1,l,iter),sze) - h(k,iter,l,iter2) = h(k,iter2,l,iter) - enddo - enddo - do k=1,l - h(k,iter,l,iter) = u_dot_v(U(1,k,iter),W(1,l,iter),sze) - h(l,iter,k,iter) = h(k,iter,l,iter) - enddo - enddo - - !DEBUG H MATRIX - !do i=1,iter - ! print '(10(x,F16.10))', h(1,i,1,1:i) - !enddo - !print *, '' - !END - - ! Diagonalize h - ! ------------- - call lapack_diag(lambda,y,h,N_st*davidson_sze_max,N_st*iter) - - ! Express eigenvectors of h in the determinant basis - ! -------------------------------------------------- - - do k=1,N_st - do i=1,sze - U(i,k,iter+1) = 0.d0 - W(i,k,iter+1) = 0.d0 - do l=1,N_st - do iter2=1,iter - U(i,k,iter+1) = U(i,k,iter+1) + U(i,l,iter2)*y(l,iter2,k,1) - W(i,k,iter+1) = W(i,k,iter+1) + W(i,l,iter2)*y(l,iter2,k,1) - enddo - enddo - enddo - enddo - - ! Compute residual vector - ! ----------------------- - - do k=1,N_st - do i=1,sze - R(i,k) = lambda(k) * U(i,k,iter+1) - W(i,k,iter+1) - enddo - residual_norm(k) = u_dot_u(R(1,k),sze) - to_print(1,k) = lambda(k) + nuclear_repulsion - 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) - call davidson_converged(lambda,residual_norm,wall,iter,cpu,N_st,converged) - if (converged) then - exit - endif - - - ! Davidson step - ! ------------- - - do k=1,N_st - do i=1,sze - U(i,k,iter+1) = -1.d0/max(H_jj(i) - lambda(k),1.d-2) * R(i,k) - enddo - enddo - - ! Gram-Schmidt - ! ------------ - - double precision :: c - do k=1,N_st - do iter2=1,iter - do l=1,N_st - c = u_dot_v(U(1,k,iter+1),U(1,l,iter2),sze) - do i=1,sze - U(i,k,iter+1) -= c * U(i,l,iter2) - enddo - enddo - enddo - do l=1,k-1 - c = u_dot_v(U(1,k,iter+1),U(1,l,iter+1),sze) - do i=1,sze - U(i,k,iter+1) -= c * U(i,l,iter+1) - enddo - enddo - call normalize( U(1,k,iter+1), sze ) - enddo - - !DEBUG : CHECK OVERLAP - !print *, '===' - !do k=1,iter+1 - ! do l=1,k - ! c = u_dot_v(U(1,1,k),U(1,1,l),sze) - ! print *, k,l, c - ! enddo - !enddo - !print *, '===' - !pause - !END DEBUG - - - enddo - - if (.not.converged) then - iter = davidson_sze_max-1 - endif - - ! Re-contract to u_in - ! ----------- - - do k=1,N_st - energies(k) = lambda(k) - do i=1,sze - u_in(i,k) = 0.d0 - do iter2=1,iter - do l=1,N_st - u_in(i,k) += U(i,l,iter2)*y(l,iter2,k,1) - enddo - enddo - enddo - enddo - - enddo - - write_buffer = '===== ' - do i=1,N_st - write_buffer = trim(write_buffer)//' ================ ================' - enddo - write(iunit,'(A)') trim(write_buffer) - write(iunit,'(A)') '' - call write_time(iunit) - - deallocate ( & - kl_pairs, & - W, & - U, & - R, & - h, & - y, & - lambda & - ) - abort_here = abort_all -end - -subroutine H_u_0_mrcc(v_0,u_0,H_jj,n,keys_tmp,Nint,istate) - use bitmasks - implicit none - BEGIN_DOC - ! Computes v_0 = H|u_0> - ! - ! n : number of determinants - ! - ! H_jj : array of - END_DOC - integer, intent(in) :: n,Nint,istate - double precision, intent(out) :: v_0(n) - double precision, intent(in) :: u_0(n) - double precision, intent(in) :: H_jj(n) - integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) - integer, allocatable :: idx(:) - double precision :: hij - double precision, allocatable :: vt(:) - integer :: i,j,k,l, jj,ii - integer :: i0, j0 - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - ASSERT (n>0) - PROVIDE ref_bitmask_energy delta_ij - integer, parameter :: block_size = 157 - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(i,hij,j,k,idx,jj,ii,vt) & - !$OMP SHARED(n_det_ref,n_det_non_ref,idx_ref,idx_non_ref,n,H_jj,u_0,keys_tmp,Nint,v_0,istate,delta_ij) - !$OMP DO SCHEDULE(static) - do i=1,n - v_0(i) = H_jj(i) * u_0(i) - enddo - !$OMP END DO - allocate(idx(0:n), vt(n)) - Vt = 0.d0 - !$OMP DO SCHEDULE(guided) - do i=1,n - idx(0) = i - call filter_connected_davidson(keys_tmp,keys_tmp(1,1,i),Nint,i-1,idx) - do jj=1,idx(0) - j = idx(jj) - if ( (dabs(u_0(j)) > 1.d-7).or.((dabs(u_0(i)) > 1.d-7)) ) then - call i_H_j(keys_tmp(1,1,j),keys_tmp(1,1,i),Nint,hij) - hij = hij - vt (i) = vt (i) + hij*u_0(j) - vt (j) = vt (j) + hij*u_0(i) - endif - enddo - enddo - !$OMP END DO - - !$OMP DO SCHEDULE(guided) - do ii=1,n_det_ref - i = idx_ref(ii) - do jj = 1, n_det_non_ref - j = idx_non_ref(jj) - vt (i) = vt (i) + delta_ij(ii,jj,istate)*u_0(j) - vt (j) = vt (j) + delta_ij(ii,jj,istate)*u_0(i) - enddo - enddo - !$OMP END DO - !$OMP CRITICAL - do i=1,n - v_0(i) = v_0(i) + vt(i) - enddo - !$OMP END CRITICAL - deallocate(idx,vt) - !$OMP END PARALLEL -end - - diff --git a/plugins/MRCC_Utils_new/mrcc_amplitudes.irp.f b/plugins/MRCC_Utils_new/mrcc_amplitudes.irp.f deleted file mode 100644 index 6746bee1..00000000 --- a/plugins/MRCC_Utils_new/mrcc_amplitudes.irp.f +++ /dev/null @@ -1,93 +0,0 @@ -subroutine get_excitation_operators_for_one_ref(det_ref,i_state,ndetnonref,N_connect_ref,excitation_operators,amplitudes_phase_less,index_connected) - use bitmasks - implicit none - integer(bit_kind), intent(in) :: det_ref(N_int,2) - integer, intent(in) :: i_state,ndetnonref - integer*2, intent(out) :: excitation_operators(5,ndetnonref) - integer, intent(out) :: index_connected(ndetnonref) - integer, intent(out) :: N_connect_ref - double precision, intent(out) :: amplitudes_phase_less(ndetnonref) - - integer :: i,j,k,l,degree,h1,p1,h2,p2,s1,s2 - integer :: exc(0:2,2,2) - double precision :: phase,hij - BEGIN_DOC - ! This subroutine provides all the amplitudes and excitation operators - ! that one needs to go from the reference to the non reference wave function - ! you enter with det_ref that is a reference determinant - ! - ! N_connect_ref is the number of determinants belonging to psi_non_ref - ! that are connected to det_ref. - ! - ! amplitudes_phase_less(i) = amplitude phase less t_{I->i} = * lambda_mrcc(i) * phase(I->i) - ! - ! excitation_operators(:,i) represents the holes and particles that - ! link the ith connected determinant to det_ref - ! if :: - ! excitation_operators(5,i) = 2 :: double excitation alpha - ! excitation_operators(5,i) = -2 :: double excitation beta - !!! excitation_operators(1,i) :: hole 1 - !!! excitation_operators(2,i) :: particle 1 - !!! excitation_operators(3,i) :: hole 2 - !!! excitation_operators(4,i) :: particle 2 - ! else if :: - ! excitation_operators(5,i) = 1 :: single excitation alpha - !!! excitation_operators(1,i) :: hole 1 - !!! excitation_operators(2,i) :: particle 1 - ! else if :: - ! excitation_operators(5,i) = -1 :: single excitation beta - !!! excitation_operators(3,i) :: hole 1 - !!! excitation_operators(4,i) :: particle 1 - ! else if :: - !!! excitation_operators(5,i) = 0 :: double excitation alpha/beta - !!! excitation_operators(1,i) :: hole 1 alpha - !!! excitation_operators(2,i) :: particle 1 alpha - !!! excitation_operators(3,i) :: hole 2 beta - !!! excitation_operators(4,i) :: particle 2 beta - END_DOC - N_connect_ref = 0 - do i = 1, ndetnonref - call i_H_j_phase_out(det_ref,psi_non_ref(1,1,i),N_int,hij,phase,exc,degree) - if (dabs(hij) <= mo_integrals_threshold) then - cycle - endif - N_connect_ref +=1 - index_connected(N_connect_ref) = i - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - amplitudes_phase_less(N_connect_ref) = hij * lambda_mrcc(i_state,i) !*phase - - if (degree==2) then - - excitation_operators(1,N_connect_ref) = h1 - excitation_operators(2,N_connect_ref) = p1 - excitation_operators(3,N_connect_ref) = h2 - excitation_operators(4,N_connect_ref) = p2 - if(s1==s2.and.s1==1)then ! double alpha - excitation_operators(5,N_connect_ref) = 2 - elseif(s1==s2.and.s1==2)then ! double beta - excitation_operators(5,N_connect_ref) = -2 - else ! double alpha/beta - excitation_operators(5,N_connect_ref) = 0 - endif - - else if(degree==1) then - - if(s1==1)then ! mono alpha - excitation_operators(5,N_connect_ref) = 1 - excitation_operators(1,N_connect_ref) = h1 - excitation_operators(2,N_connect_ref) = p1 - else ! mono beta - excitation_operators(5,N_connect_ref) = -1 - excitation_operators(3,N_connect_ref) = h1 - excitation_operators(4,N_connect_ref) = p1 - endif - - else - - N_connect_ref-=1 - - endif - - enddo - -end diff --git a/plugins/MRCC_Utils_new/mrcc_dress.irp.f b/plugins/MRCC_Utils_new/mrcc_dress.irp.f deleted file mode 100644 index ee998995..00000000 --- a/plugins/MRCC_Utils_new/mrcc_dress.irp.f +++ /dev/null @@ -1,183 +0,0 @@ -subroutine mrcc_dress(ndetref,ndetnonref,nstates,delta_ij_,delta_ii_) - use bitmasks - implicit none - integer, intent(in) :: ndetref,nstates,ndetnonref - double precision, intent(inout) :: delta_ii_(ndetref,nstates),delta_ij_(ndetref,ndetnonref,nstates) - integer :: i,j,k,l,m - integer :: i_state - integer :: N_connect_ref - integer*2,allocatable :: excitation_operators(:,:) - double precision, allocatable :: amplitudes_phase_less(:) - double precision, allocatable :: coef_test(:) - integer(bit_kind), allocatable :: key_test(:,:) - integer, allocatable :: index_connected(:) - integer :: i_hole,i_particle,ispin,i_ok,connected_to_ref,index_wf - integer, allocatable :: idx_vector(:) - double precision :: phase_ij - double precision :: dij,phase_la - double precision :: hij,phase - integer :: exc(0:2,2,2),degree - logical :: is_in_wavefunction - double precision, allocatable :: delta_ij_tmp(:,:,:), delta_ii_tmp(:,:) - logical, external :: is_in_psi_ref - - i_state = 1 - allocate(excitation_operators(5,N_det_non_ref)) - allocate(amplitudes_phase_less(N_det_non_ref)) - allocate(index_connected(N_det_non_ref)) - - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP SHARED(N_det_ref, N_det_non_ref, psi_ref, i_state, & - !$OMP N_connect_ref,index_connected,psi_non_ref, & - !$OMP excitation_operators,amplitudes_phase_less, & - !$OMP psi_non_ref_coef,N_int,lambda_mrcc, & - !$OMP delta_ii_,delta_ij_,psi_ref_coef,nstates, & - !$OMP mo_integrals_threshold,idx_non_ref_rev) & - !$OMP PRIVATE(i,j,k,l,hil,phase_il,exc,degree,t_il, & - !$OMP key_test,i_ok,phase_la,hij,phase_ij,m, & - !$OMP dij,idx_vector,delta_ij_tmp, & - !$OMP delta_ii_tmp,phase) - allocate(idx_vector(0:N_det_non_ref)) - allocate(key_test(N_int,2)) - allocate(delta_ij_tmp(size(delta_ij_,1),size(delta_ij_,2),nstates)) - allocate(delta_ii_tmp(size(delta_ij_,1),nstates)) - delta_ij_tmp = 0.d0 - delta_ii_tmp = 0.d0 - - do i = 1, N_det_ref - !$OMP SINGLE - call get_excitation_operators_for_one_ref(psi_ref(1,1,i),i_state,N_det_non_ref,N_connect_ref,excitation_operators,amplitudes_phase_less,index_connected) - print*,'N_connect_ref =',N_connect_ref - print*,'N_det_non_ref =',N_det_non_ref - !$OMP END SINGLE - !$OMP BARRIER - - !$OMP DO SCHEDULE(dynamic) - do l = 1, N_det_non_ref -! print *, l, '/', N_det_non_ref - double precision :: t_il,phase_il,hil - call i_H_j_phase_out(psi_ref(1,1,i),psi_non_ref(1,1,l),N_int,hil,phase_il,exc,degree) - t_il = hil * lambda_mrcc(i_state,l) - if (dabs(t_il) < mo_integrals_threshold) then - cycle - endif - ! loop on the non ref determinants - - do j = 1, N_connect_ref - ! loop on the excitation operators linked to i - - do k = 1, N_int - key_test(k,1) = psi_non_ref(k,1,l) - key_test(k,2) = psi_non_ref(k,2,l) - enddo - - ! we apply the excitation operator T_I->j - call apply_excitation_operator(key_test,excitation_operators(1,j),i_ok) - if(i_ok.ne.1)cycle - - ! we check if such determinant is already in the wave function - if(is_in_wavefunction(key_test,N_int))cycle - - ! we get the phase for psi_non_ref(l) -> T_I->j |psi_non_ref(l)> - call get_excitation(psi_non_ref(1,1,l),key_test,exc,degree,phase_la,N_int) - - ! we get the phase T_I->j - call i_H_j_phase_out(psi_ref(1,1,i),psi_non_ref(1,1,index_connected(j)),N_int,hij,phase_ij,exc,degree) - - ! we compute the contribution to the coef of key_test - dij = t_il * hij * phase_la *phase_ij *lambda_mrcc(i_state,index_connected(j)) * 0.5d0 - if (dabs(dij) < mo_integrals_threshold) then - cycle - endif - - ! we compute the interaction of such determinant with all the non_ref dets - call filter_connected(psi_non_ref,key_test,N_int,N_det_non_ref,idx_vector) - - do k = 1, idx_vector(0) - m = idx_vector(k) - call i_H_j_phase_out(key_test,psi_non_ref(1,1,m),N_int,hij,phase,exc,degree) - delta_ij_tmp(i,m,i_state) += hij * dij - enddo - - - enddo - - if(dabs(psi_ref_coef(i,i_state)).le.5.d-5) then - delta_ii_tmp(i,i_state) -= & - delta_ij_tmp(i,l,i_state) * psi_non_ref_coef(l,i_state) & - / psi_ref_coef(i,i_state) - endif - - enddo - !$OMP END DO - enddo - - !$OMP CRITICAL - delta_ij_ = delta_ij_ + delta_ij_tmp - delta_ii_ = delta_ii_ + delta_ii_tmp - !$OMP END CRITICAL - - deallocate(delta_ii_tmp,delta_ij_tmp) - deallocate(idx_vector) - deallocate(key_test) - !$OMP END PARALLEL - - deallocate(excitation_operators) - deallocate(amplitudes_phase_less) - -end - - - -subroutine apply_excitation_operator(key_in,excitation_operator,i_ok) - use bitmasks - implicit none - integer(bit_kind), intent(inout) :: key_in - integer, intent (out) :: i_ok - integer*2 :: excitation_operator(5) - integer :: i_particle,i_hole,ispin - ! Do excitation - if(excitation_operator(5)==1)then ! mono alpha - i_hole = excitation_operator(1) - i_particle = excitation_operator(2) - ispin = 1 - call do_mono_excitation(key_in,i_hole,i_particle,ispin,i_ok) - else if (excitation_operator(5)==-1)then ! mono beta - i_hole = excitation_operator(3) - i_particle = excitation_operator(4) - ispin = 2 - call do_mono_excitation(key_in,i_hole,i_particle,ispin,i_ok) - else if (excitation_operator(5) == -2 )then ! double beta - i_hole = excitation_operator(1) - i_particle = excitation_operator(2) - ispin = 2 - call do_mono_excitation(key_in,i_hole,i_particle,ispin,i_ok) - if(i_ok.ne.1)return - i_hole = excitation_operator(3) - i_particle = excitation_operator(4) - ispin = 2 - call do_mono_excitation(key_in,i_hole,i_particle,ispin,i_ok) - - else if (excitation_operator(5) == 2 )then ! double alpha - i_hole = excitation_operator(1) - i_particle = excitation_operator(2) - ispin = 1 - call do_mono_excitation(key_in,i_hole,i_particle,ispin,i_ok) - if(i_ok.ne.1)return - i_hole = excitation_operator(3) - i_particle = excitation_operator(4) - ispin = 1 - call do_mono_excitation(key_in,i_hole,i_particle,ispin,i_ok) - - else if (excitation_operator(5) == 0 )then ! double alpha/alpha - i_hole = excitation_operator(1) - i_particle = excitation_operator(2) - ispin = 1 - call do_mono_excitation(key_in,i_hole,i_particle,ispin,i_ok) - if(i_ok.ne.1)return - i_hole = excitation_operator(3) - i_particle = excitation_operator(4) - ispin = 2 - call do_mono_excitation(key_in,i_hole,i_particle,ispin,i_ok) - endif -end diff --git a/plugins/MRCC_Utils_new/mrcc_general.irp.f b/plugins/MRCC_Utils_new/mrcc_general.irp.f deleted file mode 100644 index 245fcb05..00000000 --- a/plugins/MRCC_Utils_new/mrcc_general.irp.f +++ /dev/null @@ -1,67 +0,0 @@ -subroutine run_mrcc - implicit none - call set_generators_bitmasks_as_holes_and_particles - call mrcc_iterations -end - -subroutine mrcc_iterations - implicit none - - integer :: i,j - - double precision :: E_new, E_old, delta_e - integer :: iteration - E_new = 0.d0 - delta_E = 1.d0 - iteration = 0 - do while (delta_E > 1.d-8) - iteration += 1 - print *, '===========================' - print *, 'MRCC Iteration', iteration - print *, '===========================' - print *, '' - E_old = sum(ci_energy_dressed) - call write_double(6,ci_energy_dressed(1),"MRCC energy") - call diagonalize_ci_dressed - E_new = sum(ci_energy_dressed) - delta_E = dabs(E_new - E_old) -! stop - if (iteration > 200) then - exit - endif - enddo - call write_double(6,ci_energy_dressed(1),"Final MRCC energy") - call ezfio_set_mrcc_cassd_energy(ci_energy_dressed(1)) - call save_wavefunction - -end - -subroutine set_generators_bitmasks_as_holes_and_particles - implicit none - integer :: i,k - do k = 1, N_generators_bitmask - do i = 1, N_int - ! Pure single part - generators_bitmask(i,1,1,k) = holes_operators(i,1) ! holes for pure single exc alpha - generators_bitmask(i,1,2,k) = particles_operators(i,1) ! particles for pure single exc alpha - generators_bitmask(i,2,1,k) = holes_operators(i,2) ! holes for pure single exc beta - generators_bitmask(i,2,2,k) = particles_operators(i,2) ! particles for pure single exc beta - - ! Double excitation - generators_bitmask(i,1,3,k) = holes_operators(i,1) ! holes for first single exc alpha - generators_bitmask(i,1,4,k) = particles_operators(i,1) ! particles for first single exc alpha - generators_bitmask(i,2,3,k) = holes_operators(i,2) ! holes for first single exc beta - generators_bitmask(i,2,4,k) = particles_operators(i,2) ! particles for first single exc beta - - generators_bitmask(i,1,5,k) = holes_operators(i,1) ! holes for second single exc alpha - generators_bitmask(i,1,6,k) = particles_operators(i,1) ! particles for second single exc alpha - generators_bitmask(i,2,5,k) = holes_operators(i,2) ! holes for second single exc beta - generators_bitmask(i,2,6,k) = particles_operators(i,2) ! particles for second single exc beta - - enddo - enddo - touch generators_bitmask - - - -end diff --git a/plugins/MRCC_Utils_new/mrcc_utils.irp.f b/plugins/MRCC_Utils_new/mrcc_utils.irp.f deleted file mode 100644 index d97696e5..00000000 --- a/plugins/MRCC_Utils_new/mrcc_utils.irp.f +++ /dev/null @@ -1,179 +0,0 @@ - BEGIN_PROVIDER [ double precision, lambda_mrcc, (N_states,psi_det_size) ] -&BEGIN_PROVIDER [ double precision, lambda_pert, (N_states,psi_det_size) ] - implicit none - BEGIN_DOC - ! cm/ or perturbative 1/Delta_E(m) - END_DOC - integer :: i,k - double precision :: ihpsi(N_states), hii - integer :: i_ok - i_ok = 0 - - do i=1,N_det_non_ref - call i_h_psi(psi_non_ref(1,1,i), psi_ref, psi_ref_coef, N_int, N_det_ref,& - size(psi_ref_coef,1), n_states, ihpsi) - call i_h_j(psi_non_ref(1,1,i),psi_non_ref(1,1,i),N_int,hii) - do k=1,N_states - lambda_pert(k,i) = 1.d0 / (psi_ref_energy_diagonalized(k)-hii) - if (dabs(ihpsi(k)).le.1.d-3) then - i_ok +=1 - lambda_mrcc(k,i) = lambda_pert(k,i) - else - lambda_mrcc(k,i) = psi_non_ref_coef(i,k)/ihpsi(k) - endif - enddo - enddo - print*,'N_det_non_ref = ',N_det_non_ref - print*,'Number of Perturbatively treated determinants = ',i_ok - print*,'psi_coef_ref_ratio = ',psi_ref_coef(2,1)/psi_ref_coef(1,1) - -END_PROVIDER - - - - -!BEGIN_PROVIDER [ double precision, delta_ij_non_ref, (N_det_non_ref, N_det_non_ref,N_states) ] -!implicit none -!BEGIN_DOC -!! Dressing matrix in SD basis -!END_DOC -!delta_ij_non_ref = 0.d0 -!call H_apply_mrcc_simple(delta_ij_non_ref,N_det_non_ref) -!END_PROVIDER - - BEGIN_PROVIDER [ double precision, delta_ij, (N_det_ref,N_det_non_ref,N_states) ] -&BEGIN_PROVIDER [ double precision, delta_ii, (N_det_ref,N_states) ] - implicit none - BEGIN_DOC - ! Dressing matrix in N_det basis - END_DOC - integer :: i,j,m - delta_ij = 0.d0 - delta_ii = 0.d0 - call mrcc_dress(N_det_ref,N_det_non_ref,N_states,delta_ij,delta_ii) - write(33,*)delta_ij - write(34,*)delta_ii -END_PROVIDER - -BEGIN_PROVIDER [ double precision, h_matrix_dressed, (N_det,N_det,N_states) ] - implicit none - BEGIN_DOC - ! Dressed H with Delta_ij - END_DOC - integer :: i, j,istate,ii,jj - do istate = 1,N_states - do j=1,N_det - do i=1,N_det - h_matrix_dressed(i,j,istate) = h_matrix_all_dets(i,j) - enddo - enddo - do ii = 1, N_det_ref - i =idx_ref(ii) - h_matrix_dressed(i,i,istate) += delta_ii(ii,istate) - do jj = 1, N_det_non_ref - j =idx_non_ref(jj) - h_matrix_dressed(i,j,istate) += delta_ij(ii,jj,istate) - h_matrix_dressed(j,i,istate) += delta_ij(ii,jj,istate) - enddo - enddo - enddo -END_PROVIDER - - - BEGIN_PROVIDER [ double precision, CI_electronic_energy_dressed, (N_states_diag) ] -&BEGIN_PROVIDER [ double precision, CI_eigenvectors_dressed, (N_det,N_states_diag) ] -&BEGIN_PROVIDER [ double precision, CI_eigenvectors_s2_dressed, (N_states_diag) ] - implicit none - BEGIN_DOC - ! Eigenvectors/values of the CI matrix - END_DOC - integer :: i,j - - do j=1,N_states_diag - do i=1,N_det - CI_eigenvectors_dressed(i,j) = psi_coef(i,j) - enddo - enddo - - if (diag_algorithm == "Davidson") then - - integer :: istate - istate = 1 - call davidson_diag_mrcc(psi_det,CI_eigenvectors_dressed,CI_electronic_energy_dressed,& - size(CI_eigenvectors_dressed,1),N_det,N_states_diag,N_int,output_determinants,istate) - - else if (diag_algorithm == "Lapack") then - - double precision, allocatable :: eigenvectors(:,:), eigenvalues(:) - allocate (eigenvectors(size(H_matrix_dressed,1),N_det)) - allocate (eigenvalues(N_det)) - call lapack_diag(eigenvalues,eigenvectors, & - H_matrix_dressed,size(H_matrix_dressed,1),N_det) - CI_electronic_energy_dressed(:) = 0.d0 - do i=1,N_det - CI_eigenvectors_dressed(i,1) = eigenvectors(i,1) - enddo - integer :: i_state - double precision :: s2 - i_state = 0 - if (s2_eig) then - do j=1,N_det - call get_s2_u0(psi_det,eigenvectors(1,j),N_det,N_det,s2) - if(dabs(s2-expected_s2).le.0.3d0)then - i_state += 1 - do i=1,N_det - CI_eigenvectors_dressed(i,i_state) = eigenvectors(i,j) - enddo - CI_electronic_energy_dressed(i_state) = eigenvalues(j) - CI_eigenvectors_s2_dressed(i_state) = s2 - endif - if (i_state.ge.N_states_diag) then - exit - endif - enddo - else - do j=1,N_states_diag - call get_s2_u0(psi_det,eigenvectors(1,j),N_det,N_det,s2) - i_state += 1 - do i=1,N_det - CI_eigenvectors_dressed(i,i_state) = eigenvectors(i,j) - enddo - CI_electronic_energy_dressed(i_state) = eigenvalues(j) - CI_eigenvectors_s2_dressed(i_state) = s2 - enddo - endif - deallocate(eigenvectors,eigenvalues) - endif - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, CI_energy_dressed, (N_states_diag) ] - implicit none - BEGIN_DOC - ! N_states lowest eigenvalues of the dressed CI matrix - END_DOC - - integer :: j - character*(8) :: st - call write_time(output_determinants) - do j=1,N_states_diag - CI_energy_dressed(j) = CI_electronic_energy_dressed(j) + nuclear_repulsion - enddo - -END_PROVIDER - -subroutine diagonalize_CI_dressed - implicit none - BEGIN_DOC -! Replace the coefficients of the CI states by the coefficients of the -! eigenstates of the CI matrix - END_DOC - integer :: i,j - do j=1,N_states_diag - do i=1,N_det - psi_coef(i,j) = CI_eigenvectors_dressed(i,j) - enddo - enddo - SOFT_TOUCH psi_coef - -end diff --git a/plugins/MRCC_Utils_new/tree_dependency.png b/plugins/MRCC_Utils_new/tree_dependency.png deleted file mode 100644 index 500e5d43..00000000 Binary files a/plugins/MRCC_Utils_new/tree_dependency.png and /dev/null differ diff --git a/plugins/MRPT_Utils/EZFIO.cfg b/plugins/MRPT_Utils/EZFIO.cfg new file mode 100644 index 00000000..2fcc26ad --- /dev/null +++ b/plugins/MRPT_Utils/EZFIO.cfg @@ -0,0 +1,7 @@ +[do_third_order_1h1p] +type: logical +doc: If true, compute the third order contribution for the 1h1p +interface: ezfio,provider,ocaml +default: True + + diff --git a/plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES b/plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..a613d5f2 --- /dev/null +++ b/plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Determinants Selectors_full Generators_full Davidson diff --git a/plugins/MRPT_Utils/README.rst b/plugins/MRPT_Utils/README.rst new file mode 100644 index 00000000..6b7a8eff --- /dev/null +++ b/plugins/MRPT_Utils/README.rst @@ -0,0 +1,13 @@ +========== +MRPT_Utils +========== + +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/MRPT_Utils/excitations_cas.irp.f b/plugins/MRPT_Utils/excitations_cas.irp.f index fb5cc953..10cfe7c0 100644 --- a/plugins/MRPT_Utils/excitations_cas.irp.f +++ b/plugins/MRPT_Utils/excitations_cas.irp.f @@ -64,7 +64,7 @@ subroutine apply_exc_to_psi(orb,hole_particle,spin_exc, & accu_elec += popcnt(det_tmp_bis(j)) enddo if(accu_elec == 1)then - phase = phase * -1.d0 + phase = -phase endif enddo do j = 1, N_states_in @@ -102,7 +102,7 @@ subroutine apply_exc_to_psi(orb,hole_particle,spin_exc, & accu_elec += popcnt(det_tmp_bis(j)) enddo if(accu_elec == 1)then - phase = phase * -1.d0 + phase = -phase endif enddo do j = 1, N_states_in diff --git a/plugins/MRPT_Utils/give_2h2p.irp.f b/plugins/MRPT_Utils/give_2h2p.irp.f new file mode 100644 index 00000000..df71e594 --- /dev/null +++ b/plugins/MRPT_Utils/give_2h2p.irp.f @@ -0,0 +1,35 @@ +subroutine give_2h2p(contrib_2h2p) + implicit none + double precision, intent(out) :: contrib_2h2p(N_states) + integer :: i,j,k,l,m + integer :: iorb,jorb,korb,lorb + + double precision :: get_mo_bielec_integral + double precision :: direct_int,exchange_int + double precision :: numerator,denominator(N_states) + + contrib_2h2p = 0.d0 + do i = 1, n_inact_orb + iorb = list_inact(i) + do j = 1, n_inact_orb + jorb = list_inact(j) + do k = 1, n_virt_orb + korb = list_virt(k) + do l = 1, n_virt_orb + lorb = list_virt(l) + direct_int = get_mo_bielec_integral(iorb,jorb,korb,lorb ,mo_integrals_map) + exchange_int = get_mo_bielec_integral(iorb,jorb,lorb,korb ,mo_integrals_map) + numerator = 3.d0 * direct_int*direct_int + exchange_int*exchange_int -2.d0 * exchange_int * direct_int + do m = 1, N_states + denominator(m) = fock_core_inactive_total_spin_trace(iorb,m) + fock_core_inactive_total_spin_trace(jorb,m) & + -fock_virt_total_spin_trace(korb,m) - fock_virt_total_spin_trace(lorb,m) + contrib_2h2p(m) += numerator / denominator(m) + enddo + enddo + enddo + enddo + enddo + contrib_2h2p = contrib_2h2p*0.5d0 + +end + diff --git a/plugins/MRPT_Utils/mrpt_utils.irp.f b/plugins/MRPT_Utils/mrpt_utils.irp.f index 80739aa2..d7b1f0f6 100644 --- a/plugins/MRPT_Utils/mrpt_utils.irp.f +++ b/plugins/MRPT_Utils/mrpt_utils.irp.f @@ -262,89 +262,87 @@ END_PROVIDER print*, 'Davidson not yet implemented for the dressing ... ' stop - else if (diag_algorithm == "Lapack") then - - allocate (eigenvectors(size(H_matrix_all_dets,1),N_det)) - allocate (eigenvalues(N_det)) - call lapack_diag(eigenvalues,eigenvectors, & - Hmatrix_dressed_pt2_new_symmetrized(1,1,1),N_det,N_det) - CI_electronic_dressed_pt2_new_energy(:) = 0.d0 - if (s2_eig) then - i_state = 0 - allocate (s2_eigvalues(N_det)) - allocate(index_good_state_array(N_det),good_state_array(N_det)) - good_state_array = .False. - do j=1,N_det - call get_s2_u0(psi_det,eigenvectors(1,j),N_det,size(eigenvectors,1),s2) - s2_eigvalues(j) = s2 - ! Select at least n_states states with S^2 values closed to "expected_s2" - if(dabs(s2-expected_s2).le.0.3d0)then - i_state +=1 - index_good_state_array(i_state) = j - good_state_array(j) = .True. - endif - if(i_state.eq.N_states) then - exit - endif - enddo - if(i_state .ne.0)then - ! Fill the first "i_state" states that have a correct S^2 value - do j = 1, i_state - do i=1,N_det - CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,index_good_state_array(j)) - enddo - CI_electronic_dressed_pt2_new_energy(j) = eigenvalues(index_good_state_array(j)) - CI_dressed_pt2_new_eigenvectors_s2(j) = s2_eigvalues(index_good_state_array(j)) - enddo - i_other_state = 0 - do j = 1, N_det - if(good_state_array(j))cycle - i_other_state +=1 - if(i_state+i_other_state.gt.n_states_diag)then - exit - endif - call get_s2_u0(psi_det,eigenvectors(1,j),N_det,size(eigenvectors,1),s2) - do i=1,N_det - CI_dressed_pt2_new_eigenvectors(i,i_state+i_other_state) = eigenvectors(i,j) - enddo - CI_electronic_dressed_pt2_new_energy(i_state+i_other_state) = eigenvalues(j) - CI_dressed_pt2_new_eigenvectors_s2(i_state+i_other_state) = s2 - enddo - - deallocate(index_good_state_array,good_state_array) + else if (diag_algorithm == "Lapack") then - else - print*,'' - print*,'!!!!!!!! WARNING !!!!!!!!!' - print*,' Within the ',N_det,'determinants selected' - print*,' and the ',N_states_diag,'states requested' - print*,' We did not find any state with S^2 values close to ',expected_s2 - print*,' We will then set the first N_states eigenvectors of the H matrix' - print*,' as the CI_dressed_pt2_new_eigenvectors' - print*,' You should consider more states and maybe ask for diagonalize_s2 to be .True. or just enlarge the CI space' - print*,'' - do j=1,min(N_states_diag,N_det) - do i=1,N_det - CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,j) - enddo - CI_electronic_dressed_pt2_new_energy(j) = eigenvalues(j) - CI_dressed_pt2_new_eigenvectors_s2(j) = s2_eigvalues(j) + allocate (eigenvectors(size(H_matrix_all_dets,1),N_det)) + allocate (eigenvalues(N_det)) + call lapack_diag(eigenvalues,eigenvectors, & + H_matrix_all_dets,size(H_matrix_all_dets,1),N_det) + CI_electronic_energy(:) = 0.d0 + if (s2_eig) then + i_state = 0 + allocate (s2_eigvalues(N_det)) + allocate(index_good_state_array(N_det),good_state_array(N_det)) + good_state_array = .False. + call u_0_S2_u_0(s2_eigvalues,eigenvectors,N_det,psi_det,N_int,& + N_det,size(eigenvectors,1)) + do j=1,N_det + ! Select at least n_states states with S^2 values closed to "expected_s2" + if(dabs(s2_eigvalues(j)-expected_s2).le.0.5d0)then + i_state +=1 + index_good_state_array(i_state) = j + good_state_array(j) = .True. + endif + if(i_state.eq.N_states) then + exit + endif enddo - endif - deallocate(s2_eigvalues) - else - ! Select the "N_states_diag" states of lowest energy - do j=1,min(N_det,N_states_diag) - call get_s2_u0(psi_det,eigenvectors(1,j),N_det,N_det,s2) - do i=1,N_det - CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,j) - enddo - CI_electronic_dressed_pt2_new_energy(j) = eigenvalues(j) - CI_dressed_pt2_new_eigenvectors_s2(j) = s2 - enddo - endif - deallocate(eigenvectors,eigenvalues) - endif + if(i_state .ne.0)then + ! Fill the first "i_state" states that have a correct S^2 value + do j = 1, i_state + do i=1,N_det + CI_eigenvectors(i,j) = eigenvectors(i,index_good_state_array(j)) + enddo + CI_electronic_energy(j) = eigenvalues(index_good_state_array(j)) + CI_eigenvectors_s2(j) = s2_eigvalues(index_good_state_array(j)) + enddo + i_other_state = 0 + do j = 1, N_det + if(good_state_array(j))cycle + i_other_state +=1 + if(i_state+i_other_state.gt.n_states_diag)then + exit + endif + do i=1,N_det + CI_eigenvectors(i,i_state+i_other_state) = eigenvectors(i,j) + enddo + CI_electronic_energy(i_state+i_other_state) = eigenvalues(j) + CI_eigenvectors_s2(i_state+i_other_state) = s2_eigvalues(i_state+i_other_state) + enddo + + else + print*,'' + print*,'!!!!!!!! WARNING !!!!!!!!!' + print*,' Within the ',N_det,'determinants selected' + print*,' and the ',N_states_diag,'states requested' + print*,' We did not find any state with S^2 values close to ',expected_s2 + print*,' We will then set the first N_states eigenvectors of the H matrix' + print*,' as the CI_eigenvectors' + print*,' You should consider more states and maybe ask for s2_eig to be .True. or just enlarge the CI space' + print*,'' + do j=1,min(N_states_diag,N_det) + do i=1,N_det + CI_eigenvectors(i,j) = eigenvectors(i,j) + enddo + CI_electronic_energy(j) = eigenvalues(j) + CI_eigenvectors_s2(j) = s2_eigvalues(j) + enddo + endif + deallocate(index_good_state_array,good_state_array) + deallocate(s2_eigvalues) + else + call u_0_S2_u_0(CI_eigenvectors_s2,eigenvectors,N_det,psi_det,N_int,& + min(N_det,N_states_diag),size(eigenvectors,1)) + ! Select the "N_states_diag" states of lowest energy + do j=1,min(N_det,N_states_diag) + do i=1,N_det + CI_eigenvectors(i,j) = eigenvectors(i,j) + enddo + CI_electronic_energy(j) = eigenvalues(j) + enddo + endif + deallocate(eigenvectors,eigenvalues) + endif END_PROVIDER diff --git a/plugins/MRPT_Utils/psi_active_prov.irp.f b/plugins/MRPT_Utils/psi_active_prov.irp.f index f08af1d5..67501727 100644 --- a/plugins/MRPT_Utils/psi_active_prov.irp.f +++ b/plugins/MRPT_Utils/psi_active_prov.irp.f @@ -182,7 +182,11 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) double precision :: delta_e_inactive(N_states) integer :: i_hole_inact - + call get_excitation_degree(det_1,det_2,degree,N_int) + if(degree>2)then + delta_e_final = -1.d+10 + return + endif call give_holes_in_inactive_space(det_2,n_holes_spin,n_holes,holes_list) delta_e_inactive = 0.d0 @@ -307,32 +311,11 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) else if (n_holes_act == 1 .and. n_particles_act == 0) then ispin = hole_list_practical(1,1) i_hole_act = hole_list_practical(2,1) -! call get_excitation_degree(det_1,det_2,degree,N_int) -! if(degree == 1)then -! call get_excitation(det_1,det_2,exc,degree,phase,N_int) -! call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) -! i_hole = list_act_reverse(h1) -! i_part = list_virt_reverse(p1) -! do i_state = 1, N_states -! if(isnan(one_creat_virt(i_hole,i_part,i_state)))then -! print*, i_hole,i_part,i_state -! call debug_det(det_1,N_int) -! call debug_det(det_2,N_int) -! stop -! endif -! delta_e_act(i_state) += one_creat_virt(i_hole,i_part,i_state) -! enddo -! else if (degree == 2)then do i_state = 1, N_states delta_e_act(i_state) += one_anhil(i_hole_act , ispin,i_state) enddo -! endif else if (n_holes_act == 1 .and. n_particles_act == 1) then -! i_hole_act = holes_active_list_spin_traced(1) -! i_particle_act = particles_active_list_spin_traced(1) -! delta_e_act += one_anhil_one_creat_spin_trace(i_hole_act,i_particle_act) - ! first hole ispin = hole_list_practical(1,1) i_hole_act = hole_list_practical(2,1) @@ -344,9 +327,6 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) enddo else if (n_holes_act == 2 .and. n_particles_act == 0) then -! i_hole_act = holes_active_list_spin_traced(1) -! j_hole_act = holes_active_list_spin_traced(1) -! delta_e_act += two_anhil_spin_trace(i_hole_act,j_hole_act) ispin = hole_list_practical(1,1) i_hole_act = hole_list_practical(2,1) jspin = hole_list_practical(1,2) @@ -356,9 +336,6 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) enddo else if (n_holes_act == 0 .and. n_particles_act == 2) then -! i_particle_act = particles_active_list_spin_traced(1) -! j_particle_act = particles_active_list_spin_traced(2) -! delta_e_act += two_creat_spin_trace(i_particle_act,j_particle_act) ispin = particle_list_practical(1,1) i_particle_act = particle_list_practical(2,1) jspin = particle_list_practical(1,2) @@ -368,14 +345,6 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) enddo else if (n_holes_act == 2 .and. n_particles_act == 1) then -! i_hole_act = holes_active_list_spin_traced(1) -! j_hole_act = holes_active_list_spin_traced(2) -! i_particle_act = particles_active_list_spin_traced(1) -! print*, 'i_hole_act,j_hole_act,i_particle_act' -! print*, i_hole_act,j_hole_act,i_particle_act -! print*, two_anhil_one_creat_spin_trace(i_hole_act,j_hole_act,i_particle_act) -! delta_e_act += two_anhil_one_creat_spin_trace(i_hole_act,j_hole_act,i_particle_act) - ! first hole ispin = hole_list_practical(1,1) i_hole_act = hole_list_practical(2,1) @@ -390,11 +359,6 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) enddo else if (n_holes_act == 1 .and. n_particles_act == 2) then -! i_hole_act = holes_active_list_spin_traced(1) -! i_particle_act = particles_active_list_spin_traced(1) -! j_particle_act = particles_active_list_spin_traced(2) -! delta_e_act += two_creat_one_anhil_spin_trace(i_hole_act,i_particle_act,j_particle_act) - ! first hole ispin = hole_list_practical(1,1) i_hole_act = hole_list_practical(2,1) @@ -410,11 +374,6 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) enddo else if (n_holes_act == 3 .and. n_particles_act == 0) then -! i_hole_act = holes_active_list_spin_traced(1) -! j_hole_act = holes_active_list_spin_traced(2) -! k_hole_act = holes_active_list_spin_traced(3) -! delta_e_act += three_anhil_spin_trace(i_hole_act,j_hole_act,k_hole_act) - ! first hole ispin = hole_list_practical(1,1) i_hole_act = hole_list_practical(2,1) @@ -429,10 +388,6 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) enddo else if (n_holes_act == 0 .and. n_particles_act == 3) then -! i_particle_act = particles_active_list_spin_traced(1) -! j_particle_act = particles_active_list_spin_traced(2) -! k_particle_act = particles_active_list_spin_traced(3) -! delta_e_act += three_creat_spin_trace(i_particle_act,j_particle_act,k_particle_act) ! first particle ispin = particle_list_practical(1,1) i_particle_act = particle_list_practical(2,1) @@ -442,7 +397,6 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) ! second particle kspin = particle_list_practical(1,3) k_particle_act = particle_list_practical(2,3) - do i_state = 1, N_states delta_e_act(i_state) += three_creat(i_particle_act,j_particle_act,k_particle_act,ispin,jspin,kspin,i_state) enddo @@ -464,12 +418,8 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) ! delta_e_act(i_state) += one_anhil_one_creat_inact_virt(i_hole,i_part,i_state) enddo endif - - else if (n_holes_act .ge. 2 .and. n_particles_act .ge.2) then - delta_e_act = -10000000.d0 - endif !print*, 'one_anhil_spin_trace' @@ -479,6 +429,7 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) do i_state = 1, n_states delta_e_final(i_state) = delta_e_act(i_state) + delta_e_inactive(i_state) - delta_e_virt(i_state) enddo +!write(*,'(100(f16.10,X))'), delta_e_final(1) , delta_e_act(1) , delta_e_inactive(1) , delta_e_virt(1) end diff --git a/plugins/MRPT_Utils/second_order_new.irp.f b/plugins/MRPT_Utils/second_order_new.irp.f index 46de6601..ba3b421b 100644 --- a/plugins/MRPT_Utils/second_order_new.irp.f +++ b/plugins/MRPT_Utils/second_order_new.irp.f @@ -198,8 +198,8 @@ subroutine give_1h2p_new(matrix_1h2p) if(ispin == kspin .and. vorb.le.rorb)then cycle_same_spin_first_order = .True. endif -! if(ispin .ne. kspin .and. cycle_same_spin_first_order == .False. )then ! condition not to double count - if(cycle_same_spin_first_order == .False. )then ! condition not to double count +! if(ispin .ne. kspin .and. cycle_same_spin_first_order .eqv. .False. )then ! condition not to double count + if(cycle_same_spin_first_order .eqv. .False. )then ! condition not to double count ! FIRST ORDER CONTRIBUTION @@ -235,7 +235,7 @@ subroutine give_1h2p_new(matrix_1h2p) if(ispin == jspin .and. vorb.le.rorb)then cycle_same_spin_second_order = .True. endif - if(cycle_same_spin_second_order == .False.)then + if(cycle_same_spin_second_order .eqv. .False.)then do corb = 1, n_act_orb if(perturb_dets_phase(corb,jspin,ispin) .le. -10.d0)cycle do inint = 1, N_int @@ -292,7 +292,7 @@ subroutine give_1h2p_new(matrix_1h2p) if(ispin == 2 .and. vorb.le.rorb)then cycle_same_spin_second_order = .True. endif - if(cycle_same_spin_second_order == .False.)then ! condition not to double count + if(cycle_same_spin_second_order .eqv. .False.)then ! condition not to double count if(perturb_dets_phase(borb,2,ispin) .le. -10.d0)cycle do inint = 1, N_int det_tmp(inint,1) = perturb_dets(inint,1,borb,2,ispin) @@ -326,7 +326,7 @@ subroutine give_1h2p_new(matrix_1h2p) if(ispin == 1 .and. vorb.le.rorb)then cycle_same_spin_second_order = .True. endif - if(cycle_same_spin_second_order == .False.)then ! condition not to double count + if(cycle_same_spin_second_order .eqv. .False.)then ! condition not to double count if(perturb_dets_phase(aorb,1,ispin) .le. -10.d0)cycle do inint = 1, N_int det_tmp(inint,1) = perturb_dets(inint,1,aorb,1,ispin) @@ -365,7 +365,7 @@ subroutine give_1h2p_new(matrix_1h2p) if(ispin == 2 .and. vorb.le.rorb)then cycle_same_spin_second_order = .True. endif - if(cycle_same_spin_second_order == .False.)then ! condition not to double count + if(cycle_same_spin_second_order .eqv. .False.)then ! condition not to double count if(perturb_dets_phase(aorb,2,ispin) .le. -10.d0)cycle do inint = 1, N_int det_tmp(inint,1) = perturb_dets(inint,1,aorb,2,ispin) @@ -400,7 +400,7 @@ subroutine give_1h2p_new(matrix_1h2p) if(ispin == 1 .and. vorb.le.rorb)then cycle_same_spin_second_order = .True. endif - if(cycle_same_spin_second_order == .False.)then ! condition not to double count + if(cycle_same_spin_second_order .eqv. .False.)then ! condition not to double count if(perturb_dets_phase(aorb,1,ispin) .le. -10.d0)cycle do inint = 1, N_int det_tmp(inint,1) = perturb_dets(inint,1,aorb,1,ispin) @@ -648,7 +648,7 @@ subroutine give_2h1p_new(matrix_2h1p) if(ispin == kspin .and. iorb.le.jorb)then cycle_same_spin_first_order = .True. endif - if(ispin .ne. kspin .or. cycle_same_spin_first_order == .False. )then! condition not to double count + if(ispin .ne. kspin .or. cycle_same_spin_first_order .eqv. .False. )then! condition not to double count ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{aorb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Idet > do inint = 1, N_int @@ -680,7 +680,7 @@ subroutine give_2h1p_new(matrix_2h1p) if(ispin == jspin .and. iorb.le.jorb)then cycle_same_spin_second_order = .True. endif - if(ispin .ne. jspin .or. cycle_same_spin_second_order == .False. )then! condition not to double count + if(ispin .ne. jspin .or. cycle_same_spin_second_order .eqv. .False. )then! condition not to double count do corb = 1, n_act_orb if(perturb_dets_phase(corb,jspin,ispin) .le. -10.d0)cycle do inint = 1, N_int diff --git a/plugins/Perturbation/NEEDED_CHILDREN_MODULES b/plugins/Perturbation/NEEDED_CHILDREN_MODULES index 6a9bca47..25b89c5f 100644 --- a/plugins/Perturbation/NEEDED_CHILDREN_MODULES +++ b/plugins/Perturbation/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Determinants Properties Hartree_Fock MRPT_Utils +Determinants Properties Hartree_Fock Davidson MRPT_Utils diff --git a/plugins/Perturbation/README.rst b/plugins/Perturbation/README.rst index 4bf62a2a..810a58e1 100644 --- a/plugins/Perturbation/README.rst +++ b/plugins/Perturbation/README.rst @@ -239,7 +239,7 @@ perturb_buffer_moller_plesset .br -`pt2_epstein_nesbet `_ +`pt2_epstein_nesbet `_ compute the standard Epstein-Nesbet perturbative first order coefficient and second order energetic contribution .br for the various N_st states. @@ -250,7 +250,7 @@ perturb_buffer_moller_plesset .br -`pt2_epstein_nesbet_2x2 `_ +`pt2_epstein_nesbet_2x2 `_ compute the Epstein-Nesbet 2x2 diagonalization coefficient and energetic contribution .br for the various N_st states. @@ -261,7 +261,7 @@ perturb_buffer_moller_plesset .br -`pt2_epstein_nesbet_sc2 `_ +`pt2_epstein_nesbet_sc2 `_ compute the standard Epstein-Nesbet perturbative first order coefficient and second order energetic contribution .br for the various N_st states, but with the CISD_SC2 energies and coefficients @@ -272,7 +272,7 @@ perturb_buffer_moller_plesset .br -`pt2_epstein_nesbet_sc2_no_projected `_ +`pt2_epstein_nesbet_sc2_no_projected `_ compute the Epstein-Nesbet perturbative first order coefficient and second order energetic contribution .br for the various N_st states, @@ -283,7 +283,7 @@ perturb_buffer_moller_plesset .br that can be repeated by repeating all the double excitations .br - : you repeat all the correlation energy already taken into account in CI_electronic_energy(1) + : you repeat all the correlation energy already taken into account in electronic_energy(1) .br that could be repeated to this determinant. .br @@ -296,7 +296,7 @@ perturb_buffer_moller_plesset H_pert_diag = c_pert -`pt2_epstein_nesbet_sc2_projected `_ +`pt2_epstein_nesbet_sc2_projected `_ compute the Epstein-Nesbet perturbative first order coefficient and second order energetic contribution .br for the various N_st states, @@ -307,7 +307,7 @@ perturb_buffer_moller_plesset .br that can be repeated by repeating all the double excitations .br - : you repeat all the correlation energy already taken into account in CI_electronic_energy(1) + : you repeat all the correlation energy already taken into account in electronic_energy(1) .br that could be repeated to this determinant. .br @@ -336,7 +336,7 @@ perturb_buffer_moller_plesset than pt2_max in absolute value -`pt2_moller_plesset `_ +`pt2_moller_plesset `_ compute the standard Moller-Plesset perturbative first order coefficient and second order energetic contribution .br for the various n_st states. @@ -347,7 +347,7 @@ perturb_buffer_moller_plesset .br -`remove_small_contributions `_ +`remove_small_contributions `_ Remove determinants with small contributions. N_states is assumed to be provided. @@ -356,15 +356,15 @@ perturb_buffer_moller_plesset Undocumented -`selection_criterion `_ +`selection_criterion `_ Threshold to select determinants. Set by selection routines. -`selection_criterion_factor `_ +`selection_criterion_factor `_ Threshold to select determinants. Set by selection routines. -`selection_criterion_min `_ +`selection_criterion_min `_ Threshold to select determinants. Set by selection routines. diff --git a/plugins/Perturbation/delta_rho_perturbation.irp.f b/plugins/Perturbation/delta_rho_perturbation.irp.f deleted file mode 100644 index c95972a6..00000000 --- a/plugins/Perturbation/delta_rho_perturbation.irp.f +++ /dev/null @@ -1,77 +0,0 @@ -subroutine pt2_delta_rho_one_point(det_pert,c_pert,e_2_pert,H_pert_diag,Nint,ndet,n_st,minilist,idx_minilist,N_minilist) - use bitmasks - implicit none - integer, intent(in) :: Nint,ndet,n_st - integer(bit_kind), intent(in) :: det_pert(Nint,2) - double precision , intent(out) :: c_pert(n_st),e_2_pert(n_st),H_pert_diag(N_st) - double precision :: i_O1_psi_array(N_st) - double precision :: i_H_psi_array(N_st) - - integer, intent(in) :: N_minilist - integer, intent(in) :: idx_minilist(0:N_det_selectors) - integer(bit_kind), intent(in) :: minilist(Nint,2,N_det_selectors) - - BEGIN_DOC - ! compute the perturbatibe contribution to the Integrated Spin density at z = z_one point of one determinant - ! - ! for the various n_st states, at various level of theory. - ! - ! c_pert(i) = /( - ) - ! - ! e_2_pert(i) = c_pert(i) * - ! - ! H_pert_diag(i) = c_pert(i)^2 * - ! - ! To get the contribution of the first order : - ! - ! = sum(over i) e_2_pert(i) - ! - ! To get the contribution of the diagonal elements of the second order : - ! - ! [ + + sum(over i) H_pert_diag(i) ] / [1. + sum(over i) c_pert(i) **2] - ! - END_DOC - - integer :: i,j - double precision :: diag_H_mat_elem,diag_o1_mat_elem_alpha_beta - integer :: exc(0:2,2,2) - integer :: degree - double precision :: phase,delta_e,h,oii,diag_o1_mat_elem - integer :: h1,h2,p1,p2,s1,s2 - ASSERT (Nint == N_int) - ASSERT (Nint > 0) - -! call get_excitation_degree(HF_bitmask,det_pert,degree,N_int) -! if(degree.gt.degree_max_generators+1)then -! H_pert_diag = 0.d0 -! e_2_pert = 0.d0 -! c_pert = 0.d0 -! return -! endif - call i_O1_psi_alpha_beta(mo_integrated_delta_rho_one_point,det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_O1_psi_array) - - !call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array) - call i_H_psi_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array) - - h = diag_H_mat_elem(det_pert,Nint) - oii = diag_O1_mat_elem_alpha_beta(mo_integrated_delta_rho_one_point,det_pert,N_int) - - - do i =1,N_st - if(CI_electronic_energy(i)>h.and.CI_electronic_energy(i).ne.0.d0)then - c_pert(i) = -1.d0 - e_2_pert(i) = selection_criterion*selection_criterion_factor*2.d0 - else if (dabs(CI_electronic_energy(i) - h) > 1.d-6) then - c_pert(i) = i_H_psi_array(i) / (CI_electronic_energy(i) - h) - e_2_pert(i) = c_pert(i) * (i_O1_psi_array(i)+i_O1_psi_array(i) ) + c_pert(i) * c_pert(i) * oii - H_pert_diag(i) = c_pert(i) * (i_O1_psi_array(i)+i_O1_psi_array(i) ) - else - c_pert(i) = -1.d0 - e_2_pert(i) = -dabs(i_H_psi_array(i)) - H_pert_diag(i) = c_pert(i) * i_O1_psi_array(i) - endif - enddo - - -end - diff --git a/plugins/Perturbation/perturbation.template.f b/plugins/Perturbation/perturbation.template.f index 94b6b8b0..a445bec0 100644 --- a/plugins/Perturbation/perturbation.template.f +++ b/plugins/Perturbation/perturbation.template.f @@ -3,7 +3,7 @@ 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) +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,electronic_energy) implicit none BEGIN_DOC ! Applly pertubration ``$PERT`` to the buffer of determinants generated in the H_apply @@ -14,6 +14,7 @@ subroutine perturb_buffer_$PERT(i_generator,buffer,buffer_size,e_2_pert_buffer,c integer(bit_kind), intent(in) :: buffer(Nint,2,buffer_size) integer(bit_kind),intent(in) :: key_mask(Nint,2) double precision, intent(in) :: fock_diag_tmp(2,0:mo_tot_num) + double precision, intent(in) :: electronic_energy(N_st) double precision, intent(inout) :: sum_norm_pert(N_st),sum_e_2_pert(N_st) double precision, intent(inout) :: coef_pert_buffer(N_st,buffer_size),e_2_pert_buffer(N_st,buffer_size),sum_H_pert_diag(N_st) double precision :: c_pert(N_st), e_2_pert(N_st), H_pert_diag(N_st) @@ -130,7 +131,6 @@ subroutine perturb_buffer_$PERT(i_generator,buffer,buffer_size,e_2_pert_buffer,c ! 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 @@ -151,7 +151,7 @@ subroutine perturb_buffer_$PERT(i_generator,buffer,buffer_size,e_2_pert_buffer,c 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, & + call pt2_$PERT(electronic_energy,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 @@ -160,11 +160,11 @@ subroutine perturb_buffer_$PERT(i_generator,buffer,buffer_size,e_2_pert_buffer,c cycle end if - call pt2_$PERT(psi_det_generators(1,1,i_generator),buffer(1,1,i), fock_diag_tmp, & + call pt2_$PERT(electronic_energy,psi_det_generators(1,1,i_generator),buffer(1,1,i), fock_diag_tmp, & c_pert,e_2_pert,H_pert_diag,Nint,N_minilist,n_st,minilist,idx_minilist,N_minilist) end if -! call pt2_$PERT(psi_det_generators(1,1,i_generator),buffer(1,1,i), fock_diag_tmp, & +! call pt2_$PERT(electronic_energy,psi_det_generators(1,1,i_generator),buffer(1,1,i), fock_diag_tmp, & ! c_pert,e_2_pert,H_pert_diag,Nint,N_minilist,n_st,minilist,idx_minilist,N_minilist) do k = 1,N_st @@ -182,7 +182,7 @@ subroutine perturb_buffer_$PERT(i_generator,buffer,buffer_size,e_2_pert_buffer,c end -subroutine perturb_buffer_by_mono_$PERT(i_generator,buffer,buffer_size,e_2_pert_buffer,coef_pert_buffer,sum_e_2_pert,sum_norm_pert,sum_H_pert_diag,N_st,Nint,key_mask,fock_diag_tmp) +subroutine perturb_buffer_by_mono_$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,electronic_energy) implicit none BEGIN_DOC ! Applly pertubration ``$PERT`` to the buffer of determinants generated in the H_apply @@ -193,6 +193,7 @@ subroutine perturb_buffer_by_mono_$PERT(i_generator,buffer,buffer_size,e_2_pert_ integer(bit_kind), intent(in) :: buffer(Nint,2,buffer_size) integer(bit_kind),intent(in) :: key_mask(Nint,2) double precision, intent(in) :: fock_diag_tmp(2,0:mo_tot_num) + double precision, intent(in) :: electronic_energy(N_st) double precision, intent(inout) :: sum_norm_pert(N_st),sum_e_2_pert(N_st) double precision, intent(inout) :: coef_pert_buffer(N_st,buffer_size),e_2_pert_buffer(N_st,buffer_size),sum_H_pert_diag(N_st) double precision :: c_pert(N_st), e_2_pert(N_st), H_pert_diag(N_st) @@ -241,7 +242,7 @@ subroutine perturb_buffer_by_mono_$PERT(i_generator,buffer,buffer_size,e_2_pert_ cycle endif - call pt2_$PERT(psi_det_generators(1,1,i_generator),buffer(1,1,i), fock_diag_tmp, & + call pt2_$PERT(electronic_energy,psi_det_generators(1,1,i_generator),buffer(1,1,i), fock_diag_tmp, & c_pert,e_2_pert,H_pert_diag,Nint,N_minilist,n_st,minilist,idx_minilist,N_minilist) do k = 1,N_st diff --git a/plugins/Perturbation/pt2_equations.irp.f b/plugins/Perturbation/pt2_equations.irp.f index b0d3e386..b29e130f 100644 --- a/plugins/Perturbation/pt2_equations.irp.f +++ b/plugins/Perturbation/pt2_equations.irp.f @@ -29,11 +29,11 @@ subroutine pt2_epstein_nesbet ($arguments) h = diag_H_mat_elem_fock(det_ref,det_pert,fock_diag_tmp,Nint) do i =1,N_st - if(CI_electronic_energy(i)>h.and.CI_electronic_energy(i).ne.0.d0)then + if(electronic_energy(i)>h.and.electronic_energy(i).ne.0.d0)then c_pert(i) = -1.d0 e_2_pert(i) = selection_criterion*selection_criterion_factor*2.d0 - else if (dabs(CI_electronic_energy(i) - h) > 1.d-6) then - c_pert(i) = i_H_psi_array(i) / (CI_electronic_energy(i) - h) + else if (dabs(electronic_energy(i) - h) > 1.d-6) then + c_pert(i) = i_H_psi_array(i) / (electronic_energy(i) - h) H_pert_diag(i) = h*c_pert(i)*c_pert(i) e_2_pert(i) = c_pert(i) * i_H_psi_array(i) else @@ -97,7 +97,6 @@ subroutine pt2_epstein_nesbet_2x2 ($arguments) double precision :: i_H_psi_array(N_st) ASSERT (Nint == N_int) ASSERT (Nint > 0) - PROVIDE CI_electronic_energy call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array) !call i_H_psi_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array) @@ -105,7 +104,7 @@ subroutine pt2_epstein_nesbet_2x2 ($arguments) h = diag_H_mat_elem_fock(det_ref,det_pert,fock_diag_tmp,Nint) do i =1,N_st if (i_H_psi_array(i) /= 0.d0) then - delta_e = h - CI_electronic_energy(i) + delta_e = h - electronic_energy(i) if (delta_e > 0.d0) then e_2_pert(i) = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * i_H_psi_array(i) * i_H_psi_array(i))) else @@ -166,7 +165,7 @@ subroutine pt2_epstein_nesbet_2x2_no_ci_diag($arguments) double precision :: i_H_psi_array(N_st) ASSERT (Nint == N_int) ASSERT (Nint > 0) - PROVIDE CI_electronic_energy + PROVIDE psi_energy call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array) !call i_H_psi_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array) @@ -174,7 +173,7 @@ subroutine pt2_epstein_nesbet_2x2_no_ci_diag($arguments) h = diag_H_mat_elem_fock(det_ref,det_pert,fock_diag_tmp,Nint) do i =1,N_st if (i_H_psi_array(i) /= 0.d0) then - delta_e = h - CI_expectation_value(i) + delta_e = h - psi_energy(i) if (delta_e > 0.d0) then e_2_pert(i) = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * i_H_psi_array(i) * i_H_psi_array(i))) else @@ -274,7 +273,7 @@ subroutine pt2_epstein_nesbet_SC2_projected ($arguments) ! ! that can be repeated by repeating all the double excitations ! - ! : you repeat all the correlation energy already taken into account in CI_electronic_energy(1) + ! : you repeat all the correlation energy already taken into account in electronic_energy(1) ! ! that could be repeated to this determinant. ! @@ -304,16 +303,16 @@ subroutine pt2_epstein_nesbet_SC2_projected ($arguments) enddo h = diag_H_mat_elem_fock(det_ref,det_pert,fock_diag_tmp,Nint) h = h + accu_e_corr - delta_E = 1.d0/(CI_SC2_electronic_energy(1) - h) + delta_E = 1.d0/(electronic_energy(1) - h) - c_pert(1) = i_H_psi_array(1) /(CI_SC2_electronic_energy(1) - h) + c_pert(1) = i_H_psi_array(1) /(electronic_energy(1) - h) e_2_pert(1) = i_H_psi_array(1) * c_pert(1) do i =2,N_st H_pert_diag(i) = h - if (dabs(CI_SC2_electronic_energy(i) - h) > 1.d-6) then - c_pert(i) = i_H_psi_array(i) / (-dabs(CI_SC2_electronic_energy(i) - h)) + if (dabs(electronic_energy(i) - h) > 1.d-6) then + c_pert(i) = i_H_psi_array(i) / (-dabs(electronic_energy(i) - h)) e_2_pert(i) = (c_pert(i) * i_H_psi_array(i)) else c_pert(i) = i_H_psi_array(i) @@ -357,7 +356,7 @@ subroutine pt2_epstein_nesbet_SC2_no_projected ($arguments) ! ! that can be repeated by repeating all the double excitations ! - ! : you repeat all the correlation energy already taken into account in CI_electronic_energy(1) + ! : you repeat all the correlation energy already taken into account in electronic_energy(1) ! ! that could be repeated to this determinant. ! @@ -387,16 +386,16 @@ subroutine pt2_epstein_nesbet_SC2_no_projected ($arguments) enddo h = diag_H_mat_elem_fock(det_ref,det_pert,fock_diag_tmp,Nint) h = h + accu_e_corr - delta_E = 1.d0/(CI_SC2_electronic_energy(1) - h) + delta_E = 1.d0/(electronic_energy(1) - h) - c_pert(1) = i_H_psi_array(1) /(CI_SC2_electronic_energy(1) - h) + c_pert(1) = i_H_psi_array(1) /(electronic_energy(1) - h) e_2_pert(1) = i_H_psi_array(1) * c_pert(1) do i =2,N_st H_pert_diag(i) = h - if (dabs(CI_SC2_electronic_energy(i) - h) > 1.d-6) then - c_pert(i) = i_H_psi_array(i) / (-dabs(CI_SC2_electronic_energy(i) - h)) + if (dabs(electronic_energy(i) - h) > 1.d-6) then + c_pert(i) = i_H_psi_array(i) / (-dabs(electronic_energy(i) - h)) e_2_pert(i) = (c_pert(i) * i_H_psi_array(i)) else c_pert(i) = i_H_psi_array(i) @@ -437,11 +436,11 @@ subroutine pt2_epstein_nesbet_sc2 ($arguments) h = diag_H_mat_elem_fock(det_ref,det_pert,fock_diag_tmp,Nint) do i =1,N_st - if(CI_SC2_electronic_energy(i)>h.and.CI_SC2_electronic_energy(i).ne.0.d0)then + if(electronic_energy(i)>h.and.electronic_energy(i).ne.0.d0)then c_pert(i) = -1.d0 e_2_pert(i) = selection_criterion*selection_criterion_factor*2.d0 - else if (dabs(CI_SC2_electronic_energy(i) - h) > 1.d-6) then - c_pert(i) = i_H_psi_array(i) / (CI_SC2_electronic_energy(i) - h) + else if (dabs(electronic_energy(i) - h) > 1.d-6) then + c_pert(i) = i_H_psi_array(i) / (electronic_energy(i) - h) H_pert_diag(i) = h*c_pert(i)*c_pert(i) e_2_pert(i) = c_pert(i) * i_H_psi_array(i) else @@ -453,11 +452,42 @@ subroutine pt2_epstein_nesbet_sc2 ($arguments) end +subroutine pt2_dummy ($arguments) + use bitmasks + implicit none + $declarations + + BEGIN_DOC + ! Dummy perturbation to add all connected determinants. + END_DOC + + integer :: i,j + double precision :: diag_H_mat_elem_fock, h + double precision :: i_H_psi_array(N_st) + PROVIDE selection_criterion + + call i_H_psi_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array) + + h = diag_H_mat_elem_fock(det_ref,det_pert,fock_diag_tmp,Nint) + do i =1,N_st + if (i_H_psi_array(i) /= 0.d0) then + c_pert(i) = i_H_psi_array(i) / (electronic_energy(i) - h) + H_pert_diag(i) = h*c_pert(i)*c_pert(i) + e_2_pert(i) = 1.d0 + else + c_pert(i) = 0.d0 + e_2_pert(i) = 0.d0 + H_pert_diag(i) = 0.d0 + endif + enddo + +end + SUBST [ arguments, declarations ] -det_ref,det_pert,fock_diag_tmp,c_pert,e_2_pert,H_pert_diag,Nint,ndet,N_st,minilist,idx_minilist,N_minilist ; +electronic_energy,det_ref,det_pert,fock_diag_tmp,c_pert,e_2_pert,H_pert_diag,Nint,ndet,N_st,minilist,idx_minilist,N_minilist ; integer, intent(in) :: Nint integer, intent(in) :: ndet @@ -466,6 +496,7 @@ det_ref,det_pert,fock_diag_tmp,c_pert,e_2_pert,H_pert_diag,Nint,ndet,N_st,minili integer(bit_kind), intent(in) :: det_ref (Nint,2) integer(bit_kind), intent(in) :: det_pert(Nint,2) double precision , intent(in) :: fock_diag_tmp(2,mo_tot_num+1) + double precision , intent(in) :: electronic_energy(N_st) double precision , intent(out) :: c_pert(N_st) double precision , intent(out) :: e_2_pert(N_st) double precision, intent(out) :: H_pert_diag(N_st) diff --git a/plugins/Perturbation/pt2_new.irp.f b/plugins/Perturbation/pt2_new.irp.f index efe7f375..2f9cfbfb 100644 --- a/plugins/Perturbation/pt2_new.irp.f +++ b/plugins/Perturbation/pt2_new.irp.f @@ -32,6 +32,7 @@ subroutine i_H_psi_pert_new_minilist(key,keys,idx_key,N_minilist,coef,Nint,Ndet, coef_pert = 0.d0 call filter_connected_i_H_psi0(keys,key,Nint,N_minilist,idx) + double precision :: coef_array(Nstate) if (Nstate == 1) then do ii=1,idx(0) @@ -40,8 +41,11 @@ subroutine i_H_psi_pert_new_minilist(key,keys,idx_key,N_minilist,coef,Nint,Ndet, !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 - call get_delta_e_dyall(keys(1,1,i_in_key),key,delta_e_final) - + do i = 1, Nstate + coef_array(i) = coef(i_in_coef,i) + enddo + call get_delta_e_dyall(keys(1,1,i_in_key),key,coef_array,hij,delta_e_final) + coef_pert += coef(i_in_coef,1)*hij / delta_e_final enddo if (coef_pert * i_H_psi_array(1) > 0.d0)then diff --git a/plugins/Perturbation/tree_dependency.png b/plugins/Perturbation/tree_dependency.png index dac64544..166e8035 100644 Binary files a/plugins/Perturbation/tree_dependency.png and b/plugins/Perturbation/tree_dependency.png differ diff --git a/plugins/Properties/.gitignore b/plugins/Properties/.gitignore index 1b17a42a..b2f0a113 100644 --- a/plugins/Properties/.gitignore +++ b/plugins/Properties/.gitignore @@ -1,23 +1,25 @@ -# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py -IRPF90_temp -IRPF90_man -irpf90_entities -tags -irpf90.make -Makefile -Makefile.depend -build.ninja -.ninja_log +# Automatically created by $QP_ROOT/scripts/module/module_handler.py .ninja_deps -ezfio_interface.irp.f -Ezfio_files +.ninja_log +AO_Basis +Bitmask Determinants +Electrons +Ezfio_files +IRPF90_man +IRPF90_temp +Integrals_Bielec Integrals_Monoelec MO_Basis -Utils -Pseudo -Bitmask -AO_Basis -Electrons +Makefile +Makefile.depend Nuclei -Integrals_Bielec \ No newline at end of file +Pseudo +Utils +ZMQ +ezfio_interface.irp.f +irpf90.make +irpf90_entities +print_hcc +print_mulliken +tags \ No newline at end of file diff --git a/plugins/Properties/NEEDED_CHILDREN_MODULES b/plugins/Properties/NEEDED_CHILDREN_MODULES index aae89501..34de8ddb 100644 --- a/plugins/Properties/NEEDED_CHILDREN_MODULES +++ b/plugins/Properties/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Determinants +Determinants Davidson diff --git a/plugins/Properties/README.rst b/plugins/Properties/README.rst index cd92ba14..92882e0f 100644 --- a/plugins/Properties/README.rst +++ b/plugins/Properties/README.rst @@ -50,6 +50,18 @@ Documentation average_spread(3) = +`conversion_factor_cm_1_hcc `_ + Conversion factor for the calculation of the hcc, according to the nuclear charge + + +`conversion_factor_gauss_hcc `_ + Conversion factor for the calculation of the hcc, according to the nuclear charge + + +`conversion_factor_mhz_hcc `_ + Conversion factor for the calculation of the hcc, according to the nuclear charge + + `delta_z `_ Undocumented @@ -62,6 +74,16 @@ Documentation Computes +`electronic_population_alpha `_ + spin population on the ao basis : + spin_population(i,j) = rho_AO(alpha)(i,j) - rho_AO(beta)(i,j) * + + +`electronic_population_beta `_ + spin population on the ao basis : + spin_population(i,j) = rho_AO(alpha)(i,j) - rho_AO(beta)(i,j) * + + `filter_connected_mono `_ Filters out the determinants that are not connected through PURE .br @@ -82,6 +104,14 @@ Documentation and with the density is stored in "density" +`gross_orbital_product_alpha `_ + gross orbital product + + +`gross_orbital_product_beta `_ + gross orbital product + + `i_o1_j `_ Returns where i and j are determinants and O1 is a ONE BODY OPERATOR @@ -128,6 +158,18 @@ Documentation .br +`iso_hcc_cm_1 `_ + isotropic hyperfine coupling constants among the various atoms + + +`iso_hcc_gauss `_ + isotropic hyperfine coupling constants among the various atoms + + +`iso_hcc_mhz `_ + isotropic hyperfine coupling constants among the various atoms + + `mo_integrated_delta_rho_one_point `_ .br array of the integrals needed of integrated_rho(alpha,z) - integrated_rho(beta,z) for z = z_one_point @@ -135,10 +177,71 @@ Documentation .br +`mulliken_densities_alpha `_ + .br + + +`mulliken_densities_beta `_ + .br + + +`mulliken_spin_densities `_ + ATOMIC SPIN POPULATION (ALPHA MINUS BETA) + + `n_z_pts `_ Undocumented +`print_hcc `_ + Undocumented + + +`print_hcc_main `_ + Undocumented + + +`print_mulliken `_ + Undocumented + + +`print_mulliken_sd `_ + Undocumented + + +`spin_density_at_nucleous `_ + value of the spin density at each nucleus + + +`spin_density_at_nucleous_contrib_mo `_ + value of the spin density at each nucleus + + +`spin_density_at_nucleous_contrib_mo_test `_ + value of the spin density at each nucleus + + +`spin_density_at_nucleous_contrib_per_mo `_ + value of the spin density at each nucleus + + +`spin_density_at_nucleous_from_mo `_ + value of the spin density at each nucleus + + +`spin_gross_orbital_product `_ + gross orbital product for the spin population + + +`spin_population `_ + spin population on the ao basis : + spin_population(i,j) = rho_AO(alpha)(i,j) - rho_AO(beta)(i,j) * + + +`spin_population_angular_momentum `_ + Undocumented + + `test_average_value `_ Undocumented diff --git a/plugins/Properties/give_mos_at_r.irp.f b/plugins/Properties/give_mos_at_r.irp.f new file mode 100644 index 00000000..20a7f712 --- /dev/null +++ b/plugins/Properties/give_mos_at_r.irp.f @@ -0,0 +1,35 @@ +subroutine give_all_act_mos_at_r(r,mos_array) + implicit none + double precision, intent(in) :: r(3) + double precision, intent(out) :: mos_array(n_act_orb) + double precision :: aos_array(ao_num),accu + integer :: i,j,iorb +!print*,'n_act_orb = ',n_act_orb + call give_all_aos_at_r(r,aos_array) + do i = 1, n_act_orb + iorb = list_act(i) + accu = 0.d0 + do j = 1, ao_num + accu += mo_coef(j,iorb) * aos_array(j) + enddo + mos_array(i) = accu + enddo +end + +subroutine give_all_core_mos_at_r(r,mos_array) + implicit none + double precision, intent(in) :: r(3) + double precision, intent(out) :: mos_array(n_core_orb) + double precision :: aos_array(ao_num),accu + integer :: i,j,iorb + call give_all_aos_at_r(r,aos_array) + do i = 1, n_core_orb + iorb = list_core(i) + accu = 0.d0 + do j = 1, ao_num + accu += mo_coef(j,iorb) * aos_array(j) + enddo + mos_array(i) = accu + enddo +end + diff --git a/plugins/Properties/test_two_body_dm.irp.f b/plugins/Properties/test_two_body_dm.irp.f index f79aed86..ec203026 100644 --- a/plugins/Properties/test_two_body_dm.irp.f +++ b/plugins/Properties/test_two_body_dm.irp.f @@ -8,7 +8,7 @@ subroutine routine implicit none integer :: i,j,k,l integer :: h1,p1,h2,p2,s1,s2 - double precision :: accu,get_two_body_dm_ab_map_element,get_mo_bielec_integral_schwartz + double precision :: accu,get_two_body_dm_ab_map_element,get_mo_bielec_integral accu = 0.d0 ! Diag part of the core two body dm @@ -50,7 +50,7 @@ subroutine routine p1 = list_act(j) do i = 1,n_act_orb ! h1 h1 = list_act(i) - accu_extra_diag += two_body_dm_ab_big_array_act(i,j,k,l) * get_mo_bielec_integral_schwartz(h1,h2,p1,p2,mo_integrals_map) + accu_extra_diag += two_body_dm_ab_big_array_act(i,j,k,l) * get_mo_bielec_integral(h1,h2,p1,p2,mo_integrals_map) enddo enddo enddo @@ -63,7 +63,7 @@ subroutine routine h1 = list_act(k) do i = 1,n_core_orb ! h2 h2 = list_core(i) - accu_extra_diag += two_body_dm_ab_big_array_core_act(i,k,l) * get_mo_bielec_integral_schwartz(h1,h2,p1,h2,mo_integrals_map) + accu_extra_diag += two_body_dm_ab_big_array_core_act(i,k,l) * get_mo_bielec_integral(h1,h2,p1,h2,mo_integrals_map) enddo enddo enddo @@ -76,7 +76,7 @@ subroutine routine print*,'Total elec = ',accu+average_mono + accu_extra_diag print*,'Total = ',accu+average_mono+nuclear_repulsion +accu_extra_diag double precision :: e_0,hij - call u0_H_u_0(e_0,psi_coef,n_det,psi_det,N_int) + call u_0_H_u_0(e_0,psi_coef,n_det,psi_det,N_int) print*,' = ',e_0 + nuclear_repulsion integer :: degree integer :: exc(0:2,2,2) diff --git a/plugins/Properties/tree_dependency.png b/plugins/Properties/tree_dependency.png index 1ba8d487..bab94f08 100644 Binary files a/plugins/Properties/tree_dependency.png and b/plugins/Properties/tree_dependency.png differ diff --git a/plugins/Psiref_CAS/.gitignore b/plugins/Psiref_CAS/.gitignore index d98a4abc..69ebdc69 100644 --- a/plugins/Psiref_CAS/.gitignore +++ b/plugins/Psiref_CAS/.gitignore @@ -6,24 +6,20 @@ Bitmask Determinants Electrons Ezfio_files -Generators_full -Hartree_Fock IRPF90_man IRPF90_temp Integrals_Bielec Integrals_Monoelec -MOGuess MO_Basis Makefile Makefile.depend Nuclei -Perturbation -Properties Pseudo -Selectors_full +Psiref_Utils Utils +ZMQ ezfio_interface.irp.f irpf90.make irpf90_entities -mrcc_general +overwrite_with_cas tags \ No newline at end of file diff --git a/plugins/Psiref_CAS/NEEDED_CHILDREN_MODULES b/plugins/Psiref_CAS/NEEDED_CHILDREN_MODULES index 7e790003..107c1643 100644 --- a/plugins/Psiref_CAS/NEEDED_CHILDREN_MODULES +++ b/plugins/Psiref_CAS/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Psiref_Utils +Psiref_Utils Davidson diff --git a/plugins/Psiref_CAS/README.rst b/plugins/Psiref_CAS/README.rst index 1715049a..5d511317 100644 --- a/plugins/Psiref_CAS/README.rst +++ b/plugins/Psiref_CAS/README.rst @@ -75,6 +75,10 @@ Documentation determinants. idx_cas gives the indice of the CAS determinant in psi_det. +`overwrite_w_cas `_ + Undocumented + + `psi_ref `_ CAS wave function, defined from the application of the CAS bitmask on the determinants. idx_cas gives the indice of the CAS determinant in psi_det. @@ -85,10 +89,14 @@ Documentation determinants. idx_cas gives the indice of the CAS determinant in psi_det. -`psi_ref_coef_restart `_ +`psi_ref_coef_inv `_ + 1/psi_ref_coef + + +`psi_ref_coef_restart `_ Projection of the CAS wave function on the restart wave function. -`psi_ref_restart `_ +`psi_ref_restart `_ Projection of the CAS wave function on the restart wave function. diff --git a/plugins/Psiref_CAS/overwrite_with_cas.irp.f b/plugins/Psiref_CAS/overwrite_with_cas.irp.f new file mode 100644 index 00000000..d3ced1d1 --- /dev/null +++ b/plugins/Psiref_CAS/overwrite_with_cas.irp.f @@ -0,0 +1,5 @@ +program overwrite_w_cas + read_wf = .True. + TOUCH read_wf + call extract_ref +end diff --git a/plugins/Psiref_CAS/psi_ref.irp.f b/plugins/Psiref_CAS/psi_ref.irp.f index f67f0587..d3b6c28f 100644 --- a/plugins/Psiref_CAS/psi_ref.irp.f +++ b/plugins/Psiref_CAS/psi_ref.irp.f @@ -26,6 +26,21 @@ use bitmasks END_PROVIDER +BEGIN_PROVIDER [ double precision, psi_ref_coef_inv, (psi_det_size,n_states) ] + implicit none + BEGIN_DOC + ! 1/psi_ref_coef + END_DOC + integer :: i, i_state + do i_state=1,N_states + do i=1,N_det_ref + psi_ref_coef_inv(i,i_state) = 1.d0/psi_ref_coef(i,i_state) + enddo + enddo + +END_PROVIDER + + BEGIN_PROVIDER [ integer(bit_kind), psi_ref_restart, (N_int,2,psi_det_size) ] &BEGIN_PROVIDER [ double precision, psi_ref_coef_restart, (psi_det_size,n_states) ] implicit none diff --git a/plugins/Psiref_CAS/tree_dependency.png b/plugins/Psiref_CAS/tree_dependency.png index 1a922bdc..5e496a28 100644 Binary files a/plugins/Psiref_CAS/tree_dependency.png and b/plugins/Psiref_CAS/tree_dependency.png differ diff --git a/plugins/Psiref_Utils/NEEDED_CHILDREN_MODULES b/plugins/Psiref_Utils/NEEDED_CHILDREN_MODULES index e69de29b..065099eb 100644 --- a/plugins/Psiref_Utils/NEEDED_CHILDREN_MODULES +++ b/plugins/Psiref_Utils/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Bitmask Determinants diff --git a/plugins/Psiref_Utils/README.rst b/plugins/Psiref_Utils/README.rst index c30cdb11..35232d23 100644 --- a/plugins/Psiref_Utils/README.rst +++ b/plugins/Psiref_Utils/README.rst @@ -119,6 +119,17 @@ Documentation Reference determinants sorted to accelerate the search of a random determinant in the wave function. +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + + +.. image:: tree_dependency.png + +* `Bitmask `_ +* `Determinants `_ + Documentation ============= .. Do not edit this section It was auto-generated @@ -129,14 +140,6 @@ Documentation Undocumented -`abort_all `_ - If True, all the calculation is aborted - - -`abort_here `_ - If True, all the calculation is aborted - - `add_poly `_ Add two polynomials D(t) =! D(t) +( B(t)+C(t)) @@ -151,11 +154,11 @@ Documentation Compute 1st dimension such that it is aligned for vectorization. -`apply_rotation `_ +`apply_rotation `_ Apply the rotation found by find_rotation -`approx_dble `_ +`approx_dble `_ Undocumented @@ -178,10 +181,6 @@ Documentation Binomial coefficients -`catch_signal `_ - What to do on Ctrl-C. If two Ctrl-C are pressed within 1 sec, the calculation if aborted. - - `dble_fact `_ Undocumented @@ -224,6 +223,10 @@ Documentation Undocumented +`extract_ref `_ + Replaces the total wave function by the normalized projection on the reference + + `f_integral `_ function that calculates the following integral \int_{\-infty}^{+\infty} x^n \exp(-p x^2) dx @@ -237,7 +240,7 @@ Documentation 1/n! -`find_rotation `_ +`find_rotation `_ Find A.C = B @@ -263,11 +266,11 @@ Documentation Undocumented -`get_index_in_psi_ref_sorted_bit `_ +`get_index_in_psi_ref_sorted_bit `_ Returns the index of the determinant in the ``psi_ref_sorted_bit`` array -`get_pseudo_inverse `_ +`get_pseudo_inverse `_ Find C = A^-1 @@ -302,7 +305,7 @@ Documentation Undocumented -`h_matrix_ref `_ +`h_matrix_ref `_ Undocumented @@ -387,7 +390,7 @@ Documentation been done going from psi_ref to psi_non_ref -`i2radix_sort `_ +`i2radix_sort `_ Sort integer array x(isize) using the radix sort algorithm. iorder in input should be (1,2,3,...,isize), and in output contains the new order of the elements. @@ -412,14 +415,14 @@ Documentation contains the new order of the elements. -`i8radix_sort `_ +`i8radix_sort `_ Sort integer array x(isize) using the radix sort algorithm. iorder in input should be (1,2,3,...,isize), and in output contains the new order of the elements. iradix should be -1 in input. -`i8radix_sort_big `_ +`i8radix_sort_big `_ Sort integer array x(isize) using the radix sort algorithm. iorder in input should be (1,2,3,...,isize), and in output contains the new order of the elements. @@ -444,14 +447,14 @@ Documentation contains the new order of the elements. -`idx_non_ref `_ +`idx_non_ref `_ Set of determinants which are not part of the reference, defined from the application of the reference bitmask on the determinants. idx_non_ref gives the indice of the determinant in psi_det. idx_non_ref_rev gives the reverse. -`idx_non_ref_rev `_ +`idx_non_ref_rev `_ Set of determinants which are not part of the reference, defined from the application of the reference bitmask on the determinants. idx_non_ref gives the indice of the determinant in psi_det. @@ -532,21 +535,21 @@ Documentation 1/i -`iradix_sort `_ +`iradix_sort `_ Sort integer array x(isize) using the radix sort algorithm. iorder in input should be (1,2,3,...,isize), and in output contains the new order of the elements. iradix should be -1 in input. -`iradix_sort_big `_ +`iradix_sort_big `_ Sort integer array x(isize) using the radix sort algorithm. iorder in input should be (1,2,3,...,isize), and in output contains the new order of the elements. iradix should be -1 in input. -`is_in_psi_ref `_ +`is_in_psi_ref `_ True if the determinant ``det`` is in the wave function @@ -568,7 +571,7 @@ Documentation contains the new order of the elements. -`lapack_diag `_ +`lapack_diag `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -579,7 +582,7 @@ Documentation .br -`lapack_diag_s2 `_ +`lapack_diag_s2 `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -590,7 +593,7 @@ Documentation .br -`lapack_diagd `_ +`lapack_diagd `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -601,7 +604,7 @@ Documentation .br -`lapack_partial_diag `_ +`lapack_partial_diag `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -616,19 +619,23 @@ Documentation n! +`lowercase `_ + Transform to lower case + + `multiply_poly `_ Multiply two polynomials D(t) =! D(t) +( B(t)*C(t)) -`n_det_non_ref `_ +`n_det_non_ref `_ Set of determinants which are not part of the reference, defined from the application of the reference bitmask on the determinants. idx_non_ref gives the indice of the determinant in psi_det. idx_non_ref_rev gives the reverse. -`normalize `_ +`normalize `_ Normalizes vector u u is expected to be aligned in memory. @@ -637,8 +644,26 @@ Documentation Number of current OpenMP threads -`ortho_lowdin `_ - Compute C_new=C_old.S^-1/2 canonical orthogonalization. +`ortho_canonical `_ + Compute C_new=C_old.U.s^-1/2 canonical orthogonalization. + .br + overlap : overlap matrix + .br + LDA : leftmost dimension of overlap array + .br + N : Overlap matrix is NxN (array is (LDA,N) ) + .br + C : Coefficients of the vectors to orthogonalize. On exit, + orthogonal vectors + .br + LDC : leftmost dimension of C + .br + m : Coefficients matrix is MxN, ( array is (LDC,N) ) + .br + + +`ortho_lowdin `_ + Compute C_new=C_old.S^-1/2 orthogonalization. .br overlap : overlap matrix .br @@ -708,46 +733,54 @@ Documentation Current status for displaying progress bars. Global variable. -`psi_coef_ref_diagonalized `_ +`psi_non_ref `_ + Set of determinants which are not part of the reference, defined from the application + of the reference bitmask on the determinants. + idx_non_ref gives the indice of the determinant in psi_det. + idx_non_ref_rev gives the reverse. + + +`psi_non_ref_coef `_ + Set of determinants which are not part of the reference, defined from the application + of the reference bitmask on the determinants. + idx_non_ref gives the indice of the determinant in psi_det. + idx_non_ref_rev gives the reverse. + + +`psi_non_ref_coef_restart `_ + Set of determinants which are not part of the reference, defined from the application + of the reference bitmask on the determinants. + idx_non_ref gives the indice of the determinant in psi_det. + But this is with respect to the restart wave function. + + +`psi_non_ref_coef_sorted_bit `_ + Reference determinants sorted to accelerate the search of a random determinant in the wave + function. + + +`psi_non_ref_coef_transp `_ + Transposed psi_non_ref_coef + + +`psi_non_ref_restart `_ + Set of determinants which are not part of the reference, defined from the application + of the reference bitmask on the determinants. + idx_non_ref gives the indice of the determinant in psi_det. + But this is with respect to the restart wave function. + + +`psi_non_ref_sorted_bit `_ + Reference determinants sorted to accelerate the search of a random determinant in the wave + function. + + +`psi_ref_coef_diagonalized `_ Undocumented -`psi_non_ref `_ - Set of determinants which are not part of the reference, defined from the application - of the reference bitmask on the determinants. - idx_non_ref gives the indice of the determinant in psi_det. - idx_non_ref_rev gives the reverse. - - -`psi_non_ref_coef `_ - Set of determinants which are not part of the reference, defined from the application - of the reference bitmask on the determinants. - idx_non_ref gives the indice of the determinant in psi_det. - idx_non_ref_rev gives the reverse. - - -`psi_non_ref_coef_restart `_ - Set of determinants which are not part of the reference, defined from the application - of the reference bitmask on the determinants. - idx_non_ref gives the indice of the determinant in psi_det. - But this is with respect to the restart wave function. - - -`psi_non_ref_coef_sorted_bit `_ - Reference determinants sorted to accelerate the search of a random determinant in the wave - function. - - -`psi_non_ref_restart `_ - Set of determinants which are not part of the reference, defined from the application - of the reference bitmask on the determinants. - idx_non_ref gives the indice of the determinant in psi_det. - But this is with respect to the restart wave function. - - -`psi_non_ref_sorted_bit `_ - Reference determinants sorted to accelerate the search of a random determinant in the wave - function. +`psi_ref_coef_normalized `_ + Normalized coefficients of the reference `psi_ref_coef_sorted_bit `_ @@ -755,11 +788,15 @@ Documentation function. -`psi_ref_energy `_ +`psi_ref_coef_transp `_ + Transposed psi_ref_coef + + +`psi_ref_energy `_ Undocumented -`psi_ref_energy_diagonalized `_ +`psi_ref_energy_diagonalized `_ Undocumented @@ -772,6 +809,10 @@ Documentation Recenter two polynomials +`ref_hamiltonian_matrix `_ + H matrix in the Reference space + + `rint `_ .. math:: .br @@ -819,7 +860,7 @@ Documentation to be in integer*8 format -`set_zero_extra_diag `_ +`set_zero_extra_diag `_ Undocumented @@ -837,11 +878,16 @@ Documentation Stop the progress bar -`trap_signals `_ - What to do when a signal is caught. Here, trap Ctrl-C and call the control_C subroutine. +`svd `_ + Compute A = U.D.Vt + .br + LDx : leftmost dimension of x + .br + Dimsneion of A is m x n + .br -`u_dot_u `_ +`u_dot_u `_ Compute diff --git a/plugins/Psiref_Utils/extract_ref.irp.f b/plugins/Psiref_Utils/extract_ref.irp.f new file mode 100644 index 00000000..0e9b5741 --- /dev/null +++ b/plugins/Psiref_Utils/extract_ref.irp.f @@ -0,0 +1,24 @@ +subroutine extract_ref + implicit none + BEGIN_DOC + ! Replaces the total wave function by the normalized projection on the reference + END_DOC + + integer :: i,j,k + do k=1,N_states + do j=1,N_det_ref + psi_coef(j,k) = psi_ref_coef_normalized(j,k) + enddo + enddo + + do j=1,N_det_ref + do k=1,N_int + psi_det(k,1,j) = psi_ref(k,1,j) + psi_det(k,2,j) = psi_ref(k,2,j) + enddo + enddo + N_det = N_det_ref + + call save_wavefunction + +end diff --git a/plugins/Psiref_Utils/psi_ref_utils.irp.f b/plugins/Psiref_Utils/psi_ref_utils.irp.f index fb45b13d..41db2f10 100644 --- a/plugins/Psiref_Utils/psi_ref_utils.irp.f +++ b/plugins/Psiref_Utils/psi_ref_utils.irp.f @@ -14,6 +14,47 @@ use bitmasks END_PROVIDER +BEGIN_PROVIDER [ double precision, psi_ref_coef_transp, (n_states,psi_det_size) ] + implicit none + BEGIN_DOC +! Transposed psi_ref_coef + END_DOC + integer :: i,j + do j=1,N_det_ref + do i=1, n_states + psi_ref_coef_transp(i,j) = psi_ref_coef(j,i) + enddo + enddo +END_PROVIDER + +BEGIN_PROVIDER [ double precision, psi_ref_coef_normalized, (psi_det_size,n_states) ] + implicit none + BEGIN_DOC +! Normalized coefficients of the reference + END_DOC + integer :: i,j,k + do k=1,N_states + do j=1,N_det_ref + psi_ref_coef_normalized(j,k) = psi_ref_coef(j,k) + enddo + call normalize(psi_ref_coef_normalized(1,k), N_det_ref) + enddo + +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, psi_non_ref_coef_transp, (n_states,psi_det_size) ] + implicit none + BEGIN_DOC +! Transposed psi_non_ref_coef + END_DOC + integer :: i,j + do j=1,N_det_non_ref + do i=1, n_states + psi_non_ref_coef_transp(i,j) = psi_non_ref_coef(j,i) + enddo + enddo +END_PROVIDER BEGIN_PROVIDER [ integer(bit_kind), psi_non_ref, (N_int,2,psi_det_size) ] &BEGIN_PROVIDER [ double precision, psi_non_ref_coef, (psi_det_size,n_states) ] diff --git a/plugins/Psiref_Utils/tree_dependency.png b/plugins/Psiref_Utils/tree_dependency.png index 20482ad2..c527d617 100644 Binary files a/plugins/Psiref_Utils/tree_dependency.png and b/plugins/Psiref_Utils/tree_dependency.png differ diff --git a/plugins/QmcChem/NEEDED_CHILDREN_MODULES b/plugins/QmcChem/NEEDED_CHILDREN_MODULES index aae89501..34de8ddb 100644 --- a/plugins/QmcChem/NEEDED_CHILDREN_MODULES +++ b/plugins/QmcChem/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Determinants +Determinants Davidson diff --git a/plugins/QmcChem/dressed_dmc.irp.f b/plugins/QmcChem/dressed_dmc.irp.f new file mode 100644 index 00000000..803e55dc --- /dev/null +++ b/plugins/QmcChem/dressed_dmc.irp.f @@ -0,0 +1,73 @@ +program dressed_dmc + implicit none + double precision :: E0, hij + double precision, allocatable :: H_jj(:), energies(:), delta_jj(:), cj(:), hj(:) + integer :: i + double precision, external :: diag_h_mat_elem + + if (.not.read_wf) then + stop 'read_wf should be true' + endif + + PROVIDE mo_bielec_integrals_in_map + allocate ( H_jj(N_det), delta_jj(N_det), hj(N_det), cj(N_det), energies(N_states) ) + + ! Read + ! -=-=-=-==-=-=-= + + character*(32) :: w, w2 + integer :: k + do while (.True.) + read(*,*) w + if ( trim(w) == 'Ci_h_psidet' ) then + exit + endif + enddo + do i=1,N_det + read(*,*) k, w, hj(i) + enddo + + do while (.True.) + read(*,*) w + if ( trim(w) == 'Ci_overlap_psidet' ) then + exit + endif + enddo + do i=1,N_det + read(*,*) k, w, cj(i) + enddo + + read(*,*) + read(*,*) w, w2, E0 + print *, 'E0=', E0 + print *, 'Ndet = ', N_det + + ! Compute delta_ii + ! -=-=-=-==-=-=-=- + + do i=1,N_det + call i_H_psi(psi_det(1,1,i),psi_det,cj,N_int,N_det,size(psi_coef,1),N_states,energies) + if (dabs(cj(i)) < 1.d-6) then + delta_jj(i) = 0.d0 + else + delta_jj(i) = (hj(i) - energies(1))/cj(i) + endif + H_jj(i) = diag_h_mat_elem(psi_det(1,1,i),N_int) + delta_jj(i) + print *, 'Delta_jj(',i,') = ', Delta_jj(i), H_jj(i) + enddo + + + call davidson_diag_hjj(psi_det,psi_coef,H_jj,energies,size(psi_coef,1),N_det,N_states,N_states_diag,N_int,6) + + call save_wavefunction + call write_spindeterminants + + E0 = 0.d0 + do i=1,N_det + call i_H_psi(psi_det(1,1,i),psi_det,psi_coef(1,1),N_int,N_det,size(psi_coef,1),N_states,energies) + E0 += psi_coef(i,1) * energies(1) + enddo + print *, 'Trial energy: ', E0 + nuclear_repulsion + + deallocate (H_jj, delta_jj, energies, cj) +end diff --git a/plugins/QmcChem/e_curve_qmc.irp.f b/plugins/QmcChem/e_curve_qmc.irp.f new file mode 100644 index 00000000..4beed3fa --- /dev/null +++ b/plugins/QmcChem/e_curve_qmc.irp.f @@ -0,0 +1,102 @@ +program e_curve + use bitmasks + implicit none + integer :: i,j,k, nab, m, l + double precision :: norm, E, hij, num, ci, cj + integer, allocatable :: iorder(:) + double precision , allocatable :: norm_sort(:) + nab = n_det_alpha_unique+n_det_beta_unique + allocate ( norm_sort(0:nab), iorder(0:nab) ) + + + norm_sort(0) = 0.d0 + iorder(0) = 0 + do i=1,n_det_alpha_unique + norm_sort(i) = det_alpha_norm(i) + iorder(i) = i + enddo + + do i=1,n_det_beta_unique + norm_sort(i+n_det_alpha_unique) = det_beta_norm(i) + iorder(i+n_det_alpha_unique) = -i + enddo + + call dsort(norm_sort(1),iorder(1),nab) + + if (.not.read_wf) then + stop 'Please set read_wf to true' + endif + + PROVIDE psi_bilinear_matrix_values nuclear_repulsion + print *, '' + print *, '==============================' + print *, 'Energies at different cut-offs' + print *, '==============================' + print *, '' + print *, '==========================================================' + print '(A8,2X,A8,2X,A12,2X,A10,2X,A12)', 'Thresh.', 'Ndet', 'Cost', 'Norm', 'E' + print *, '==========================================================' + double precision :: thresh + integer(bit_kind), allocatable :: det_i(:,:), det_j(:,:) + thresh = 1.d-10 + do j=0,nab + i = iorder(j) + if (i<0) then + do k=1,n_det + if (psi_bilinear_matrix_columns(k) == -i) then + psi_bilinear_matrix_values(k,1) = 0.d0 + endif + enddo + else + do k=1,n_det + if (psi_bilinear_matrix_rows(k) == i) then + psi_bilinear_matrix_values(k,1) = 0.d0 + endif + enddo + endif + if (thresh > norm_sort(j)) then + cycle + endif + num = 0.d0 + norm = 0.d0 + m = 0 + !$OMP PARALLEL DEFAULT(SHARED) PRIVATE(k,l,det_i,det_j,ci,cj,hij) REDUCTION(+:norm,m,num) + allocate( det_i(N_int,2), det_j(N_int,2)) + !$OMP DO SCHEDULE(guided) + do k=1,n_det + if (psi_bilinear_matrix_values(k,1) == 0.d0) then + cycle + endif + ci = psi_bilinear_matrix_values(k,1) + det_i(:,1) = psi_det_alpha_unique(:,psi_bilinear_matrix_rows(k)) + det_i(:,2) = psi_det_beta_unique(:,psi_bilinear_matrix_columns(k)) + do l=1,n_det + if (psi_bilinear_matrix_values(l,1) == 0.d0) then + cycle + endif + cj = psi_bilinear_matrix_values(l,1) + det_j(:,1) = psi_det_alpha_unique(:,psi_bilinear_matrix_rows(l)) + det_j(:,2) = psi_det_beta_unique(:,psi_bilinear_matrix_columns(l)) + call i_h_j(det_i, det_j, N_int, hij) + num = num + ci*cj*hij + enddo + norm = norm + ci*ci + m = m+1 + enddo + !$OMP END DO + deallocate (det_i,det_j) + !$OMP END PARALLEL + if (m == 0) then + exit + endif + E = num / norm + nuclear_repulsion + print '(E9.1,2X,I8,2X,F10.2,2X,F10.8,2X,F12.6)', thresh, m, & + dble( elec_alpha_num**3 + elec_alpha_num**2 * (nab-1) ) / & + dble( elec_alpha_num**3 + elec_alpha_num**2 * (j-1)), norm, E + thresh = thresh * 2.d0 + enddo + print *, '==========================================================' + + deallocate (iorder, norm_sort) +end + diff --git a/plugins/QmcChem/save_for_qmcchem.irp.f b/plugins/QmcChem/save_for_qmcchem.irp.f index c8ddb4d9..a281a184 100644 --- a/plugins/QmcChem/save_for_qmcchem.irp.f +++ b/plugins/QmcChem/save_for_qmcchem.irp.f @@ -1,9 +1,46 @@ program save_for_qmc - read_wf = .True. - TOUCH read_wf - print *, "N_det = ", N_det - call write_spindeterminants - if (do_pseudo) then - call write_pseudopotential - endif + + integer :: iunit + integer, external :: get_unit_and_open + logical :: exists + double precision :: e_ref + + ! Determinants + read_wf = .True. + TOUCH read_wf + print *, "N_det = ", N_det + call write_spindeterminants + + ! Reference Energy + if (do_pseudo) then + call write_pseudopotential + endif + call system( & + 'mkdir -p '//trim(ezfio_filename)//'/simulation ;' // & + 'cp '//trim(ezfio_filename)//'/.version '//trim(ezfio_filename)//'/simulation/.version ; ' // & + 'mkdir -p '//trim(ezfio_filename)//'/properties ;' // & + 'cp '//trim(ezfio_filename)//'/.version '//trim(ezfio_filename)//'/properties/.version ; ' // & + 'echo T > '//trim(ezfio_filename)//'/properties/e_loc' & + ) + iunit = 13 + open(unit=iunit,file=trim(ezfio_filename)//'/simulation/e_ref',action='write') + call ezfio_has_full_ci_energy_pt2(exists) + if (exists) then + call ezfio_get_full_ci_energy_pt2(e_ref) + else + call ezfio_has_full_ci_energy(exists) + if (exists) then + call ezfio_get_full_ci_energy(e_ref) + else + call ezfio_has_hartree_fock_energy(exists) + if (exists) then + call ezfio_get_hartree_fock_energy(e_ref) + else + e_ref = 0.d0 + endif + endif + endif + write(iunit,*) e_ref + close(iunit) + end diff --git a/plugins/Selectors_full/README.rst b/plugins/Selectors_full/README.rst index 795234b4..393e9421 100644 --- a/plugins/Selectors_full/README.rst +++ b/plugins/Selectors_full/README.rst @@ -165,35 +165,22 @@ Documentation Determinants on which we apply for perturbation. -`psi_selectors_ab `_ - 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. - - `psi_selectors_coef `_ Determinants on which we apply for perturbation. -`psi_selectors_coef_ab `_ - 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. - - `psi_selectors_diag_h_mat `_ Diagonal elements of the H matrix for each selectors -`psi_selectors_next_ab `_ - 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. - - `psi_selectors_size `_ Undocumented + +`zmq_get_psi `_ + Get the wave function from the qp_run scheduler + + +`zmq_put_psi `_ + Put the wave function on the qp_run scheduler + diff --git a/plugins/Selectors_full/selectors.irp.f b/plugins/Selectors_full/selectors.irp.f index ce5e8367..fd719136 100644 --- a/plugins/Selectors_full/selectors.irp.f +++ b/plugins/Selectors_full/selectors.irp.f @@ -6,26 +6,27 @@ BEGIN_PROVIDER [ integer, psi_selectors_size ] END_PROVIDER BEGIN_PROVIDER [ integer, N_det_selectors] - implicit none - BEGIN_DOC - ! For Single reference wave functions, the number of selectors is 1 : the - ! Hartree-Fock determinant - END_DOC - integer :: i - double precision :: norm - call write_time(output_determinants) - norm = 0.d0 - N_det_selectors = N_det - do i=1,N_det - norm = norm + psi_average_norm_contrib_sorted(i) - - if (norm > threshold_selectors) then - N_det_selectors = i-1 - exit - endif - enddo - N_det_selectors = max(N_det_selectors,1) - call write_int(output_determinants,N_det_selectors,'Number of selectors') + implicit none + BEGIN_DOC + ! For Single reference wave functions, the number of selectors is 1 : the + ! Hartree-Fock determinant + END_DOC + integer :: i + double precision :: norm, norm_max + call write_time(output_determinants) + N_det_selectors = N_det_generators + if (threshold_generators < 1.d0) then + norm = 0.d0 + do i=1,N_det + norm = norm + psi_average_norm_contrib_sorted(i) + if (norm > threshold_selectors) then + N_det_selectors = i + exit + endif + enddo + N_det_selectors = max(N_det_selectors,N_det_generators) + endif + call write_int(output_determinants,N_det_selectors,'Number of selectors') END_PROVIDER BEGIN_PROVIDER [ integer(bit_kind), psi_selectors, (N_int,2,psi_selectors_size) ] @@ -49,7 +50,21 @@ END_PROVIDER enddo END_PROVIDER - BEGIN_PROVIDER [ double precision, psi_selectors_diag_h_mat, (psi_selectors_size) ] +BEGIN_PROVIDER [ double precision, psi_selectors_coef_transp, (N_states,psi_selectors_size) ] + implicit none + BEGIN_DOC + ! Transposed psi_selectors + END_DOC + integer :: i,k + + do i=1,N_det_selectors + do k=1,N_states + psi_selectors_coef_transp(k,i) = psi_selectors_coef(i,k) + enddo + enddo +END_PROVIDER + +BEGIN_PROVIDER [ double precision, psi_selectors_diag_h_mat, (psi_selectors_size) ] implicit none BEGIN_DOC ! Diagonal elements of the H matrix for each selectors @@ -59,6 +74,6 @@ END_PROVIDER do i = 1, N_det_selectors psi_selectors_diag_h_mat(i) = diag_H_mat_elem(psi_selectors(1,1,i),N_int) enddo - END_PROVIDER +END_PROVIDER diff --git a/plugins/Selectors_full/tree_dependency.png b/plugins/Selectors_full/tree_dependency.png index f49b2e9a..66b2e88a 100644 Binary files a/plugins/Selectors_full/tree_dependency.png and b/plugins/Selectors_full/tree_dependency.png differ diff --git a/plugins/Selectors_full/zmq.irp.f b/plugins/Selectors_full/zmq.irp.f index 9f6f616c..8046212b 100644 --- a/plugins/Selectors_full/zmq.irp.f +++ b/plugins/Selectors_full/zmq.irp.f @@ -1,4 +1,4 @@ -subroutine zmq_put_psi(zmq_to_qp_run_socket,worker_id) +subroutine zmq_put_psi(zmq_to_qp_run_socket,worker_id, energy, size_energy) use f77_zmq implicit none BEGIN_DOC @@ -6,6 +6,8 @@ subroutine zmq_put_psi(zmq_to_qp_run_socket,worker_id) END_DOC integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket integer, intent(in) :: worker_id + integer, intent(in) :: size_energy + double precision, intent(out) :: energy(size_energy) integer :: rc character*(256) :: msg @@ -23,9 +25,15 @@ subroutine zmq_put_psi(zmq_to_qp_run_socket,worker_id) stop 'error' endif - rc = f77_zmq_send(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,0) + rc = f77_zmq_send(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE) if (rc /= psi_det_size*N_states*8) then - print *, 'f77_zmq_send(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,0)' + print *, 'f77_zmq_send(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE)' + stop 'error' + endif + + rc = f77_zmq_send(zmq_to_qp_run_socket,energy,size_energy*8,0) + if (rc /= size_energy*8) then + print *, 'f77_zmq_send(zmq_to_qp_run_socket,energy,size_energy*8,0)' stop 'error' endif @@ -40,7 +48,7 @@ end -subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id) +subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id, energy, size_energy) use f77_zmq implicit none BEGIN_DOC @@ -48,6 +56,8 @@ subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id) END_DOC integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket integer, intent(in) :: worker_id + integer, intent(in) :: size_energy + double precision, intent(out) :: energy(size_energy) integer :: rc character*(64) :: msg @@ -69,7 +79,7 @@ subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id) integer :: N_states_read, N_det_read, psi_det_size_read integer :: N_det_selectors_read, N_det_generators_read read(msg(14:rc),*) rc, N_states_read, N_det_read, psi_det_size_read, & - N_det_selectors_read, N_det_generators_read + N_det_generators_read, N_det_selectors_read if (rc /= worker_id) then print *, 'Wrong worker ID' stop 'error' @@ -86,26 +96,27 @@ subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id) stop 'error' endif - rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,0) + rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE) if (rc /= psi_det_size*N_states*8) then - print *, '77_zmq_recv(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,0)' + print *, '77_zmq_recv(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE)' + stop 'error' + endif + TOUCH psi_det psi_coef + + rc = f77_zmq_recv(zmq_to_qp_run_socket,energy,size_energy*8,0) + if (rc /= size_energy*8) then + print *, '77_zmq_recv(zmq_to_qp_run_socket,energy,size_energy*8,0)' stop 'error' endif if (N_det_generators_read > 0) then N_det_generators = N_det_generators_read + TOUCH N_det_generators endif if (N_det_selectors_read > 0) then N_det_selectors = N_det_selectors_read + TOUCH N_det_selectors endif - SOFT_TOUCH psi_det psi_coef N_det_selectors N_det_generators psi_coef_generators psi_det_generators -! n_det_generators -! n_det_selectors -! psi_coef -! psi_coef_generators -! psi_det -! psi_det_generators - end diff --git a/plugins/Selectors_no_sorted/README.rst b/plugins/Selectors_no_sorted/README.rst index 361b5845..1170123a 100644 --- a/plugins/Selectors_no_sorted/README.rst +++ b/plugins/Selectors_no_sorted/README.rst @@ -185,3 +185,165 @@ Needed Modules * `Determinants `_ +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + + +.. image:: tree_dependency.png + +* `Determinants `_ + +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + + +`coef_hf_selector `_ + energy of correlation per determinant respect to the Hartree Fock determinant + .br + for the all the double excitations in the selectors determinants + .br + E_corr_per_selectors(i) = * c(D_i)/c(HF) if |D_i> is a double excitation + .br + E_corr_per_selectors(i) = -1000.d0 if it is not a double excitation + .br + coef_hf_selector = coefficient of the Hartree Fock determinant in the selectors determinants + + +`delta_e_per_selector `_ + energy of correlation per determinant respect to the Hartree Fock determinant + .br + for the all the double excitations in the selectors determinants + .br + E_corr_per_selectors(i) = * c(D_i)/c(HF) if |D_i> is a double excitation + .br + E_corr_per_selectors(i) = -1000.d0 if it is not a double excitation + .br + coef_hf_selector = coefficient of the Hartree Fock determinant in the selectors determinants + + +`double_index_selectors `_ + degree of excitation respect to Hartree Fock for the wave function + .br + for the all the selectors determinants + .br + double_index_selectors = list of the index of the double excitations + .br + n_double_selectors = number of double excitations in the selectors determinants + + +`e_corr_double_only `_ + energy of correlation per determinant respect to the Hartree Fock determinant + .br + for the all the double excitations in the selectors determinants + .br + E_corr_per_selectors(i) = * c(D_i)/c(HF) if |D_i> is a double excitation + .br + E_corr_per_selectors(i) = -1000.d0 if it is not a double excitation + .br + coef_hf_selector = coefficient of the Hartree Fock determinant in the selectors determinants + + +`e_corr_per_selectors `_ + energy of correlation per determinant respect to the Hartree Fock determinant + .br + for the all the double excitations in the selectors determinants + .br + E_corr_per_selectors(i) = * c(D_i)/c(HF) if |D_i> is a double excitation + .br + E_corr_per_selectors(i) = -1000.d0 if it is not a double excitation + .br + coef_hf_selector = coefficient of the Hartree Fock determinant in the selectors determinants + + +`e_corr_second_order `_ + energy of correlation per determinant respect to the Hartree Fock determinant + .br + for the all the double excitations in the selectors determinants + .br + E_corr_per_selectors(i) = * c(D_i)/c(HF) if |D_i> is a double excitation + .br + E_corr_per_selectors(i) = -1000.d0 if it is not a double excitation + .br + coef_hf_selector = coefficient of the Hartree Fock determinant in the selectors determinants + + +`exc_degree_per_selectors `_ + degree of excitation respect to Hartree Fock for the wave function + .br + for the all the selectors determinants + .br + double_index_selectors = list of the index of the double excitations + .br + n_double_selectors = number of double excitations in the selectors determinants + + +`i_h_hf_per_selectors `_ + energy of correlation per determinant respect to the Hartree Fock determinant + .br + for the all the double excitations in the selectors determinants + .br + E_corr_per_selectors(i) = * c(D_i)/c(HF) if |D_i> is a double excitation + .br + E_corr_per_selectors(i) = -1000.d0 if it is not a double excitation + .br + coef_hf_selector = coefficient of the Hartree Fock determinant in the selectors determinants + + +`inv_selectors_coef_hf `_ + energy of correlation per determinant respect to the Hartree Fock determinant + .br + for the all the double excitations in the selectors determinants + .br + E_corr_per_selectors(i) = * c(D_i)/c(HF) if |D_i> is a double excitation + .br + E_corr_per_selectors(i) = -1000.d0 if it is not a double excitation + .br + coef_hf_selector = coefficient of the Hartree Fock determinant in the selectors determinants + + +`inv_selectors_coef_hf_squared `_ + energy of correlation per determinant respect to the Hartree Fock determinant + .br + for the all the double excitations in the selectors determinants + .br + E_corr_per_selectors(i) = * c(D_i)/c(HF) if |D_i> is a double excitation + .br + E_corr_per_selectors(i) = -1000.d0 if it is not a double excitation + .br + coef_hf_selector = coefficient of the Hartree Fock determinant in the selectors determinants + + +`n_det_selectors `_ + For Single reference wave functions, the number of selectors is 1 : the + Hartree-Fock determinant + + +`n_double_selectors `_ + degree of excitation respect to Hartree Fock for the wave function + .br + for the all the selectors determinants + .br + double_index_selectors = list of the index of the double excitations + .br + n_double_selectors = number of double excitations in the selectors determinants + + +`psi_selectors `_ + Determinants on which we apply for perturbation. + + +`psi_selectors_coef `_ + Determinants on which we apply for perturbation. + + +`psi_selectors_diag_h_mat `_ + Diagonal elements of the H matrix for each selectors + + +`psi_selectors_size `_ + Undocumented + diff --git a/plugins/loc_cele/loc_cele.irp.f b/plugins/loc_cele/loc_cele.irp.f index bb4509e0..2d47c633 100644 --- a/plugins/loc_cele/loc_cele.irp.f +++ b/plugins/loc_cele/loc_cele.irp.f @@ -263,7 +263,7 @@ enddo !big loop over symmetry - 10 format (4E18.12) + 10 format (4E19.12) ! Now we copyt the newcmo into the mo_coef diff --git a/plugins/mrcepa0/EZFIO.cfg b/plugins/mrcepa0/EZFIO.cfg new file mode 100644 index 00000000..61f3392f --- /dev/null +++ b/plugins/mrcepa0/EZFIO.cfg @@ -0,0 +1,33 @@ +[lambda_type] +type: Positive_int +doc: lambda type +interface: ezfio,provider,ocaml +default: 0 + +[energy] +type: double precision +doc: Calculated energy +interface: ezfio + +[energy_pt2] +type: double precision +doc: Calculated energy with PT2 contribution +interface: ezfio + +[energy] +type: double precision +doc: Calculated energy +interface: ezfio + +[thresh_dressed_ci] +type: Threshold +doc: Threshold on the convergence of the dressed CI energy +interface: ezfio,provider,ocaml +default: 5.e-5 + +[n_it_max_dressed_ci] +type: Strictly_positive_int +doc: Maximum number of dressed CI iterations +interface: ezfio,provider,ocaml +default: 10 + diff --git a/plugins/MRCC_CASSD/NEEDED_CHILDREN_MODULES b/plugins/mrcepa0/NEEDED_CHILDREN_MODULES similarity index 91% rename from plugins/MRCC_CASSD/NEEDED_CHILDREN_MODULES rename to plugins/mrcepa0/NEEDED_CHILDREN_MODULES index a8404d62..8b6c5a18 100644 --- a/plugins/MRCC_CASSD/NEEDED_CHILDREN_MODULES +++ b/plugins/mrcepa0/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Selectors_full Generators_full Psiref_CAS MRCC_Utils +Perturbation Selectors_full Generators_full Psiref_CAS MRCC_Utils ZMQ diff --git a/plugins/mrcepa0/README.rst b/plugins/mrcepa0/README.rst new file mode 100644 index 00000000..997d005e --- /dev/null +++ b/plugins/mrcepa0/README.rst @@ -0,0 +1,12 @@ +======= +mrcepa0 +======= + +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/mrcepa0/dressing.irp.f b/plugins/mrcepa0/dressing.irp.f new file mode 100644 index 00000000..3646b0b2 --- /dev/null +++ b/plugins/mrcepa0/dressing.irp.f @@ -0,0 +1,1008 @@ +use bitmasks + + + + BEGIN_PROVIDER [ double precision, delta_ij_mrcc, (N_states,N_det_non_ref,N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ii_mrcc, (N_states, N_det_ref) ] + use bitmasks + implicit none + integer :: gen, h, p, n, t, i, h1, h2, p1, p2, s1, s2, iproc + integer(bit_kind) :: mask(N_int, 2), omask(N_int, 2) + integer(bit_kind),allocatable :: buf(:,:,:) + logical :: ok + logical, external :: detEq + + delta_ij_mrcc = 0d0 + delta_ii_mrcc = 0d0 + print *, "Dij", dij(1,1,1) + provide hh_shortcut psi_det_size! lambda_mrcc + !$OMP PARALLEL DO default(none) schedule(dynamic) & + !$OMP shared(psi_det_generators, N_det_generators, hh_exists, pp_exists, N_int, hh_shortcut) & + !$OMP shared(N_det_non_ref, N_det_ref, delta_ii_mrcc, delta_ij_mrcc) & + !$OMP private(h, n, mask, omask, buf, ok, iproc) + do gen= 1, N_det_generators + allocate(buf(N_int, 2, N_det_non_ref)) + iproc = omp_get_thread_num() + 1 + if(mod(gen, 1000) == 0) print *, "mrcc ", gen, "/", N_det_generators + do h=1, hh_shortcut(0) + call apply_hole_local(psi_det_generators(1,1,gen), hh_exists(1, h), mask, ok, N_int) + if(.not. ok) cycle + omask = 0_bit_kind + if(hh_exists(1, h) /= 0) omask = mask + n = 1 + do p=hh_shortcut(h), hh_shortcut(h+1)-1 + call apply_particle_local(mask, pp_exists(1, p), buf(1,1,n), ok, N_int) + if(ok) n = n + 1 + if(n > N_det_non_ref) stop "MRCC..." + end do + n = n - 1 + + if(n /= 0) call mrcc_part_dress(delta_ij_mrcc, delta_ii_mrcc,gen,n,buf,N_int,omask) + + end do + deallocate(buf) + end do + !$OMP END PARALLEL DO +END_PROVIDER + + +! subroutine blit(b1, b2) +! double precision :: b1(N_states,N_det_non_ref,N_det_ref), b2(N_states,N_det_non_ref,N_det_ref) +! b1 = b1 + b2 +! end subroutine + + +subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffer,Nint,key_mask) + use bitmasks + implicit none + + integer, intent(in) :: i_generator,n_selected, Nint + double precision, intent(inout) :: delta_ij_(N_states,N_det_non_ref,N_det_ref) + double precision, intent(inout) :: delta_ii_(N_states,N_det_ref) + + integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) + integer :: i,j,k,l,m + integer,allocatable :: idx_alpha(:), degree_alpha(:) + logical :: good, fullMatch + + integer(bit_kind),allocatable :: tq(:,:,:) + integer :: N_tq, c_ref ,degree + + double precision :: hIk, hla, hIl, dIk(N_states), dka(N_states), dIa(N_states) + double precision, allocatable :: dIa_hla(:,:) + double precision :: haj, phase, phase2 + double precision :: f(N_states), ci_inv(N_states) + integer :: exc(0:2,2,2) + integer :: h1,h2,p1,p2,s1,s2 + integer(bit_kind) :: tmp_det(Nint,2) + integer :: iint, ipos + integer :: i_state, k_sd, l_sd, i_I, i_alpha + + integer(bit_kind),allocatable :: miniList(:,:,:) + integer(bit_kind),intent(in) :: key_mask(Nint, 2) + integer,allocatable :: idx_miniList(:) + integer :: N_miniList, ni, leng + double precision, allocatable :: hij_cache(:) + + integer(bit_kind), allocatable :: microlist(:,:,:), microlist_zero(:,:,:) + integer, allocatable :: idx_microlist(:), N_microlist(:), ptr_microlist(:), idx_microlist_zero(:) + integer :: mobiles(2), smallerlist + logical, external :: detEq, is_generable + !double precision, external :: get_dij, get_dij_index + + + leng = max(N_det_generators, N_det_non_ref) + allocate(miniList(Nint, 2, leng), tq(Nint,2,n_selected), idx_minilist(leng), hij_cache(N_det_non_ref)) + allocate(idx_alpha(0:psi_det_size), degree_alpha(psi_det_size)) + !create_minilist_find_previous(key_mask, fullList, miniList, N_fullList, N_miniList, fullMatch, Nint) + call create_minilist_find_previous(key_mask, psi_det_generators, miniList, i_generator-1, N_miniList, fullMatch, Nint) + +! if(fullMatch) then +! return +! end if + + allocate(ptr_microlist(0:mo_tot_num*2+1), & + N_microlist(0:mo_tot_num*2) ) + allocate( microlist(Nint,2,N_minilist*4), & + idx_microlist(N_minilist*4)) + + if(key_mask(1,1) /= 0) then + call create_microlist(miniList, N_minilist, key_mask, microlist, idx_microlist, N_microlist, ptr_microlist, Nint) + call filter_tq_micro(i_generator,n_selected,det_buffer,Nint,tq,N_tq,microlist,ptr_microlist,N_microlist,key_mask) + else + call filter_tq(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist) + end if + + + + deallocate(microlist, idx_microlist) + + allocate (dIa_hla(N_states,N_det_non_ref)) + + ! |I> + + ! |alpha> + + if(N_tq > 0) then + call create_minilist(key_mask, psi_non_ref, miniList, idx_minilist, N_det_non_ref, N_minilist, Nint) + if(N_minilist == 0) return + + + if(key_mask(1,1) /= 0) then !!!!!!!!!!! PAS GENERAL !!!!!!!!! + allocate(microlist_zero(Nint,2,N_minilist), idx_microlist_zero(N_minilist)) + + allocate( microlist(Nint,2,N_minilist*4), & + idx_microlist(N_minilist*4)) + call create_microlist(miniList, N_minilist, key_mask, microlist, idx_microlist, N_microlist, ptr_microlist, Nint) + + + do i=0,mo_tot_num*2 + do k=ptr_microlist(i),ptr_microlist(i+1)-1 + idx_microlist(k) = idx_minilist(idx_microlist(k)) + end do + end do + + do l=1,N_microlist(0) + do k=1,Nint + microlist_zero(k,1,l) = microlist(k,1,l) + microlist_zero(k,2,l) = microlist(k,2,l) + enddo + idx_microlist_zero(l) = idx_microlist(l) + enddo + end if + end if + + + do i_alpha=1,N_tq + if(key_mask(1,1) /= 0) then + call getMobiles(tq(1,1,i_alpha), key_mask, mobiles, Nint) + + if(N_microlist(mobiles(1)) < N_microlist(mobiles(2))) then + smallerlist = mobiles(1) + else + smallerlist = mobiles(2) + end if + + + do l=0,N_microlist(smallerlist)-1 + microlist_zero(:,:,ptr_microlist(1) + l) = microlist(:,:,ptr_microlist(smallerlist) + l) + idx_microlist_zero(ptr_microlist(1) + l) = idx_microlist(ptr_microlist(smallerlist) + l) + end do + + call get_excitation_degree_vector(microlist_zero,tq(1,1,i_alpha),degree_alpha,Nint,N_microlist(smallerlist)+N_microlist(0),idx_alpha) + do j=1,idx_alpha(0) + idx_alpha(j) = idx_microlist_zero(idx_alpha(j)) + end do + + else + call get_excitation_degree_vector(miniList,tq(1,1,i_alpha),degree_alpha,Nint,N_minilist,idx_alpha) + do j=1,idx_alpha(0) + idx_alpha(j) = idx_miniList(idx_alpha(j)) + end do + end if + + + do l_sd=1,idx_alpha(0) + k_sd = idx_alpha(l_sd) + call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hij_cache(k_sd)) + enddo + ! |I> + do i_I=1,N_det_ref + ! Find triples and quadruple grand parents + call get_excitation_degree(tq(1,1,i_alpha),psi_ref(1,1,i_I),degree,Nint) + if (degree > 4) then + cycle + endif + + do i_state=1,N_states + dIa(i_state) = 0.d0 + enddo + + ! |alpha> + do k_sd=1,idx_alpha(0) + ! Loop if lambda == 0 + logical :: loop +! loop = .True. +! do i_state=1,N_states +! if (lambda_mrcc(i_state,idx_alpha(k_sd)) /= 0.d0) then +! loop = .False. +! exit +! endif +! enddo +! if (loop) then +! cycle +! endif + + call get_excitation_degree(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),degree,Nint) + if (degree > 2) then + cycle + endif + + ! + ! + !hIk = hij_mrcc(idx_alpha(k_sd),i_I) + ! call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),Nint,hIk) + + do i_state=1,N_states + dIK(i_state) = dij(i_I, idx_alpha(k_sd), i_state) + !dIk(i_state) = get_dij(psi_ref(1,1,i_I), psi_non_ref(1,1,idx_alpha(k_sd)), N_int) !!hIk * lambda_mrcc(i_state,idx_alpha(k_sd)) + !dIk(i_state) = psi_non_ref_coef(idx_alpha(k_sd), i_state) / psi_ref_coef(i_I, i_state) + enddo + + + ! |l> = Exc(k -> alpha) |I> + call get_excitation(psi_non_ref(1,1,idx_alpha(k_sd)),tq(1,1,i_alpha),exc,degree,phase,Nint) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + do k=1,N_int + tmp_det(k,1) = psi_ref(k,1,i_I) + tmp_det(k,2) = psi_ref(k,2,i_I) + enddo + logical :: ok + call apply_excitation(psi_ref(1,1,i_I), exc, tmp_det, ok, Nint) + if(.not. ok) cycle + + ! + do i_state=1,N_states + dka(i_state) = 0.d0 + enddo + do l_sd=k_sd+1,idx_alpha(0) + call get_excitation_degree(tmp_det,psi_non_ref(1,1,idx_alpha(l_sd)),degree,Nint) + if (degree == 0) then + +! loop = .True. +! do i_state=1,N_states +! if (lambda_mrcc(i_state,idx_alpha(l_sd)) /= 0.d0) then +! loop = .False. +! exit +! endif +! enddo + loop = .false. + if (.not.loop) then + call get_excitation(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),exc,degree,phase2,Nint) + hIl = hij_mrcc(idx_alpha(l_sd),i_I) +! call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hIl) + do i_state=1,N_states + dka(i_state) = dij(i_I, idx_alpha(l_sd), i_state) * phase * phase2 + !dka(i_state) = get_dij(psi_ref(1,1,i_I), psi_non_ref(1,1,idx_alpha(l_sd)), N_int) * phase * phase2 !hIl * lambda_mrcc(i_state,idx_alpha(l_sd)) * phase * phase2 + !dka(i_state) = psi_non_ref_coef(idx_alpha(l_sd), i_state) / psi_ref_coef(i_I, i_state) * phase * phase2 + enddo + endif + + exit + endif + enddo + do i_state=1,N_states + dIa(i_state) = dIa(i_state) + dIk(i_state) * dka(i_state) + enddo + enddo + + do i_state=1,N_states + ci_inv(i_state) = psi_ref_coef_inv(i_I,i_state) + enddo + do l_sd=1,idx_alpha(0) + k_sd = idx_alpha(l_sd) + hla = hij_cache(k_sd) +! call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hla) + do i_state=1,N_states + dIa_hla(i_state,k_sd) = dIa(i_state) * hla + enddo + enddo + call omp_set_lock( psi_ref_lock(i_I) ) + do i_state=1,N_states + if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5)then + do l_sd=1,idx_alpha(0) + k_sd = idx_alpha(l_sd) + delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + dIa_hla(i_state,k_sd) + delta_ii_(i_state,i_I) = delta_ii_(i_state,i_I) - dIa_hla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) + enddo + else + delta_ii_(i_state,i_I) = 0.d0 + do l_sd=1,idx_alpha(0) + k_sd = idx_alpha(l_sd) + delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + 0.5d0*dIa_hla(i_state,k_sd) + enddo + endif + enddo + call omp_unset_lock( psi_ref_lock(i_I) ) + enddo + enddo + deallocate (dIa_hla,hij_cache) + deallocate(miniList, idx_miniList) +end + + + + + BEGIN_PROVIDER [ double precision, delta_ij, (N_states,N_det_non_ref,N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ii, (N_states, N_det_ref) ] + use bitmasks + implicit none + integer :: i, j, i_state + + !mrmode : 1=mrcepa0, 2=mrsc2 add, 3=mrcc + + do i_state = 1, N_states + if(mrmode == 3) then + do i = 1, N_det_ref + delta_ii(i_state,i)= delta_ii_mrcc(i_state,i) + do j = 1, N_det_non_ref + delta_ij(i_state,j,i) = delta_ij_mrcc(i_state,j,i) + end do + end do +! +! do i = 1, N_det_ref +! delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) - delta_sub_ii(i,i_state) +! do j = 1, N_det_non_ref +! delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state) - delta_sub_ij(i,j,i_state) +! end do +! end do + else if(mrmode == 2) then + do i = 1, N_det_ref + delta_ii(i_state,i)= delta_ii_old(i_state,i) + do j = 1, N_det_non_ref + delta_ij(i_state,j,i) = delta_ij_old(i_state,j,i) + end do + end do + else if(mrmode == 1) then + do i = 1, N_det_ref + delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) + do j = 1, N_det_non_ref + delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state) + end do + end do + else + stop "invalid mrmode" + end if + end do +END_PROVIDER + + +BEGIN_PROVIDER [ integer, HP, (2,N_det_non_ref) ] + integer :: i + do i=1,N_det_non_ref + call getHP(psi_non_ref(1,1,i), HP(1,i), HP(2,i), N_int) + end do +END_PROVIDER + + BEGIN_PROVIDER [ integer, cepa0_shortcut, (0:N_det_non_ref+1) ] +&BEGIN_PROVIDER [ integer, det_cepa0_idx, (N_det_non_ref) ] +&BEGIN_PROVIDER [ integer(bit_kind), det_cepa0_active, (N_int,2,N_det_non_ref) ] +&BEGIN_PROVIDER [ integer(bit_kind), det_ref_active, (N_int,2,N_det_ref) ] +&BEGIN_PROVIDER [ integer(bit_kind), active_sorb, (N_int,2) ] +&BEGIN_PROVIDER [ integer(bit_kind), det_cepa0, (N_int,2,N_det_non_ref) ] +&BEGIN_PROVIDER [ integer, nlink, (N_det_ref) ] +&BEGIN_PROVIDER [ integer, linked, (N_det_non_ref,N_det_ref) ] +&BEGIN_PROVIDER [ integer, blokMwen, (N_det_non_ref,N_det_ref) ] +&BEGIN_PROVIDER [ double precision, searchance, (N_det_ref) ] +&BEGIN_PROVIDER [ integer, child_num, (N_det_non_ref,N_det_ref) ] + + use bitmasks + implicit none + + integer(bit_kind),allocatable :: det_noactive(:,:,:) + integer, allocatable :: shortcut(:), idx(:) + integer(bit_kind) :: nonactive_sorb(N_int,2), det(N_int, 2) + integer i, II, j, k, n, ni, blok, degree + logical, external :: detEq + + allocate(det_noactive(N_int, 2, N_det_non_ref)) + allocate(idx(N_det_non_ref), shortcut(0:N_det_non_ref+1)) + print *, "pre start" + active_sorb(:,:) = 0_8 + nonactive_sorb(:,:) = not(0_8) + + if(N_det_ref > 1) then + do i=1, N_det_ref + do k=1, N_int + active_sorb(k,1) = ior(psi_ref(k,1,i), active_sorb(k,1)) + active_sorb(k,2) = ior(psi_ref(k,2,i), active_sorb(k,2)) + nonactive_sorb(k,1) = iand(psi_ref(k,1,i), nonactive_sorb(k,1)) + nonactive_sorb(k,2) = iand(psi_ref(k,2,i), nonactive_sorb(k,2)) + end do + end do + do k=1, N_int + active_sorb(k,1) = iand(active_sorb(k,1), not(nonactive_sorb(k,1))) + active_sorb(k,2) = iand(active_sorb(k,2), not(nonactive_sorb(k,2))) + end do + end if + + + do i=1, N_det_non_ref + do k=1, N_int + det_noactive(k,1,i) = iand(psi_non_ref(k,1,i), not(active_sorb(k,1))) + det_noactive(k,2,i) = iand(psi_non_ref(k,2,i), not(active_sorb(k,2))) + end do + end do + + call sort_dets_ab(det_noactive, det_cepa0_idx, cepa0_shortcut, N_det_non_ref, N_int) + + do i=1,N_det_non_ref + det_cepa0(:,:,i) = psi_non_ref(:,:,det_cepa0_idx(i)) + end do + + cepa0_shortcut(0) = 1 + cepa0_shortcut(1) = 1 + do i=2,N_det_non_ref + if(.not. detEq(det_noactive(1,1,i), det_noactive(1,1,i-1), N_int)) then + cepa0_shortcut(0) += 1 + cepa0_shortcut(cepa0_shortcut(0)) = i + end if + end do + cepa0_shortcut(cepa0_shortcut(0)+1) = N_det_non_ref+1 + + if(.true.) then + do i=1,cepa0_shortcut(0) + n = cepa0_shortcut(i+1) - cepa0_shortcut(i) + call sort_dets_ab(det_cepa0(1,1,cepa0_shortcut(i)), idx, shortcut, n, N_int) + do k=1,n + idx(k) = det_cepa0_idx(cepa0_shortcut(i)-1+idx(k)) + end do + det_cepa0_idx(cepa0_shortcut(i):cepa0_shortcut(i)+n-1) = idx(:n) + end do + end if + + + do i=1,N_det_ref + do k=1, N_int + det_ref_active(k,1,i) = iand(psi_ref(k,1,i), active_sorb(k,1)) + det_ref_active(k,2,i) = iand(psi_ref(k,2,i), active_sorb(k,2)) + end do + end do + + do i=1,N_det_non_ref + do k=1, N_int + det_cepa0_active(k,1,i) = iand(psi_non_ref(k,1,det_cepa0_idx(i)), active_sorb(k,1)) + det_cepa0_active(k,2,i) = iand(psi_non_ref(k,2,det_cepa0_idx(i)), active_sorb(k,2)) + end do + end do + + do i=1,N_det_non_ref + if(.not. detEq(psi_non_ref(1,1,det_cepa0_idx(i)), det_cepa0(1,1,i),N_int)) stop "STOOOP" + end do + + searchance = 0d0 + child_num = 0 + do J = 1, N_det_ref + nlink(J) = 0 + do blok=1,cepa0_shortcut(0) + do k=cepa0_shortcut(blok), cepa0_shortcut(blok+1)-1 + call get_excitation_degree(psi_ref(1,1,J),det_cepa0(1,1,k),degree,N_int) + if(degree <= 2) then + nlink(J) += 1 + linked(nlink(J),J) = k + child_num(k, J) = nlink(J) + blokMwen(nlink(J),J) = blok + searchance(J) += 1d0 + log(dfloat(cepa0_shortcut(blok+1) - cepa0_shortcut(blok))) + end if + end do + end do + end do + print *, "pre done" +END_PROVIDER + + +! BEGIN_PROVIDER [ double precision, delta_cas, (N_det_ref, N_det_ref, N_states) ] +! use bitmasks +! implicit none +! integer :: i,j,k +! double precision :: Hjk, Hki, Hij, pre(N_det_ref), wall +! integer :: i_state, degree, npre, ipre(N_det_ref), npres(N_det_ref) +! +! ! provide lambda_mrcc +! npres = 0 +! delta_cas = 0d0 +! call wall_time(wall) +! print *, "dcas ", wall +! do i_state = 1, N_states +! !!$OMP PARALLEL DO default(none) schedule(dynamic) private(pre,npre,ipre,j,k,Hjk,Hki,degree) shared(npres,lambda_mrcc,i_state, N_det_non_ref,psi_ref, psi_non_ref,N_int,delta_cas,N_det_ref) +! do k=1,N_det_non_ref +! if(lambda_mrcc(i_state, k) == 0d0) cycle +! npre = 0 +! do i=1,N_det_ref +! call i_h_j(psi_non_ref(1,1,k),psi_ref(1,1,i), N_int,Hki) +! if(Hki /= 0d0) then +! !!$OMP ATOMIC +! npres(i) += 1 +! npre += 1 +! ipre(npre) = i +! pre(npre) = Hki +! end if +! end do +! +! +! do i=1,npre +! do j=1,i +! !!$OMP ATOMIC +! delta_cas(ipre(i),ipre(j),i_state) += pre(i) * pre(j) * lambda_mrcc(i_state, k) +! end do +! end do +! end do +! !!$OMP END PARALLEL DO +! npre=0 +! do i=1,N_det_ref +! npre += npres(i) +! end do +! !stop +! do i=1,N_det_ref +! do j=1,i +! delta_cas(j,i,i_state) = delta_cas(i,j,i_state) +! end do +! end do +! end do +! +! call wall_time(wall) +! print *, "dcas", wall +! ! stop +! END_PROVIDER + + + BEGIN_PROVIDER [ double precision, delta_cas, (N_det_ref, N_det_ref, N_states) ] + use bitmasks + implicit none + integer :: i,j,k + double precision :: Hjk, Hki, Hij + !double precision, external :: get_dij + integer i_state, degree + + provide lambda_mrcc dIj + do i_state = 1, N_states + !$OMP PARALLEL DO default(none) schedule(dynamic) private(j,k,Hjk,Hki,degree) shared(lambda_mrcc,i_state, N_det_non_ref,psi_ref, psi_non_ref,N_int,delta_cas,N_det_ref,dij) + do i=1,N_det_ref + do j=1,i + call get_excitation_degree(psi_ref(1,1,i), psi_ref(1,1,j), degree, N_int) + delta_cas(i,j,i_state) = 0d0 + do k=1,N_det_non_ref + + call i_h_j(psi_ref(1,1,j), psi_non_ref(1,1,k),N_int,Hjk) + + delta_cas(i,j,i_state) += Hjk * dij(i, k, i_state) ! * Hki * lambda_mrcc(i_state, k) + !print *, Hjk * get_dij(psi_ref(1,1,i), psi_non_ref(1,1,k), N_int), Hki * get_dij(psi_ref(1,1,j), psi_non_ref(1,1,k), N_int) + end do + delta_cas(j,i,i_state) = delta_cas(i,j,i_state) + end do + end do + !$OMP END PARALLEL DO + end do + END_PROVIDER + + + + +logical function isInCassd(a,Nint) + use bitmasks + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: a(Nint,2) + integer(bit_kind) :: inac, virt + integer :: ni, i, deg + + + isInCassd = .false. + + deg = 0 + do i=1,2 + do ni=1,Nint + virt = iand(not(HF_bitmask(ni,i)), not(active_sorb(ni,i))) + deg += popcnt(iand(virt, a(ni,i))) + if(deg > 2) return + end do + end do + + deg = 0 + do i=1,2 + do ni=1,Nint + inac = iand(HF_bitmask(ni,i), not(active_sorb(ni,i))) + deg += popcnt(xor(iand(inac,a(ni,i)), inac)) + if(deg > 2) return + end do + end do + isInCassd = .true. +end function + + +subroutine getHP(a,h,p,Nint) + use bitmasks + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: a(Nint,2) + integer, intent(out) :: h, p + integer(bit_kind) :: inac, virt + integer :: ni, i, deg + + + !isInCassd = .false. + h = 0 + p = 0 + + deg = 0 + lp : do i=1,2 + do ni=1,Nint + virt = iand(not(HF_bitmask(ni,i)), not(active_sorb(ni,i))) + deg += popcnt(iand(virt, a(ni,i))) + if(deg > 2) exit lp + end do + end do lp + p = deg + + deg = 0 + lh : do i=1,2 + do ni=1,Nint + inac = iand(HF_bitmask(ni,i), not(active_sorb(ni,i))) + deg += popcnt(xor(iand(inac,a(ni,i)), inac)) + if(deg > 2) exit lh + end do + end do lh + h = deg + !isInCassd = .true. +end function + + + BEGIN_PROVIDER [ double precision, delta_mrcepa0_ij, (N_det_ref,N_det_non_ref,N_states) ] +&BEGIN_PROVIDER [ double precision, delta_mrcepa0_ii, (N_det_ref,N_states) ] + use bitmasks + implicit none + + integer :: i_state, i, i_I, J, k, degree, degree2, m, l, deg, ni + integer :: p1,p2,h1,h2,s1,s2, p1_,p2_,h1_,h2_,s1_,s2_, sortRefIdx(N_det_ref) + logical :: ok + double precision :: phase_iI, phase_Ik, phase_Jl, phase_IJ, phase_al, diI, hIi, hJi, delta_JI, dkI(1), HkI, ci_inv(1), dia_hla(1) + double precision :: contrib, contrib2, HIIi, HJk, wall + integer, dimension(0:2,2,2) :: exc_iI, exc_Ik, exc_IJ + integer(bit_kind) :: det_tmp(N_int, 2), made_hole(N_int,2), made_particle(N_int,2), myActive(N_int,2) + integer(bit_kind),allocatable :: sortRef(:,:,:) + integer, allocatable :: idx_sorted_bit(:) + integer, external :: get_index_in_psi_det_sorted_bit, searchDet + logical, external :: is_in_wavefunction, detEq + !double precision, external :: get_dij + integer :: II, blok + integer*8, save :: notf = 0 + + call wall_time(wall) + allocate(idx_sorted_bit(N_det), sortRef(N_int,2,N_det_ref)) + + sortRef(:,:,:) = det_ref_active(:,:,:) + call sort_det(sortRef, sortRefIdx, N_det_ref, N_int) + + idx_sorted_bit(:) = -1 + do i=1,N_det_non_ref + idx_sorted_bit(get_index_in_psi_det_sorted_bit(psi_non_ref(1,1,i), N_int)) = i + enddo + + ! To provide everything + contrib = dij(1, 1, 1) + + do i_state = 1, N_states + delta_mrcepa0_ii(:,:) = 0d0 + delta_mrcepa0_ij(:,:,:) = 0d0 + + !$OMP PARALLEL DO default(none) schedule(dynamic) shared(delta_mrcepa0_ij, delta_mrcepa0_ii) & + !$OMP private(m,i,II,J,k,degree,myActive,made_hole,made_particle,hjk,contrib,contrib2) & + !$OMP shared(active_sorb, psi_non_ref, psi_non_ref_coef, psi_ref, psi_ref_coef, cepa0_shortcut, det_cepa0_active) & + !$OMP shared(N_det_ref, N_det_non_ref,N_int,det_cepa0_idx,lambda_mrcc,det_ref_active, delta_cas) & + !$OMP shared(notf,i_state, sortRef, sortRefIdx, dij) + do blok=1,cepa0_shortcut(0) + do i=cepa0_shortcut(blok), cepa0_shortcut(blok+1)-1 + do II=1,N_det_ref + call get_excitation_degree(psi_ref(1,1,II),psi_non_ref(1,1,det_cepa0_idx(i)),degree,N_int) + if (degree > 2 ) cycle + + do ni=1,N_int + made_hole(ni,1) = iand(det_ref_active(ni,1,II), xor(det_cepa0_active(ni,1,i), det_ref_active(ni,1,II))) + made_hole(ni,2) = iand(det_ref_active(ni,2,II), xor(det_cepa0_active(ni,2,i), det_ref_active(ni,2,II))) + + made_particle(ni,1) = iand(det_cepa0_active(ni,1,i), xor(det_cepa0_active(ni,1,i), det_ref_active(ni,1,II))) + made_particle(ni,2) = iand(det_cepa0_active(ni,2,i), xor(det_cepa0_active(ni,2,i), det_ref_active(ni,2,II))) + end do + + + kloop: do k=cepa0_shortcut(blok), cepa0_shortcut(blok+1)-1 !i + !if(lambda_mrcc(i_state, det_cepa0_idx(k)) == 0d0) cycle + + do ni=1,N_int + if(iand(made_hole(ni,1), det_cepa0_active(ni,1,k)) /= 0) cycle kloop + if(iand(made_particle(ni,1), det_cepa0_active(ni,1,k)) /= made_particle(ni,1)) cycle kloop + if(iand(made_hole(ni,2), det_cepa0_active(ni,2,k)) /= 0) cycle kloop + if(iand(made_particle(ni,2), det_cepa0_active(ni,2,k)) /= made_particle(ni,2)) cycle kloop + end do + do ni=1,N_int + myActive(ni,1) = xor(det_cepa0_active(ni,1,k), made_hole(ni,1)) + myActive(ni,1) = xor(myActive(ni,1), made_particle(ni,1)) + myActive(ni,2) = xor(det_cepa0_active(ni,2,k), made_hole(ni,2)) + myActive(ni,2) = xor(myActive(ni,2), made_particle(ni,2)) + end do + + j = searchDet(sortRef, myActive, N_det_ref, N_int) + if(j == -1) then + cycle + end if + j = sortRefIdx(j) + !$OMP ATOMIC + notf = notf+1 + +! call i_h_j(psi_non_ref(1,1,det_cepa0_idx(k)),psi_ref(1,1,J),N_int,HJk) + contrib = delta_cas(II, J, i_state) * dij(J, det_cepa0_idx(k), i_state) + + if(dabs(psi_ref_coef(J,i_state)).ge.5.d-5) then + contrib2 = contrib / psi_ref_coef(J, i_state) * psi_non_ref_coef(det_cepa0_idx(i),i_state) + !$OMP ATOMIC + delta_mrcepa0_ii(J,i_state) -= contrib2 + else + contrib = contrib * 0.5d0 + end if + !$OMP ATOMIC + delta_mrcepa0_ij(J, det_cepa0_idx(i), i_state) += contrib + + end do kloop + end do + end do + end do + !$OMP END PARALLEL DO + end do + deallocate(idx_sorted_bit) + call wall_time(wall) + print *, "cepa0", wall, notf + !stop +END_PROVIDER + + + BEGIN_PROVIDER [ double precision, delta_sub_ij, (N_det_ref,N_det_non_ref,N_states) ] +&BEGIN_PROVIDER [ double precision, delta_sub_ii, (N_det_ref, N_states) ] + use bitmasks + implicit none + + integer :: i_state, i, i_I, J, k, degree, degree2, l, deg, ni + integer :: p1,p2,h1,h2,s1,s2, p1_,p2_,h1_,h2_,s1_,s2_ + logical :: ok + double precision :: phase_Ji, phase_Ik, phase_Ii + double precision :: contrib, contrib2, delta_IJk, HJk, HIk, HIl + integer, dimension(0:2,2,2) :: exc_Ik, exc_Ji, exc_Ii + integer(bit_kind) :: det_tmp(N_int, 2), det_tmp2(N_int, 2) + integer, allocatable :: idx_sorted_bit(:) + integer, external :: get_index_in_psi_det_sorted_bit + + integer :: II, blok + + provide delta_cas lambda_mrcc + allocate(idx_sorted_bit(N_det)) + idx_sorted_bit(:) = -1 + do i=1,N_det_non_ref + idx_sorted_bit(get_index_in_psi_det_sorted_bit(psi_non_ref(1,1,i), N_int)) = i + enddo + + do i_state = 1, N_states + delta_sub_ij(:,:,:) = 0d0 + delta_sub_ii(:,:) = 0d0 + + provide mo_bielec_integrals_in_map + + + !$OMP PARALLEL DO default(none) schedule(dynamic,10) shared(delta_sub_ij, delta_sub_ii) & + !$OMP private(i, J, k, degree, degree2, l, deg, ni) & + !$OMP private(p1,p2,h1,h2,s1,s2, p1_,p2_,h1_,h2_,s1_,s2_) & + !$OMP private(ok, phase_Ji, phase_Ik, phase_Ii, contrib2, contrib, delta_IJk, HJk, HIk, HIl, exc_Ik, exc_Ji, exc_Ii) & + !$OMP private(det_tmp, det_tmp2, II, blok) & + !$OMP shared(idx_sorted_bit, N_det_non_ref, N_det_ref, N_int, psi_non_ref, psi_non_ref_coef, psi_ref, psi_ref_coef) & + !$OMP shared(i_state,lambda_mrcc, hf_bitmask, active_sorb) + do i=1,N_det_non_ref + if(mod(i,1000) == 0) print *, i, "/", N_det_non_ref + do J=1,N_det_ref + call get_excitation(psi_ref(1,1,J),psi_non_ref(1,1,i),exc_Ji,degree,phase_Ji,N_int) + if(degree == -1) cycle + + + do II=1,N_det_ref + call apply_excitation(psi_ref(1,1,II),exc_Ji,det_tmp,ok,N_int) + + if(.not. ok) cycle + l = get_index_in_psi_det_sorted_bit(det_tmp, N_int) + if(l == 0) cycle + l = idx_sorted_bit(l) + + call i_h_j(psi_ref(1,1,II), det_tmp, N_int, HIl) + + do k=1,N_det_non_ref + if(lambda_mrcc(i_state, k) == 0d0) cycle + call get_excitation(psi_ref(1,1,II),psi_non_ref(1,1,k),exc_Ik,degree2,phase_Ik,N_int) + + det_tmp(:,:) = 0_bit_kind + det_tmp2(:,:) = 0_bit_kind + + ok = .true. + do ni=1,N_int + det_tmp(ni,1) = iand(xor(HF_bitmask(ni,1), psi_non_ref(ni,1,k)), not(active_sorb(ni,1))) + det_tmp(ni,2) = iand(xor(HF_bitmask(ni,1), psi_non_ref(ni,1,i)), not(active_sorb(ni,1))) + ok = ok .and. (popcnt(det_tmp(ni,1)) + popcnt(det_tmp(ni,2)) == popcnt(xor(det_tmp(ni,1), det_tmp(ni,2)))) + + det_tmp(ni,1) = iand(xor(HF_bitmask(ni,2), psi_non_ref(ni,2,k)), not(active_sorb(ni,2))) + det_tmp(ni,2) = iand(xor(HF_bitmask(ni,2), psi_non_ref(ni,2,i)), not(active_sorb(ni,2))) + ok = ok .and. (popcnt(det_tmp(ni,1)) + popcnt(det_tmp(ni,2)) == popcnt(xor(det_tmp(ni,1), det_tmp(ni,2)))) + end do + + if(ok) cycle + + + call i_h_j(psi_ref(1,1,J), psi_non_ref(1,1,k), N_int, HJk) + call i_h_j(psi_ref(1,1,II), psi_non_ref(1,1,k), N_int, HIk) + if(HJk == 0) cycle + !assert HIk == 0 + delta_IJk = HJk * HIk * lambda_mrcc(i_state, k) + call apply_excitation(psi_non_ref(1,1,i),exc_Ik,det_tmp,ok,N_int) + if(ok) cycle + contrib = delta_IJk * HIl * lambda_mrcc(i_state,l) + if(dabs(psi_ref_coef(II,i_state)).ge.5.d-5) then + contrib2 = contrib / psi_ref_coef(II, i_state) * psi_non_ref_coef(l,i_state) + !$OMP ATOMIC + delta_sub_ii(II,i_state) -= contrib2 + else + contrib = contrib * 0.5d0 + endif + !$OMP ATOMIC + delta_sub_ij(II, i, i_state) += contrib + end do + end do + end do + end do + !$OMP END PARALLEL DO + end do + deallocate(idx_sorted_bit) +END_PROVIDER + + +subroutine set_det_bit(det, p, s) + implicit none + integer(bit_kind),intent(inout) :: det(N_int, 2) + integer, intent(in) :: p, s + integer :: ni, pos + + ni = (p-1)/bit_kind_size + 1 + pos = mod(p-1, bit_kind_size) + det(ni,s) = ibset(det(ni,s), pos) +end subroutine + + +BEGIN_PROVIDER [ double precision, h_, (N_det_ref,N_det_non_ref) ] + implicit none + integer :: i,j + do i=1,N_det_ref + do j=1,N_det_non_ref + call i_h_j(psi_ref(1,1,i), psi_non_ref(1,1,j), N_int, h_(i,j)) + end do + end do +END_PROVIDER + + + +subroutine filter_tq(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_miniList) + + use bitmasks + implicit none + + integer, intent(in) :: i_generator,n_selected, Nint + + integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) + integer :: i,j,k,m + logical :: is_in_wavefunction + integer,allocatable :: degree(:) + integer,allocatable :: idx(:) + logical :: good + + integer(bit_kind), intent(inout) :: tq(Nint,2,n_selected) !! intent(out) + integer, intent(out) :: N_tq + + integer :: nt,ni + logical, external :: is_connected_to, is_generable + + integer(bit_kind),intent(in) :: miniList(Nint,2,N_det_generators) + integer,intent(in) :: N_miniList + + allocate(degree(psi_det_size)) + allocate(idx(0:psi_det_size)) + N_tq = 0 + + i_loop : do i=1,N_selected + do k=1, N_minilist + if(is_generable(miniList(1,1,k), det_buffer(1,1,i), Nint)) cycle i_loop + end do + + ! Select determinants that are triple or quadruple excitations + ! from the ref + good = .True. + call get_excitation_degree_vector(psi_ref,det_buffer(1,1,i),degree,Nint,N_det_ref,idx) + !good=(idx(0) == 0) tant que degree > 2 pas retourné par get_excitation_degree_vector + do k=1,idx(0) + if (degree(k) < 3) then + good = .False. + exit + endif + enddo + if (good) then + if (.not. is_in_wavefunction(det_buffer(1,1,i),Nint)) then + N_tq += 1 + do k=1,N_int + tq(k,1,N_tq) = det_buffer(k,1,i) + tq(k,2,N_tq) = det_buffer(k,2,i) + enddo + endif + endif + enddo i_loop +end + + +subroutine filter_tq_micro(i_generator,n_selected,det_buffer,Nint,tq,N_tq,microlist,ptr_microlist,N_microlist,key_mask) + + use bitmasks + implicit none + + integer, intent(in) :: i_generator,n_selected, Nint + + integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) + integer :: i,j,k,m + logical :: is_in_wavefunction + integer,allocatable :: degree(:) + integer,allocatable :: idx(:) + logical :: good + + integer(bit_kind), intent(inout) :: tq(Nint,2,n_selected) !! intent(out) + integer, intent(out) :: N_tq + + integer :: nt,ni + logical, external :: is_connected_to, is_generable + + integer(bit_kind),intent(in) :: microlist(Nint,2,*) + integer,intent(in) :: ptr_microlist(0:*) + integer,intent(in) :: N_microlist(0:*) + integer(bit_kind),intent(in) :: key_mask(Nint, 2) + + integer :: mobiles(2), smallerlist + + + allocate(degree(psi_det_size)) + allocate(idx(0:psi_det_size)) + N_tq = 0 + + i_loop : do i=1,N_selected + call getMobiles(det_buffer(1,1,i), key_mask, mobiles, Nint) + if(N_microlist(mobiles(1)) < N_microlist(mobiles(2))) then + smallerlist = mobiles(1) + else + smallerlist = mobiles(2) + end if + + if(N_microlist(smallerlist) > 0) then + do k=ptr_microlist(smallerlist), ptr_microlist(smallerlist)+N_microlist(smallerlist)-1 + if(is_generable(microlist(1,1,k), det_buffer(1,1,i), Nint)) cycle i_loop + end do + end if + + if(N_microlist(0) > 0) then + do k=1, N_microlist(0) + if(is_generable(microlist(1,1,k), det_buffer(1,1,i), Nint)) cycle i_loop + end do + end if + + ! Select determinants that are triple or quadruple excitations + ! from the ref + good = .True. + call get_excitation_degree_vector(psi_ref,det_buffer(1,1,i),degree,Nint,N_det_ref,idx) + !good=(idx(0) == 0) tant que degree > 2 pas retourné par get_excitation_degree_vector + do k=1,idx(0) + if (degree(k) < 3) then + good = .False. + exit + endif + enddo + if (good) then + if (.not. is_in_wavefunction(det_buffer(1,1,i),Nint)) then + N_tq += 1 + do k=1,N_int + tq(k,1,N_tq) = det_buffer(k,1,i) + tq(k,2,N_tq) = det_buffer(k,2,i) + enddo + endif + endif + enddo i_loop +end + + + + diff --git a/plugins/mrcepa0/dressing_slave.irp.f b/plugins/mrcepa0/dressing_slave.irp.f new file mode 100644 index 00000000..f1d6f029 --- /dev/null +++ b/plugins/mrcepa0/dressing_slave.irp.f @@ -0,0 +1,593 @@ +subroutine mrsc2_dressing_slave_tcp(i) + implicit none + integer, intent(in) :: i + BEGIN_DOC +! Task for parallel MR-SC2 + END_DOC + call mrsc2_dressing_slave(0,i) +end + + +subroutine mrsc2_dressing_slave_inproc(i) + implicit none + integer, intent(in) :: i + BEGIN_DOC +! Task for parallel MR-SC2 + END_DOC + call mrsc2_dressing_slave(1,i) +end + +subroutine mrsc2_dressing_slave(thread,iproc) + use f77_zmq + + implicit none + BEGIN_DOC +! Task for parallel MR-SC2 + END_DOC + integer, intent(in) :: thread, iproc +! integer :: j,l + integer :: rc + + integer :: worker_id, task_id + 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 + + double precision, allocatable :: delta(:,:,:) + + + + integer :: i_state, i, i_I, J, k, k2, k1, kk, ll, degree, degree2, m, l, deg, ni, m2 + integer :: n(2) + integer :: p1,p2,h1,h2,s1,s2, blok, I_s, J_s, kn + logical :: ok + double precision :: phase_iI, phase_Ik, phase_Jl, phase_Ji, phase_al + double precision :: diI, hIi, hJi, delta_JI, dkI, HkI, ci_inv(N_states), cj_inv(N_states) + double precision :: contrib, wall, iwall + double precision, allocatable :: dleat(:,:,:) + integer, dimension(0:2,2,2) :: exc_iI, exc_Ik, exc_IJ + integer(bit_kind) :: det_tmp(N_int, 2), det_tmp2(N_int, 2), inac, virt + integer, external :: get_index_in_psi_det_sorted_bit, searchDet, detCmp + logical, external :: is_in_wavefunction, isInCassd, detEq + integer,allocatable :: komon(:) + logical :: komoned + !double precision, external :: get_dij + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + zmq_socket_push = new_zmq_push_socket(thread) + + call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) + + allocate (dleat(N_states, N_det_non_ref, 2), delta(N_states,0:N_det_non_ref, 2)) + allocate(komon(0:N_det_non_ref)) + + do + call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task) + if (task_id == 0) exit + read (task,*) i_I, J, k1, k2 + do i_state=1, N_states + ci_inv(i_state) = 1.d0 / psi_ref_coef(i_I,i_state) + cj_inv(i_state) = 1.d0 / psi_ref_coef(J,i_state) + end do + !delta = 0.d0 + n = 0 + delta(:,0,:) = 0d0 + delta(:,:nlink(J),1) = 0d0 + delta(:,:nlink(i_I),2) = 0d0 + komon(0) = 0 + komoned = .false. + + + + + do kk = k1, k2 + k = det_cepa0_idx(linked(kk, i_I)) + blok = blokMwen(kk, i_I) + + call get_excitation(psi_ref(1,1,i_I),psi_non_ref(1,1,k),exc_Ik,degree,phase_Ik,N_int) + + if(J /= i_I) then + call apply_excitation(psi_ref(1,1,J),exc_Ik,det_tmp2,ok,N_int) + if(.not. ok) cycle + + l = searchDet(det_cepa0(1,1,cepa0_shortcut(blok)), det_tmp2, cepa0_shortcut(blok+1)-cepa0_shortcut(blok), N_int) + if(l == -1) cycle + ll = cepa0_shortcut(blok)-1+l + l = det_cepa0_idx(ll) + ll = child_num(ll, J) + else + l = k + ll = kk + end if + + + if(.not. komoned) then + m = 0 + m2 = 0 + + do while(m < nlink(i_I) .and. m2 < nlink(J)) + m += 1 + m2 += 1 + if(linked(m, i_I) < linked(m2, J)) then + m2 -= 1 + cycle + else if(linked(m, i_I) > linked(m2, J)) then + m -= 1 + cycle + end if + i = det_cepa0_idx(linked(m, i_I)) + + if(h_(J,i) == 0.d0) cycle + if(h_(i_I,i) == 0.d0) cycle + + !ok = .false. + !do i_state=1, N_states + ! if(lambda_mrcc(i_state, i) /= 0d0) then + ! ok = .true. + ! exit + ! end if + !end do + !if(.not. ok) cycle +! + + komon(0) += 1 + kn = komon(0) + komon(kn) = i + + +! call get_excitation(psi_ref(1,1,J),psi_non_ref(1,1,i),exc_IJ,degree2,phase_Ji,N_int) +! if(I_i /= J) call get_excitation(psi_ref(1,1,I_i),psi_non_ref(1,1,i),exc_IJ,degree2,phase_Ii,N_int) +! if(I_i == J) phase_Ii = phase_Ji + + do i_state = 1,N_states + dkI = h_(J,i) * dij(i_I, i, i_state)!get_dij(psi_ref(1,1,i_I), psi_non_ref(1,1,i), N_int) + !dkI = h_(J,i) * h_(i_I,i) * lambda_mrcc(i_state, i) + dleat(i_state, kn, 1) = dkI + dleat(i_state, kn, 2) = dkI + end do + + end do + + komoned = .true. + end if + + + do m = 1, komon(0) + + i = komon(m) + + call apply_excitation(psi_non_ref(1,1,i),exc_Ik,det_tmp,ok,N_int) + if(.not. ok) cycle + if(HP(1,i) + HP(1,k) <= 2 .and. HP(2,i) + HP(2,k) <= 2) then +! if(is_in_wavefunction(det_tmp, N_int)) cycle + cycle + end if + + !if(isInCassd(det_tmp, N_int)) cycle + + do i_state = 1, N_states + !if(lambda_mrcc(i_state, i) == 0d0) cycle + + + !contrib = h_(i_I,k) * lambda_mrcc(i_state, k) * dleat(i_state, m, 2)! * phase_al + contrib = dij(i_I, k, i_state) * dleat(i_state, m, 2) + delta(i_state,ll,1) += contrib + if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5) then + delta(i_state,0,1) -= contrib * ci_inv(i_state) * psi_non_ref_coef(l,i_state) + endif + + if(I_i == J) cycle + !contrib = h_(J,l) * lambda_mrcc(i_state, l) * dleat(i_state, m, 1)! * phase_al + contrib = dij(J, l, i_state) * dleat(i_state, m, 1) + delta(i_state,kk,2) += contrib + if(dabs(psi_ref_coef(J,i_state)).ge.5.d-5) then + delta(i_state,0,2) -= contrib * cj_inv(i_state) * psi_non_ref_coef(k,i_state) + end if + enddo !i_state + end do ! while + end do ! kk + + + call push_mrsc2_results(zmq_socket_push, I_i, J, delta, task_id) + call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) + +! end if + + enddo + + deallocate(delta) + + call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + call end_zmq_push_socket(zmq_socket_push,thread) + +end + + +subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, task_id) + use f77_zmq + implicit none + BEGIN_DOC +! Push integrals in the push socket + END_DOC + + integer, intent(in) :: i_I, J + integer(ZMQ_PTR), intent(in) :: zmq_socket_push + double precision,intent(inout) :: delta(N_states, 0:N_det_non_ref, 2) + integer, intent(in) :: task_id + integer :: rc , i_state, i, kk, li + integer,allocatable :: idx(:,:) + integer :: n(2) + logical :: ok + + allocate(idx(N_det_non_ref,2)) + rc = f77_zmq_send( zmq_socket_push, i_I, 4, ZMQ_SNDMORE) + if (rc /= 4) then + print *, irp_here, 'f77_zmq_send( zmq_socket_push, i_I, 4, ZMQ_SNDMORE)' + stop 'error' + endif + + rc = f77_zmq_send( zmq_socket_push, J, 4, ZMQ_SNDMORE) + if (rc /= 4) then + print *, irp_here, 'f77_zmq_send( zmq_socket_push, J, 4, ZMQ_SNDMORE)' + stop 'error' + endif + + + do kk=1,2 + n(kk)=0 + if(kk == 1) li = nlink(j) + if(kk == 2) li = nlink(i_I) + do i=1, li + ok = .false. + do i_state=1,N_states + if(delta(i_state, i, kk) /= 0d0) then + ok = .true. + exit + end if + end do + + if(ok) then + n(kk) += 1 +! idx(n,kk) = i + if(kk == 1) then + idx(n(1),1) = det_cepa0_idx(linked(i, J)) + else + idx(n(2),2) = det_cepa0_idx(linked(i, i_I)) + end if + + do i_state=1, N_states + delta(i_state, n(kk), kk) = delta(i_state, i, kk) + end do + end if + end do + + rc = f77_zmq_send( zmq_socket_push, n(kk), 4, ZMQ_SNDMORE) + if (rc /= 4) then + print *, irp_here, 'f77_zmq_send( zmq_socket_push, n, 4, ZMQ_SNDMORE)' + stop 'error' + endif + + if(n(kk) /= 0) then + rc = f77_zmq_send( zmq_socket_push, delta(1,0,kk), (n(kk)+1)*8*N_states, ZMQ_SNDMORE) ! delta(1,0,1) = delta_I delta(1,0,2) = delta_J + if (rc /= (n(kk)+1)*8*N_states) then + print *, irp_here, 'f77_zmq_send( zmq_socket_push, delta, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)' + stop 'error' + endif + + rc = f77_zmq_send( zmq_socket_push, idx(1,kk), n(kk)*4, ZMQ_SNDMORE) + if (rc /= n(kk)*4) then + print *, irp_here, 'f77_zmq_send( zmq_socket_push, delta, 8*n(kk), ZMQ_SNDMORE)' + stop 'error' + endif + end if + end do + + + 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 pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, task_id) + use f77_zmq + implicit none + BEGIN_DOC +! Push integrals in the push socket + END_DOC + + integer(ZMQ_PTR), intent(in) :: zmq_socket_pull + integer, intent(out) :: i_I, J, n(2) + double precision, intent(inout) :: delta(N_states, 0:N_det_non_ref, 2) + integer, intent(out) :: task_id + integer :: rc , i, kk + integer,intent(inout) :: idx(N_det_non_ref,2) + logical :: ok + + rc = f77_zmq_recv( zmq_socket_pull, i_I, 4, ZMQ_SNDMORE) + if (rc /= 4) then + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, i_I, 4, ZMQ_SNDMORE)' + stop 'error' + endif + + rc = f77_zmq_recv( zmq_socket_pull, J, 4, ZMQ_SNDMORE) + if (rc /= 4) then + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, J, 4, ZMQ_SNDMORE)' + stop 'error' + endif + + do kk = 1, 2 + rc = f77_zmq_recv( zmq_socket_pull, n(kk), 4, ZMQ_SNDMORE) + if (rc /= 4) then + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, n, 4, ZMQ_SNDMORE)' + stop 'error' + endif + + if(n(kk) /= 0) then + rc = f77_zmq_recv( zmq_socket_pull, delta(1,0,kk), (n(kk)+1)*8*N_states, ZMQ_SNDMORE) + if (rc /= (n(kk)+1)*8*N_states) then + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, delta, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)' + stop 'error' + endif + + rc = f77_zmq_recv( zmq_socket_pull, idx(1,kk), n(kk)*4, ZMQ_SNDMORE) + if (rc /= n(kk)*4) then + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, delta, n(kk)*4, ZMQ_SNDMORE)' + stop 'error' + endif + end if + end do + + 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 + + +! ! Activate is zmq_socket_pull is a REP +! integer :: idummy +! rc = f77_zmq_send( zmq_socket_pull, idummy, 4, 0) +! if (rc /= 4) then +! print *, irp_here, 'f77_zmq_send( zmq_socket_pull, idummy, 4, 0)' +! stop 'error' +! endif +end + + + +subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_) + use f77_zmq + implicit none + BEGIN_DOC +! Collects results from the AO integral calculation + END_DOC + + double precision,intent(inout) :: delta_ij_(N_states,N_det_non_ref,N_det_ref) + double precision,intent(inout) :: delta_ii_(N_states,N_det_ref) + +! integer :: j,l + integer :: rc + + double precision, allocatable :: delta(:,:,:) + + 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 + + integer :: I_i, J, l, i_state, n(2), kk + integer,allocatable :: idx(:,:) + + delta_ii_(:,:) = 0d0 + delta_ij_(:,:,:) = 0d0 + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + zmq_socket_pull = new_zmq_pull_socket() + + allocate ( delta(N_states,0:N_det_non_ref,2) ) + + allocate(idx(N_det_non_ref,2)) + more = 1 + do while (more == 1) + + call pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, task_id) + + + do l=1, n(1) + do i_state=1,N_states + delta_ij_(i_state,idx(l,1),i_I) += delta(i_state,l,1) + end do + end do + + do l=1, n(2) + do i_state=1,N_states + delta_ij_(i_state,idx(l,2),J) += delta(i_state,l,2) + end do + end do + + +! +! do l=1,nlink(J) +! do i_state=1,N_states +! delta_ij_(i_state,det_cepa0_idx(linked(l,J)),i_I) += delta(i_state,l,1) +! delta_ij_(i_state,det_cepa0_idx(linked(l,i_I)),j) += delta(i_state,l,2) +! end do +! end do +! + if(n(1) /= 0) then + do i_state=1,N_states + delta_ii_(i_state,i_I) += delta(i_state,0,1) + end do + end if + + if(n(2) /= 0) then + do i_state=1,N_states + delta_ii_(i_state,J) += delta(i_state,0,2) + end do + end if + + + if (task_id /= 0) then + call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more) + endif + + + enddo + deallocate( delta ) + + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + call end_zmq_pull_socket(zmq_socket_pull) + +end + + + + + BEGIN_PROVIDER [ double precision, delta_ij_old, (N_states,N_det_non_ref,N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ii_old, (N_states,N_det_ref) ] + implicit none + + integer :: i_state, i, i_I, J, k, kk, degree, degree2, m, l, deg, ni, m2 + integer :: p1,p2,h1,h2,s1,s2, blok, I_s, J_s, nex, nzer, ntot +! integer, allocatable :: linked(:,:), blokMwen(:, :), nlink(:) + logical :: ok + double precision :: phase_iI, phase_Ik, phase_Jl, phase_Ji, phase_al, diI, hIi, hJi, delta_JI, dkI(N_states), HkI, ci_inv(N_states), dia_hla(N_states) + double precision :: contrib, wall, iwall ! , searchance(N_det_ref) + integer, dimension(0:2,2,2) :: exc_iI, exc_Ik, exc_IJ + integer(bit_kind) :: det_tmp(N_int, 2), det_tmp2(N_int, 2), inac, virt + integer, external :: get_index_in_psi_det_sorted_bit, searchDet, detCmp + logical, external :: is_in_wavefunction, isInCassd, detEq + character*(512) :: task + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + + integer :: KKsize = 1000000 + + + call new_parallel_job(zmq_to_qp_run_socket,'mrsc2') + + + call wall_time(iwall) +! allocate(linked(N_det_non_ref, N_det_ref), blokMwen(N_det_non_ref, N_det_ref), nlink(N_det_ref)) + + +! searchance = 0d0 +! do J = 1, N_det_ref +! nlink(J) = 0 +! do blok=1,cepa0_shortcut(0) +! do k=cepa0_shortcut(blok), cepa0_shortcut(blok+1)-1 +! call get_excitation_degree(psi_ref(1,1,J),det_cepa0(1,1,k),degree,N_int) +! if(degree <= 2) then +! nlink(J) += 1 +! linked(nlink(J),J) = k +! blokMwen(nlink(J),J) = blok +! searchance(J) += 1d0 + log(dfloat(cepa0_shortcut(blok+1) - cepa0_shortcut(blok))) +! end if +! end do +! end do +! end do + + + +! stop + nzer = 0 + ntot = 0 + do nex = 3, 0, -1 + print *, "los ",nex + do I_s = N_det_ref, 1, -1 +! if(mod(I_s,1) == 0) then +! call wall_time(wall) +! wall = wall-iwall +! print *, I_s, "/", N_det_ref, wall * (dfloat(N_det_ref) / dfloat(I_s)), wall, wall * (dfloat(N_det_ref) / dfloat(I_s))-wall +! end if + + + do J_s = 1, I_s + + call get_excitation_degree(psi_ref(1,1,J_s), psi_ref(1,1,I_s), degree, N_int) + if(degree /= nex) cycle + if(nex == 3) nzer = nzer + 1 + ntot += 1 +! if(degree > 3) then +! deg += 1 +! cycle +! else if(degree == -10) then +! KKsize = 100000 +! else +! KKsize = 1000000 +! end if + + + + if(searchance(I_s) < searchance(J_s)) then + i_I = I_s + J = J_s + else + i_I = J_s + J = I_s + end if + + KKsize = nlink(1) + if(nex == 0) KKsize = int(float(nlink(1)) / float(nlink(i_I)) * (float(nlink(1)) / 64d0)) + + !if(KKsize == 0) stop "ZZEO" + + do kk = 1 , nlink(i_I), KKsize + write(task,*) I_i, J, kk, int(min(kk+KKsize-1, nlink(i_I))) + call add_task_to_taskserver(zmq_to_qp_run_socket,task) + end do + + ! do kk = 1 , nlink(i_I) + ! k = linked(kk,i_I) + ! blok = blokMwen(kk,i_I) + ! write(task,*) I_i, J, k, blok + ! call add_task_to_taskserver(zmq_to_qp_run_socket,task) + ! + ! enddo !kk + enddo !J + + enddo !I + end do ! nex + print *, "tasked" +! integer(ZMQ_PTR) ∷ collector_thread +! external ∷ ao_bielec_integrals_in_map_collector +! rc = pthread_create(collector_thread, mrsc2_dressing_collector) + print *, nzer, ntot, float(nzer) / float(ntot) + provide nproc + !$OMP PARALLEL DEFAULT(none) SHARED(delta_ii_old,delta_ij_old) PRIVATE(i) NUM_THREADS(nproc+1) + i = omp_get_thread_num() + if (i==0) then + call mrsc2_dressing_collector(delta_ii_old,delta_ij_old) + else + call mrsc2_dressing_slave_inproc(i) + endif + !$OMP END PARALLEL + +! rc = pthread_join(collector_thread) + call end_parallel_job(zmq_to_qp_run_socket, 'mrsc2') + + +END_PROVIDER + + + diff --git a/plugins/mrcepa0/mrcc.irp.f b/plugins/mrcepa0/mrcc.irp.f new file mode 100644 index 00000000..91592e62 --- /dev/null +++ b/plugins/mrcepa0/mrcc.irp.f @@ -0,0 +1,19 @@ +program mrsc2sub + implicit none + double precision, allocatable :: energy(:) + allocate (energy(N_states)) + + !mrmode : 1=mrcepa0, 2=mrsc2 add, 3=mrcc + mrmode = 3 + + read_wf = .True. + SOFT_TOUCH read_wf + call print_cas_coefs + call set_generators_bitmasks_as_holes_and_particles + call run(N_states,energy) + if(do_pt2_end)then + call run_pt2(N_states,energy) + endif + deallocate(energy) +end + diff --git a/plugins/mrcepa0/mrcepa0.irp.f b/plugins/mrcepa0/mrcepa0.irp.f new file mode 100644 index 00000000..34d3dec5 --- /dev/null +++ b/plugins/mrcepa0/mrcepa0.irp.f @@ -0,0 +1,19 @@ +program mrcepa0 + implicit none + double precision, allocatable :: energy(:) + allocate (energy(N_states)) + + !mrmode : 1=mrcepa0, 2=mrsc2 add, 3=mrcc + mrmode = 1 + + read_wf = .True. + SOFT_TOUCH read_wf + call print_cas_coefs + call set_generators_bitmasks_as_holes_and_particles + call run(N_states,energy) + if(do_pt2_end)then + call run_pt2(N_states,energy) + endif + deallocate(energy) +end + diff --git a/plugins/mrcepa0/mrcepa0_general.irp.f b/plugins/mrcepa0/mrcepa0_general.irp.f new file mode 100644 index 00000000..63f03360 --- /dev/null +++ b/plugins/mrcepa0/mrcepa0_general.irp.f @@ -0,0 +1,244 @@ + + +subroutine run(N_st,energy) + implicit none + + integer, intent(in) :: N_st + double precision, intent(out) :: energy(N_st) + + integer :: i,j + + double precision :: E_new, E_old, delta_e + integer :: iteration + double precision :: E_past(4), lambda + + integer :: n_it_mrcc_max + double precision :: thresh_mrcc + + + + thresh_mrcc = thresh_dressed_ci + n_it_mrcc_max = n_it_max_dressed_ci + + if(n_it_mrcc_max == 1) then + do j=1,N_states_diag + do i=1,N_det + psi_coef(i,j) = CI_eigenvectors_dressed(i,j) + enddo + enddo + SOFT_TOUCH psi_coef ci_energy_dressed + call write_double(6,ci_energy_dressed(1),"Final MRCC energy") + call ezfio_set_mrcepa0_energy(ci_energy_dressed(1)) + call save_wavefunction + energy(:) = ci_energy_dressed(:) + else + E_new = 0.d0 + delta_E = 1.d0 + iteration = 0 + lambda = 1.d0 + do while (delta_E > thresh_mrcc) + iteration += 1 + print *, '===========================' + print *, 'MRCEPA0 Iteration', iteration + print *, '===========================' + print *, '' + E_old = sum(ci_energy_dressed) + call write_double(6,ci_energy_dressed(1),"MRCEPA0 energy") + call diagonalize_ci_dressed(lambda) + E_new = sum(ci_energy_dressed) + delta_E = dabs(E_new - E_old) + call save_wavefunction + call ezfio_set_mrcepa0_energy(ci_energy_dressed(1)) + if (iteration >= n_it_mrcc_max) then + exit + endif + enddo + call write_double(6,ci_energy_dressed(1),"Final MRCEPA0 energy") + energy(:) = ci_energy_dressed(:) + endif +end + + +subroutine print_cas_coefs + implicit none + + integer :: i,j + print *, 'CAS' + print *, '===' + do i=1,N_det_cas + print *, psi_cas_coef(i,:) + call debug_det(psi_cas(1,1,i),N_int) + enddo + call write_double(6,ci_energy(1),"Initial CI energy") + +end + + + + +subroutine run_pt2_old(N_st,energy) + implicit none + integer :: i,j,k + integer, intent(in) :: N_st + double precision, intent(in) :: energy(N_st) + double precision :: pt2_redundant(N_st), pt2(N_st) + double precision :: norm_pert(N_st),H_pert_diag(N_st) + + pt2_redundant = 0.d0 + pt2 = 0d0 + !if(lambda_mrcc_pt2(0) == 0) return + + print*,'Last iteration only to compute the PT2' + + print * ,'Computing the redundant PT2 contribution' + + if (mrmode == 1) then + + N_det_generators = lambda_mrcc_kept(0) + N_det_selectors = lambda_mrcc_kept(0) + + do i=1,N_det_generators + j = lambda_mrcc_kept(i) + do k=1,N_int + psi_det_generators(k,1,i) = psi_non_ref(k,1,j) + psi_det_generators(k,2,i) = psi_non_ref(k,2,j) + psi_selectors(k,1,i) = psi_non_ref(k,1,j) + psi_selectors(k,2,i) = psi_non_ref(k,2,j) + enddo + do k=1,N_st + psi_coef_generators(i,k) = psi_non_ref_coef(j,k) + psi_selectors_coef(i,k) = psi_non_ref_coef(j,k) + enddo + enddo + + else + + N_det_generators = N_det_non_ref + N_det_selectors = N_det_non_ref + + do i=1,N_det_generators + j = i + do k=1,N_int + psi_det_generators(k,1,i) = psi_non_ref(k,1,j) + psi_det_generators(k,2,i) = psi_non_ref(k,2,j) + psi_selectors(k,1,i) = psi_non_ref(k,1,j) + psi_selectors(k,2,i) = psi_non_ref(k,2,j) + enddo + do k=1,N_st + psi_coef_generators(i,k) = psi_non_ref_coef(j,k) + psi_selectors_coef(i,k) = psi_non_ref_coef(j,k) + enddo + enddo + + endif + + SOFT_TOUCH N_det_selectors psi_selectors_coef psi_selectors N_det_generators psi_det_generators psi_coef_generators ci_eigenvectors_dressed ci_eigenvectors_s2_dressed ci_electronic_energy_dressed + SOFT_TOUCH psi_ref_coef_diagonalized psi_ref_energy_diagonalized + + call H_apply_mrcepa_PT2(pt2_redundant, norm_pert, H_pert_diag, N_st) + + print * ,'Computing the remaining contribution' + + threshold_selectors = 1.d0 + threshold_generators = 0.999d0 + + N_det_generators = N_det_non_ref + N_det_ref + N_det_selectors = N_det_non_ref + N_det_ref + + psi_det_generators(:,:,:N_det_ref) = psi_ref(:,:,:N_det_ref) + psi_selectors(:,:,:N_det_ref) = psi_ref(:,:,:N_det_ref) + psi_coef_generators(:N_det_ref,:) = psi_ref_coef(:N_det_ref,:) + psi_selectors_coef(:N_det_ref,:) = psi_ref_coef(:N_det_ref,:) + + do i=N_det_ref+1,N_det_generators + j = i-N_det_ref + do k=1,N_int + psi_det_generators(k,1,i) = psi_non_ref(k,1,j) + psi_det_generators(k,2,i) = psi_non_ref(k,2,j) + psi_selectors(k,1,i) = psi_non_ref(k,1,j) + psi_selectors(k,2,i) = psi_non_ref(k,2,j) + enddo + do k=1,N_st + psi_coef_generators(i,k) = psi_non_ref_coef(j,k) + psi_selectors_coef(i,k) = psi_non_ref_coef(j,k) + enddo + enddo + + SOFT_TOUCH N_det_selectors psi_selectors_coef psi_selectors N_det_generators psi_det_generators psi_coef_generators ci_eigenvectors_dressed ci_eigenvectors_s2_dressed ci_electronic_energy_dressed + SOFT_TOUCH psi_ref_coef_diagonalized psi_ref_energy_diagonalized + + call H_apply_mrcepa_PT2(pt2, norm_pert, H_pert_diag, N_st) + + + print *, "Redundant PT2 :",pt2_redundant + print *, "Full PT2 :",pt2 + print *, lambda_mrcc_kept(0), N_det, N_det_ref, psi_coef(1,1), psi_ref_coef(1,1) + pt2 = pt2 - pt2_redundant + + print *, 'Final step' + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + print *, 'PT2 = ', pt2 + print *, 'E = ', energy + print *, 'E+PT2 = ', energy+pt2 + print *, '-----' + + + call ezfio_set_mrcepa0_energy_pt2(energy(1)+pt2(1)) + +end + +subroutine run_pt2(N_st,energy) + implicit none + integer :: i,j,k + integer, intent(in) :: N_st + double precision, intent(in) :: energy(N_st) + double precision :: pt2(N_st) + double precision :: norm_pert(N_st),H_pert_diag(N_st) + + pt2 = 0d0 + !if(lambda_mrcc_pt2(0) == 0) return + + print*,'Last iteration only to compute the PT2' + + N_det_generators = N_det_cas + N_det_selectors = N_det_non_ref + + do i=1,N_det_generators + do k=1,N_int + psi_det_generators(k,1,i) = psi_ref(k,1,i) + psi_det_generators(k,2,i) = psi_ref(k,2,i) + enddo + do k=1,N_st + psi_coef_generators(i,k) = psi_ref_coef(i,k) + enddo + enddo + do i=1,N_det + do k=1,N_int + psi_selectors(k,1,i) = psi_det_sorted(k,1,i) + psi_selectors(k,2,i) = psi_det_sorted(k,2,i) + enddo + do k=1,N_st + psi_selectors_coef(i,k) = psi_coef_sorted(i,k) + enddo + enddo + + SOFT_TOUCH N_det_selectors psi_selectors_coef psi_selectors N_det_generators psi_det_generators psi_coef_generators ci_eigenvectors_dressed ci_eigenvectors_s2_dressed ci_electronic_energy_dressed + SOFT_TOUCH psi_ref_coef_diagonalized psi_ref_energy_diagonalized + + call H_apply_mrcepa_PT2(pt2, norm_pert, H_pert_diag, N_st) + +! call ezfio_set_full_ci_energy_pt2(energy+pt2) + + print *, 'Final step' + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + print *, 'PT2 = ', pt2 + print *, 'E = ', energy + print *, 'E+PT2 = ', energy+pt2 + print *, '-----' + + call ezfio_set_mrcepa0_energy_pt2(energy(1)+pt2(1)) + +end + diff --git a/plugins/mrcepa0/mrsc2.irp.f b/plugins/mrcepa0/mrsc2.irp.f new file mode 100644 index 00000000..d0f44a33 --- /dev/null +++ b/plugins/mrcepa0/mrsc2.irp.f @@ -0,0 +1,19 @@ +program mrsc2 + implicit none + double precision, allocatable :: energy(:) + allocate (energy(N_states)) + + !mrmode : 1=mrcepa0, 2=mrsc2 add, 3=mrcc + mrmode = 2 + read_wf = .True. + SOFT_TOUCH read_wf + call print_cas_coefs + call set_generators_bitmasks_as_holes_and_particles + call run(N_states,energy) + if(do_pt2_end)then + call run_pt2(N_states,energy) + endif + deallocate(energy) +end + + diff --git a/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py b/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py index 3298129d..e911af28 100755 --- a/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py +++ b/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py @@ -183,6 +183,9 @@ def get_nb_permutation(str_): def order_l_l_sym(l_l_sym): + + l_order_mo = [i for i,_ in enumerate(l_l_sym)] + n = 1 for i in range(len(l_l_sym)): if n != 1: @@ -192,11 +195,11 @@ def order_l_l_sym(l_l_sym): l = l_l_sym[i] n = get_nb_permutation(l[2]) - l_l_sym[i:i + n] = sorted(l_l_sym[i:i + n], - key=lambda x: x[2], - cmp=compare_gamess_style) + l_l_sym[i:i + n], l_order_mo[i:i+n] = zip(*sorted(zip(l_l_sym[i:i + n],l_order_mo[i:i+n]), + key=lambda x: x[0][2], + cmp=compare_gamess_style)) - return l_l_sym + return l_l_sym, l_order_mo #========================== @@ -205,8 +208,13 @@ def order_l_l_sym(l_l_sym): l_sym_without_header = sym_raw.split("\n")[3:-2] l_l_sym_raw = [i.split() for i in l_sym_without_header] +print len(l_l_sym_raw) + l_l_sym_expend_sym = expend_sym_l(l_l_sym_raw) -l_l_sym_ordered = order_l_l_sym(l_l_sym_expend_sym) +print len(l_l_sym_expend_sym) + +l_l_sym_ordered, l_order_mo = order_l_l_sym(l_l_sym_expend_sym) + #======== #MO COEF @@ -348,6 +356,7 @@ d_rep={"+":"1","-":"0"} det_without_header = det_raw[pos+2::] + for line_raw in det_without_header.split("\n"): line = line_raw @@ -355,8 +364,14 @@ for line_raw in det_without_header.split("\n"): try: float(line) except ValueError: + + print line_raw.strip(), len(line_raw.strip()) + print l_order_mo, len(l_order_mo) + + line_order = [line_raw[i] for i in l_order_mo] 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/scripts/compilation/qp_create_ninja.py b/scripts/compilation/qp_create_ninja.py index d089e76b..b495019a 100755 --- a/scripts/compilation/qp_create_ninja.py +++ b/scripts/compilation/qp_create_ninja.py @@ -37,7 +37,7 @@ from qp_path import QP_ROOT, QP_SRC, QP_EZFIO LIB = "" # join(QP_ROOT, "lib", "rdtsc.o") EZFIO_LIB = join(QP_ROOT, "lib", "libezfio_irp.a") -ZMQ_LIB = join(QP_ROOT, "lib", "libf77zmq.a") + " " + join(QP_ROOT, "lib", "libzmq.a") + " -lstdc++ -lrt" +ZMQ_LIB = join(QP_ROOT, "lib", "libf77zmq.a") + " " + join(QP_ROOT, "lib", "libzmq.a") + " -lstdc++ -lrt" ROOT_BUILD_NINJA = join(QP_ROOT, "config", "build.ninja") header = r"""# @@ -96,7 +96,8 @@ def ninja_create_env_variable(pwd_config_file): l_string.append(str_) lib_lapack = get_compilation_option(pwd_config_file, "LAPACK_LIB") - l_string.append("LIB = {0} {1} {2} {3}".format(LIB, lib_lapack, EZFIO_LIB, ZMQ_LIB)) + str_lib = " ".join([LIB, lib_lapack, EZFIO_LIB, ZMQ_LIB]) + l_string.append("LIB = {0} ".format(str_lib)) l_string.append("") @@ -184,7 +185,7 @@ def ninja_ezfio_config_rule(): def get_children_of_ezfio_cfg(l_module_with_ezfio_cfg): """ - From a module list of ezfio_cfg return all the stuff create by him + From a module list of ezfio_cfg return all the stuff created by it """ config_folder = join(QP_EZFIO, "config") @@ -387,6 +388,8 @@ def get_l_file_for_module(path_module): l_src.append(f) obj = '{0}.o'.format(os.path.splitext(f)[0]) l_obj.append(obj) + elif f.lower().endswith(".o"): + l_obj.append(join(path_module.abs, f)) elif f == "EZFIO.cfg": l_depend.append(join(path_module.abs, "ezfio_interface.irp.f")) @@ -785,10 +788,18 @@ def create_build_ninja_global(): " command = module_handler.py clean --all", " description = Cleaning all modules", ""] + l_string += ["rule make_ocaml", + " command = make -C {0}/ocaml".format(QP_ROOT), + " pool = console", + " description = Compiling OCaml tools", + ""] + + l_string += ["build dummy_target: update_build_ninja_root", + "build ocaml_target: make_ocaml all", "", "build all: make_all dummy_target", - "default all", + "default ocaml_target", "", "build clean: make_clean dummy_target", "", ] diff --git a/scripts/ezfio_interface/ei_handler.py b/scripts/ezfio_interface/ei_handler.py index a3f3600b..ef15c9b8 100755 --- a/scripts/ezfio_interface/ei_handler.py +++ b/scripts/ezfio_interface/ei_handler.py @@ -45,7 +45,7 @@ Optional: (by default is one) Example : 1, =sum(ao_num); (ao_num,3) ATTENTION : The module and the value are separed by a "." not a "_". - For exemple (determinants.n_det) + For example (determinants.n_det) ezfio_name: The name for the EZFIO lib (by default is ) ezfio_dir: Will be the folder of EZFIO. @@ -345,7 +345,7 @@ def save_ezfio_provider(path_head, dict_code_provider): path = "{0}/ezfio_interface.irp.f".format(path_head) l_output = ["! DO NOT MODIFY BY HAND", - "! Created by $QP_ROOT/scripts/ezfio_interface.py", + "! Created by $QP_ROOT/scripts/ezfio_interface/ei_handler.py", "! from file {0}/EZFIO.cfg".format(path_head), "\n"] diff --git a/scripts/ezfio_interface/ezfio_generate_provider.py b/scripts/ezfio_interface/ezfio_generate_provider.py index 6cd919dc..89fdfa03 100755 --- a/scripts/ezfio_interface/ezfio_generate_provider.py +++ b/scripts/ezfio_interface/ezfio_generate_provider.py @@ -22,6 +22,7 @@ BEGIN_PROVIDER [ %(type)s, %(name)s %(size)s ] logical :: has PROVIDE ezfio_filename + %(test_null_size)s call ezfio_has_%(ezfio_dir)s_%(ezfio_name)s(has) if (has) then call ezfio_get_%(ezfio_dir)s_%(ezfio_name)s(%(name)s) @@ -44,6 +45,7 @@ END_PROVIDER def __repr__(self): self.set_write() + self.set_test_null_size() for v in self.values: if not v: msg = "Error : %s is not set in EZFIO.cfg" % (v) @@ -54,20 +56,31 @@ END_PROVIDER return self.data % self.__dict__ + def set_test_null_size(self): + if "size" not in self.__dict__: + self.__dict__["size"] = "" + if self.size != "": + self.test_null_size = "if (size(%s) == 0) return\n" % ( self.name ) + else: + self.test_null_size = "" + def set_write(self): self.write = "" - if self.type in self.write_correspondance: - write = self.write_correspondance[self.type] - output = self.output - name = self.name + if "size" in self.__dict__: + return + else: + if self.type in self.write_correspondance: + write = self.write_correspondance[self.type] + output = self.output + name = self.name - l_write = ["", - " call write_time(%(output)s)", - " call %(write)s(%(output)s, %(name)s, &", - " '%(name)s')", - ""] + l_write = ["", + " call write_time(%(output)s)", + " call %(write)s(%(output)s, %(name)s, &", + " '%(name)s')", + ""] - self.write = "\n".join(l_write) % locals() + self.write = "\n".join(l_write) % locals() def set_type(self, t): self.type = t.lower() diff --git a/scripts/ezfio_interface/qp_edit_template b/scripts/ezfio_interface/qp_edit_template index 408ca3f7..9c7a1386 100644 --- a/scripts/ezfio_interface/qp_edit_template +++ b/scripts/ezfio_interface/qp_edit_template @@ -6,7 +6,7 @@ open Core.Std;; WARNING This file is autogenerad by -`${{QP_ROOT}}/script/ezfio_interface/ei_handler.py` +`${{QP_ROOT}}/scripts/ezfio_interface/ei_handler.py` *) @@ -120,7 +120,7 @@ let set str s = | Nuclei -> write Nuclei.(of_rst, write) s | Ao_basis -> () (* TODO *) | Mo_basis -> () (* TODO *) - end + end ;; @@ -169,7 +169,9 @@ let run check_only ezfio_filename = in (* Create the temp file *) - let temp_filename = create_temp_file ezfio_filename tasks in + let temp_filename = + create_temp_file ezfio_filename tasks + in (* Open the temp file with external editor *) let editor = @@ -193,7 +195,7 @@ let run check_only ezfio_filename = List.iter ~f:(fun x -> set temp_string x) tasks; (* Remove temp_file *) - Sys.remove temp_filename; + Sys.remove temp_filename ;; diff --git a/scripts/generate_h_apply.py b/scripts/generate_h_apply.py index 149c03b1..cfb1d6bf 100755 --- a/scripts/generate_h_apply.py +++ b/scripts/generate_h_apply.py @@ -80,6 +80,7 @@ class H_apply(object): s["params_post"] = "" self.selection_pt2 = None + self.energy = "CI_electronic_energy" self.perturbation = None self.do_double_exc = do_double_exc #s["omp_parallel"] = """!$OMP PARALLEL DEFAULT(NONE) & @@ -331,13 +332,13 @@ class H_apply(object): """ self.data["deinit_thread"] = """ - !$ call omp_set_lock(lck) + ! OMP CRITICAL do k=1,N_st sum_e_2_pert_in(k) = sum_e_2_pert_in(k) + sum_e_2_pert(k) sum_norm_pert_in(k) = sum_norm_pert_in(k) + sum_norm_pert(k) sum_H_pert_diag_in(k) = sum_H_pert_diag_in(k) + sum_H_pert_diag(k) enddo - !$ call omp_unset_lock(lck) + ! OMP END CRITICAL deallocate (e_2_pert_buffer, coef_pert_buffer) """ self.data["size_max"] = "8192" @@ -348,13 +349,13 @@ class H_apply(object): 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) + sum_norm_pert,sum_H_pert_diag,N_st,N_int,key_mask,fock_diag_tmp,%s) + """%(pert,self.energy) 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) + sum_norm_pert,sum_H_pert_diag,N_st,N_int,key_mask,fock_diag_tmp,%s) + """%(pert,self.energy) self.data["finalization"] = """ @@ -439,12 +440,12 @@ class H_apply(object): self.data["skip"] = """ if (i_generator < size_select_max) then if (select_max(i_generator) < selection_criterion_min*selection_criterion_factor) then - !$ call omp_set_lock(lck) + ! OMP CRITICAL do k=1,N_st norm_psi(k) = norm_psi(k) + psi_coef_generators(i_generator,k)*psi_coef_generators(i_generator,k) pt2_old(k) = 0.d0 enddo - !$ call omp_unset_lock(lck) + ! OMP END CRITICAL cycle endif select_max(i_generator) = 0.d0 @@ -483,8 +484,18 @@ class H_apply_zmq(H_apply): norm_pert(k) = 0.d0 H_pert_diag(k) = 0.d0 norm_psi(k) = 0.d0 + energy(k) = %s(k) enddo - """ + """ % (self.energy) + self.data["copy_buffer"] = """ + do i=1,N_det_generators + do k=1,N_st + pt2(k) = pt2(k) + pt2_generators(k,i) + norm_pert(k) = norm_pert(k) + norm_pert_generators(k,i) + H_pert_diag(k) = H_pert_diag(k) + H_pert_diag_generators(k,i) + enddo + enddo + """ def set_selection_pt2(self,pert): H_apply.set_selection_pt2(self,pert) @@ -499,3 +510,4 @@ class H_apply_zmq(H_apply): select_max(i_generator) = 0.d0 endif """ + diff --git a/scripts/module/create_executables_list.sh b/scripts/module/create_executables_list.sh index 66e9ef2d..8299a505 100755 --- a/scripts/module/create_executables_list.sh +++ b/scripts/module/create_executables_list.sh @@ -11,7 +11,7 @@ fi cd ${QP_ROOT}/data rm -f executables -EXES=$(find -L ${QP_ROOT}/src -executable -type f | grep -e "${QP_ROOT}/src/[^/]*/[^/]*$" |sort ) +EXES=$(find -L ${QP_ROOT}/src -maxdepth 2 -depth -executable -type f | grep -e "${QP_ROOT}/src/[^/]*/[^/]*$" |sort ) for EXE in $EXES do diff --git a/scripts/module/qp_module.py b/scripts/module/qp_module.py index 06ad5dd2..adeb3a46 100755 --- a/scripts/module/qp_module.py +++ b/scripts/module/qp_module.py @@ -213,7 +213,7 @@ def main(arguments): print "[ OK ]" print "" print "You can now compile as usual" - print "`cd {0} ; ninja` for exemple".format(QP_ROOT) + print "`cd {0} ; ninja` for example".format(QP_ROOT) print " or --in developement mode-- you can cd in a directory and compile here" elif arguments["uninstall"]: diff --git a/scripts/qp_set_frozen_core.py b/scripts/qp_set_frozen_core.py index 3f95a9e6..2bfd89e5 100755 --- a/scripts/qp_set_frozen_core.py +++ b/scripts/qp_set_frozen_core.py @@ -19,9 +19,13 @@ for charge in ezfio.nuclei_nucl_charge: mo_tot_num = ezfio.mo_basis_mo_tot_num +if len(sys.argv)>2: + if sys.argv[2] == '-q': + print nb + sys.exit(0) + if nb == 0: os.system( """qp_set_mo_class -act "[1-%d]" %s"""%(mo_tot_num, sys.argv[1]) ) else: os.system( """qp_set_mo_class -core "[1-%d]" -act "[%d-%d]" %s"""%(nb, nb+1, mo_tot_num, sys.argv[1]) ) - diff --git a/src/AO_Basis/EZFIO.cfg b/src/AO_Basis/EZFIO.cfg index 34bf2879..9e548514 100644 --- a/src/AO_Basis/EZFIO.cfg +++ b/src/AO_Basis/EZFIO.cfg @@ -54,3 +54,25 @@ type: logical doc: If true, use AOs in Cartesian coordinates (6d,10f,...) interface: ezfio, provider default: false + +[integral_overlap] +type: double precision +doc: Overlap integrals in AO basis set +size: (ao_basis.ao_num,ao_basis.ao_num) +interface: ezfio +default: false + +[integral_nuclear] +type: double precision +doc: Nucleus-electron integrals in AO basis set +size: (ao_basis.ao_num,ao_basis.ao_num) +interface: ezfio +default: false + +[integral_kinetic] +type: double precision +doc: Kinetic energy integrals in AO basis set +size: (ao_basis.ao_num,ao_basis.ao_num) +interface: ezfio +default: false + diff --git a/src/AO_Basis/README.rst b/src/AO_Basis/README.rst index 0596085c..ae9acdf0 100644 --- a/src/AO_Basis/README.rst +++ b/src/AO_Basis/README.rst @@ -56,56 +56,72 @@ Documentation .. by the `update_README.py` script. -`ao_coef `_ - AO Coefficients, read from input. Those should not be used directly, as the MOs are expressed on the basis of **normalized** AOs. +`ao_cartesian `_ + If true, use AOs in Cartesian coordinates (6d,10f,...) + + +`ao_coef `_ + Primitive coefficients, read from input. Those should not be used directly, as the MOs are expressed on the basis of **normalized** AOs. + + +`ao_coef_normalization_factor `_ + Coefficients including the AO normalization + + +`ao_coef_normalization_libint_factor `_ + Coefficients including the AO normalization `ao_coef_normalized `_ Coefficients including the AO normalization -`ao_coef_normalized_ordered `_ +`ao_coef_normalized_ordered `_ Sorted primitives to accelerate 4 index MO transformation -`ao_coef_normalized_ordered_transp `_ +`ao_coef_normalized_ordered_transp `_ Transposed ao_coef_normalized_ordered -`ao_expo `_ - expo for each primitive of each ao_basis +`ao_expo `_ + Exponents for each primitive of each AO -`ao_expo_ordered `_ +`ao_expo_ordered `_ Sorted primitives to accelerate 4 index MO transformation -`ao_expo_ordered_transp `_ +`ao_expo_ordered_transp `_ Transposed ao_expo_ordered -`ao_l `_ +`ao_l `_ ao_l = l value of the AO: a+b+c in x^a y^b z^c -`ao_l_char `_ +`ao_l_char `_ ao_l = l value of the AO: a+b+c in x^a y^b z^c -`ao_l_char_space `_ +`ao_l_char_space `_ Undocumented +`ao_l_max `_ + ao_l = l value of the AO: a+b+c in x^a y^b z^c + + `ao_md5 `_ - MD5 key characteristic of the AO basis + MD5 key, specific of the AO basis -`ao_nucl `_ - Index of the nuclei on which the ao is centered +`ao_nucl `_ + Index of the nucleus on which the AO is centered -`ao_num `_ - number of ao +`ao_num `_ + number of AOs `ao_num_align `_ @@ -137,11 +153,17 @@ Documentation :math:`\int \chi_i(r) \chi_j(r) dr)` -`ao_power `_ - power for each dimension for each ao_basis +`ao_power `_ + Powers of x, y and z for each AO -`ao_prim_num `_ +`ao_power_index `_ + Unique index given to a triplet of powers: + .br + 1/2 (l-n_x)*(l-n_x+1) + n_z + 1 + + +`ao_prim_num `_ Number of primitives per atomic orbital @@ -149,15 +171,63 @@ Documentation Undocumented -`ao_prim_num_max_align `_ +`ao_prim_num_max_align `_ Number of primitives per atomic orbital aligned -`l_to_charater `_ +`ao_value `_ + return the value of the ith ao at point r + + +`cart_to_sphe_0 `_ + Spherical -> Cartesian Transformation matrix for l=0 + + +`cart_to_sphe_1 `_ + Spherical -> Cartesian Transformation matrix for l=1 + + +`cart_to_sphe_2 `_ + Spherical -> Cartesian Transformation matrix for l=2 + + +`cart_to_sphe_3 `_ + Spherical -> Cartesian Transformation matrix for l=3 + + +`cart_to_sphe_4 `_ + Spherical -> Cartesian Transformation matrix for l=4 + + +`cart_to_sphe_5 `_ + Spherical -> Cartesian Transformation matrix for l=5 + + +`cart_to_sphe_6 `_ + Spherical -> Cartesian Transformation matrix for l=6 + + +`cart_to_sphe_7 `_ + Spherical -> Cartesian Transformation matrix for l=7 + + +`cart_to_sphe_8 `_ + Spherical -> Cartesian Transformation matrix for l=8 + + +`cart_to_sphe_9 `_ + Spherical -> Cartesian Transformation matrix for l=9 + + +`give_all_aos_at_r `_ + gives the values of aos at a given point r + + +`l_to_charater `_ character corresponding to the "L" value of an AO orbital -`n_aos_max `_ +`n_aos_max `_ Number of AOs per atom @@ -169,21 +239,21 @@ Documentation Undocumented -`nucl_aos `_ +`nucl_aos `_ List of AOs attached on each atom -`nucl_list_shell_aos `_ +`nucl_list_shell_aos `_ Index of the shell type Aos and of the corresponding Aos Per convention, for P,D,F and G AOs, we take the index of the AO with the the corresponding power in the "X" axis -`nucl_n_aos `_ +`nucl_n_aos `_ Number of AOs per atom -`nucl_num_shell_aos `_ +`nucl_num_shell_aos `_ Index of the shell type Aos and of the corresponding Aos Per convention, for P,D,F and G AOs, we take the index of the AO with the the corresponding power in the "X" axis diff --git a/src/AO_Basis/ao_overlap.irp.f b/src/AO_Basis/ao_overlap.irp.f index 4487ff77..edf48b25 100644 --- a/src/AO_Basis/ao_overlap.irp.f +++ b/src/AO_Basis/ao_overlap.irp.f @@ -14,51 +14,60 @@ double precision :: alpha, beta, c double precision :: A_center(3), B_center(3) integer :: power_A(3), power_B(3) - dim1=100 - !$OMP PARALLEL DO SCHEDULE(GUIDED) & - !$OMP DEFAULT(NONE) & - !$OMP PRIVATE(A_center,B_center,power_A,power_B,& - !$OMP overlap_x,overlap_y, overlap_z, overlap, & - !$OMP alpha, beta,i,j,c) & - !$OMP SHARED(nucl_coord,ao_power,ao_prim_num, & - !$OMP ao_overlap_x,ao_overlap_y,ao_overlap_z,ao_overlap,ao_num,ao_coef_normalized_ordered_transp,ao_nucl, & - !$OMP ao_expo_ordered_transp,dim1) - do j=1,ao_num - A_center(1) = nucl_coord( ao_nucl(j), 1 ) - A_center(2) = nucl_coord( ao_nucl(j), 2 ) - A_center(3) = nucl_coord( ao_nucl(j), 3 ) - power_A(1) = ao_power( j, 1 ) - power_A(2) = ao_power( j, 2 ) - power_A(3) = ao_power( j, 3 ) - !DEC$ VECTOR ALIGNED - !DEC$ VECTOR ALWAYS - do i= 1,ao_num - ao_overlap(i,j)= 0.d0 - ao_overlap_x(i,j)= 0.d0 - ao_overlap_y(i,j)= 0.d0 - ao_overlap_z(i,j)= 0.d0 - B_center(1) = nucl_coord( ao_nucl(i), 1 ) - B_center(2) = nucl_coord( ao_nucl(i), 2 ) - B_center(3) = nucl_coord( ao_nucl(i), 3 ) - power_B(1) = ao_power( i, 1 ) - power_B(2) = ao_power( i, 2 ) - power_B(3) = ao_power( i, 3 ) - do n = 1,ao_prim_num(j) - alpha = ao_expo_ordered_transp(n,j) - !DEC$ VECTOR ALIGNED - do l = 1, ao_prim_num(i) - beta = ao_expo_ordered_transp(l,i) - call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x,overlap_y,overlap_z,overlap,dim1) - c = ao_coef_normalized_ordered_transp(n,j) * ao_coef_normalized_ordered_transp(l,i) - ao_overlap(i,j) += c * overlap - ao_overlap_x(i,j) += c * overlap_x - ao_overlap_y(i,j) += c * overlap_y - ao_overlap_z(i,j) += c * overlap_z - enddo +! if (read_ao_one_integrals) then +! call ezfio_get_ao_basis_integral_overlap(ao_overlap(1:ao_num, 1:ao_num)) +! print *, 'AO overlap integrals read from disk' +! else + dim1=100 + !$OMP PARALLEL DO SCHEDULE(GUIDED) & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(A_center,B_center,power_A,power_B,& + !$OMP overlap_x,overlap_y, overlap_z, overlap, & + !$OMP alpha, beta,i,j,c) & + !$OMP SHARED(nucl_coord,ao_power,ao_prim_num, & + !$OMP ao_overlap_x,ao_overlap_y,ao_overlap_z,ao_overlap,ao_num,ao_coef_normalized_ordered_transp,ao_nucl, & + !$OMP ao_expo_ordered_transp,dim1) + do j=1,ao_num + A_center(1) = nucl_coord( ao_nucl(j), 1 ) + A_center(2) = nucl_coord( ao_nucl(j), 2 ) + A_center(3) = nucl_coord( ao_nucl(j), 3 ) + power_A(1) = ao_power( j, 1 ) + power_A(2) = ao_power( j, 2 ) + power_A(3) = ao_power( j, 3 ) + !DEC$ VECTOR ALIGNED + !DEC$ VECTOR ALWAYS + do i= 1,ao_num + ao_overlap(i,j)= 0.d0 + ao_overlap_x(i,j)= 0.d0 + ao_overlap_y(i,j)= 0.d0 + ao_overlap_z(i,j)= 0.d0 + B_center(1) = nucl_coord( ao_nucl(i), 1 ) + B_center(2) = nucl_coord( ao_nucl(i), 2 ) + B_center(3) = nucl_coord( ao_nucl(i), 3 ) + power_B(1) = ao_power( i, 1 ) + power_B(2) = ao_power( i, 2 ) + power_B(3) = ao_power( i, 3 ) + do n = 1,ao_prim_num(j) + alpha = ao_expo_ordered_transp(n,j) + !DEC$ VECTOR ALIGNED + do l = 1, ao_prim_num(i) + beta = ao_expo_ordered_transp(l,i) + call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x,overlap_y,overlap_z,overlap,dim1) + c = ao_coef_normalized_ordered_transp(n,j) * ao_coef_normalized_ordered_transp(l,i) + ao_overlap(i,j) += c * overlap + ao_overlap_x(i,j) += c * overlap_x + ao_overlap_y(i,j) += c * overlap_y + ao_overlap_z(i,j) += c * overlap_z + enddo + enddo enddo - enddo - enddo - !$OMP END PARALLEL DO + enddo + !$OMP END PARALLEL DO +! endif +! if (write_ao_one_integrals) then +! call ezfio_set_ao_basis_integral_overlap(ao_overlap(1:ao_num, 1:ao_num)) +! print *, 'AO overlap integrals written to disk' +! endif END_PROVIDER diff --git a/src/AO_Basis/aos.irp.f b/src/AO_Basis/aos.irp.f index 9ccbb981..0938d3bd 100644 --- a/src/AO_Basis/aos.irp.f +++ b/src/AO_Basis/aos.irp.f @@ -25,7 +25,7 @@ END_PROVIDER BEGIN_DOC ! Coefficients including the AO normalization END_DOC - double precision :: norm, norm2,overlap_x,overlap_y,overlap_z,C_A(3), c + double precision :: norm,overlap_x,overlap_y,overlap_z,C_A(3), c integer :: l, powA(3), nz integer :: i,j,k nz=100 @@ -34,9 +34,11 @@ END_PROVIDER C_A(3) = 0.d0 ao_coef_normalized = 0.d0 do i=1,ao_num + powA(1) = ao_power(i,1) powA(2) = ao_power(i,2) powA(3) = ao_power(i,3) + do j=1,ao_prim_num(i) call overlap_gaussian_xyz(C_A,C_A,ao_expo(i,j),ao_expo(i,j),powA,powA,overlap_x,overlap_y,overlap_z,norm,nz) ao_coef_normalized(i,j) = ao_coef(i,j)/sqrt(norm) @@ -51,8 +53,42 @@ END_PROVIDER enddo ao_coef_normalization_factor(i) = 1.d0/sqrt(norm) enddo + END_PROVIDER +BEGIN_PROVIDER [ double precision, ao_coef_normalization_libint_factor, (ao_num) ] + implicit none + BEGIN_DOC + ! Coefficients including the AO normalization + END_DOC + double precision :: norm,overlap_x,overlap_y,overlap_z,C_A(3), c + integer :: l, powA(3), nz + integer :: i,j,k + nz=100 + C_A(1) = 0.d0 + C_A(2) = 0.d0 + C_A(3) = 0.d0 + + do i=1,ao_num + powA(1) = ao_l(i) + powA(2) = 0 + powA(3) = 0 + + ! Normalization of the contracted basis functions + norm = 0.d0 + do j=1,ao_prim_num(i) + do k=1,ao_prim_num(i) + call overlap_gaussian_xyz(C_A,C_A,ao_expo(i,j),ao_expo(i,k),powA,powA,overlap_x,overlap_y,overlap_z,c,nz) + norm = norm+c*ao_coef_normalized(i,j)*ao_coef_normalized(i,k) + enddo + enddo + ao_coef_normalization_libint_factor(i) = ao_coef_normalization_factor(i) * sqrt(norm) + + enddo + +END_PROVIDER + + BEGIN_PROVIDER [ double precision, ao_coef_normalized_ordered, (ao_num_align,ao_prim_num_max) ] &BEGIN_PROVIDER [ double precision, ao_expo_ordered, (ao_num_align,ao_prim_num_max) ] implicit none diff --git a/src/Bitmask/README.rst b/src/Bitmask/README.rst index 697ef620..fbf13d22 100644 --- a/src/Bitmask/README.rst +++ b/src/Bitmask/README.rst @@ -72,16 +72,16 @@ Documentation Transform a bit string to a string for printing -`cas_bitmask `_ +`cas_bitmask `_ Bitmasks for CAS reference determinants. (N_int, alpha/beta, CAS reference) -`cis_ijkl_bitmask `_ - Bitmask to include all possible single excitations from Hartree-Fock +`closed_shell_ref_bitmask `_ + Undocumented -`core_bitmask `_ - Reunion of the inactive, active and virtual bitmasks +`core_bitmask `_ + Core orbitals bitmask `debug_det `_ @@ -98,7 +98,11 @@ Documentation Bitmask to include all possible MOs -`generators_bitmask `_ +`full_ijkl_bitmask_4 `_ + Undocumented + + +`generators_bitmask `_ Bitmasks for generator determinants. (N_int, alpha/beta, hole/particle, generator). .br @@ -118,7 +122,7 @@ Documentation .br -`generators_bitmask_restart `_ +`generators_bitmask_restart `_ Bitmasks for generator determinants. (N_int, alpha/beta, hole/particle, generator). .br @@ -138,64 +142,160 @@ Documentation .br -`hf_bitmask `_ +`hf_bitmask `_ Hartree Fock bit mask -`i_bitmask_gen `_ +`i_bitmask_gen `_ Current bitmask for the generators -`inact_bitmask `_ - Bitmasks for the inactive orbitals that are excited in post CAS method +`inact_bitmask `_ + 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 -`inact_virt_bitmask `_ +`inact_virt_bitmask `_ Reunion of the inactive and virtual bitmasks +`index_holes_bitmask `_ + Index of the holes in the generators_bitmasks + + +`index_particl_bitmask `_ + Index of the holes in the generators_bitmasks + + +`initialize_bitmask_to_restart_ones `_ + Initialization of the generators_bitmask to the restart bitmask + + +`is_a_1h `_ + Undocumented + + +`is_a_1h1p `_ + Undocumented + + +`is_a_1h2p `_ + Undocumented + + +`is_a_1p `_ + Undocumented + + +`is_a_2p `_ + Undocumented + + `is_a_two_holes_two_particles `_ Undocumented -`list_inact `_ +`is_the_hole_in_det `_ Undocumented +`is_the_particl_in_det `_ + Undocumented + + +`list_act `_ + list of active orbitals + + +`list_core `_ + List of the core orbitals that are never excited in post CAS method + + +`list_inact `_ + 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 + + `list_to_bitstring `_ Returns the physical string "string(N_int,2)" from the array of occupations "list(N_int*bit_kind_size,2) -`list_virt `_ - Undocumented +`list_virt `_ + 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 -`n_cas_bitmask `_ +`modify_bitmasks_for_hole `_ + modify the generators_bitmask in order that one can only excite + the electrons occupying i_hole + + +`modify_bitmasks_for_hole_in_out `_ + modify the generators_bitmask in order that one can only excite + the electrons occupying i_hole + + +`modify_bitmasks_for_particl `_ + modify the generators_bitmask in order that one can only excite + the electrons to the orbital i_part + + +`n_act_orb `_ + number of active orbitals + + +`n_cas_bitmask `_ Number of bitmasks for CAS -`n_generators_bitmask `_ +`n_core_orb `_ + Core orbitals bitmask + + +`n_generators_bitmask `_ Number of bitmasks for generators -`n_inact_orb `_ - Bitmasks for the inactive orbitals that are excited in post CAS method +`n_generators_bitmask_restart `_ + Number of bitmasks for generators + + +`n_inact_orb `_ + 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 `n_int `_ Number of 64-bit integers needed to represent determinants as binary strings -`n_virt_orb `_ - Bitmasks for the inactive orbitals that are excited in post CAS method +`n_virt_orb `_ + 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 `number_of_holes `_ Undocumented -`number_of_holes_verbose `_ +`number_of_holes_verbose `_ Undocumented @@ -203,7 +303,7 @@ Documentation Undocumented -`number_of_particles_verbose `_ +`number_of_particles_verbose `_ Undocumented @@ -211,22 +311,61 @@ Documentation Subroutine to print the content of a determinant using the '+-' notation +`print_generators_bitmasks_holes `_ + Undocumented + + +`print_generators_bitmasks_holes_for_one_generator `_ + Undocumented + + +`print_generators_bitmasks_particles `_ + Undocumented + + +`print_generators_bitmasks_particles_for_one_generator `_ + Undocumented + + `print_spindet `_ Subroutine to print the content of a determinant using the '+-' notation -`ref_bitmask `_ +`ref_bitmask `_ Reference bit mask, used in Slater rules, chosen as Hartree-Fock bitmask -`reunion_of_bitmask `_ +`reunion_of_bitmask `_ Reunion of the inactive, active and virtual bitmasks -`unpaired_alpha_electrons `_ +`reunion_of_cas_inact_bitmask `_ + Reunion of the inactive, active and virtual bitmasks + + +`reunion_of_core_inact_bitmask `_ + Reunion of the inactive, active and virtual bitmasks + + +`set_bitmask_hole_as_input `_ + set the generators_bitmask for the holes + as the input_bimask + + +`set_bitmask_particl_as_input `_ + set the generators_bitmask for the particles + as the input_bimask + + +`unpaired_alpha_electrons `_ Bitmask reprenting the unpaired alpha electrons in the HF_bitmask -`virt_bitmask `_ - Bitmasks for the inactive orbitals that are excited in post CAS method +`virt_bitmask `_ + 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 diff --git a/src/Davidson/EZFIO.cfg b/src/Davidson/EZFIO.cfg new file mode 100644 index 00000000..415e359e --- /dev/null +++ b/src/Davidson/EZFIO.cfg @@ -0,0 +1,12 @@ +[threshold_davidson] +type: Threshold +doc: Thresholds of Davidson's algorithm +interface: ezfio,provider,ocaml +default: 1.e-12 + +[n_states_diag] +type: States_number +doc: n_states_diag +default: 10 +interface: ezfio,provider,ocaml + diff --git a/src/Davidson/NEEDED_CHILDREN_MODULES b/src/Davidson/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..aae89501 --- /dev/null +++ b/src/Davidson/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Determinants diff --git a/src/Davidson/davidson_parallel.irp.f b/src/Davidson/davidson_parallel.irp.f new file mode 100644 index 00000000..cede52c9 --- /dev/null +++ b/src/Davidson/davidson_parallel.irp.f @@ -0,0 +1,576 @@ + +!brought to you by garniroy inc. + +use bitmasks +use f77_zmq + +subroutine davidson_process(blockb, blockb2, N, idx, vt, st, bs, istep) + + implicit none + + + integer , intent(in) :: blockb, bs, blockb2, istep + integer , intent(inout) :: N + integer , intent(inout) :: idx(bs) + double precision , intent(inout) :: vt(N_states_diag, bs) + double precision , intent(inout) :: st(N_states_diag, bs) + + integer :: i,ii, j, sh, sh2, exa, ext, org_i, org_j, istate, ni, endi + integer(bit_kind) :: sorted_i(N_int) + double precision :: s2, hij + logical, allocatable :: wrotten(:) + + allocate(wrotten(bs)) + wrotten = .false. + PROVIDE dav_det + + ii=0 + sh = blockb + do sh2=1,shortcut_(0,1) + exa = 0 + do ni=1,N_int + exa = exa + popcnt(xor(version_(ni,sh,1), version_(ni,sh2,1))) + end do + if(exa > 2) cycle + + do i=blockb2+shortcut_(sh,1),shortcut_(sh+1,1)-1, istep + ii = i - shortcut_(blockb,1) + 1 + + org_i = sort_idx_(i,1) + do ni=1,N_int + sorted_i(ni) = sorted_(ni,i,1) + enddo + + do j=shortcut_(sh2,1), shortcut_(sh2+1,1)-1 + if(i == j) cycle + org_j = sort_idx_(j,1) + ext = exa + do ni=1,N_int + ext = ext + popcnt(xor(sorted_i(ni), sorted_(ni,j,1))) + end do + if(ext <= 4) then + call get_s2(dav_det(1,1,org_j),dav_det(1,1,org_i),n_int,s2) + call i_h_j (dav_det(1,1,org_j),dav_det(1,1,org_i),n_int,hij) + if(.not. wrotten(ii)) then + wrotten(ii) = .true. + idx(ii) = org_i + vt (:,ii) = 0d0 + st (:,ii) = 0d0 + end if + do istate=1,N_states_diag + vt (istate,ii) += hij*dav_ut(istate,org_j) + st (istate,ii) += s2*dav_ut(istate,org_j) + enddo + endif + enddo + enddo + enddo + + + if (blockb <= shortcut_(0,2)) then + sh=blockb + do sh2=sh, shortcut_(0,2), shortcut_(0,1) + do i=blockb2+shortcut_(sh2,2),shortcut_(sh2+1,2)-1, istep + ii += 1 + org_i = sort_idx_(i,2) + do j=shortcut_(sh2,2),shortcut_(sh2+1,2)-1 + if(i == j) cycle + org_j = sort_idx_(j,2) + ext = 0 + do ni=1,N_int + ext = ext + popcnt(xor(sorted_(ni,i,2), sorted_(ni,j,2))) + end do + if(ext == 4) then + call i_h_j (dav_det(1,1,org_j),dav_det(1,1,org_i),n_int,hij) + call get_s2(dav_det(1,1,org_j),dav_det(1,1,org_i),n_int,s2) + if(.not. wrotten(ii)) then + wrotten(ii) = .true. + idx(ii) = org_i + vt (:,ii) = 0d0 + st (:,ii) = 0d0 + end if + do istate=1,N_states_diag + vt (istate,ii) += hij*dav_ut(istate,org_j) + st (istate,ii) += s2*dav_ut(istate,org_j) + enddo + end if + end do + end do + enddo + endif + + N=0 + do i=1,bs + if(wrotten(i)) then + N += 1 + idx(N) = idx(i) + vt(:,N) = vt(:,i) + st(:,N) = st(:,i) + end if + end do + + +end subroutine + + + + +subroutine davidson_collect(N, idx, vt, st , v0t, s0t) + implicit none + + + integer , intent(in) :: N + integer , intent(in) :: idx(N) + double precision , intent(in) :: vt(N_states_diag, N) + double precision , intent(in) :: st(N_states_diag, N) + double precision , intent(inout) :: v0t(N_states_diag,dav_size) + double precision , intent(inout) :: s0t(N_states_diag,dav_size) + + integer :: i, j, k + + !DIR$ IVDEP + do i=1,N + k = idx(i) + !DIR$ IVDEP + do j=1,N_states_diag + v0t(j,k) = v0t(j,k) + vt(j,i) + s0t(j,k) = s0t(j,k) + st(j,i) + enddo + end do +end subroutine + + +subroutine davidson_init(zmq_to_qp_run_socket,n,n_st_8,ut) + use f77_zmq + implicit none + + integer(ZMQ_PTR), intent(out) :: zmq_to_qp_run_socket + integer, intent(in) :: n, n_st_8 + double precision, intent(in) :: ut(n_st_8,n) + integer :: i,k + + + dav_size = n + touch dav_size + + do i=1,n + do k=1,N_int + dav_det(k,1,i) = psi_det(k,1,i) + dav_det(k,2,i) = psi_det(k,2,i) + enddo + enddo + do i=1,n + do k=1,N_states_diag + dav_ut(k,i) = ut(k,i) + enddo + enddo + + touch dav_det dav_ut + + call new_parallel_job(zmq_to_qp_run_socket,"davidson") +end subroutine + + + +subroutine davidson_add_task(zmq_to_qp_run_socket, blockb, blockb2, istep) + use f77_zmq + implicit none + + integer(ZMQ_PTR) ,intent(in) :: zmq_to_qp_run_socket + integer ,intent(in) :: blockb, blockb2, istep + character*(512) :: task + + + write(task,*) blockb, blockb2, istep + call add_task_to_taskserver(zmq_to_qp_run_socket, task) +end subroutine + + + +subroutine davidson_slave_inproc(i) + implicit none + integer, intent(in) :: i + + call davidson_run_slave(1,i) +end + + +subroutine davidson_slave_tcp(i) + implicit none + integer, intent(in) :: i + + call davidson_run_slave(0,i) +end + + + +subroutine davidson_run_slave(thread,iproc) + use f77_zmq + implicit none + + integer, intent(in) :: thread, iproc + + integer :: worker_id, task_id, blockb + 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) + call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) + if(worker_id == -1) then + print *, "WORKER -1" + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + call end_zmq_push_socket(zmq_socket_push,thread) + return + end if + + call davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, worker_id) + call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + call end_zmq_push_socket(zmq_socket_push,thread) +end subroutine + + + +subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, worker_id) + use f77_zmq + implicit none + + integer(ZMQ_PTR),intent(in) :: zmq_to_qp_run_socket + integer(ZMQ_PTR),intent(in) :: zmq_socket_push + integer,intent(in) :: worker_id + integer :: task_id + character*(512) :: task + + + integer :: blockb, blockb2, istep + integer :: N + integer , allocatable :: idx(:) + double precision , allocatable :: vt(:,:) + double precision , allocatable :: st(:,:) + + integer :: bs, i, j + + allocate(idx(1), vt(1,1), st(1,1)) + + do + call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task) + if(task_id == 0) exit + read (task,*) blockb, blockb2, istep + bs = shortcut_(blockb+1,1) - shortcut_(blockb, 1) + do i=blockb, shortcut_(0,2), shortcut_(0,1) + do j=i, min(i, shortcut_(0,2)) + bs += shortcut_(j+1,2) - shortcut_(j, 2) + end do + end do + if(bs > size(idx)) then + deallocate(idx, vt, st) + allocate(idx(bs)) + allocate(vt(N_states_diag, bs)) + allocate(st(N_states_diag, bs)) + end if + + call davidson_process(blockb, blockb2, N, idx, vt, st, bs, istep) + call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) + call davidson_push_results(zmq_socket_push, blockb, blockb2, N, idx, vt, st, task_id) + end do + +end subroutine + + + +subroutine davidson_push_results(zmq_socket_push, blockb, blocke, N, idx, vt, st, task_id) + use f77_zmq + implicit none + + integer(ZMQ_PTR) ,intent(in) :: zmq_socket_push + integer ,intent(in) :: task_id + + integer ,intent(in) :: blockb, blocke + integer ,intent(in) :: N + integer ,intent(in) :: idx(N) + double precision ,intent(in) :: vt(N_states_diag, N) + double precision ,intent(in) :: st(N_states_diag, N) + integer :: rc + + rc = f77_zmq_send( zmq_socket_push, blockb, 4, ZMQ_SNDMORE) + if(rc /= 4) stop "davidson_push_results failed to push blockb" + + rc = f77_zmq_send( zmq_socket_push, blocke, 4, ZMQ_SNDMORE) + if(rc /= 4) stop "davidson_push_results failed to push blocke" + + rc = f77_zmq_send( zmq_socket_push, N, 4, ZMQ_SNDMORE) + if(rc /= 4) stop "davidson_push_results failed to push N" + + rc = f77_zmq_send( zmq_socket_push, idx, 4*N, ZMQ_SNDMORE) + if(rc /= 4*N) stop "davidson_push_results failed to push idx" + + rc = f77_zmq_send( zmq_socket_push, vt, 8*N_states_diag* N, ZMQ_SNDMORE) + if(rc /= 8*N_states_diag* N) stop "davidson_push_results failed to push vt" + + rc = f77_zmq_send( zmq_socket_push, st, 8*N_states_diag* N, ZMQ_SNDMORE) + if(rc /= 8*N_states_diag* N) stop "davidson_push_results failed to push st" + + rc = f77_zmq_send( zmq_socket_push, task_id, 4, 0) + if(rc /= 4) stop "davidson_push_results failed to push task_id" +end subroutine + + + +subroutine davidson_pull_results(zmq_socket_pull, blockb, blocke, N, idx, vt, st, task_id) + use f77_zmq + implicit none + + integer(ZMQ_PTR) ,intent(in) :: zmq_socket_pull + integer ,intent(out) :: task_id + integer ,intent(out) :: blockb, blocke + integer ,intent(out) :: N + integer ,intent(out) :: idx(*) + double precision ,intent(out) :: vt(N_states_diag, *) + double precision ,intent(out) :: st(N_states_diag, *) + + integer :: rc + + rc = f77_zmq_recv( zmq_socket_pull, blockb, 4, 0) + if(rc /= 4) stop "davidson_push_results failed to pull blockb" + + rc = f77_zmq_recv( zmq_socket_pull, blocke, 4, 0) + if(rc /= 4) stop "davidson_push_results failed to pull blocke" + + rc = f77_zmq_recv( zmq_socket_pull, N, 4, 0) + if(rc /= 4) stop "davidson_push_results failed to pull N" + + rc = f77_zmq_recv( zmq_socket_pull, idx, 4*N, 0) + if(rc /= 4*N) stop "davidson_push_results failed to pull idx" + + rc = f77_zmq_recv( zmq_socket_pull, vt, 8*N_states_diag* N, 0) + if(rc /= 8*N_states_diag* N) stop "davidson_push_results failed to pull vt" + + rc = f77_zmq_recv( zmq_socket_pull, st, 8*N_states_diag* N, 0) + if(rc /= 8*N_states_diag* N) stop "davidson_push_results failed to pull st" + + rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0) + if(rc /= 4) stop "davidson_pull_results failed to pull task_id" +end subroutine + + + +subroutine davidson_collector(zmq_to_qp_run_socket, zmq_socket_pull , v0, s0, LDA) + use f77_zmq + implicit none + + integer :: LDA + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + integer(ZMQ_PTR), intent(in) :: zmq_socket_pull + + double precision ,intent(inout) :: v0(LDA, N_states_diag) + double precision ,intent(inout) :: s0(LDA, N_states_diag) + + integer :: more, task_id, taskn + + integer :: blockb, blocke + integer :: N + integer , allocatable :: idx(:) + double precision , allocatable :: vt(:,:), v0t(:,:), s0t(:,:) + double precision , allocatable :: st(:,:) + + integer :: msize + + msize = (1 + max_blocksize)*2 + allocate(idx(msize)) + allocate(vt(N_states_diag, msize)) + allocate(st(N_states_diag, msize)) + allocate(v0t(N_states_diag, dav_size)) + allocate(s0t(N_states_diag, dav_size)) + + v0t = 00.d0 + s0t = 00.d0 + + more = 1 + + do while (more == 1) + call davidson_pull_results(zmq_socket_pull, blockb, blocke, N, idx, vt, st, task_id) + !DIR$ FORCEINLINE + call davidson_collect(N, idx, vt, st , v0t, s0t) + call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more) + end do + deallocate(idx,vt,st) + + integer :: i,j + !DIR$ IVDEP + do j=1,N_states_diag + !DIR$ IVDEP + do i=1,dav_size + v0(i,j) = v0t(j,i) + s0(i,j) = s0t(j,i) + enddo + enddo + + deallocate(v0t,s0t) +end subroutine + + +subroutine davidson_run(zmq_to_qp_run_socket , v0, s0, LDA) + use f77_zmq + implicit none + + integer :: LDA + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_collector + integer(ZMQ_PTR), external :: new_zmq_pull_socket + integer(ZMQ_PTR) :: zmq_socket_pull + + integer :: i + integer, external :: omp_get_thread_num + + double precision , intent(inout) :: v0(LDA, N_states_diag) + double precision , intent(inout) :: s0(LDA, N_states_diag) + + call zmq_set_running(zmq_to_qp_run_socket) + + zmq_collector = new_zmq_to_qp_run_socket() + zmq_socket_pull = new_zmq_pull_socket() + i = omp_get_thread_num() + + + PROVIDE nproc + + !$OMP PARALLEL NUM_THREADS(nproc+2) PRIVATE(i) + i = omp_get_thread_num() + if (i == 0 ) then + call davidson_collector(zmq_collector, zmq_socket_pull , v0, s0, LDA) + call end_zmq_to_qp_run_socket(zmq_collector) + call end_zmq_pull_socket(zmq_socket_pull) + call davidson_miniserver_end() + else if (i == 1 ) then + call davidson_miniserver_run () + else + call davidson_slave_inproc(i) + endif + !$OMP END PARALLEL + + call end_parallel_job(zmq_to_qp_run_socket, 'davidson') +end subroutine + + + +subroutine davidson_miniserver_run() + use f77_zmq + implicit none + integer(ZMQ_PTR) responder + character*(64) address + character(len=:), allocatable :: buffer + integer rc + + allocate (character(len=20) :: buffer) + address = 'tcp://*:11223' + + responder = f77_zmq_socket(zmq_context, ZMQ_REP) + rc = f77_zmq_bind(responder,address) + + do + rc = f77_zmq_recv(responder, buffer, 5, 0) + if (buffer(1:rc) /= 'end') then + rc = f77_zmq_send (responder, dav_size, 4, ZMQ_SNDMORE) + rc = f77_zmq_send (responder, dav_det, 16*N_int*dav_size, ZMQ_SNDMORE) + rc = f77_zmq_send (responder, dav_ut, 8*dav_size*N_states_diag, 0) + else + rc = f77_zmq_send (responder, "end", 3, 0) + exit + endif + enddo + + rc = f77_zmq_close(responder) +end subroutine + + +subroutine davidson_miniserver_end() + implicit none + use f77_zmq + + integer(ZMQ_PTR) requester + character*(64) address + integer rc + character*(64) buf + + address = trim(qp_run_address)//':11223' + requester = f77_zmq_socket(zmq_context, ZMQ_REQ) + rc = f77_zmq_connect(requester,address) + + rc = f77_zmq_send(requester, "end", 3, 0) + rc = f77_zmq_recv(requester, buf, 3, 0) + rc = f77_zmq_close(requester) +end subroutine + + +subroutine davidson_miniserver_get() + implicit none + use f77_zmq + + integer(ZMQ_PTR) requester + character*(64) address + character*(20) buffer + integer rc + + address = trim(qp_run_address)//':11223' + + requester = f77_zmq_socket(zmq_context, ZMQ_REQ) + rc = f77_zmq_connect(requester,address) + + rc = f77_zmq_send(requester, "Hello", 5, 0) + rc = f77_zmq_recv(requester, dav_size, 4, 0) + TOUCH dav_size + rc = f77_zmq_recv(requester, dav_det, 16*N_int*dav_size, 0) + rc = f77_zmq_recv(requester, dav_ut, 8*dav_size*N_states_diag, 0) + TOUCH dav_det dav_ut + + +end subroutine + + + + BEGIN_PROVIDER [ integer(bit_kind), dav_det, (N_int, 2, dav_size) ] +&BEGIN_PROVIDER [ double precision, dav_ut, (N_states_diag, dav_size) ] + use bitmasks + implicit none + BEGIN_DOC +! Temporary arrays for parallel davidson +! +! Touched in davidson_miniserver_get + END_DOC + dav_det = 0_bit_kind + dav_ut = -huge(1.d0) +END_PROVIDER + + +BEGIN_PROVIDER [ integer, dav_size ] + implicit none + BEGIN_DOC +! Size of the arrays for Davidson +! +! Touched in davidson_miniserver_get + END_DOC + dav_size = 1 +END_PROVIDER + + + BEGIN_PROVIDER [ integer, shortcut_, (0:dav_size+1, 2) ] +&BEGIN_PROVIDER [ integer(bit_kind), version_, (N_int, dav_size, 2) ] +&BEGIN_PROVIDER [ integer(bit_kind), sorted_, (N_int, dav_size, 2) ] +&BEGIN_PROVIDER [ integer, sort_idx_, (dav_size, 2) ] +&BEGIN_PROVIDER [ integer, max_blocksize ] +implicit none + call sort_dets_ab_v(dav_det, sorted_(1,1,1), sort_idx_(1,1), shortcut_(0,1), version_(1,1,1), dav_size, N_int) + call sort_dets_ba_v(dav_det, sorted_(1,1,2), sort_idx_(1,2), shortcut_(0,2), version_(1,1,2), dav_size, N_int) + max_blocksize = max(shortcut_(0,1), shortcut_(0,2)) +END_PROVIDER + + diff --git a/src/Davidson/davidson_slave.irp.f b/src/Davidson/davidson_slave.irp.f new file mode 100644 index 00000000..e28712e2 --- /dev/null +++ b/src/Davidson/davidson_slave.irp.f @@ -0,0 +1,39 @@ +program davidson_slave + use f77_zmq + implicit none + + + integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + double precision :: energy(N_states_diag) + character*(64) :: state + + call provide_everything + call switch_qp_run_to_master + + zmq_context = f77_zmq_ctx_new () + zmq_state = 'davidson' + state = 'Waiting' + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + + do + call wait_for_state(zmq_state,state) + if(trim(state) /= "davidson") exit + call davidson_miniserver_get() + + integer :: rc, i + + print *, 'Davidson slave running' + + !$OMP PARALLEL PRIVATE(i) + i = omp_get_thread_num() + call davidson_slave_tcp(i) + !$OMP END PARALLEL + end do +end + +subroutine provide_everything + PROVIDE mo_bielec_integrals_in_map psi_det_sorted_bit N_states_diag zmq_context +end subroutine + diff --git a/src/Determinants/davidson.irp.f b/src/Davidson/diagonalization.irp.f similarity index 63% rename from src/Determinants/davidson.irp.f rename to src/Davidson/diagonalization.irp.f index 130bd56d..9bbd00f5 100644 --- a/src/Determinants/davidson.irp.f +++ b/src/Davidson/diagonalization.irp.f @@ -1,21 +1,4 @@ -BEGIN_PROVIDER [ integer, davidson_iter_max ] - implicit none - BEGIN_DOC - ! Max number of Davidson iterations - END_DOC - davidson_iter_max = 100 -END_PROVIDER - -BEGIN_PROVIDER [ integer, davidson_sze_max ] - implicit none - BEGIN_DOC - ! Max number of Davidson sizes - END_DOC - ASSERT (davidson_sze_max <= davidson_iter_max) - davidson_sze_max = max(8,2*N_states_diag) -END_PROVIDER - -subroutine davidson_diag(dets_in,u_in,energies,dim_in,sze,N_st,Nint,iunit) +subroutine davidson_diag(dets_in,u_in,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) use bitmasks implicit none BEGIN_DOC @@ -36,9 +19,9 @@ subroutine davidson_diag(dets_in,u_in,energies,dim_in,sze,N_st,Nint,iunit) ! ! Initial guess vectors are not necessarily orthonormal END_DOC - integer, intent(in) :: dim_in, sze, N_st, Nint, iunit + integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint, iunit integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) - double precision, intent(inout) :: u_in(dim_in,N_st) + double precision, intent(inout) :: u_in(dim_in,N_st_diag) double precision, intent(out) :: energies(N_st) double precision, allocatable :: H_jj(:) @@ -61,7 +44,7 @@ subroutine davidson_diag(dets_in,u_in,energies,dim_in,sze,N_st,Nint,iunit) !$OMP END DO !$OMP END PARALLEL - call davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nint,iunit) + call davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) deallocate (H_jj) end @@ -69,6 +52,9 @@ end logical function det_inf(key1, key2, Nint) use bitmasks implicit none + BEGIN_DOC +! Ordering function for determinants + END_DOC integer,intent(in) :: Nint integer(bit_kind),intent(in) :: key1(Nint, 2), key2(Nint, 2) integer :: i,j @@ -91,7 +77,6 @@ end function subroutine tamiser(key, idx, no, n, Nint, N_key) use bitmasks implicit none - BEGIN_DOC ! Uncodumented : TODO END_DOC @@ -241,8 +226,8 @@ subroutine sort_dets_ab(key, idx, shortcut, N_key, Nint) 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(inout) :: idx(N_key) + integer,intent(inout) :: shortcut(0:N_key+1) integer(bit_kind) :: tmp(Nint, 2) integer :: tmpidx,i,ni @@ -285,7 +270,7 @@ subroutine sort_dets_ab(key, idx, shortcut, N_key, Nint) end subroutine -subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nint,iunit) +subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) use bitmasks implicit none BEGIN_DOC @@ -303,41 +288,54 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nint,iun ! sze : Number of determinants ! ! N_st : Number of eigenstates + ! + ! N_st_diag : Number of states in which H is diagonalized ! ! iunit : Unit for the I/O ! ! Initial guess vectors are not necessarily orthonormal END_DOC - integer, intent(in) :: dim_in, sze, N_st, Nint + integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) double precision, intent(in) :: H_jj(sze) integer, intent(in) :: iunit - double precision, intent(inout) :: u_in(dim_in,N_st) - double precision, intent(out) :: energies(N_st) + double precision, intent(inout) :: u_in(dim_in,N_st_diag) + double precision, intent(out) :: energies(N_st_diag) + integer :: sze_8 integer :: iter integer :: i,j,k,l,m logical :: converged - double precision :: overlap(N_st,N_st) + double precision, allocatable :: overlap(:,:) double precision :: u_dot_v, u_dot_u integer, allocatable :: kl_pairs(:,:) integer :: k_pairs, kl integer :: iter2 - double precision, allocatable :: W(:,:,:), U(:,:,:), R(:,:), Wt(:) + double precision, allocatable :: W(:,:,:), U(:,:,:), R(:,:) double precision, allocatable :: y(:,:,:,:), h(:,:,:,:), lambda(:) + double precision, allocatable :: c(:), H_small(:,:) double precision :: diag_h_mat_elem - double precision :: residual_norm(N_st) + double precision, allocatable :: residual_norm(:) character*(16384) :: write_buffer double precision :: to_print(2,N_st) double precision :: cpu, wall + include 'constants.include.F' + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, R, y, h, lambda + + if(store_full_H_mat) then + stop 'TODO : put S^2 in stor_full_H_mat' + endif + if(store_full_H_mat.and.sze.le.n_det_max_stored)then provide H_matrix_all_dets endif + PROVIDE nuclear_repulsion call write_time(iunit) call wall_time(wall) @@ -347,6 +345,7 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nint,iun write(iunit,'(A)') '------------------------' write(iunit,'(A)') '' call write_int(iunit,N_st,'Number of states') + call write_int(iunit,N_st_diag,'Number of states in diagonalization') call write_int(iunit,sze,'Number of determinants') write(iunit,'(A)') '' write_buffer = '===== ' @@ -365,144 +364,142 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nint,iun enddo write(iunit,'(A)') trim(write_buffer) + integer, external :: align_double + sze_8 = align_double(sze) + allocate( & - kl_pairs(2,N_st*(N_st+1)/2), & - W(sze,N_st,davidson_sze_max), & - Wt(sze), & - U(sze,N_st,davidson_sze_max), & - R(sze,N_st), & - h(N_st,davidson_sze_max,N_st,davidson_sze_max), & - y(N_st,davidson_sze_max,N_st,davidson_sze_max), & - lambda(N_st*davidson_sze_max)) + kl_pairs(2,N_st_diag*(N_st_diag+1)/2), & + W(sze_8,N_st_diag,davidson_sze_max), & + U(sze_8,N_st_diag,davidson_sze_max), & + R(sze_8,N_st_diag), & + h(N_st_diag,davidson_sze_max,N_st_diag,davidson_sze_max), & + y(N_st_diag,davidson_sze_max,N_st_diag,davidson_sze_max), & + residual_norm(N_st_diag), & + overlap(N_st_diag,N_st_diag), & + c(N_st_diag*davidson_sze_max), & + H_small(N_st_diag,N_st_diag), & + lambda(N_st_diag*davidson_sze_max)) ASSERT (N_st > 0) + ASSERT (N_st_diag >= N_st) ASSERT (sze > 0) ASSERT (Nint > 0) ASSERT (Nint == N_int) - ! Initialization - ! ============== - - - k_pairs=0 - do l=1,N_st - do k=1,l - k_pairs+=1 - kl_pairs(1,k_pairs) = k - kl_pairs(2,k_pairs) = l - enddo - enddo - - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP SHARED(U,sze,N_st,overlap,kl_pairs,k_pairs, & - !$OMP Nint,dets_in,u_in) & - !$OMP PRIVATE(k,l,kl,i) - - - ! Orthonormalize initial guess - ! ============================ - - !$OMP DO - do kl=1,k_pairs - k = kl_pairs(1,kl) - l = kl_pairs(2,kl) - if (k/=l) then - overlap(k,l) = u_dot_v(U_in(1,k),U_in(1,l),sze) - overlap(l,k) = overlap(k,l) - else - overlap(k,k) = u_dot_u(U_in(1,k),sze) - endif - enddo - !$OMP END DO - !$OMP END PARALLEL - - call ortho_lowdin(overlap,size(overlap,1),N_st,U_in,size(U_in,1),sze) - ! Davidson iterations ! =================== converged = .False. + do k=1,N_st_diag + + if (k > N_st) then + do i=1,sze + double precision :: r1, r2 + call random_number(r1) + call random_number(r2) + u_in(i,k) = dsqrt(-2.d0*dlog(r1))*dcos(dtwo_pi*r2) + enddo + endif + + ! Gram-Schmidt + ! ------------ + call dgemv('T',sze,k-1,1.d0,u_in,size(u_in,1), & + u_in(1,k),1,0.d0,c,1) + call dgemv('N',sze,k-1,-1.d0,u_in,size(u_in,1), & + c,1,1.d0,u_in(1,k),1) + call normalize(u_in(1,k),sze) + enddo + + + do while (.not.converged) - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(k,i) SHARED(U,u_in,sze,N_st) - do k=1,N_st - !$OMP DO + do k=1,N_st_diag do i=1,sze U(i,k,1) = u_in(i,k) enddo - !$OMP END DO enddo - !$OMP END PARALLEL - + do iter=1,davidson_sze_max-1 - ! Compute W_k = H |u_k> - ! ---------------------- + ! Compute |W_k> = \sum_i |i> + ! ----------------------------------------- - do k=1,N_st - if(store_full_H_mat.and.sze.le.n_det_max_stored)then - call H_u_0_stored(W(1,k,iter),U(1,k,iter),H_matrix_all_dets,sze) - else - call H_u_0(W(1,k,iter),U(1,k,iter),H_jj,sze,dets_in,Nint) - endif - enddo + call H_u_0_nstates(W(1,1,iter),U(1,1,iter),H_jj,sze,dets_in,Nint,N_st_diag,sze_8) +! do k=1,N_st +! if(store_full_H_mat.and.sze.le.n_det_max_stored)then +! call H_u_0_stored(W(1,k,iter),U(1,k,iter),H_matrix_all_dets,sze) +! else +! call H_u_0(W(1,k,iter),U(1,k,iter),H_jj,sze,dets_in,Nint) +! endif +! enddo ! Compute h_kl = = ! ------------------------------------------- - do l=1,N_st - do k=1,N_st - do iter2=1,iter-1 - h(k,iter2,l,iter) = u_dot_v(U(1,k,iter2),W(1,l,iter),sze) - h(k,iter,l,iter2) = h(k,iter2,l,iter) - enddo - enddo - do k=1,l - h(k,iter,l,iter) = u_dot_v(U(1,k,iter),W(1,l,iter),sze) - h(l,iter,k,iter) = h(k,iter,l,iter) - enddo - enddo - !DEBUG H MATRIX - !do i=1,iter - ! print '(10(x,F16.10))', h(1,i,1,1:i) - !enddo - !print *, '' - !END - +! do l=1,N_st_diag +! do k=1,N_st_diag +! do iter2=1,iter-1 +! h(k,iter2,l,iter) = u_dot_v(U(1,k,iter2),W(1,l,iter),sze) +! h(k,iter,l,iter2) = h(k,iter2,l,iter) +! enddo +! enddo +! do k=1,l +! h(k,iter,l,iter) = u_dot_v(U(1,k,iter),W(1,l,iter),sze) +! h(l,iter,k,iter) = h(k,iter,l,iter) +! enddo +! enddo + + call dgemm('T','N', N_st_diag*iter, N_st_diag, sze, & + 1.d0, U, size(U,1), W(1,1,iter), size(W,1), & + 0.d0, h(1,1,1,iter), size(h,1)*size(h,2)) + ! Diagonalize h ! ------------- - call lapack_diag(lambda,y,h,N_st*davidson_sze_max,N_st*iter) + call lapack_diag(lambda,y,h,N_st_diag*davidson_sze_max,N_st_diag*iter) ! Express eigenvectors of h in the determinant basis ! -------------------------------------------------- - do k=1,N_st + do k=1,N_st_diag do i=1,sze U(i,k,iter+1) = 0.d0 W(i,k,iter+1) = 0.d0 - do l=1,N_st - do iter2=1,iter - U(i,k,iter+1) = U(i,k,iter+1) + U(i,l,iter2)*y(l,iter2,k,1) - W(i,k,iter+1) = W(i,k,iter+1) + W(i,l,iter2)*y(l,iter2,k,1) - enddo - enddo enddo enddo - +! do k=1,N_st_diag +! do iter2=1,iter +! do l=1,N_st_diag +! do i=1,sze +! U(i,k,iter+1) = U(i,k,iter+1) + U(i,l,iter2)*y(l,iter2,k,1) +! W(i,k,iter+1) = W(i,k,iter+1) + W(i,l,iter2)*y(l,iter2,k,1) +! enddo +! enddo +! enddo +! enddo +! +! + call dgemm('N','N', sze, N_st_diag, N_st_diag*iter, & + 1.d0, U, size(U,1), y, size(y,1)*size(y,2), 0.d0, U(1,1,iter+1), size(U,1)) + call dgemm('N','N',sze,N_st_diag,N_st_diag*iter, & + 1.d0, W, size(W,1), y, size(y,1)*size(y,2), 0.d0, W(1,1,iter+1), size(W,1)) + + ! Compute residual vector ! ----------------------- - do k=1,N_st + do k=1,N_st_diag do i=1,sze R(i,k) = lambda(k) * U(i,k,iter+1) - W(i,k,iter+1) enddo - residual_norm(k) = u_dot_u(R(1,k),sze) - to_print(1,k) = lambda(k) + nuclear_repulsion - to_print(2,k) = residual_norm(k) + if (k <= N_st) then + residual_norm(k) = u_dot_u(R(1,k),sze) + to_print(1,k) = lambda(k) + nuclear_repulsion + to_print(2,k) = residual_norm(k) + endif enddo write(iunit,'(X,I3,X,100(X,F16.10,X,E16.6))') iter, to_print(:,1:N_st) @@ -511,11 +508,10 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nint,iun exit endif - ! Davidson step ! ------------- - do k=1,N_st + do k=1,N_st_diag do i=1,sze U(i,k,iter+1) = -1.d0/max(H_jj(i) - lambda(k),1.d-2) * R(i,k) enddo @@ -524,37 +520,36 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nint,iun ! Gram-Schmidt ! ------------ - double precision :: c - do k=1,N_st - do iter2=1,iter - do l=1,N_st - c = u_dot_v(U(1,k,iter+1),U(1,l,iter2),sze) - do i=1,sze - U(i,k,iter+1) -= c * U(i,l,iter2) - enddo - enddo - enddo - do l=1,k-1 - c = u_dot_v(U(1,k,iter+1),U(1,l,iter+1),sze) - do i=1,sze - U(i,k,iter+1) -= c * U(i,l,iter+1) - enddo - enddo + do k=1,N_st_diag + +! do iter2=1,iter +! do l=1,N_st_diag +! c(1) = u_dot_v(U(1,k,iter+1),U(1,l,iter2),sze) +! do i=1,sze +! U(i,k,iter+1) = U(i,k,iter+1) - c(1) * U(i,l,iter2) +! enddo +! enddo +! enddo +! + call dgemv('T',sze,N_st_diag*iter,1.d0,U,size(U,1), & + U(1,k,iter+1),1,0.d0,c,1) + call dgemv('N',sze,N_st_diag*iter,-1.d0,U,size(U,1), & + c,1,1.d0,U(1,k,iter+1),1) +! +! do l=1,k-1 +! c(1) = u_dot_v(U(1,k,iter+1),U(1,l,iter+1),sze) +! do i=1,sze +! U(i,k,iter+1) = U(i,k,iter+1) - c(1) * U(i,l,iter+1) +! enddo +! enddo +! + call dgemv('T',sze,k-1,1.d0,U(1,1,iter+1),size(U,1), & + U(1,k,iter+1),1,0.d0,c,1) + call dgemv('N',sze,k-1,-1.d0,U(1,1,iter+1),size(U,1), & + c,1,1.d0,U(1,k,iter+1),1) + call normalize( U(1,k,iter+1), sze ) enddo - - !DEBUG : CHECK OVERLAP - !print *, '===' - !do k=1,iter+1 - ! do l=1,k - ! c = u_dot_v(U(1,1,k),U(1,1,l),sze) - ! print *, k,l, c - ! enddo - !enddo - !print *, '===' - !pause - !END DEBUG - enddo @@ -565,17 +560,25 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nint,iun ! Re-contract to u_in ! ----------- - do k=1,N_st + do k=1,N_st_diag energies(k) = lambda(k) do i=1,sze u_in(i,k) = 0.d0 - do iter2=1,iter - do l=1,N_st - u_in(i,k) += U(i,l,iter2)*y(l,iter2,k,1) - enddo - enddo enddo enddo +! do k=1,N_st_diag +! do i=1,sze +! do iter2=1,iter +! do l=1,N_st_diag +! u_in(i,k) += U(i,l,iter2)*y(l,iter2,k,1) +! enddo +! enddo +! enddo +! enddo + + call dgemm('N','N', sze, N_st_diag, N_st_diag*iter, 1.d0, & + U, size(U,1), y, N_st_diag*davidson_sze_max, & + 0.d0, u_in, size(u_in,1)) enddo @@ -589,57 +592,12 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nint,iun deallocate ( & kl_pairs, & - W, & - Wt, & - U, & - R, & + W, residual_norm, & + U, overlap, & + R, c, & h, & y, & lambda & ) end -BEGIN_PROVIDER [ character(64), davidson_criterion ] - implicit none - BEGIN_DOC - ! Can be : [ energy | residual | both | wall_time | cpu_time | iterations ] - END_DOC - davidson_criterion = 'residual' -END_PROVIDER - -subroutine davidson_converged(energy,residual,wall,iterations,cpu,N_st,converged) - implicit none - BEGIN_DOC -! True if the Davidson algorithm is converged - END_DOC - integer, intent(in) :: N_st, iterations - logical, intent(out) :: converged - double precision, intent(in) :: energy(N_st), residual(N_st) - double precision, intent(in) :: wall, cpu - double precision :: E(N_st), time - double precision, allocatable, save :: energy_old(:) - - if (.not.allocated(energy_old)) then - allocate(energy_old(N_st)) - energy_old = 0.d0 - endif - - E = energy - energy_old - energy_old = energy - if (davidson_criterion == 'energy') then - converged = dabs(maxval(E(1:N_st))) < threshold_davidson - else if (davidson_criterion == 'residual') then - converged = dabs(maxval(residual(1:N_st))) < threshold_davidson - else if (davidson_criterion == 'both') then - converged = dabs(maxval(residual(1:N_st))) + dabs(maxval(E(1:N_st)) ) & - < threshold_davidson - else if (davidson_criterion == 'wall_time') then - call wall_time(time) - converged = time - wall > threshold_davidson - else if (davidson_criterion == 'cpu_time') then - call cpu_time(time) - converged = time - cpu > threshold_davidson - else if (davidson_criterion == 'iterations') then - converged = iterations >= int(threshold_davidson) - endif -end diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f new file mode 100644 index 00000000..12265810 --- /dev/null +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -0,0 +1,359 @@ +subroutine davidson_diag_hs2(dets_in,u_in,s2_out,dim_in,energies,sze,N_st,N_st_diag,Nint,iunit) + use bitmasks + implicit none + BEGIN_DOC + ! Davidson diagonalization. + ! + ! dets_in : bitmasks corresponding to determinants + ! + ! u_in : guess coefficients on the various states. Overwritten + ! on exit + ! + ! dim_in : leftmost dimension of u_in + ! + ! sze : Number of determinants + ! + ! N_st : Number of eigenstates + ! + ! iunit : Unit number for the I/O + ! + ! Initial guess vectors are not necessarily orthonormal + END_DOC + integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint, iunit + integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) + double precision, intent(inout) :: u_in(dim_in,N_st_diag) + double precision, intent(out) :: energies(N_st), s2_out(N_st_diag) + double precision, allocatable :: H_jj(:), S2_jj(:) + + double precision :: diag_h_mat_elem + integer :: i + ASSERT (N_st > 0) + ASSERT (sze > 0) + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + PROVIDE mo_bielec_integrals_in_map + allocate(H_jj(sze), S2_jj(sze)) + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP SHARED(sze,H_jj,S2_jj, dets_in,Nint) & + !$OMP PRIVATE(i) + !$OMP DO SCHEDULE(guided) + do i=1,sze + H_jj(i) = diag_h_mat_elem(dets_in(1,1,i),Nint) + call get_s2(dets_in(1,1,i),dets_in(1,1,i),Nint,S2_jj(i)) + enddo + !$OMP END DO + !$OMP END PARALLEL + + call davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) + do i=1,N_st_diag + s2_out(i) = S2_jj(i) + enddo + deallocate (H_jj,S2_jj) +end + + +subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) + use bitmasks + implicit none + BEGIN_DOC + ! Davidson diagonalization with specific diagonal elements of the H matrix + ! + ! H_jj : specific diagonal H matrix elements to diagonalize de Davidson + ! + ! S2_jj : specific diagonal S^2 matrix elements + ! + ! dets_in : bitmasks corresponding to determinants + ! + ! u_in : guess coefficients on the various states. Overwritten + ! on exit + ! + ! dim_in : leftmost dimension of u_in + ! + ! sze : Number of determinants + ! + ! N_st : Number of eigenstates + ! + ! N_st_diag : Number of states in which H is diagonalized. Assumed > sze + ! + ! iunit : Unit for the I/O + ! + ! Initial guess vectors are not necessarily orthonormal + END_DOC + integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint + integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) + double precision, intent(in) :: H_jj(sze) + double precision, intent(inout) :: S2_jj(sze) + integer, intent(in) :: iunit + double precision, intent(inout) :: u_in(dim_in,N_st_diag) + double precision, intent(out) :: energies(N_st_diag) + + integer :: sze_8 + integer :: iter + integer :: i,j,k,l,m + logical :: converged + + double precision :: u_dot_v, u_dot_u + + integer :: k_pairs, kl + + integer :: iter2 + double precision, allocatable :: W(:,:), U(:,:), S(:,:) + double precision, allocatable :: y(:,:), h(:,:), lambda(:), s2(:) + double precision, allocatable :: c(:), s_(:,:), s_tmp(:,:) + double precision :: diag_h_mat_elem + double precision, allocatable :: residual_norm(:) + character*(16384) :: write_buffer + double precision :: to_print(3,N_st) + double precision :: cpu, wall + integer :: shift, shift2, itermax + include 'constants.include.F' + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, S, y, h, lambda + if (N_st_diag*3 > sze) then + print *, 'error in Davidson :' + print *, 'Increase n_det_max_jacobi to ', N_st_diag*3 + stop -1 + endif + + PROVIDE nuclear_repulsion + + call write_time(iunit) + call wall_time(wall) + call cpu_time(cpu) + write(iunit,'(A)') '' + write(iunit,'(A)') 'Davidson Diagonalization' + write(iunit,'(A)') '------------------------' + write(iunit,'(A)') '' + call write_int(iunit,N_st,'Number of states') + call write_int(iunit,N_st_diag,'Number of states in diagonalization') + call write_int(iunit,sze,'Number of determinants') + write(iunit,'(A)') '' + write_buffer = '===== ' + do i=1,N_st + write_buffer = trim(write_buffer)//' ================ =========== ===========' + enddo + write(iunit,'(A)') trim(write_buffer) + write_buffer = ' Iter' + do i=1,N_st + write_buffer = trim(write_buffer)//' Energy S^2 Residual' + enddo + write(iunit,'(A)') trim(write_buffer) + write_buffer = '===== ' + do i=1,N_st + write_buffer = trim(write_buffer)//' ================ =========== ===========' + enddo + write(iunit,'(A)') trim(write_buffer) + + integer, external :: align_double + sze_8 = align_double(sze) + + itermax = min(davidson_sze_max, sze/N_st_diag) + allocate( & + W(sze_8,N_st_diag*itermax), & + U(sze_8,N_st_diag*itermax), & + S(sze_8,N_st_diag*itermax), & + h(N_st_diag*itermax,N_st_diag*itermax), & + y(N_st_diag*itermax,N_st_diag*itermax), & + s_(N_st_diag*itermax,N_st_diag*itermax), & + s_tmp(N_st_diag*itermax,N_st_diag*itermax), & + residual_norm(N_st_diag), & + c(N_st_diag*itermax), & + s2(N_st_diag*itermax), & + lambda(N_st_diag*itermax)) + + h = 0.d0 + s_ = 0.d0 + s_tmp = 0.d0 + U = 0.d0 + W = 0.d0 + S = 0.d0 + y = 0.d0 + + + ASSERT (N_st > 0) + ASSERT (N_st_diag >= N_st) + ASSERT (sze > 0) + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + + ! Davidson iterations + ! =================== + + converged = .False. + + double precision :: r1, r2 + do k=N_st+1,N_st_diag-2,2 + do i=1,sze + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + u_in(i,k) = r1*dcos(r2) + u_in(i,k+1) = r1*dsin(r2) + enddo + enddo + do k=N_st_diag-1,N_st_diag + do i=1,sze + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + u_in(i,k) = r1*dcos(r2) + enddo + enddo + + + do while (.not.converged) + + do k=1,N_st_diag + do i=1,sze + U(i,k) = u_in(i,k) + enddo + enddo + + do iter=1,itermax-1 + + shift = N_st_diag*(iter-1) + shift2 = N_st_diag*iter + + call ortho_qr(U,size(U,1),sze,shift2) + + ! Compute |W_k> = \sum_i |i> + ! ----------------------------------------- + + + call H_S2_u_0_nstates(W(1,shift+1),S(1,shift+1),U(1,shift+1),H_jj,S2_jj,sze,dets_in,Nint,N_st_diag,sze_8) + + + ! Compute h_kl = = + ! ------------------------------------------- + + call dgemm('T','N', shift2, shift2, sze, & + 1.d0, U(1,1), size(U,1), W(1,1), size(W,1), & + 0.d0, h(1,1), size(h,1)) + + call dgemm('T','N', shift2, shift2, sze, & + 1.d0, U(1,1), size(U,1), S(1,1), size(S,1), & + 0.d0, s_(1,1), size(s_,1)) + + + ! Diagonalize h + ! ------------- + call lapack_diag(lambda,y,h,size(h,1),shift2) + + ! Compute S2 for each eigenvector + ! ------------------------------- + + call dgemm('N','N',shift2,shift2,shift2, & + 1.d0, s_, size(s_,1), y, size(y,1), & + 0.d0, s_tmp, size(s_tmp,1)) + + call dgemm('T','N',shift2,shift2,shift2, & + 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), & + 0.d0, s_, size(s_,1)) + + do k=1,shift2 + s2(k) = s_(k,k) + S_z2_Sz + enddo + + if (s2_eig) then + logical :: state_ok(N_st_diag*davidson_sze_max) + do k=1,shift2 + state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0) + enddo + do k=1,shift2 + if (.not. state_ok(k)) then + do l=k+1,shift2 + if (state_ok(l)) then + call dswap(shift2, y(1,k), 1, y(1,l), 1) + call dswap(1, s2(k), 1, s2(l), 1) + call dswap(1, lambda(k), 1, lambda(l), 1) + state_ok(k) = .True. + state_ok(l) = .False. + exit + endif + enddo + endif + enddo + endif + + + ! Express eigenvectors of h in the determinant basis + ! -------------------------------------------------- + + call dgemm('N','N', sze, N_st_diag, shift2, & + 1.d0, U, size(U,1), y, size(y,1), 0.d0, U(1,shift2+1), size(U,1)) + call dgemm('N','N', sze, N_st_diag, shift2, & + 1.d0, W, size(W,1), y, size(y,1), 0.d0, W(1,shift2+1), size(W,1)) + call dgemm('N','N', sze, N_st_diag, shift2, & + 1.d0, S, size(S,1), y, size(y,1), 0.d0, S(1,shift2+1), size(S,1)) + + ! Compute residual vector and davidson step + ! ----------------------------------------- + + do k=1,N_st_diag + do i=1,sze + U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & + * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz & + )/max(H_jj(i) - lambda (k),1.d-2) + enddo + if (k <= N_st) then + residual_norm(k) = u_dot_u(U(1,shift2+k),sze) + to_print(1,k) = lambda(k) + nuclear_repulsion + to_print(2,k) = s2(k) + to_print(3,k) = residual_norm(k) + endif + enddo + + write(iunit,'(X,I3,X,100(X,F16.10,X,F11.6,X,E11.3))') iter, to_print(1:3,1:N_st) + call davidson_converged(lambda,residual_norm,wall,iter,cpu,N_st,converged) + do k=1,N_st + if (residual_norm(k) > 1.e8) then + print *, '' + stop 'Davidson failed' + endif + enddo + if (converged) then + exit + endif + + enddo + + if (.not.converged) then + iter = itermax-1 + endif + + ! Re-contract to u_in + ! ----------- + + do k=1,N_st_diag + energies(k) = lambda(k) + enddo + + call dgemm('N','N', sze, N_st_diag, N_st_diag*iter, 1.d0, & + U, size(U,1), y, size(y,1), 0.d0, u_in, size(u_in,1)) + + enddo + + do k=1,N_st_diag + S2_jj(k) = s2(k) + enddo + write_buffer = '===== ' + do i=1,N_st + write_buffer = trim(write_buffer)//' ================ =========== ===========' + enddo + write(iunit,'(A)') trim(write_buffer) + write(iunit,'(A)') '' + call write_time(iunit) + + deallocate ( & + W, residual_norm, & + U, & + c, S, & + h, & + y, s_, s_tmp, & + lambda & + ) +end + diff --git a/src/Davidson/diagonalize_CI.irp.f b/src/Davidson/diagonalize_CI.irp.f new file mode 100644 index 00000000..3b2c9ed0 --- /dev/null +++ b/src/Davidson/diagonalize_CI.irp.f @@ -0,0 +1,167 @@ + +BEGIN_PROVIDER [ double precision, CI_energy, (N_states_diag) ] + implicit none + BEGIN_DOC + ! N_states lowest eigenvalues of the CI matrix + END_DOC + + integer :: j + character*(8) :: st + call write_time(output_determinants) + do j=1,min(N_det,N_states_diag) + CI_energy(j) = CI_electronic_energy(j) + nuclear_repulsion + enddo + do j=1,min(N_det,N_states) + write(st,'(I4)') j + call write_double(output_determinants,CI_energy(j),'Energy of state '//trim(st)) + call write_double(output_determinants,CI_eigenvectors_s2(j),'S^2 of state '//trim(st)) + enddo + +END_PROVIDER + + BEGIN_PROVIDER [ double precision, CI_electronic_energy, (N_states_diag) ] +&BEGIN_PROVIDER [ double precision, CI_eigenvectors, (N_det,N_states_diag) ] +&BEGIN_PROVIDER [ double precision, CI_eigenvectors_s2, (N_states_diag) ] + BEGIN_DOC + ! Eigenvectors/values of the CI matrix + END_DOC + implicit none + double precision :: ovrlp,u_dot_v + integer :: i_good_state + integer, allocatable :: index_good_state_array(:) + logical, allocatable :: good_state_array(:) + double precision, allocatable :: s2_values_tmp(:) + integer :: i_other_state + double precision, allocatable :: eigenvectors(:,:), eigenvalues(:) + integer :: i_state + double precision :: e_0 + integer :: i,j,k + double precision, allocatable :: s2_eigvalues(:) + double precision, allocatable :: e_array(:) + integer, allocatable :: iorder(:) + + ! Guess values for the "N_states" states of the CI_eigenvectors + do j=1,min(N_states,N_det) + do i=1,N_det + CI_eigenvectors(i,j) = psi_coef(i,j) + enddo + enddo + + do j=min(N_states,N_det)+1,N_states_diag + do i=1,N_det + CI_eigenvectors(i,j) = 0.d0 + enddo + enddo + + if (diag_algorithm == "Davidson") then + +! call davidson_diag(psi_det,CI_eigenvectors,CI_electronic_energy, & +! size(CI_eigenvectors,1), & +! N_det,min(N_det,N_states),min(N_det,N_states_diag),N_int,output_determinants) +! +! call u_0_S2_u_0(CI_eigenvectors_s2,CI_eigenvectors,N_det,psi_det,N_int,& +! min(N_det,N_states_diag),size(CI_eigenvectors,1)) + + call davidson_diag_HS2(psi_det,CI_eigenvectors, CI_eigenvectors_s2, & + size(CI_eigenvectors,1),CI_electronic_energy, & + N_det,min(N_det,N_states),min(N_det,N_states_diag),N_int,output_determinants) + + + else if (diag_algorithm == "Lapack") then + + allocate (eigenvectors(size(H_matrix_all_dets,1),N_det)) + allocate (eigenvalues(N_det)) + call lapack_diag(eigenvalues,eigenvectors, & + H_matrix_all_dets,size(H_matrix_all_dets,1),N_det) + CI_electronic_energy(:) = 0.d0 + if (s2_eig) then + i_state = 0 + allocate (s2_eigvalues(N_det)) + allocate(index_good_state_array(N_det),good_state_array(N_det)) + good_state_array = .False. + call u_0_S2_u_0(s2_eigvalues,eigenvectors,N_det,psi_det,N_int,& + N_det,size(eigenvectors,1)) + do j=1,N_det + ! Select at least n_states states with S^2 values closed to "expected_s2" + if(dabs(s2_eigvalues(j)-expected_s2).le.0.5d0)then + i_state +=1 + index_good_state_array(i_state) = j + good_state_array(j) = .True. + endif + if(i_state.eq.N_states) then + exit + endif + enddo + if(i_state .ne.0)then + ! Fill the first "i_state" states that have a correct S^2 value + do j = 1, i_state + do i=1,N_det + CI_eigenvectors(i,j) = eigenvectors(i,index_good_state_array(j)) + enddo + CI_electronic_energy(j) = eigenvalues(index_good_state_array(j)) + CI_eigenvectors_s2(j) = s2_eigvalues(index_good_state_array(j)) + enddo + i_other_state = 0 + do j = 1, N_det + if(good_state_array(j))cycle + i_other_state +=1 + if(i_state+i_other_state.gt.n_states_diag)then + exit + endif + do i=1,N_det + CI_eigenvectors(i,i_state+i_other_state) = eigenvectors(i,j) + enddo + CI_electronic_energy(i_state+i_other_state) = eigenvalues(j) + CI_eigenvectors_s2(i_state+i_other_state) = s2_eigvalues(i_state+i_other_state) + enddo + + else + print*,'' + print*,'!!!!!!!! WARNING !!!!!!!!!' + print*,' Within the ',N_det,'determinants selected' + print*,' and the ',N_states_diag,'states requested' + print*,' We did not find any state with S^2 values close to ',expected_s2 + print*,' We will then set the first N_states eigenvectors of the H matrix' + print*,' as the CI_eigenvectors' + print*,' You should consider more states and maybe ask for s2_eig to be .True. or just enlarge the CI space' + print*,'' + do j=1,min(N_states_diag,N_det) + do i=1,N_det + CI_eigenvectors(i,j) = eigenvectors(i,j) + enddo + CI_electronic_energy(j) = eigenvalues(j) + CI_eigenvectors_s2(j) = s2_eigvalues(j) + enddo + endif + deallocate(index_good_state_array,good_state_array) + deallocate(s2_eigvalues) + else + call u_0_S2_u_0(CI_eigenvectors_s2,eigenvectors,N_det,psi_det,N_int,& + min(N_det,N_states_diag),size(eigenvectors,1)) + ! Select the "N_states_diag" states of lowest energy + do j=1,min(N_det,N_states_diag) + do i=1,N_det + CI_eigenvectors(i,j) = eigenvectors(i,j) + enddo + CI_electronic_energy(j) = eigenvalues(j) + enddo + endif + deallocate(eigenvectors,eigenvalues) + endif + +END_PROVIDER + +subroutine diagonalize_CI + implicit none + BEGIN_DOC +! Replace the coefficients of the CI states by the coefficients of the +! eigenstates of the CI matrix + END_DOC + integer :: i,j + do j=1,N_states + do i=1,N_det + psi_coef(i,j) = CI_eigenvectors(i,j) + enddo + enddo + SOFT_TOUCH psi_coef CI_electronic_energy CI_energy CI_eigenvectors CI_eigenvectors_s2 +end diff --git a/src/Determinants/diagonalize_restart_and_save_all_states.irp.f b/src/Davidson/diagonalize_restart_and_save_all_states.irp.f similarity index 100% rename from src/Determinants/diagonalize_restart_and_save_all_states.irp.f rename to src/Davidson/diagonalize_restart_and_save_all_states.irp.f diff --git a/src/Determinants/diagonalize_restart_and_save_lowest_state.irp.f b/src/Davidson/diagonalize_restart_and_save_lowest_state.irp.f similarity index 100% rename from src/Determinants/diagonalize_restart_and_save_lowest_state.irp.f rename to src/Davidson/diagonalize_restart_and_save_lowest_state.irp.f diff --git a/src/Determinants/diagonalize_restart_and_save_one_states.irp.f b/src/Davidson/diagonalize_restart_and_save_one_state.irp.f similarity index 100% rename from src/Determinants/diagonalize_restart_and_save_one_states.irp.f rename to src/Davidson/diagonalize_restart_and_save_one_state.irp.f diff --git a/src/Determinants/guess_lowest_state.irp.f b/src/Davidson/guess_lowest_state.irp.f similarity index 100% rename from src/Determinants/guess_lowest_state.irp.f rename to src/Davidson/guess_lowest_state.irp.f diff --git a/src/Davidson/parameters.irp.f b/src/Davidson/parameters.irp.f new file mode 100644 index 00000000..82315495 --- /dev/null +++ b/src/Davidson/parameters.irp.f @@ -0,0 +1,62 @@ +BEGIN_PROVIDER [ integer, davidson_iter_max ] + implicit none + BEGIN_DOC + ! Max number of Davidson iterations + END_DOC + davidson_iter_max = 100 +END_PROVIDER + +BEGIN_PROVIDER [ integer, davidson_sze_max ] + implicit none + BEGIN_DOC + ! Max number of Davidson sizes + END_DOC + ASSERT (davidson_sze_max <= davidson_iter_max) + davidson_sze_max = N_states+7 +END_PROVIDER + + +BEGIN_PROVIDER [ character(64), davidson_criterion ] + implicit none + BEGIN_DOC + ! Can be : [ energy | residual | both | wall_time | cpu_time | iterations ] + END_DOC + davidson_criterion = 'residual' +END_PROVIDER + +subroutine davidson_converged(energy,residual,wall,iterations,cpu,N_st,converged) + implicit none + BEGIN_DOC +! True if the Davidson algorithm is converged + END_DOC + integer, intent(in) :: N_st, iterations + logical, intent(out) :: converged + double precision, intent(in) :: energy(N_st), residual(N_st) + double precision, intent(in) :: wall, cpu + double precision :: E(N_st), time + double precision, allocatable, save :: energy_old(:) + + if (.not.allocated(energy_old)) then + allocate(energy_old(N_st)) + energy_old = 0.d0 + endif + + E = energy - energy_old + energy_old = energy + if (davidson_criterion == 'energy') then + converged = dabs(maxval(E(1:N_st))) < threshold_davidson + else if (davidson_criterion == 'residual') then + converged = dabs(maxval(residual(1:N_st))) < threshold_davidson + else if (davidson_criterion == 'both') then + converged = dabs(maxval(residual(1:N_st))) + dabs(maxval(E(1:N_st)) ) & + < threshold_davidson + else if (davidson_criterion == 'wall_time') then + call wall_time(time) + converged = time - wall > threshold_davidson + else if (davidson_criterion == 'cpu_time') then + call cpu_time(time) + converged = time - cpu > threshold_davidson + else if (davidson_criterion == 'iterations') then + converged = iterations >= int(threshold_davidson) + endif +end diff --git a/src/Determinants/print_H_matrix_restart.irp.f b/src/Davidson/print_H_matrix_restart.irp.f similarity index 82% rename from src/Determinants/print_H_matrix_restart.irp.f rename to src/Davidson/print_H_matrix_restart.irp.f index 813f14d0..57fc3633 100644 --- a/src/Determinants/print_H_matrix_restart.irp.f +++ b/src/Davidson/print_H_matrix_restart.irp.f @@ -106,27 +106,24 @@ subroutine routine double precision, allocatable :: eigenvectors(:,:), eigenvalues(:) double precision, allocatable :: s2_eigvalues(:) allocate (eigenvectors(size(H_matrix_all_dets,1),N_det)) - allocate (eigenvalues(N_det)) + allocate (eigenvalues(N_det),s2_eigvalues(N_det)) call lapack_diag(eigenvalues,eigenvectors, & H_matrix_all_dets,size(H_matrix_all_dets,1),N_det) print*,'Two first eigenvectors ' - do j = 1, n_states -!do j = 1, 1 - print*,'State ',j - call get_s2_u0(keys_tmp,eigenvectors(1,j),N_det,size(eigenvectors,1),s2) - print*,'s2 = ',s2 + call u_0_S2_u_0(s2_eigvalues,eigenvectors,n_det,keys_tmp,N_int,N_det,size(eigenvectors,1)) + do j =1, N_states + print*,'s2 = ',s2_eigvalues(j) print*,'e = ',eigenvalues(j) print*,'coefs : ' do i = 1, N_det print*,'i = ',i,eigenvectors(i,j) enddo - if(j>1)then print*,'Delta E(H) = ',eigenvalues(1) - eigenvalues(j) print*,'Delta E(eV) = ',(eigenvalues(1) - eigenvalues(j))*27.2114d0 endif enddo - double precision :: get_mo_bielec_integral_schwartz,k_a_iv,k_b_iv + double precision :: get_mo_bielec_integral,k_a_iv,k_b_iv integer :: h1,p1,h2,p2 h1 = 10 p1 = 16 @@ -136,10 +133,10 @@ subroutine routine !p1 = 4 !h2 = 2 !p2 = 2 - k_a_iv = get_mo_bielec_integral_schwartz(h1,h2,p2,p1,mo_integrals_map) + k_a_iv = get_mo_bielec_integral(h1,h2,p2,p1,mo_integrals_map) h2 = 15 p2 = 15 - k_b_iv = get_mo_bielec_integral_schwartz(h1,h2,p2,p1,mo_integrals_map) + k_b_iv = get_mo_bielec_integral(h1,h2,p2,p1,mo_integrals_map) print*,'k_a_iv = ',k_a_iv print*,'k_b_iv = ',k_b_iv double precision :: k_av,k_bv,k_ai,k_bi @@ -147,24 +144,24 @@ subroutine routine p1 = 14 h2 = 14 p2 = 16 - k_av = get_mo_bielec_integral_schwartz(h1,h2,p1,p2,mo_integrals_map) + k_av = get_mo_bielec_integral(h1,h2,p1,p2,mo_integrals_map) h1 = 16 p1 = 15 h2 = 15 p2 = 16 - k_bv = get_mo_bielec_integral_schwartz(h1,h2,p1,p2,mo_integrals_map) + k_bv = get_mo_bielec_integral(h1,h2,p1,p2,mo_integrals_map) h1 = 10 p1 = 14 h2 = 14 p2 = 10 - k_ai = get_mo_bielec_integral_schwartz(h1,h2,p1,p2,mo_integrals_map) + k_ai = get_mo_bielec_integral(h1,h2,p1,p2,mo_integrals_map) h1 = 10 p1 = 15 h2 = 15 p2 = 10 - k_bi = get_mo_bielec_integral_schwartz(h1,h2,p1,p2,mo_integrals_map) + k_bi = get_mo_bielec_integral(h1,h2,p1,p2,mo_integrals_map) print*,'k_av, k_bv = ',k_av,k_bv print*,'k_ai, k_bi = ',k_ai,k_bi @@ -174,6 +171,6 @@ subroutine routine p1 = 16 h2 = 16 p2 = 10 - k_iv = get_mo_bielec_integral_schwartz(h1,h2,p1,p2,mo_integrals_map) + k_iv = get_mo_bielec_integral(h1,h2,p1,p2,mo_integrals_map) print*,'k_iv = ',k_iv end diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f new file mode 100644 index 00000000..9ab30476 --- /dev/null +++ b/src/Davidson/u0Hu0.irp.f @@ -0,0 +1,282 @@ +subroutine u_0_H_u_0(e_0,u_0,n,keys_tmp,Nint,N_st,sze_8) + use bitmasks + implicit none + BEGIN_DOC + ! Computes e_0 = / + ! + ! n : number of determinants + ! + END_DOC + integer, intent(in) :: n,Nint, N_st, sze_8 + double precision, intent(out) :: e_0(N_st) + double precision, intent(in) :: u_0(sze_8,N_st) + integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) + + double precision, allocatable :: H_jj(:), v_0(:,:) + double precision :: u_dot_u,u_dot_v,diag_H_mat_elem + integer :: i,j + allocate (H_jj(n), v_0(sze_8,N_st)) + do i = 1, n + H_jj(i) = diag_H_mat_elem(keys_tmp(1,1,i),Nint) + enddo + + call H_u_0_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,N_st,sze_8) + do i=1,N_st + e_0(i) = u_dot_v(v_0(1,i),u_0(1,i),n)/u_dot_u(u_0(1,i),n) + enddo + deallocate (H_jj, v_0) +end + + +subroutine H_u_0_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,N_st,sze_8) + use bitmasks + implicit none + BEGIN_DOC + ! Computes v_0 = H|u_0> + ! + ! n : number of determinants + ! + ! H_jj : array of + END_DOC + integer, intent(in) :: N_st,n,Nint, sze_8 + double precision, intent(out) :: v_0(sze_8,N_st) + double precision, intent(in) :: u_0(sze_8,N_st) + double precision, intent(in) :: H_jj(n) + integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) + double precision :: hij + double precision, allocatable :: vt(:,:) + double precision, allocatable :: ut(:,:) + integer :: i,j,k,l, jj,ii + integer :: i0, j0 + + integer, allocatable :: shortcut(:,:), sort_idx(:,:) + integer(bit_kind), allocatable :: sorted(:,:,:), version(:,:,:) + integer(bit_kind) :: sorted_i(Nint) + + integer :: sh, sh2, ni, exa, ext, org_i, org_j, endi, istate + integer :: N_st_8 + + integer, external :: align_double + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: vt, ut + + N_st_8 = align_double(N_st) + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + ASSERT (n>0) + PROVIDE ref_bitmask_energy + + allocate (shortcut(0:n+1,2), sort_idx(n,2), sorted(Nint,n,2), version(Nint,n,2)) + allocate(ut(N_st_8,n)) + + v_0 = 0.d0 + + do i=1,n + do istate=1,N_st + ut(istate,i) = u_0(i,istate) + enddo + enddo + + call sort_dets_ab_v(keys_tmp, sorted(1,1,1), sort_idx(1,1), shortcut(0,1), version(1,1,1), n, Nint) + call sort_dets_ba_v(keys_tmp, sorted(1,1,2), sort_idx(1,2), shortcut(0,2), version(1,1,2), n, Nint) + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(i,hij,j,k,jj,vt,ii,sh,sh2,ni,exa,ext,org_i,org_j,endi,sorted_i,istate)& + !$OMP SHARED(n,H_jj,keys_tmp,ut,Nint,v_0,sorted,shortcut,sort_idx,version,N_st,N_st_8) + allocate(vt(N_st_8,n)) + Vt = 0.d0 + + !$OMP DO SCHEDULE(dynamic) + do sh=1,shortcut(0,1) + do sh2=sh,shortcut(0,1) + exa = 0 + do ni=1,Nint + exa = exa + popcnt(xor(version(ni,sh,1), version(ni,sh2,1))) + end do + if(exa > 2) then + cycle + end if + + do i=shortcut(sh,1),shortcut(sh+1,1)-1 + org_i = sort_idx(i,1) + if(sh==sh2) then + endi = i-1 + else + endi = shortcut(sh2+1,1)-1 + end if + do ni=1,Nint + sorted_i(ni) = sorted(ni,i,1) + enddo + + do j=shortcut(sh2,1),endi + org_j = sort_idx(j,1) + ext = exa + do ni=1,Nint + ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) + end do + if(ext <= 4) then + call i_H_j(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),Nint,hij) + do istate=1,N_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,org_j) + vt (istate,org_j) = vt (istate,org_j) + hij*ut(istate,org_i) + enddo + endif + enddo + enddo + enddo + enddo + !$OMP END DO NOWAIT + + !$OMP DO SCHEDULE(dynamic) + do sh=1,shortcut(0,2) + do i=shortcut(sh,2),shortcut(sh+1,2)-1 + org_i = sort_idx(i,2) + do j=shortcut(sh,2),i-1 + org_j = sort_idx(j,2) + ext = 0 + do ni=1,Nint + ext = ext + popcnt(xor(sorted(ni,i,2), sorted(ni,j,2))) + end do + if(ext == 4) then + call i_H_j(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),Nint,hij) + do istate=1,N_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,org_j) + vt (istate,org_j) = vt (istate,org_j) + hij*ut(istate,org_i) + enddo + end if + end do + end do + enddo + !$OMP END DO NOWAIT + + !$OMP CRITICAL + do istate=1,N_st + do i=n,1,-1 + v_0(i,istate) = v_0(i,istate) + vt(istate,i) + enddo + enddo + !$OMP END CRITICAL + + deallocate(vt) + !$OMP END PARALLEL + + do istate=1,N_st + do i=1,n + v_0(i,istate) += H_jj(i) * u_0(i,istate) + enddo + enddo + deallocate (shortcut, sort_idx, sorted, version, ut) +end + +BEGIN_PROVIDER [ double precision, psi_energy, (N_states) ] + implicit none + BEGIN_DOC +! Energy of the current wave function + END_DOC + call u_0_H_u_0(psi_energy,psi_coef,N_det,psi_det,N_int,N_states,psi_det_size) +END_PROVIDER + + +subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) + use bitmasks + use f77_zmq + implicit none + BEGIN_DOC + ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> + ! + ! n : number of determinants + ! + ! H_jj : array of + ! + ! S2_jj : array of + END_DOC + integer, intent(in) :: N_st,n,Nint, sze_8 + double precision, intent(out) :: v_0(sze_8,N_st), s_0(sze_8,N_st) + double precision, intent(in) :: u_0(sze_8,N_st) + double precision, intent(in) :: H_jj(n), S2_jj(n) + integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) + double precision :: hij,s2 + double precision, allocatable :: ut(:,:) + integer :: i,j,k,l, jj,ii + integer :: i0, j0 + + integer, allocatable :: shortcut(:,:), sort_idx(:) + integer(bit_kind), allocatable :: sorted(:,:), version(:,:) + integer(bit_kind) :: sorted_i(Nint) + + integer :: sh, sh2, ni, exa, ext, org_i, org_j, endi, istate + integer :: N_st_8 + + integer, external :: align_double + integer :: blockb, blockb2, istep + double precision :: ave_workload, workload, target_workload_inv + + integer(ZMQ_PTR) :: handler + + if(N_st /= N_states_diag .or. sze_8 < N_det) stop "assert fail in H_S2_u_0_nstates" + N_st_8 = N_st ! align_double(N_st) + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + ASSERT (n>0) + PROVIDE ref_bitmask_energy + + allocate (shortcut(0:n+1,2), sort_idx(n), sorted(Nint,n), version(Nint,n)) + allocate(ut(N_st_8,n)) + + v_0 = 0.d0 + s_0 = 0.d0 + + do i=1,n + do istate=1,N_st + ut(istate,i) = u_0(i,istate) + enddo + enddo + call sort_dets_ab_v(keys_tmp, sorted, sort_idx, shortcut(0,1), version, n, Nint) + call sort_dets_ba_v(keys_tmp, sorted, sort_idx, shortcut(0,2), version, n, Nint) + + blockb = shortcut(0,1) + call davidson_init(handler,n,N_st_8,ut) + + + ave_workload = 0.d0 + do sh=1,shortcut(0,1) + ave_workload += shortcut(0,1) + ave_workload += (shortcut(sh+1,1) - shortcut(sh,1))**2 + do i=sh, shortcut(0,2), shortcut(0,1) + do j=i, min(i, shortcut(0,2)) + ave_workload += (shortcut(j+1,2) - shortcut(j, 2))**2 + end do + end do + enddo + ave_workload = ave_workload/dble(shortcut(0,1)) + target_workload_inv = 0.001d0/ave_workload + + + do sh=1,shortcut(0,1),1 + workload = shortcut(0,1)+dble(shortcut(sh+1,1) - shortcut(sh,1))**2 + do i=sh, shortcut(0,2), shortcut(0,1) + do j=i, min(i, shortcut(0,2)) + workload += (shortcut(j+1,2) - shortcut(j, 2))**2 + end do + end do + istep = 1+ int(workload*target_workload_inv) + do blockb2=0, istep-1 + call davidson_add_task(handler, sh, blockb2, istep) + enddo + enddo + + call davidson_run(handler, v_0, s_0, size(v_0,1)) + + do istate=1,N_st + do i=1,n + v_0(i,istate) = v_0(i,istate) + H_jj(i) * u_0(i,istate) + s_0(i,istate) = s_0(i,istate) + s2_jj(i)* u_0(i,istate) + enddo + enddo + deallocate(shortcut, sort_idx, sorted, version) + deallocate(ut) +end + + + diff --git a/src/Determinants/EZFIO.cfg b/src/Determinants/EZFIO.cfg index afb2644e..0676649e 100644 --- a/src/Determinants/EZFIO.cfg +++ b/src/Determinants/EZFIO.cfg @@ -40,18 +40,6 @@ 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 -interface: ezfio,provider,ocaml -default: 1.e-12 - [threshold_generators] type: Threshold doc: Thresholds on generators (fraction of the norm) @@ -64,12 +52,6 @@ doc: Thresholds on selectors (fraction of the norm) interface: ezfio,provider,ocaml default: 0.999 -[n_states_diag] -type: States_number -doc: n_states_diag -default: 1 -interface: ezfio,provider,ocaml - [n_int] interface: ezfio doc: n_int diff --git a/src/Determinants/H_apply.irp.f b/src/Determinants/H_apply.irp.f index d5b972e4..20eb3e83 100644 --- a/src/Determinants/H_apply.irp.f +++ b/src/Determinants/H_apply.irp.f @@ -192,7 +192,7 @@ subroutine copy_H_apply_buffer_to_wf SOFT_TOUCH N_det psi_det psi_coef logical :: found_duplicates - call remove_duplicates_in_psi_det(found_duplicates) + !call remove_duplicates_in_psi_det(found_duplicates) end subroutine remove_duplicates_in_psi_det(found_duplicates) @@ -306,14 +306,14 @@ subroutine fill_H_apply_buffer_no_selection(n_selected,det_buffer,Nint,iproc) call omp_unset_lock(H_apply_buffer_lock(1,iproc)) end -subroutine push_pt2(zmq_socket_push,pt2,norm_pert,H_pert_diag,N_st,task_id) +subroutine push_pt2(zmq_socket_push,pt2,norm_pert,H_pert_diag,i_generator,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 + integer, intent(in) :: N_st, i_generator double precision, intent(in) :: pt2(N_st), norm_pert(N_st), H_pert_diag(N_st) integer, intent(in) :: task_id integer :: rc @@ -342,6 +342,12 @@ subroutine push_pt2(zmq_socket_push,pt2,norm_pert,H_pert_diag,N_st,task_id) stop 'error' endif + rc = f77_zmq_send( zmq_socket_push, i_generator, 4, ZMQ_SNDMORE) + if (rc /= 4) then + print *, irp_here, 'f77_zmq_send( zmq_socket_push, i_generator, 4, 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)' @@ -357,7 +363,7 @@ subroutine push_pt2(zmq_socket_push,pt2,norm_pert,H_pert_diag,N_st,task_id) ! endif end -subroutine pull_pt2(zmq_socket_pull,pt2,norm_pert,H_pert_diag,N_st,n,task_id) +subroutine pull_pt2(zmq_socket_pull,pt2,norm_pert,H_pert_diag,i_generator,N_st,n,task_id) use f77_zmq implicit none BEGIN_DOC @@ -367,7 +373,7 @@ subroutine pull_pt2(zmq_socket_pull,pt2,norm_pert,H_pert_diag,N_st,n,task_id) 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, intent(out) :: n, i_generator integer :: rc n=0 @@ -385,7 +391,11 @@ subroutine pull_pt2(zmq_socket_pull,pt2,norm_pert,H_pert_diag,N_st,n,task_id) 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)' + print *, '' + print *, '' + print *, '' + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, pt2(1) , 8*N_st, 0)' + print *, rc stop 'error' endif @@ -401,6 +411,12 @@ subroutine pull_pt2(zmq_socket_pull,pt2,norm_pert,H_pert_diag,N_st,n,task_id) stop 'error' endif + rc = f77_zmq_recv( zmq_socket_pull, i_generator, 4, 0) + if (rc /= 4) then + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, i_generator, 4, 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)' diff --git a/src/Determinants/H_apply.template.f b/src/Determinants/H_apply.template.f index bb095ff4..5f59fe84 100644 --- a/src/Determinants/H_apply.template.f +++ b/src/Determinants/H_apply.template.f @@ -11,9 +11,16 @@ subroutine $subroutine_diexc(key_in, key_prev, hole_1,particl_1, hole_2, particl integer(bit_kind), intent(in) :: key_prev(N_int, 2, *) PROVIDE N_int PROVIDE N_det - + $declarations +! print *, "bbbbbbbbbbbbbbb" +! call debug_det(key_in, N_int) +! call debug_det(hole_1, N_int) +! call debug_det(hole_2, N_int) +! call debug_det(particl_1, N_int) +! call debug_det(particl_2, N_int) +! print *, "eeeeeeeeeeeeeeee" highest = 0 do k=1,N_int*bit_kind_size @@ -167,11 +174,6 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl 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 @@ -187,7 +189,7 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl $initialization - + $omp_parallel !$ iproc = omp_get_thread_num() allocate (keys_out(N_int,2,size_max), hole_save(N_int,2), & @@ -432,7 +434,6 @@ subroutine $subroutine_monoexc(key_in, hole_1,particl_1,fock_diag_tmp,i_generato 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 integer(bit_kind) :: key_mask(N_int, 2) @@ -457,11 +458,6 @@ subroutine $subroutine_monoexc(key_in, hole_1,particl_1,fock_diag_tmp,i_generato $check_double_excitation - if (ifirst == 0) then - ifirst=1 -!$ call omp_init_lock(lck) - endif - $initialization $omp_parallel diff --git a/src/Determinants/H_apply_nozmq.template.f b/src/Determinants/H_apply_nozmq.template.f index e5220d49..0c319fe3 100644 --- a/src/Determinants/H_apply_nozmq.template.f +++ b/src/Determinants/H_apply_nozmq.template.f @@ -11,7 +11,6 @@ subroutine $subroutine($params_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 @@ -23,8 +22,6 @@ subroutine $subroutine($params_main) nmax = mod( N_det_generators,nproc ) - !$ call omp_init_lock(lck) - call wall_time(wall_0) iproc = 0 @@ -129,19 +126,18 @@ subroutine $subroutine($params_main) mask(1,1,s_hole ), mask(1,1,s_part ), & fock_diag_tmp, i_generator, iproc $params_post) endif - !$ call omp_set_lock(lck) + !$OMP CRITICAL 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) + !$OMP END CRITICAL enddo !$OMP END DO deallocate( mask, fock_diag_tmp ) !$OMP END PARALLEL - !$ call omp_destroy_lock(lck) $copy_buffer $generate_psi_guess diff --git a/src/Determinants/H_apply_zmq.template.f b/src/Determinants/H_apply_zmq.template.f index c492a739..59544b79 100644 --- a/src/Determinants/H_apply_zmq.template.f +++ b/src/Determinants/H_apply_zmq.template.f @@ -10,9 +10,9 @@ subroutine $subroutine($params_main) $decls_main + integer :: i integer :: i_generator double precision :: wall_0, wall_1 - integer(omp_lock_kind) :: lck integer(bit_kind), allocatable :: mask(:,:,:) integer :: ispin, k integer :: rc @@ -26,35 +26,41 @@ subroutine $subroutine($params_main) integer(ZMQ_PTR) :: zmq_socket_pair integer(ZMQ_PTR) :: zmq_to_qp_run_socket + double precision, allocatable :: pt2_generators(:,:), norm_pert_generators(:,:) + double precision, allocatable :: H_pert_diag_generators(:,:) + double precision :: energy(N_st) + 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) + call zmq_put_psi(zmq_to_qp_run_socket,1,energy,size(energy)) - do i_generator=N_det_generators,1,-1 + do i_generator=1,N_det_generators $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) + allocate ( pt2_generators(N_states,N_det_generators), & + norm_pert_generators(N_states,N_det_generators), & + H_pert_diag_generators(N_states,N_det_generators) ) - !$OMP PARALLEL DEFAULT(private) - !$OMP TASK PRIVATE(rc) - rc = omp_get_thread_num() - call $subroutine_slave_inproc(rc) - !$OMP END TASK - !$OMP TASKWAIT + PROVIDE nproc N_states + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(i) & + !$OMP SHARED(zmq_socket_pair,N_states, pt2_generators, norm_pert_generators, H_pert_diag_generators, n, task_id, i_generator) & + !$OMP num_threads(nproc+1) + i = omp_get_thread_num() + if (i == 0) then + call $subroutine_collector() + integer :: n, task_id + call pull_pt2(zmq_socket_pair, pt2_generators, norm_pert_generators, H_pert_diag_generators, i_generator, size(pt2_generators), n, task_id) + else + call $subroutine_slave_inproc(i) + endif !$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') @@ -62,6 +68,7 @@ subroutine $subroutine($params_main) $copy_buffer $generate_psi_guess + deallocate ( pt2_generators, norm_pert_generators, H_pert_diag_generators) end subroutine $subroutine_slave_tcp(iproc) @@ -129,7 +136,7 @@ subroutine $subroutine_slave(thread, iproc) pt2 = 0.d0 norm_pert = 0.d0 - H_pert_diag = 0.d0 + H_pert_diag = 0.d0 ! Create bit masks for holes and particles do ispin=1,2 @@ -168,8 +175,8 @@ subroutine $subroutine_slave(thread, iproc) 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) + call task_done_to_taskserver(zmq_to_qp_run_socket, worker_id, task_id) + call push_pt2(zmq_socket_push,pt2,norm_pert,H_pert_diag,i_generator,N_st,task_id) enddo @@ -186,7 +193,7 @@ subroutine $subroutine_collector use f77_zmq implicit none BEGIN_DOC -! Collects results from the selection +! Collects results from the selection in an array of generators END_DOC integer :: k, rc @@ -194,7 +201,7 @@ subroutine $subroutine_collector integer(ZMQ_PTR), external :: new_zmq_pull_socket integer(ZMQ_PTR) :: zmq_socket_pull integer*8 :: control, accu - integer :: n, more, task_id + integer :: n, more, task_id, i_generator integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket integer(ZMQ_PTR) :: zmq_to_qp_run_socket @@ -202,22 +209,25 @@ subroutine $subroutine_collector 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)) + double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:) + double precision, allocatable :: pt2_result(:,:), norm_pert_result(:,:), H_pert_diag_result(:,:) + allocate (pt2(N_states), norm_pert(N_states), H_pert_diag(N_states)) + allocate (pt2_result(N_states,N_det_generators), norm_pert_result(N_states,N_det_generators), & + H_pert_diag_result(N_states,N_det_generators)) - pt2 = 0.d0 - norm_pert = 0.d0 - H_pert_diag = 0.d0 + pt2_result = 0.d0 + norm_pert_result = 0.d0 + H_pert_diag_result = 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) + call pull_pt2(zmq_socket_pull, pt2, norm_pert, H_pert_diag, i_generator, 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) + pt2_result(k,i_generator) = pt2(k) + norm_pert_result(k,i_generator) = norm_pert(k) + H_pert_diag_result(k,i_generator) = H_pert_diag(k) enddo accu = accu + 1_8 call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more) @@ -234,9 +244,10 @@ subroutine $subroutine_collector 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) + call push_pt2(socket_result, pt2_result, norm_pert_result, H_pert_diag_result, i_generator, & + N_states*N_det_generators,0) - deallocate ( pt2, norm_pert, H_pert_diag) + deallocate (pt2, norm_pert, H_pert_diag, pt2_result, norm_pert_result, H_pert_diag_result) call end_zmq_pair_socket(socket_result) diff --git a/src/Determinants/README.rst b/src/Determinants/README.rst index bd5c91ab..c6685945 100644 --- a/src/Determinants/README.rst +++ b/src/Determinants/README.rst @@ -15,22 +15,26 @@ Documentation .. by the `update_README.py` script. -`a_operator `_ +`a_operator `_ Needed for diag_H_mat_elem -`abs_psi_coef_max `_ +`abs_psi_coef_max `_ Max and min values of the coefficients -`abs_psi_coef_min `_ +`abs_psi_coef_min `_ Max and min values of the coefficients -`ac_operator `_ +`ac_operator `_ Needed for diag_H_mat_elem +`apply_excitation `_ + Undocumented + + `apply_mono `_ Undocumented @@ -39,12 +43,12 @@ Documentation Energy of the reference bitmask used in Slater rules -`bitstring_to_list_ab `_ +`bitstring_to_list_ab `_ Gives the inidices(+1) of the bits set to 1 in the bit string For alpha/beta determinants -`bitstring_to_list_ab_old `_ +`bitstring_to_list_ab_old `_ Gives the inidices(+1) of the bits set to 1 in the bit string For alpha/beta determinants @@ -82,11 +86,11 @@ Documentation N_states lowest eigenvalues of the CI matrix -`ci_sc2_eigenvectors `_ +`ci_sc2_eigenvectors `_ Eigenvectors/values of the CI matrix -`ci_sc2_electronic_energy `_ +`ci_sc2_electronic_energy `_ Eigenvectors/values of the CI matrix @@ -115,11 +119,11 @@ Documentation Initial guess vectors are not necessarily orthonormal -`connected_to_ref `_ +`connected_to_ref `_ Undocumented -`connected_to_ref_by_mono `_ +`connected_to_ref_by_mono `_ Undocumented @@ -128,11 +132,15 @@ Documentation After calling this subroutine, N_det, psi_det and psi_coef need to be touched -`create_minilist `_ +`create_microlist `_ Undocumented -`create_minilist_find_previous `_ +`create_minilist `_ + Undocumented + + +`create_minilist_find_previous `_ Undocumented @@ -141,11 +149,11 @@ Documentation of alpha and beta determinants -`davidson_converged `_ +`davidson_converged `_ True if the Davidson algorithm is converged -`davidson_criterion `_ +`davidson_criterion `_ Can be : [ energy | residual | both | wall_time | cpu_time | iterations ] @@ -217,7 +225,7 @@ Documentation ||Da||_i \sum_j C_{ij}**2 -`det_coef `_ +`det_coef `_ det_coef @@ -225,7 +233,7 @@ Documentation Undocumented -`det_occ `_ +`det_occ `_ det_occ @@ -241,16 +249,20 @@ Documentation Diagonalization algorithm (Davidson or Lapack) -`diag_h_mat_elem `_ +`diag_h_elements_sc2 `_ + Eigenvectors/values of the CI matrix + + +`diag_h_mat_elem `_ Computes -`diag_h_mat_elem_fock `_ +`diag_h_mat_elem_fock `_ Computes when i is at most a double excitation from a reference. -`diagonalize_ci `_ +`diagonalize_ci `_ Replace the coefficients of the CI states by the coefficients of the eigenstates of the CI matrix @@ -260,11 +272,26 @@ Documentation eigenstates of the CI matrix -`diagonalize_ci_sc2 `_ +`diagonalize_ci_sc2 `_ Replace the coefficients of the CI states_diag by the coefficients of the eigenstates of the CI matrix +`diagonalize_s2 `_ + Diagonalize the S^2 operator within the n_states_diag states required. Notice : the vectors are sorted by increasing S^2 values. + + +`diagonalize_s2_betweenstates `_ + 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 + + `do_mono_excitation `_ Apply the mono excitation operator : a^{dager}_(i_particle) a_(i_hole) of spin = ispin on key_in @@ -282,18 +309,34 @@ Documentation for a given couple of hole/particle excitations i. +`doubly_occ_empty_in_couple `_ + 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 + + +`doubly_occ_empty_in_couple_and_no_hund_elsewhere `_ + 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 + + `expected_s2 `_ Expected value of S2 : S*(S+1) -`fill_h_apply_buffer_no_selection `_ +`fill_h_apply_buffer_no_selection `_ Fill the H_apply buffer with determiants for CISD -`filter_3_highest_electrons `_ - Returns a determinant with only the 3 highest electrons - - `filter_connected `_ Filters out the determinants that are not connected by H .br @@ -306,7 +349,7 @@ Documentation idx(0) is the number of determinants that interact with key1 -`filter_connected_i_h_psi0 `_ +`filter_connected_i_h_psi0 `_ returns the array idx which contains the index of the .br determinants in the array key1 that interact @@ -316,7 +359,7 @@ Documentation idx(0) is the number of determinants that interact with key1 -`filter_connected_i_h_psi0_sc2 `_ +`filter_connected_i_h_psi0_sc2 `_ standard filter_connected_i_H_psi but returns in addition .br the array of the index of the non connected determinants to key1 @@ -348,7 +391,7 @@ Documentation Returns the excitation degree between two determinants -`get_excitation_degree_vector `_ +`get_excitation_degree_vector `_ Applies get_excitation_degree to an array of determinants @@ -364,11 +407,11 @@ Documentation Returns the index of the determinant in the ``psi_det_sorted_bit`` array -`get_mono_excitation `_ +`get_mono_excitation `_ Returns the excitation operator between two singly excited determinants and the phase -`get_occ_from_key `_ +`get_occ_from_key `_ Returns a list of occupation numbers from a bitstring @@ -384,6 +427,19 @@ Documentation Undocumented +`get_uj_s2_ui `_ + returns the matrix elements of S^2 "s2(i,j)" between the "nstates" states + psi_coefs_tmp(:,i) and psi_coefs_tmp(:,j) + + +`getmobiles `_ + Undocumented + + +`give_index_of_doubly_occ_in_active_space `_ + Undocumented + + `h_apply_buffer_allocated `_ Buffer of determinants/coefficients/perturbative energy for H_apply. Uninitialized. Filled by H_apply subroutines. @@ -402,7 +458,7 @@ Documentation Undocumented -`h_u_0 `_ +`h_u_0 `_ Computes v_0 = H|u_0> .br n : number of determinants @@ -410,19 +466,19 @@ Documentation H_jj : array of -`i_h_j `_ +`i_h_j `_ Returns where i and j are determinants -`i_h_j_phase_out `_ +`i_h_j_phase_out `_ Returns where i and j are determinants -`i_h_j_verbose `_ +`i_h_j_verbose `_ Returns where i and j are determinants -`i_h_psi `_ +`i_h_psi `_ Computes = \sum_J c_J . .br Uses filter_connected_i_H_psi0 to get all the |J> to which |i> @@ -431,14 +487,14 @@ Documentation minilists -`i_h_psi_minilist `_ +`i_h_psi_minilist `_ Computes = \sum_J c_J . .br Uses filter_connected_i_H_psi0 to get all the |J> to which |i> is connected. The |J> are searched in short pre-computed lists. -`i_h_psi_sc2 `_ +`i_h_psi_sc2 `_ for the various Nstate .br returns in addition @@ -452,7 +508,7 @@ Documentation to repeat the excitations -`i_h_psi_sc2_verbose `_ +`i_h_psi_sc2_verbose `_ for the various Nstate .br returns in addition @@ -466,7 +522,7 @@ Documentation to repeat the excitations -`i_h_psi_sec_ord `_ +`i_h_psi_sec_ord `_ for the various Nstates @@ -481,19 +537,11 @@ Documentation idx_non_cas gives the indice of the determinant in psi_det. -`int_of_3_highest_electrons `_ - Returns an integer*8 as : - .br - |_<--- 21 bits ---><--- 21 bits ---><--- 21 bits --->| - .br - |0<--- i1 ---><--- i2 ---><--- i3 --->| - .br - It encodes the value of the indices of the 3 highest MOs - in descending order - .br +`is_connected_to `_ + Undocumented -`is_connected_to `_ +`is_connected_to_by_mono `_ Undocumented @@ -517,6 +565,14 @@ Documentation Energy of the reference bitmask used in Slater rules +`n_closed_shell `_ + Undocumented + + +`n_closed_shell_cas `_ + Undocumented + + `n_det `_ Number of determinants in the wave function @@ -534,15 +590,15 @@ Documentation determinants. idx_cas gives the indice of the CAS determinant in psi_det. -`n_det_max `_ +`n_det_max `_ Max number of determinants in the wave function -`n_det_max_jacobi `_ +`n_det_max_jacobi `_ Maximum number of determinants diagonalized by Jacobi -`n_det_max_property `_ +`n_det_max_property `_ Max number of determinants in the wave function when you select for a given property @@ -562,11 +618,15 @@ Documentation psi_occ_pattern(:,2,j) = jth occ_pattern of the wave function : represent all the double occupation +`n_open_shell `_ + Undocumented + + `n_single_exc_bitmasks `_ Number of single excitation bitmasks -`n_states `_ +`n_states `_ Number of states to consider @@ -574,6 +634,16 @@ Documentation Number of states to consider for the diagonalization +`neutral_no_hund_in_couple `_ + 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 + + `nucl_elec_ref_bitmask_energy `_ Energy of the reference bitmask used in Slater rules @@ -590,7 +660,15 @@ Documentation Number of possible determinants for a given occ_pattern -`one_body_dm_mo `_ +`one_body_dm_ao_alpha `_ + one body density matrix on the AO basis : rho_AO(alpha) , rho_AO(beta) + + +`one_body_dm_ao_beta `_ + one body density matrix on the AO basis : rho_AO(alpha) , rho_AO(beta) + + +`one_body_dm_mo `_ One-body density matrix @@ -602,19 +680,23 @@ Documentation Alpha and beta one-body density matrix for each state -`one_body_single_double_dm_mo_alpha `_ +`one_body_single_double_dm_mo_alpha `_ Alpha and beta one-body density matrix for each state -`one_body_single_double_dm_mo_beta `_ +`one_body_single_double_dm_mo_beta `_ Alpha and beta one-body density matrix for each state -`one_body_spin_density_mo `_ +`one_body_spin_density_ao `_ + one body spin density matrix on the AO basis : rho_AO(alpha) - rho_AO(beta) + + +`one_body_spin_density_mo `_ rho(alpha) - rho(beta) -`only_single_double_dm `_ +`only_single_double_dm `_ If true, The One body DM is calculated with ignoring the Double<->Doubles extra diag elements @@ -683,11 +765,11 @@ Documentation Undocumented -`psi_coef_max `_ +`psi_coef_max `_ Max and min values of the coefficients -`psi_coef_min `_ +`psi_coef_min `_ Max and min values of the coefficients @@ -695,13 +777,6 @@ Documentation Wave function sorted by determinants contribution to the norm (state-averaged) -`psi_coef_sorted_ab `_ - 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. - - `psi_coef_sorted_bit `_ Determinants on which we apply for perturbation. They are sorted by determinants interpreted as integers. Useful @@ -738,13 +813,6 @@ Documentation Wave function sorted by determinants contribution to the norm (state-averaged) -`psi_det_sorted_ab `_ - 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. - - `psi_det_sorted_bit `_ Determinants on which we apply for perturbation. They are sorted by determinants interpreted as integers. Useful @@ -752,13 +820,6 @@ Documentation function. -`psi_det_sorted_next_ab `_ - 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. - - `psi_non_cas `_ Set of determinants which are not part of the CAS, defined from the application of the CAS bitmask on the determinants. @@ -787,15 +848,23 @@ Documentation psi_occ_pattern(:,2,j) = jth occ_pattern of the wave function : represent all the double occupation +`pull_pt2 `_ + Pull PT2 calculation in the collector + + +`push_pt2 `_ + Push PT2 calculation to the collector + + `put_gess `_ Undocumented -`read_dets `_ +`read_dets `_ Reads the determinants from the EZFIO file -`read_wf `_ +`read_wf `_ If true, read the wave function from the EZFIO file @@ -816,7 +885,7 @@ Documentation be set before calling this function. -`s2_eig `_ +`s2_eig `_ Force the wave function to be an eigenfunction of S^2 @@ -832,27 +901,35 @@ Documentation z component of the Spin +`save_hf `_ + Undocumented + + `save_natorb `_ Undocumented -`save_natural_mos `_ +`save_natural_mos `_ Save natural orbitals, obtained by diagonalization of the one-body density matrix in the MO basis -`save_wavefunction `_ +`save_ref_determinant `_ + Undocumented + + +`save_wavefunction `_ Save the wave function into the EZFIO file -`save_wavefunction_general `_ +`save_wavefunction_general `_ Save the wave function into the EZFIO file -`save_wavefunction_specified `_ +`save_wavefunction_specified `_ Save the wave function into the EZFIO file -`save_wavefunction_unsorted `_ +`save_wavefunction_unsorted `_ Save the wave function into the EZFIO file @@ -860,7 +937,7 @@ Documentation Undocumented -`set_natural_mos `_ +`set_natural_mos `_ Set natural orbitals, obtained by diagonalization of the one-body density matrix in the MO basis @@ -882,13 +959,6 @@ Documentation Uncodumented : TODO -`sort_dets_by_3_highest_electrons `_ - 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. - - `sort_dets_by_det_search_key `_ Determinants are sorted are sorted according to their det_search_key. Useful to accelerate the search of a random determinant in the wave @@ -899,7 +969,7 @@ Documentation Return an integer*8 corresponding to a determinant index for searching -`state_average_weight `_ +`state_average_weight `_ Weights in the state-average calculation of the density matrix @@ -907,7 +977,7 @@ Documentation Uncodumented : TODO -`target_energy `_ +`target_energy `_ Energy that should be obtained when truncating the wave function (optional) @@ -915,11 +985,11 @@ Documentation convergence of the correlation energy of SC2 iterations -`threshold_davidson `_ +`threshold_davidson `_ Thresholds of Davidson's algorithm -`threshold_generators `_ +`threshold_generators `_ Thresholds on generators (fraction of the norm) @@ -927,6 +997,13 @@ Documentation Thresholds on selectors (fraction of the norm) +`u0_h_u_0 `_ + Computes e_0 = / + .br + n : number of determinants + .br + + `write_spindeterminants `_ Undocumented diff --git a/src/Determinants/SC2.irp.f b/src/Determinants/SC2.irp.f deleted file mode 100644 index 4f321b87..00000000 --- a/src/Determinants/SC2.irp.f +++ /dev/null @@ -1,216 +0,0 @@ -subroutine CISD_SC2(dets_in,u_in,energies,diag_H_elements,dim_in,sze,N_st,Nint,convergence) - use bitmasks - implicit none - BEGIN_DOC - ! CISD+SC2 method :: take off all the disconnected terms of a CISD (selected or not) - ! - ! dets_in : bitmasks corresponding to determinants - ! - ! u_in : guess coefficients on the various states. Overwritten - ! on exit - ! - ! dim_in : leftmost dimension of u_in - ! - ! sze : Number of determinants - ! - ! N_st : Number of eigenstates - ! - ! Initial guess vectors are not necessarily orthonormal - END_DOC - integer, intent(in) :: dim_in, sze, N_st, Nint - integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) - double precision, intent(inout) :: u_in(dim_in,N_st) - double precision, intent(out) :: energies(N_st) - double precision, intent(out) :: diag_H_elements(dim_in) - double precision, intent(in) :: convergence - ASSERT (N_st > 0) - ASSERT (sze > 0) - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - integer :: iter - integer :: i,j,k,l,m - logical :: converged - double precision :: overlap(N_st,N_st) - double precision :: u_dot_v, u_dot_u - - integer :: degree,N_double,index_hf - double precision :: hij_elec, e_corr_double,e_corr,diag_h_mat_elem,inv_c0 - double precision :: e_corr_double_before,accu,cpu_2,cpu_1 - integer,allocatable :: degree_exc(:), index_double(:) - integer :: i_ok - double precision,allocatable :: e_corr_array(:),H_jj_ref(:),H_jj_dressed(:),hij_double(:) - integer(bit_kind), allocatable :: doubles(:,:,:) - - - allocate (doubles(Nint,2,sze),e_corr_array(sze),H_jj_ref(sze),H_jj_dressed(sze),& - index_double(sze), degree_exc(sze), hij_double(sze)) - call write_time(output_determinants) - write(output_determinants,'(A)') '' - write(output_determinants,'(A)') 'CISD SC2' - write(output_determinants,'(A)') '========' - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP SHARED(sze,N_st, & - !$OMP H_jj_ref,Nint,dets_in,u_in) & - !$OMP PRIVATE(i) - - !$OMP DO SCHEDULE(guided) - do i=1,sze - H_jj_ref(i) = diag_h_mat_elem(dets_in(1,1,i),Nint) - enddo - !$OMP END DO NOWAIT - !$OMP END PARALLEL - - N_double = 0 - e_corr = 0.d0 - e_corr_double = 0.d0 - do i = 1, sze - call get_excitation_degree(ref_bitmask,dets_in(1,1,i),degree,Nint) - degree_exc(i) = degree+1 - if(degree==0)then - index_hf=i - else if (degree == 2)then - N_double += 1 - index_double(N_double) = i - doubles(:,:,N_double) = dets_in(:,:,i) - call i_H_j(ref_bitmask,dets_in(1,1,i),Nint,hij_elec) - hij_double(N_double) = hij_elec - e_corr_array(N_double) = u_in(i,1)* hij_elec - e_corr_double += e_corr_array(N_double) - e_corr += e_corr_array(N_double) - else if (degree == 1)then - call i_H_j(ref_bitmask,dets_in(1,1,i),Nint,hij_elec) - e_corr += u_in(i,1)* hij_elec - endif - enddo - inv_c0 = 1.d0/u_in(index_hf,1) - do i = 1, N_double - e_corr_array(i) = e_corr_array(i) * inv_c0 - enddo - e_corr = e_corr * inv_c0 - e_corr_double = e_corr_double * inv_c0 - converged = .False. - e_corr_double_before = e_corr_double - iter = 0 - do while (.not.converged) - iter +=1 - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(i,j,degree,accu) & - !$OMP SHARED(H_jj_dressed,sze,H_jj_ref,index_hf,N_int,N_double,& - !$OMP dets_in,doubles,degree_exc,e_corr_array,e_corr_double) - !$OMP DO SCHEDULE(STATIC) - do i=1,sze - H_jj_dressed(i) = H_jj_ref(i) - if (i==index_hf)cycle - accu = -e_corr_double - select case (N_int) - case (1) - do j=1,N_double - degree = & - popcnt(xor( dets_in(1,1,i),doubles(1,1,j))) + & - popcnt(xor( dets_in(1,2,i),doubles(1,2,j))) - - if (degree<=ishft(degree_exc(i),1)) then - accu += e_corr_array(j) - endif - enddo - case (2) - do j=1,N_double - degree = & - popcnt(xor( dets_in(1,1,i),doubles(1,1,j))) + & - popcnt(xor( dets_in(1,2,i),doubles(1,2,j))) + & - popcnt(xor( dets_in(2,1,i),doubles(2,1,j))) + & - popcnt(xor( dets_in(2,2,i),doubles(2,2,j))) - - if (degree<=ishft(degree_exc(i),1)) then - accu += e_corr_array(j) - endif - enddo - case (3) - do j=1,N_double - degree = & - popcnt(xor( dets_in(1,1,i),doubles(1,1,j))) + & - popcnt(xor( dets_in(1,2,i),doubles(1,2,j))) + & - popcnt(xor( dets_in(2,1,i),doubles(2,1,j))) + & - popcnt(xor( dets_in(2,2,i),doubles(2,2,j))) + & - popcnt(xor( dets_in(3,1,i),doubles(3,1,j))) + & - popcnt(xor( dets_in(3,2,i),doubles(3,2,j))) - - if (degree<=ishft(degree_exc(i),1)) then - accu += e_corr_array(j) - endif - enddo - case default - do j=1,N_double - call get_excitation_degree(dets_in(1,1,i),doubles(1,1,j),degree,N_int) - if (degree<=degree_exc(i)) then - accu += e_corr_array(j) - endif - enddo - end select - H_jj_dressed(i) -= accu - enddo - !$OMP END DO - !$OMP END PARALLEL - - if(sze<=N_det_max_jacobi)then - double precision, allocatable :: eigenvectors(:,:), eigenvalues(:),H_matrix_tmp(:,:) - allocate (H_matrix_tmp(size(H_matrix_all_dets,1),sze),eigenvalues(sze),eigenvectors(size(H_matrix_all_dets,1),sze)) - do j=1,sze - do i=1,sze - H_matrix_tmp(i,j) = H_matrix_all_dets(i,j) - enddo - enddo - do i = 1,sze - H_matrix_tmp(i,i) = H_jj_dressed(i) - enddo - call lapack_diag(eigenvalues,eigenvectors, & - H_matrix_tmp,size(H_matrix_all_dets,1),sze) - do j=1,min(N_states_diag,sze) - do i=1,sze - u_in(i,j) = eigenvectors(i,j) - enddo - energies(j) = eigenvalues(j) - enddo - deallocate (H_matrix_tmp, eigenvalues, eigenvectors) - else - call davidson_diag_hjj(dets_in,u_in,H_jj_dressed,energies,dim_in,sze,N_st,Nint,output_determinants) - endif - - e_corr_double = 0.d0 - inv_c0 = 1.d0/u_in(index_hf,1) - do i = 1, N_double - e_corr_array(i) = u_in(index_double(i),1)*inv_c0 * hij_double(i) - e_corr_double += e_corr_array(i) - enddo - write(output_determinants,'(A,I3)') 'SC2 Iteration ', iter - write(output_determinants,'(A)') '------------------' - write(output_determinants,'(A)') '' - write(output_determinants,'(A)') '===== ================' - write(output_determinants,'(A)') 'State Energy ' - write(output_determinants,'(A)') '===== ================' - do i=1,N_st - 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 - if (converged) then - do i = 1, dim_in - diag_H_elements(i) = H_jj_dressed(i) - H_jj_ref(i) - enddo - exit - endif - e_corr_double_before = e_corr_double - - enddo - - call write_time(output_determinants) - deallocate (doubles,e_corr_array,H_jj_ref,H_jj_dressed, & - index_double, degree_exc, hij_double) - -end - - diff --git a/src/Determinants/connected_to_ref.irp.f b/src/Determinants/connected_to_ref.irp.f index 7a54bdbc..9aa7f631 100644 --- a/src/Determinants/connected_to_ref.irp.f +++ b/src/Determinants/connected_to_ref.irp.f @@ -109,8 +109,6 @@ integer function get_index_in_psi_det_sorted_bit(key,Nint) continue else in_wavefunction = .True. - !DIR$ IVDEP - !DIR$ LOOP COUNT MIN(3) do l=2,Nint if ( (key(l,1) /= psi_det_sorted_bit(l,1,i)).or. & (key(l,2) /= psi_det_sorted_bit(l,2,i)) ) then @@ -165,7 +163,7 @@ logical function is_connected_to(key,keys,Nint,Ndet) integer :: i, l integer :: degree_x2 - + logical, external :: is_generable_cassd ASSERT (Nint > 0) ASSERT (Nint == N_int) @@ -175,7 +173,6 @@ logical function is_connected_to(key,keys,Nint,Ndet) 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))) @@ -183,12 +180,35 @@ logical function is_connected_to(key,keys,Nint,Ndet) if (degree_x2 > 4) then cycle else +! if(.not. is_generable_cassd(keys(1,1,i), key(1,1), Nint)) cycle !!!Nint==1 !!!!! is_connected_to = .true. return endif enddo end + +logical function is_generable_cassd(det1, det2, Nint) !!! TEST Cl HARD !!!!! + use bitmasks + implicit none + integer, intent(in) :: Nint + integer(bit_kind) :: det1(Nint, 2), det2(Nint, 2) + integer :: degree, f, exc(0:2, 2, 2), h1, h2, p1, p2, s1, s2, t + double precision :: phase + + is_generable_cassd = .false. + call get_excitation(det1, det2, exc, degree, phase, Nint) + if(degree == -1) return + if(degree == 0) then + is_generable_cassd = .true. + return + end if + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + if(degree == 1 .and. h1 <= 11) is_generable_cassd = .true. + if(degree == 2 .and. h1 <= 11 .and. h2 <= 11) is_generable_cassd = .true. +end function + + logical function is_connected_to_by_mono(key,keys,Nint,Ndet) use bitmasks implicit none @@ -208,7 +228,6 @@ logical function is_connected_to_by_mono(key,keys,Nint,Ndet) 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))) @@ -302,10 +321,12 @@ integer function connected_to_ref(key,keys,Nint,N_past_in,Ndet) do i=N_past-1,1,-1 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))) + if (degree_x2 > 4) then + exit + endif enddo if (degree_x2 > 4) then cycle @@ -406,7 +427,6 @@ integer function connected_to_ref_by_mono(key,keys,Nint,N_past_in,Ndet) do i=N_past-1,1,-1 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))) diff --git a/src/Determinants/determinants.irp.f b/src/Determinants/determinants.irp.f index a7727cda..39b0f58e 100644 --- a/src/Determinants/determinants.irp.f +++ b/src/Determinants/determinants.irp.f @@ -1,5 +1,22 @@ use bitmasks +BEGIN_PROVIDER [ character*(64), diag_algorithm ] + implicit none + BEGIN_DOC + ! Diagonalization algorithm (Davidson or Lapack) + END_DOC + if (N_det > N_det_max_jacobi) then + diag_algorithm = "Davidson" + else + diag_algorithm = "Lapack" + endif + + if (N_det < N_states) then + diag_algorithm = "Lapack" + endif +END_PROVIDER + + BEGIN_PROVIDER [ integer, N_det ] implicit none BEGIN_DOC @@ -73,6 +90,7 @@ BEGIN_PROVIDER [ integer(bit_kind), psi_det, (N_int,2,psi_det_size) ] logical :: exists character*64 :: label + psi_det = 0_bit_kind if (read_wf) then call ezfio_has_determinants_N_int(exists) if (exists) then @@ -225,7 +243,7 @@ END_PROVIDER END_PROVIDER -BEGIN_PROVIDER [ double precision, psi_coef, (psi_det_size,N_states_diag) ] +BEGIN_PROVIDER [ double precision, psi_coef, (psi_det_size,N_states) ] implicit none BEGIN_DOC ! The wave function coefficients. Initialized with Hartree-Fock if the EZFIO file @@ -238,7 +256,7 @@ BEGIN_PROVIDER [ double precision, psi_coef, (psi_det_size,N_states_diag) ] character*(64) :: label psi_coef = 0.d0 - do i=1,N_states_diag + do i=1,min(N_states,psi_det_size) psi_coef(i,i) = 1.d0 enddo @@ -288,6 +306,10 @@ BEGIN_PROVIDER [ double precision, psi_average_norm_contrib, (psi_det_size) ] psi_coef(i,k)*psi_coef(i,k)*f enddo enddo + f = 1.d0/sum(psi_average_norm_contrib(1:N_det)) + do i=1,N_det + psi_average_norm_contrib(i) = psi_average_norm_contrib(i)*f + enddo END_PROVIDER @@ -314,7 +336,6 @@ END_PROVIDER iorder(i) = i enddo call dsort(psi_average_norm_contrib_sorted,iorder,N_det) - !DIR$ IVDEP do i=1,N_det do j=1,N_int psi_det_sorted(j,1,i) = psi_det(j,1,iorder(i)) @@ -330,6 +351,24 @@ END_PROVIDER END_PROVIDER +subroutine flip_generators() + integer :: i,j,k + integer(bit_kind) :: detmp(N_int,2) + double precision :: tmp(N_states) + + do i=1,N_det_generators/2 + detmp(:,:) = psi_det_sorted(:,:,i) + tmp = psi_coef_sorted(i, :) + psi_det_sorted(:,:,i) = psi_det_sorted(:,:,N_det_generators+1-i) + psi_coef_sorted(i, :) = psi_coef_sorted(N_det_generators+1-i, :) + + psi_det_sorted(:,:,N_det_generators+1-i) = detmp(:,:) + psi_coef_sorted(N_det_generators+1-i, :) = tmp + end do + + TOUCH psi_det_sorted psi_coef_sorted psi_average_norm_contrib_sorted +end subroutine + BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_bit, (N_int,2,psi_det_size) ] &BEGIN_PROVIDER [ double precision, psi_coef_sorted_bit, (psi_det_size,N_states) ] implicit none @@ -664,3 +703,194 @@ subroutine save_wavefunction_specified(ndet,nstates,psidet,psicoef,ndetsave,inde end +logical function detEq(a,b,Nint) + use bitmasks + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: a(Nint,2), b(Nint,2) + integer :: ni, i + + detEq = .false. + do i=1,2 + do ni=1,Nint + if(a(ni,i) /= b(ni,i)) return + end do + end do + detEq = .true. +end function + + +integer function detCmp(a,b,Nint) + use bitmasks + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: a(Nint,2), b(Nint,2) + integer :: ni, i + + detCmp = 0 + do i=1,2 + do ni=Nint,1,-1 + + if(a(ni,i) < b(ni,i)) then + detCmp = -1 + return + else if(a(ni,i) > b(ni,i)) then + detCmp = 1 + return + end if + + end do + end do +end function + + +subroutine apply_excitation(det, exc, res, ok, Nint) + use bitmasks + implicit none + + integer, intent(in) :: Nint + integer, intent(in) :: exc(0:2,2,2) + integer(bit_kind),intent(in) :: det(Nint, 2) + integer(bit_kind),intent(out) :: res(Nint, 2) + logical, intent(out) :: ok + integer :: h1,p1,h2,p2,s1,s2,degree + integer :: ii, pos + + + ok = .false. + degree = exc(0,1,1) + exc(0,1,2) + + if(.not. (degree > 0 .and. degree <= 2)) then + print *, degree + print *, "apply ex" + STOP + endif + + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + res = det + + ii = (h1-1)/bit_kind_size + 1 + pos = mod(h1-1, 64)!iand(h1-1,bit_kind_size-1) ! mod 64 + if(iand(det(ii, s1), ishft(1_bit_kind, pos)) == 0_8) return + res(ii, s1) = ibclr(res(ii, s1), pos) + + ii = (p1-1)/bit_kind_size + 1 + pos = mod(p1-1, 64)!iand(p1-1,bit_kind_size-1) + if(iand(det(ii, s1), ishft(1_bit_kind, pos)) /= 0_8) return + res(ii, s1) = ibset(res(ii, s1), pos) + + if(degree == 2) then + ii = (h2-1)/bit_kind_size + 1 + pos = mod(h2-1, 64)!iand(h2-1,bit_kind_size-1) + if(iand(det(ii, s2), ishft(1_bit_kind, pos)) == 0_8) return + res(ii, s2) = ibclr(res(ii, s2), pos) + + ii = (p2-1)/bit_kind_size + 1 + pos = mod(p2-1, 64)!iand(p2-1,bit_kind_size-1) + if(iand(det(ii, s2), ishft(1_bit_kind, pos)) /= 0_8) return + res(ii, s2) = ibset(res(ii, s2), pos) + endif + + ok = .true. +end subroutine + + +subroutine apply_particles(det, s1, p1, s2, p2, res, ok, Nint) + use bitmasks + implicit none + integer, intent(in) :: Nint + integer, intent(in) :: s1, p1, s2, p2 + integer(bit_kind),intent(in) :: det(Nint, 2) + integer(bit_kind),intent(out) :: res(Nint, 2) + logical, intent(out) :: ok + integer :: ii, pos + + ok = .false. + res = det + + if(p1 /= 0) then + ii = (p1-1)/bit_kind_size + 1 + pos = mod(p1-1, 64)!iand(p1-1,bit_kind_size-1) + if(iand(det(ii, s1), ishft(1_bit_kind, pos)) /= 0_8) return + res(ii, s1) = ibset(res(ii, s1), pos) + end if + + ii = (p2-1)/bit_kind_size + 1 + pos = mod(p2-1, 64)!iand(p2-1,bit_kind_size-1) + if(iand(det(ii, s2), ishft(1_bit_kind, pos)) /= 0_8) return + res(ii, s2) = ibset(res(ii, s2), pos) + + ok = .true. +end subroutine + + +subroutine apply_holes(det, s1, h1, s2, h2, res, ok, Nint) + use bitmasks + implicit none + integer, intent(in) :: Nint + integer, intent(in) :: s1, h1, s2, h2 + integer(bit_kind),intent(in) :: det(Nint, 2) + integer(bit_kind),intent(out) :: res(Nint, 2) + logical, intent(out) :: ok + integer :: ii, pos + + ok = .false. + res = det + + if(h1 /= 0) then + ii = (h1-1)/bit_kind_size + 1 + pos = mod(h1-1, 64)!iand(h1-1,bit_kind_size-1) + if(iand(det(ii, s1), ishft(1_bit_kind, pos)) == 0_8) return + res(ii, s1) = ibclr(res(ii, s1), pos) + end if + + ii = (h2-1)/bit_kind_size + 1 + pos = mod(h2-1, 64)!iand(h2-1,bit_kind_size-1) + if(iand(det(ii, s2), ishft(1_bit_kind, pos)) == 0_8) return + res(ii, s2) = ibclr(res(ii, s2), pos) + + ok = .true. +end subroutine + +subroutine apply_particle(det, s1, p1, res, ok, Nint) + use bitmasks + implicit none + integer, intent(in) :: Nint + integer, intent(in) :: s1, p1 + integer(bit_kind),intent(in) :: det(Nint, 2) + integer(bit_kind),intent(out) :: res(Nint, 2) + logical, intent(out) :: ok + integer :: ii, pos + + ok = .false. + res = det + + ii = (p1-1)/bit_kind_size + 1 + pos = mod(p1-1, 64)!iand(p1-1,bit_kind_size-1) + if(iand(det(ii, s1), ishft(1_bit_kind, pos)) /= 0_8) return + res(ii, s1) = ibset(res(ii, s1), pos) + + ok = .true. +end subroutine + + +subroutine apply_hole(det, s1, h1, res, ok, Nint) + use bitmasks + implicit none + integer, intent(in) :: Nint + integer, intent(in) :: s1, h1 + integer(bit_kind),intent(in) :: det(Nint, 2) + integer(bit_kind),intent(out) :: res(Nint, 2) + logical, intent(out) :: ok + integer :: ii, pos + + ok = .false. + res = det + + ii = (h1-1)/bit_kind_size + 1 + pos = mod(h1-1, 64)!iand(h1-1,bit_kind_size-1) + if(iand(det(ii, s1), ishft(1_bit_kind, pos)) == 0_8) return + res(ii, s1) = ibclr(res(ii, s1), pos) + + ok = .true. +end subroutine diff --git a/src/Determinants/diagonalize_CI.irp.f b/src/Determinants/diagonalize_CI.irp.f deleted file mode 100644 index 6f94eedb..00000000 --- a/src/Determinants/diagonalize_CI.irp.f +++ /dev/null @@ -1,278 +0,0 @@ -BEGIN_PROVIDER [ character*(64), diag_algorithm ] - implicit none - BEGIN_DOC - ! Diagonalization algorithm (Davidson or Lapack) - END_DOC - if (N_det > N_det_max_jacobi) then - diag_algorithm = "Davidson" - else - diag_algorithm = "Lapack" - endif - - if (N_det < N_states_diag) then - diag_algorithm = "Lapack" - endif - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, CI_energy, (N_states_diag) ] - implicit none - BEGIN_DOC - ! N_states lowest eigenvalues of the CI matrix - END_DOC - - integer :: j - character*(8) :: st - call write_time(output_determinants) - do j=1,N_states_diag - CI_energy(j) = CI_electronic_energy(j) + nuclear_repulsion - write(st,'(I4)') j - call write_double(output_determinants,CI_energy(j),'Energy of state '//trim(st)) - call write_double(output_determinants,CI_eigenvectors_s2(j),'S^2 of state '//trim(st)) - enddo - -END_PROVIDER - - BEGIN_PROVIDER [ double precision, CI_expectation_value, (N_states_diag) ] - implicit none - integer :: i - do i = 1, N_states - call u0_H_u_0(CI_expectation_value(i),psi_coef(1,i),n_det,psi_det,N_int) - enddo - END_PROVIDER - - BEGIN_PROVIDER [ double precision, CI_electronic_energy, (N_states_diag) ] -&BEGIN_PROVIDER [ double precision, CI_eigenvectors, (N_det,N_states_diag) ] -&BEGIN_PROVIDER [ double precision, CI_eigenvectors_s2, (N_states_diag) ] - BEGIN_DOC - ! Eigenvectors/values of the CI matrix - END_DOC - implicit none - double precision :: ovrlp,u_dot_v - integer :: i_good_state - integer, allocatable :: index_good_state_array(:) - logical, allocatable :: good_state_array(:) - double precision, allocatable :: s2_values_tmp(:) - integer :: i_other_state - double precision, allocatable :: eigenvectors(:,:), eigenvalues(:) - integer :: i_state - double precision :: s2,e_0 - integer :: i,j,k - double precision, allocatable :: s2_eigvalues(:) - double precision, allocatable :: e_array(:) - integer, allocatable :: iorder(:) - - ! Guess values for the "N_states_diag" states of the CI_eigenvectors - do j=1,min(N_states_diag,N_det) - do i=1,N_det - CI_eigenvectors(i,j) = psi_coef(i,j) - enddo - enddo - - do j=N_det+1,N_states_diag - do i=1,N_det - CI_eigenvectors(i,j) = 0.d0 - enddo - enddo - - if (diag_algorithm == "Davidson") then - - call davidson_diag(psi_det,CI_eigenvectors,CI_electronic_energy, & - size(CI_eigenvectors,1),N_det,N_states_diag,N_int,output_determinants) - do j=1,N_states_diag - call get_s2_u0(psi_det,CI_eigenvectors(1,j),N_det,size(CI_eigenvectors,1),CI_eigenvectors_s2(j)) - enddo - - - else if (diag_algorithm == "Lapack") then - - allocate (eigenvectors(size(H_matrix_all_dets,1),N_det)) - allocate (eigenvalues(N_det)) - call lapack_diag(eigenvalues,eigenvectors, & - H_matrix_all_dets,size(H_matrix_all_dets,1),N_det) - CI_electronic_energy(:) = 0.d0 - if (s2_eig) then - i_state = 0 - allocate (s2_eigvalues(N_det)) - allocate(index_good_state_array(N_det),good_state_array(N_det)) - good_state_array = .False. - do j=1,N_det - call get_s2_u0(psi_det,eigenvectors(1,j),N_det,size(eigenvectors,1),s2) - s2_eigvalues(j) = s2 - print*, eigenvalues(j) + nuclear_repulsion - ! Select at least n_states states with S^2 values closed to "expected_s2" - if(dabs(s2-expected_s2).le.0.3d0)then - i_state +=1 - index_good_state_array(i_state) = j - good_state_array(j) = .True. - endif - if(i_state.eq.N_states) then - exit - endif - enddo - if(i_state .ne.0)then - ! Fill the first "i_state" states that have a correct S^2 value - do j = 1, i_state - do i=1,N_det - CI_eigenvectors(i,j) = eigenvectors(i,index_good_state_array(j)) - enddo - CI_electronic_energy(j) = eigenvalues(index_good_state_array(j)) - CI_eigenvectors_s2(j) = s2_eigvalues(index_good_state_array(j)) - enddo - i_other_state = 0 - do j = 1, N_det - if(good_state_array(j))cycle - i_other_state +=1 - if(i_state+i_other_state.gt.n_states_diag)then - exit - endif - call get_s2_u0(psi_det,eigenvectors(1,j),N_det,size(eigenvectors,1),s2) - do i=1,N_det - CI_eigenvectors(i,i_state+i_other_state) = eigenvectors(i,j) - enddo - CI_electronic_energy(i_state+i_other_state) = eigenvalues(j) - CI_eigenvectors_s2(i_state+i_other_state) = s2 - enddo - - deallocate(index_good_state_array,good_state_array) - - else - print*,'' - print*,'!!!!!!!! WARNING !!!!!!!!!' - print*,' Within the ',N_det,'determinants selected' - print*,' and the ',N_states_diag,'states requested' - print*,' We did not find any state with S^2 values close to ',expected_s2 - print*,' We will then set the first N_states eigenvectors of the H matrix' - print*,' as the CI_eigenvectors' - print*,' You should consider more states and maybe ask for diagonalize_s2 to be .True. or just enlarge the CI space' - print*,'' - do j=1,min(N_states_diag,N_det) - do i=1,N_det - CI_eigenvectors(i,j) = eigenvectors(i,j) - enddo - CI_electronic_energy(j) = eigenvalues(j) - CI_eigenvectors_s2(j) = s2_eigvalues(j) - enddo - endif - deallocate(s2_eigvalues) - else - ! Select the "N_states_diag" states of lowest energy - do j=1,min(N_det,N_states_diag) - call get_s2_u0(psi_det,eigenvectors(1,j),N_det,N_det,s2) - do i=1,N_det - CI_eigenvectors(i,j) = eigenvectors(i,j) - enddo - CI_electronic_energy(j) = eigenvalues(j) - CI_eigenvectors_s2(j) = s2 - enddo - endif - deallocate(eigenvectors,eigenvalues) - endif - - if(diagonalize_s2.and.n_states_diag > 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 - 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 = 2, N_states_diag - if(store_full_H_mat.and.n_det.le.n_det_max_stored)then - call u_0_H_u_0_stored(e_0,CI_eigenvectors(1,j),H_matrix_all_dets,n_det) - else - call u0_H_u_0(e_0,CI_eigenvectors(1,j),n_det,psi_det,N_int) - endif - e_array(j) = e_0 - iorder(j) = j - enddo - call dsort(e_array,iorder,n_states_diag) - do j = 2, 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 - implicit none - BEGIN_DOC -! Replace the coefficients of the CI states by the coefficients of the -! eigenstates of the CI matrix - END_DOC - integer :: i,j - do j=1,N_states_diag - do i=1,N_det - psi_coef(i,j) = CI_eigenvectors(i,j) - enddo - enddo - SOFT_TOUCH psi_coef CI_electronic_energy CI_energy CI_eigenvectors CI_eigenvectors_s2 -end diff --git a/src/Determinants/diagonalize_CI_SC2.irp.f b/src/Determinants/diagonalize_CI_SC2.irp.f deleted file mode 100644 index 498792d9..00000000 --- a/src/Determinants/diagonalize_CI_SC2.irp.f +++ /dev/null @@ -1,62 +0,0 @@ -BEGIN_PROVIDER [ double precision, CI_SC2_energy, (N_states_diag) ] - implicit none - BEGIN_DOC - ! N_states_diag lowest eigenvalues of the CI matrix - END_DOC - - integer :: j - character*(8) :: st - call write_time(output_determinants) - do j=1,N_states_diag - CI_SC2_energy(j) = CI_SC2_electronic_energy(j) + nuclear_repulsion - write(st,'(I4)') j - call write_double(output_determinants,CI_SC2_energy(j),'Energy of state '//trim(st)) - enddo - -END_PROVIDER - - BEGIN_PROVIDER [ double precision, threshold_convergence_SC2] - implicit none - BEGIN_DOC - ! convergence of the correlation energy of SC2 iterations - END_DOC - threshold_convergence_SC2 = 1.d-10 - - END_PROVIDER - - BEGIN_PROVIDER [ double precision, CI_SC2_electronic_energy, (N_states_diag) ] -&BEGIN_PROVIDER [ double precision, CI_SC2_eigenvectors, (N_det,N_states_diag) ] -&BEGIN_PROVIDER [ double precision, Diag_H_elements_SC2, (N_det) ] - implicit none - BEGIN_DOC - ! Eigenvectors/values of the CI matrix - END_DOC - integer :: i,j - - do j=1,N_states_diag - do i=1,N_det - CI_SC2_eigenvectors(i,j) = psi_coef(i,j) - enddo - CI_SC2_electronic_energy(j) = CI_electronic_energy(j) - enddo - - call CISD_SC2(psi_det,CI_SC2_eigenvectors,CI_SC2_electronic_energy, & -! size(CI_SC2_eigenvectors,1),N_det,N_states_diag,N_int,threshold_convergence_SC2) - diag_H_elements_SC2,size(CI_SC2_eigenvectors,1),N_det,N_states_diag,N_int,threshold_convergence_SC2) -END_PROVIDER - -subroutine diagonalize_CI_SC2 - implicit none - BEGIN_DOC -! Replace the coefficients of the CI states_diag by the coefficients of the -! eigenstates of the CI matrix - END_DOC - integer :: i,j - do j=1,N_states_diag - do i=1,N_det - psi_coef(i,j) = CI_SC2_eigenvectors(i,j) - enddo - enddo - SOFT_TOUCH psi_coef CI_SC2_electronic_energy CI_SC2_energy CI_SC2_eigenvectors diag_h_elements_sc2 -! SOFT_TOUCH psi_coef CI_SC2_electronic_energy CI_SC2_energy CI_SC2_eigenvectors -end diff --git a/src/Determinants/diagonalize_CI_mono.irp.f b/src/Determinants/diagonalize_CI_mono.irp.f deleted file mode 100644 index 3f9b94ec..00000000 --- a/src/Determinants/diagonalize_CI_mono.irp.f +++ /dev/null @@ -1,86 +0,0 @@ - BEGIN_PROVIDER [ double precision, CI_electronic_energy_mono, (N_states_diag) ] -&BEGIN_PROVIDER [ double precision, CI_eigenvectors_mono, (N_det,N_states_diag) ] -&BEGIN_PROVIDER [ double precision, CI_eigenvectors_s2_mono, (N_states_diag) ] - implicit none - BEGIN_DOC - ! Eigenvectors/values of the CI matrix - END_DOC - integer :: i,j - - do j=1,N_states_diag - do i=1,N_det - CI_eigenvectors_mono(i,j) = psi_coef(i,j) - enddo - enddo - - if (diag_algorithm == "Davidson") then - - call davidson_diag(psi_det,CI_eigenvectors_mono,CI_electronic_energy, & - size(CI_eigenvectors_mono,1),N_det,N_states_diag,N_int,output_determinants) - - else if (diag_algorithm == "Lapack") then - - double precision, allocatable :: eigenvectors(:,:), eigenvalues(:) - allocate (eigenvectors(size(H_matrix_all_dets,1),N_det)) - allocate (eigenvalues(N_det)) - call lapack_diag(eigenvalues,eigenvectors, & - H_matrix_all_dets,size(H_matrix_all_dets,1),N_det) - CI_electronic_energy_mono(:) = 0.d0 - do i=1,N_det - CI_eigenvectors_mono(i,1) = eigenvectors(i,1) - enddo - integer :: i_state - double precision :: s2 - i_state = 0 - if (s2_eig) then - do j=1,N_det - call get_s2_u0(psi_det,eigenvectors(1,j),N_det,N_det,s2) - if(dabs(s2-expected_s2).le.0.3d0)then - print*,'j = ',j - print*,'e = ',eigenvalues(j) - print*,'c = ',dabs(eigenvectors(1,j)) - if(dabs(eigenvectors(1,j)).gt.0.9d0)then - i_state += 1 - do i=1,N_det - CI_eigenvectors_mono(i,i_state) = eigenvectors(i,j) - enddo - CI_electronic_energy_mono(i_state) = eigenvalues(j) - CI_eigenvectors_s2_mono(i_state) = s2 - endif - endif - if (i_state.ge.N_states_diag) then - exit - endif - enddo - else - do j=1,N_states_diag - call get_s2_u0(psi_det,eigenvectors(1,j),N_det,N_det,s2) - if(dabs(eigenvectors(1,j)).gt.0.9d0)then - i_state += 1 - do i=1,N_det - CI_eigenvectors_mono(i,i_state) = eigenvectors(i,j) - enddo - CI_electronic_energy_mono(i_state) = eigenvalues(j) - CI_eigenvectors_s2_mono(i_state) = s2 - endif - enddo - endif - deallocate(eigenvectors,eigenvalues) - endif - -END_PROVIDER - -subroutine diagonalize_CI_mono - implicit none - BEGIN_DOC -! Replace the coefficients of the CI states by the coefficients of the -! eigenstates of the CI matrix - END_DOC - integer :: i,j - do j=1,N_states_diag - do i=1,N_det - psi_coef(i,j) = CI_eigenvectors_mono(i,j) - enddo - enddo - SOFT_TOUCH psi_coef CI_electronic_energy_mono CI_eigenvectors_mono CI_eigenvectors_s2_mono -end diff --git a/src/Determinants/filter_connected.irp.f b/src/Determinants/filter_connected.irp.f index 46280b31..da333b1e 100644 --- a/src/Determinants/filter_connected.irp.f +++ b/src/Determinants/filter_connected.irp.f @@ -207,6 +207,7 @@ subroutine create_microlist(minilist, N_minilist, key_mask, microlist, idx_micro do j=1,n_element(1) nt = list(j,1) idx_microlist(cur_microlist(nt)) = i + ! TODO : Page faults do k=1,Nint microlist(k,1,cur_microlist(nt)) = minilist(k,1,i) microlist(k,2,cur_microlist(nt)) = minilist(k,2,i) @@ -299,7 +300,6 @@ subroutine filter_connected_i_H_psi0(key1,key2,Nint,sze,idx) else - integer, save :: icount(4) = (/0,0,0,0/) !DIR$ LOOP COUNT (1000) outer: do i=1,sze degree_x2 = 0 @@ -317,7 +317,6 @@ subroutine filter_connected_i_H_psi0(key1,key2,Nint,sze,idx) enddo idx(l) = i l = l+1 - icount(3) = icount(3) + 1_8 enddo outer endif diff --git a/src/Determinants/mono_excitations.irp.f b/src/Determinants/mono_excitations.irp.f new file mode 100644 index 00000000..01af4c25 --- /dev/null +++ b/src/Determinants/mono_excitations.irp.f @@ -0,0 +1,154 @@ + use bitmasks +BEGIN_PROVIDER [integer(bit_kind), ref_closed_shell_bitmask, (N_int,2)] + implicit none + integer :: i,i0 + integer :: n_occ_ab(2) + integer :: occ(N_int*bit_kind_size,2) + call bitstring_to_list_ab(ref_bitmask, occ, n_occ_ab, N_int) + ! do the closed shell determinant + do i = 1, N_int + ref_closed_shell_bitmask(i,1) = ref_bitmask(i,1) + ref_closed_shell_bitmask(i,2) = ref_bitmask(i,2) + enddo + do i0 = elec_beta_num+1, elec_alpha_num + i=occ(i0,1) + call clear_bit_to_integer(i,ref_closed_shell_bitmask(1,1),N_int) + enddo + + +END_PROVIDER + + +BEGIN_PROVIDER [double precision, fock_operator_closed_shell_ref_bitmask, (mo_tot_num_align, mo_tot_num) ] + implicit none + integer :: i0,j0,i,j,k0,k + integer :: n_occ_ab(2) + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab_virt(2) + integer :: occ_virt(N_int*bit_kind_size,2) + integer(bit_kind) :: key_test(N_int) + integer(bit_kind) :: key_virt(N_int,2) + + call bitstring_to_list_ab(ref_closed_shell_bitmask, occ, n_occ_ab, N_int) + do i = 1, N_int + key_virt(i,1) = full_ijkl_bitmask(i) + key_virt(i,2) = full_ijkl_bitmask(i) + key_virt(i,1) = xor(key_virt(i,1),ref_closed_shell_bitmask(i,1)) + key_virt(i,2) = xor(key_virt(i,2),ref_closed_shell_bitmask(i,2)) + enddo + double precision :: array_coulomb(mo_tot_num),array_exchange(mo_tot_num) + call bitstring_to_list_ab(key_virt, occ_virt, n_occ_ab_virt, N_int) + ! docc ---> virt mono excitations + do i0 = 1, n_occ_ab(1) + i=occ(i0,1) + do j0 = 1, n_occ_ab_virt(1) + j = occ_virt(j0,1) + call get_mo_bielec_integrals_coulomb_ii(i,j,mo_tot_num,array_coulomb,mo_integrals_map) + call get_mo_bielec_integrals_exch_ii(i,j,mo_tot_num,array_exchange,mo_integrals_map) + double precision :: accu + accu = 0.d0 + do k0 = 1, n_occ_ab(1) + k = occ(k0,1) + accu += 2.d0 * array_coulomb(k) - array_exchange(k) + enddo + fock_operator_closed_shell_ref_bitmask(i,j) = accu + mo_mono_elec_integral(i,j) + fock_operator_closed_shell_ref_bitmask(j,i) = accu + mo_mono_elec_integral(i,j) + enddo + enddo + + ! virt ---> virt mono excitations + do i0 = 1, n_occ_ab_virt(1) + i=occ_virt(i0,1) + do j0 = 1, n_occ_ab_virt(1) + j = occ_virt(j0,1) + call get_mo_bielec_integrals_coulomb_ii(i,j,mo_tot_num,array_coulomb,mo_integrals_map) + call get_mo_bielec_integrals_exch_ii(i,j,mo_tot_num,array_exchange,mo_integrals_map) + accu = 0.d0 + do k0 = 1, n_occ_ab(1) + k = occ(k0,1) + accu += 2.d0 * array_coulomb(k) - array_exchange(k) + enddo + fock_operator_closed_shell_ref_bitmask(i,j) = accu+ mo_mono_elec_integral(i,j) + fock_operator_closed_shell_ref_bitmask(j,i) = accu+ mo_mono_elec_integral(i,j) + enddo + enddo + + ! docc ---> docc mono excitations + do i0 = 1, n_occ_ab(1) + i=occ(i0,1) + do j0 = 1, n_occ_ab(1) + j = occ(j0,1) + call get_mo_bielec_integrals_coulomb_ii(i,j,mo_tot_num,array_coulomb,mo_integrals_map) + call get_mo_bielec_integrals_exch_ii(i,j,mo_tot_num,array_exchange,mo_integrals_map) + accu = 0.d0 + do k0 = 1, n_occ_ab(1) + k = occ(k0,1) + accu += 2.d0 * array_coulomb(k) - array_exchange(k) + enddo + fock_operator_closed_shell_ref_bitmask(i,j) = accu+ mo_mono_elec_integral(i,j) + fock_operator_closed_shell_ref_bitmask(j,i) = accu+ mo_mono_elec_integral(i,j) + enddo + enddo + +END_PROVIDER + +subroutine get_mono_excitation_from_fock(det_1,det_2,h,p,spin,phase,hij) + use bitmasks + implicit none + integer,intent(in) :: h,p,spin + double precision, intent(in) :: phase + integer(bit_kind), intent(in) :: det_1(N_int,2), det_2(N_int,2) + double precision, intent(out) :: hij + integer(bit_kind) :: differences(N_int,2) + integer(bit_kind) :: hole(N_int,2) + integer(bit_kind) :: partcl(N_int,2) + integer :: occ_hole(N_int*bit_kind_size,2) + integer :: occ_partcl(N_int*bit_kind_size,2) + integer :: n_occ_ab_hole(2),n_occ_ab_partcl(2) + integer :: i0,i + do i = 1, N_int + differences(i,1) = xor(det_1(i,1),ref_closed_shell_bitmask(i,1)) + differences(i,2) = xor(det_1(i,2),ref_closed_shell_bitmask(i,2)) + hole(i,1) = iand(differences(i,1),ref_closed_shell_bitmask(i,1)) + hole(i,2) = iand(differences(i,2),ref_closed_shell_bitmask(i,2)) + partcl(i,1) = iand(differences(i,1),det_1(i,1)) + partcl(i,2) = iand(differences(i,2),det_1(i,2)) + enddo + call bitstring_to_list_ab(hole, occ_hole, n_occ_ab_hole, N_int) + call bitstring_to_list_ab(partcl, occ_partcl, n_occ_ab_partcl, N_int) + hij = fock_operator_closed_shell_ref_bitmask(h,p) + ! holes :: direct terms + do i0 = 1, n_occ_ab_hole(1) + i = occ_hole(i0,1) + hij -= big_array_coulomb_integrals(i,h,p) ! get_mo_bielec_integral_schwartz(h,i,p,i,mo_integrals_map) + enddo + do i0 = 1, n_occ_ab_hole(2) + i = occ_hole(i0,2) + hij -= big_array_coulomb_integrals(i,h,p) !get_mo_bielec_integral_schwartz(h,i,p,i,mo_integrals_map) + enddo + + ! holes :: exchange terms + do i0 = 1, n_occ_ab_hole(spin) + i = occ_hole(i0,spin) + hij += big_array_exchange_integrals(i,h,p) ! get_mo_bielec_integral_schwartz(h,i,i,p,mo_integrals_map) + enddo + + ! particles :: direct terms + do i0 = 1, n_occ_ab_partcl(1) + i = occ_partcl(i0,1) + hij += big_array_coulomb_integrals(i,h,p)!get_mo_bielec_integral_schwartz(h,i,p,i,mo_integrals_map) + enddo + do i0 = 1, n_occ_ab_partcl(2) + i = occ_partcl(i0,2) + hij += big_array_coulomb_integrals(i,h,p) !get_mo_bielec_integral_schwartz(h,i,p,i,mo_integrals_map) + enddo + + ! particles :: exchange terms + do i0 = 1, n_occ_ab_partcl(spin) + i = occ_partcl(i0,spin) + hij -= big_array_exchange_integrals(i,h,p)!get_mo_bielec_integral_schwartz(h,i,i,p,mo_integrals_map) + enddo + hij = hij * phase + +end + diff --git a/src/Determinants/occ_pattern.irp.f b/src/Determinants/occ_pattern.irp.f index c58d1f82..6abdf13e 100644 --- a/src/Determinants/occ_pattern.irp.f +++ b/src/Determinants/occ_pattern.irp.f @@ -35,7 +35,7 @@ subroutine occ_pattern_to_dets_size(o,sze,n_alpha,Nint) bmax += popcnt( o(k,1) ) amax -= popcnt( o(k,2) ) enddo - sze = int( min(binom_func(bmax, amax), 1.d8) ) + sze = 2*int( min(binom_func(bmax, amax), 1.d8) ) end @@ -76,27 +76,6 @@ subroutine occ_pattern_to_dets(o,d,sze,n_alpha,Nint) enddo enddo -! !TODO DEBUG -! integer :: j,s -! do i=1,nd -! do j=1,i-1 -! na=0 -! do k=1,Nint -! if((d(k,1,j) /= d(k,1,i)).or. & -! (d(k,2,j) /= d(k,2,i))) then -! s=1 -! exit -! endif -! enddo -! if ( j== 0 ) then -! print *, 'det ',i,' and ',j,' equal:' -! call debug_det(d(1,1,j),Nint) -! call debug_det(d(1,1,i),Nint) -! stop -! endif -! enddo -! enddo -! !TODO DEBUG end recursive subroutine rec_occ_pattern_to_dets(list_todo,nt,list_a,na,d,nd,sze,amax,Nint) @@ -226,26 +205,7 @@ end enddo deallocate(iorder,duplicate,bit_tmp,tmp_array) -! !TODO DEBUG -! integer :: s -! do i=1,N_occ_pattern -! do j=i+1,N_occ_pattern -! s = 0 -! do k=1,N_int -! if((psi_occ_pattern(k,1,j) /= psi_occ_pattern(k,1,i)).or. & -! (psi_occ_pattern(k,2,j) /= psi_occ_pattern(k,2,i))) then -! s=1 -! exit -! endif -! enddo -! if ( s == 0 ) then -! print *, 'Error : occ ', j, 'already in wf' -! call debug_det(psi_occ_pattern(1,1,j),N_int) -! stop -! endif -! enddo -! enddo -! !TODO DEBUG + END_PROVIDER subroutine make_s2_eigenfunction @@ -253,7 +213,7 @@ subroutine make_s2_eigenfunction integer :: i,j,k integer :: smax, s integer(bit_kind), allocatable :: d(:,:,:), det_buffer(:,:,:) - integer :: N_det_new + integer :: N_det_new, iproc integer, parameter :: bufsze = 1000 logical, external :: is_in_wavefunction @@ -294,7 +254,7 @@ subroutine make_s2_eigenfunction deallocate(d,det_buffer) - call write_int(output_determinants,N_det_new, 'Added deteminants for S^2') + call write_int(output_determinants,N_det_new, 'Added determinants for S^2') end diff --git a/src/Determinants/options.irp.f b/src/Determinants/options.irp.f deleted file mode 100644 index d4283128..00000000 --- a/src/Determinants/options.irp.f +++ /dev/null @@ -1,22 +0,0 @@ -BEGIN_PROVIDER [ integer, N_states_diag ] - implicit none - BEGIN_DOC -! Number of states to consider for the diagonalization - END_DOC - - logical :: has - PROVIDE ezfio_filename - call ezfio_has_determinants_n_states_diag(has) - if (has) then - call ezfio_get_determinants_n_states_diag(N_states_diag) - else - N_states_diag = N_states - endif - - call write_time(output_determinants) - call write_int(output_determinants, N_states_diag, & - 'N_states_diag') - - -END_PROVIDER - diff --git a/src/Determinants/print_wf.irp.f b/src/Determinants/print_wf.irp.f index e7ca5dc6..af109e2d 100644 --- a/src/Determinants/print_wf.irp.f +++ b/src/Determinants/print_wf.irp.f @@ -15,7 +15,7 @@ subroutine routine integer :: exc(0:2,2,2) double precision :: phase integer :: h1,p1,h2,p2,s1,s2 - double precision :: get_mo_bielec_integral_schwartz + double precision :: get_mo_bielec_integral double precision :: norm_mono_a,norm_mono_b norm_mono_a = 0.d0 norm_mono_b = 0.d0 @@ -40,7 +40,7 @@ subroutine routine else norm_mono_b += dabs(psi_coef(i,1)/psi_coef(1,1)) endif - print*,'< h | Ka| p > = ',get_mo_bielec_integral_schwartz(h1,list_act(1),list_act(1),p1,mo_integrals_map) + print*,'< h | Ka| p > = ',get_mo_bielec_integral(h1,list_act(1),list_act(1),p1,mo_integrals_map) double precision :: hmono,hdouble call i_H_j_verbose(psi_det(1,1,1),psi_det(1,1,i),N_int,hij,hmono,hdouble) print*,'hmono = ',hmono @@ -52,7 +52,7 @@ subroutine routine print*,'h1,p1 = ',h1,p1 print*,'s2',s2 print*,'h2,p2 = ',h2,p2 - print*,'< h | Ka| p > = ',get_mo_bielec_integral_schwartz(h1,h2,p1,p2,mo_integrals_map) + print*,'< h | Ka| p > = ',get_mo_bielec_integral(h1,h2,p1,p2,mo_integrals_map) endif print*,' = ',hij diff --git a/src/Determinants/psi_cas.irp.f b/src/Determinants/psi_cas.irp.f index 304a2370..968ced57 100644 --- a/src/Determinants/psi_cas.irp.f +++ b/src/Determinants/psi_cas.irp.f @@ -21,9 +21,9 @@ use bitmasks do k=1,N_int good = good .and. ( & iand(not(cas_bitmask(k,1,l)), psi_det(k,1,i)) == & - iand(not(cas_bitmask(k,1,l)), psi_det(k,1,1)) ) .and. ( & + iand(not(cas_bitmask(k,1,l)), hf_bitmask(k,1)) ) .and. ( & iand(not(cas_bitmask(k,2,l)), psi_det(k,2,i)) == & - iand(not(cas_bitmask(k,2,l)), psi_det(k,2,1)) ) + iand(not(cas_bitmask(k,2,l)), hf_bitmask(k,2)) ) enddo if (good) then exit diff --git a/src/Determinants/s2.irp.f b/src/Determinants/s2.irp.f index 344e0160..c6bb8390 100644 --- a/src/Determinants/s2.irp.f +++ b/src/Determinants/s2.irp.f @@ -1,4 +1,4 @@ -subroutine get_s2(key_i,key_j,s2,Nint) +subroutine get_s2(key_i,key_j,Nint,s2) implicit none use bitmasks BEGIN_DOC @@ -59,7 +59,6 @@ BEGIN_PROVIDER [ double precision, expected_s2] double precision :: S S = (elec_alpha_num-elec_beta_num)*0.5d0 expected_s2 = S * (S+1.d0) -! expected_s2 = elec_alpha_num - elec_beta_num + 0.5d0 * ((elec_alpha_num - elec_beta_num)**2*0.5d0 - (elec_alpha_num-elec_beta_num)) endif END_PROVIDER @@ -70,319 +69,407 @@ BEGIN_PROVIDER [ double precision, s2_values, (N_states) ] ! array of the averaged values of the S^2 operator on the various states END_DOC integer :: i - double precision :: s2 - do i = 1, N_states - call get_s2_u0(psi_det,psi_coef(1,i),n_det,size(psi_coef,1),s2) - s2_values(i) = s2 - enddo + call u_0_S2_u_0(s2_values,psi_coef,n_det,psi_det,N_int,N_states,psi_det_size) END_PROVIDER -subroutine get_s2_u0_old(psi_keys_tmp,psi_coefs_tmp,n,nmax,s2) - implicit none - use bitmasks - 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 - double precision :: s2_tmp - s2 = 0.d0 - !$OMP PARALLEL DO DEFAULT(NONE) & - !$OMP PRIVATE(i,j,s2_tmp) SHARED(n,psi_coefs_tmp,psi_keys_tmp,N_int) REDUCTION(+:s2) SCHEDULE(dynamic) - do i=1,n - do j=i+1,n - call get_s2(psi_keys_tmp(1,1,i),psi_keys_tmp(1,1,j),s2_tmp,N_int) - s2 += psi_coefs_tmp(i)*psi_coefs_tmp(j)*s2_tmp - enddo - enddo - !$OMP END PARALLEL DO - s2 = s2+s2 - do i=1,n - call get_s2(psi_keys_tmp(1,1,i),psi_keys_tmp(1,1,i),s2_tmp,N_int) - s2 += psi_coefs_tmp(i)*psi_coefs_tmp(i)*s2_tmp - enddo - s2 += S_z2_Sz + +subroutine u_0_S2_u_0(e_0,u_0,n,keys_tmp,Nint,N_st,sze_8) + use bitmasks + implicit none + BEGIN_DOC + ! Computes e_0 = / + ! + ! n : number of determinants + ! + END_DOC + integer, intent(in) :: n,Nint, N_st, sze_8 + double precision, intent(out) :: e_0(N_st) + double precision, intent(in) :: u_0(sze_8,N_st) + integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) + + double precision, allocatable :: v_0(:,:) + double precision :: u_dot_u,u_dot_v + integer :: i,j + allocate (v_0(sze_8,N_st)) + + call S2_u_0_nstates(v_0,u_0,n,keys_tmp,Nint,N_st,sze_8) + do i=1,N_st + e_0(i) = u_dot_v(v_0(1,i),u_0(1,i),n)/u_dot_u(u_0(1,i),n) + S_z2_Sz + enddo end -subroutine get_s2_u0(psi_keys_tmp,psi_coefs_tmp,n,nmax,s2) - implicit none + + +subroutine S2_u_0(v_0,u_0,n,keys_tmp,Nint) use bitmasks - 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 + implicit none + BEGIN_DOC + ! Computes v_0 = S^2|u_0> + ! + ! n : number of determinants + ! + END_DOC + integer, intent(in) :: n,Nint + double precision, intent(out) :: v_0(n) + double precision, intent(in) :: u_0(n) + integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) + call S2_u_0_nstates(v_0,u_0,n,keys_tmp,Nint,1,n) +end + +subroutine S2_u_0_nstates(v_0,u_0,n,keys_tmp,Nint,N_st,sze_8) + use bitmasks + implicit none + BEGIN_DOC + ! Computes v_0 = S^2|u_0> + ! + ! n : number of determinants + ! + END_DOC + integer, intent(in) :: N_st,n,Nint, sze_8 + double precision, intent(out) :: v_0(sze_8,N_st) + double precision, intent(in) :: u_0(sze_8,N_st) + integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) double precision :: s2_tmp - integer :: i,j,l,jj,ii - integer, allocatable :: idx(:) + double precision, allocatable :: vt(:,:) + integer :: i,j,k,l, jj,ii + integer :: i0, j0 - integer, allocatable :: shortcut(:), sort_idx(:) - integer(bit_kind), allocatable :: sorted(:,:), version(:,:) - integer :: sh, sh2, ni, exa, ext, org_i, org_j, endi, pass - double precision :: davidson_threshold_bis + integer, allocatable :: shortcut(:,:), sort_idx(:,:) + integer(bit_kind), allocatable :: sorted(:,:,:), version(:,:,:) + integer(bit_kind) :: sorted_i(Nint) - allocate (shortcut(0:n+1), sort_idx(n), sorted(N_int,n), version(N_int,n)) - s2 = 0.d0 - davidson_threshold_bis = threshold_davidson - call sort_dets_ab_v(psi_keys_tmp, sorted, sort_idx, shortcut, version, n, N_int) + integer :: sh, sh2, ni, exa, ext, org_i, org_j, endi, istate + + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + ASSERT (n>0) + PROVIDE ref_bitmask_energy + + allocate (shortcut(0:n+1,2), sort_idx(n,2), sorted(Nint,n,2), version(Nint,n,2)) + v_0 = 0.d0 + + call sort_dets_ab_v(keys_tmp, sorted(1,1,1), sort_idx(1,1), shortcut(0,1), version(1,1,1), n, Nint) + call sort_dets_ba_v(keys_tmp, sorted(1,1,2), sort_idx(1,2), shortcut(0,2), version(1,1,2), n, Nint) !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(i,j,s2_tmp,sh, sh2, ni, exa, ext, org_i, org_j, endi, pass)& - !$OMP SHARED(n,psi_coefs_tmp,psi_keys_tmp,N_int,threshold_davidson,shortcut,sorted,sort_idx,version)& - !$OMP REDUCTION(+:s2) + !$OMP PRIVATE(i,s2_tmp,j,k,jj,vt,ii,sh,sh2,ni,exa,ext,org_i,org_j,endi,sorted_i,istate)& + !$OMP SHARED(n,u_0,keys_tmp,Nint,v_0,sorted,shortcut,sort_idx,version,N_st,sze_8) + allocate(vt(sze_8,N_st)) + vt = 0.d0 !$OMP DO SCHEDULE(dynamic) - do sh=1,shortcut(0) - - do sh2=1,sh + do sh=1,shortcut(0,1) + do sh2=sh,shortcut(0,1) exa = 0 - do ni=1,N_int - exa += popcnt(xor(version(ni,sh), version(ni,sh2))) + do ni=1,Nint + exa = exa + popcnt(xor(version(ni,sh,1), version(ni,sh2,1))) end do if(exa > 2) then cycle end if - do i=shortcut(sh),shortcut(sh+1)-1 + do i=shortcut(sh,1),shortcut(sh+1,1)-1 + org_i = sort_idx(i,1) if(sh==sh2) then endi = i-1 else - endi = shortcut(sh2+1)-1 + endi = shortcut(sh2+1,1)-1 end if + do ni=1,Nint + sorted_i(ni) = sorted(ni,i,1) + enddo - do j=shortcut(sh2),endi + do j=shortcut(sh2,1),endi + org_j = sort_idx(j,1) ext = exa - do ni=1,N_int - ext += popcnt(xor(sorted(ni,i), sorted(ni,j))) + do ni=1,Nint + ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) end do if(ext <= 4) then - org_i = sort_idx(i) - org_j = sort_idx(j) - - if ( dabs(psi_coefs_tmp(org_j)) + dabs(psi_coefs_tmp(org_i))& - > threshold_davidson ) then - call get_s2(psi_keys_tmp(1,1,org_i),psi_keys_tmp(1,1,org_j),s2_tmp,N_int) - s2 = s2 + psi_coefs_tmp(org_i)*psi_coefs_tmp(org_j)*s2_tmp - endif - end if - end do - end do - end do + call get_s2(keys_tmp(1,1,org_i),keys_tmp(1,1,org_j),Nint,s2_tmp) + do istate=1,N_st + vt (org_i,istate) = vt (org_i,istate) + s2_tmp*u_0(org_j,istate) + vt (org_j,istate) = vt (org_j,istate) + s2_tmp*u_0(org_i,istate) + enddo + endif + enddo + enddo + enddo enddo - !$OMP END DO - - !$OMP END PARALLEL - - call sort_dets_ba_v(psi_keys_tmp, sorted, sort_idx, shortcut, version, n, N_int) - - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(i,j,s2_tmp,sh, sh2, ni, exa, ext, org_i, org_j, endi, pass)& - !$OMP SHARED(n,psi_coefs_tmp,psi_keys_tmp,N_int,threshold_davidson,shortcut,sorted,sort_idx,version)& - !$OMP REDUCTION(+:s2) + !$OMP END DO NOWAIT !$OMP DO SCHEDULE(dynamic) - do sh=1,shortcut(0) - do i=shortcut(sh),shortcut(sh+1)-1 - do j=shortcut(sh),i-1 + do sh=1,shortcut(0,2) + do i=shortcut(sh,2),shortcut(sh+1,2)-1 + org_i = sort_idx(i,2) + do j=shortcut(sh,2),i-1 + org_j = sort_idx(j,2) ext = 0 - do ni=1,N_int - ext += popcnt(xor(sorted(ni,i), sorted(ni,j))) + do ni=1,Nint + ext = ext + popcnt(xor(sorted(ni,i,2), sorted(ni,j,2))) end do if(ext == 4) then - org_i = sort_idx(i) - org_j = sort_idx(j) - - if ( dabs(psi_coefs_tmp(org_j)) + dabs(psi_coefs_tmp(org_i))& - > threshold_davidson ) then - call get_s2(psi_keys_tmp(1,1,org_i),psi_keys_tmp(1,1,org_j),s2_tmp,N_int) - s2 = s2 + psi_coefs_tmp(org_i)*psi_coefs_tmp(org_j)*s2_tmp - endif + call get_s2(keys_tmp(1,1,org_i),keys_tmp(1,1,org_j),Nint,s2_tmp) + do istate=1,N_st + vt (org_i,istate) = vt (org_i,istate) + s2_tmp*u_0(org_j,istate) + vt (org_j,istate) = vt (org_j,istate) + s2_tmp*u_0(org_i,istate) + enddo end if end do end do enddo - !$OMP END DO + !$OMP END DO NOWAIT - !$OMP END PARALLEL - s2 = s2+s2 - do i=1,n - call get_s2(psi_keys_tmp(1,1,i),psi_keys_tmp(1,1,i),s2_tmp,N_int) - s2 = s2 + psi_coefs_tmp(i)*psi_coefs_tmp(i)*s2_tmp + !$OMP CRITICAL + do istate=1,N_st + do i=n,1,-1 + v_0(i,istate) = v_0(i,istate) + vt(i,istate) + enddo enddo - s2 = s2 + S_z2_Sz + !$OMP END CRITICAL + + deallocate(vt) + !$OMP END PARALLEL + + do i=1,n + call get_s2(keys_tmp(1,1,i),keys_tmp(1,1,i),Nint,s2_tmp) + do istate=1,N_st + v_0(i,istate) += s2_tmp * u_0(i,istate) + enddo + enddo + 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) + 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(:) + 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,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 = n,1,-1 ! Better OMP scheduling + call get_s2(psi_keys_tmp(1,1,i),psi_keys_tmp(1,1,i),N_int,s2_tmp) + 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),N_int,s2_tmp) + 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 + deallocate(idx) + !$OMP END PARALLEL + s2(ll,jj) += accu 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 + 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 - 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)) +subroutine diagonalize_s2_betweenstates(keys_tmp,u_0,n,nmax_keys,nmax_coefs,nstates,s2_eigvalues) + BEGIN_DOC + ! You enter with nstates vectors in u_0 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) :: u_0(nmax_coefs,nstates) + double precision, intent(out) :: s2_eigvalues(nstates) + + + double precision,allocatable :: s2(:,:),overlap(:,:) + double precision, allocatable :: 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)) + overlap = 0.d0 + call dgemm('T','N',nstates,nstates,n, 1.d0, u_0, size(u_0,1), & + u_0, size(u_0,1), 0.d0, overlap, size(overlap,1)) + call ortho_lowdin(overlap,size(overlap,1),nstates,u_0,size(u_0,1),n) + + double precision, allocatable :: v_0(:,:) + allocate ( v_0(size(u_0,1),nstates) ) + call S2_u_0_nstates(v_0,u_0,n,keys_tmp,N_int,nstates,size(u_0,1)) + + call dgemm('T','N',nstates,nstates,n, 1.d0, u_0, size(u_0,1), & + v_0, size(v_0,1), 0.d0, s2, size(s2,1)) + + print*,'S^2 matrix in the basis of the states considered' 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 + write(*,'(100(F5.2,X))')s2(i,:) 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' + + 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 not combine states of the same spin symmetry + do j = i+1, nstates + if( dabs(s2(i,i) - s2(j,j)) .le.0.5d0) then + s2(i,j) = 0.d0 + s2(j,i) = 0.d0 + endif + enddo + ! Do not rotate if the diagonal is correct + if( dabs(s2(i,i) - expected_s2).le.5.d-3) then + do j = 1, nstates + if (j==i) cycle + s2(i,j) = 0.d0 + s2(j,i) = 0.d0 + enddo + endif + enddo + + print*,'Modified S^2 matrix that will be diagonalized' + do i = 1, nstates + write(*,'(10(F5.2,X))')s2(i,:) + s2(i,i) = s2(i,i) + enddo + + allocate(eigvectors(nstates,nstates,2)) +! call svd(s2, size(s2,1), eigvectors, size(eigvectors,1), s2_eigvalues,& +! eigvectors(1,1,2), size(eigvectors,1), nstates, nstates) + + call lapack_diagd(s2_eigvalues,eigvectors,s2,nstates,nstates) + print*,'Eigenvalues' + double precision :: t(nstates) + integer :: iorder(nstates) + do i = 1, nstates + t(i) = dabs(s2_eigvalues(i)) + iorder(i) = i + enddo + call dsort(t,iorder,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) + s2_eigvalues(i) = t(i) + do j=1,nstates + eigvectors(j,i,2) = eigvectors(j,iorder(i),1) + enddo + print*,'s2 = ',s2_eigvalues(i) + enddo + + 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,2) ! + do i = 1, n_det + psi_coefs_tmp(i,j) += u_0(i,k) * coef_contract + enddo 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.0.5d0 ) ) then - s2(i,j) = 0.d0 - s2(j,i) = 0.d0 - endif + do j = 1, nstates + accu = 1.d0/u_dot_u(psi_coefs_tmp(1,j),n_det) + do i = 1, n_det + u_0(i,j) = psi_coefs_tmp(i,j) * accu + enddo 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) - + + deallocate(s2,v_0,eigvectors,psi_coefs_tmp,overlap ) + end +subroutine i_S2_psi_minilist(key,keys,idx_key,N_minilist,coef,Nint,Ndet,Ndet_max,Nstate,i_S2_psi_array) + use bitmasks + implicit none + integer, intent(in) :: Nint, Ndet,Ndet_max,Nstate,idx_key(Ndet), N_minilist + integer(bit_kind), intent(in) :: keys(Nint,2,Ndet) + integer(bit_kind), intent(in) :: key(Nint,2) + double precision, intent(in) :: coef(Ndet_max,Nstate) + double precision, intent(out) :: i_S2_psi_array(Nstate) + + integer :: i, ii,j, i_in_key, i_in_coef + double precision :: phase + integer :: exc(0:2,2,2) + double precision :: s2ij + integer :: idx(0:Ndet) + BEGIN_DOC +! Computes = \sum_J c_J . +! +! Uses filter_connected_i_H_psi0 to get all the |J> to which |i> +! is connected. The |J> are searched in short pre-computed lists. + END_DOC + + ASSERT (Nint > 0) + ASSERT (N_int == Nint) + ASSERT (Nstate > 0) + ASSERT (Ndet > 0) + ASSERT (Ndet_max >= Ndet) + i_S2_psi_array = 0.d0 + + call filter_connected_i_H_psi0(keys,key,Nint,N_minilist,idx) + if (Nstate == 1) then + + do ii=1,idx(0) + i_in_key = idx(ii) + i_in_coef = idx_key(idx(ii)) + !DIR$ FORCEINLINE + call get_s2(keys(1,1,i_in_key),key,Nint,s2ij) + ! TODO : Cache misses + i_S2_psi_array(1) = i_S2_psi_array(1) + coef(i_in_coef,1)*s2ij + enddo + + else + + do ii=1,idx(0) + i_in_key = idx(ii) + i_in_coef = idx_key(idx(ii)) + !DIR$ FORCEINLINE + call get_s2(keys(1,1,i_in_key),key,Nint,s2ij) + do j = 1, Nstate + i_S2_psi_array(j) = i_S2_psi_array(j) + coef(i_in_coef,j)*s2ij + enddo + enddo + + endif + +end diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index f98947a2..ed299447 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -139,6 +139,72 @@ subroutine decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) end +subroutine decode_exc_int2(exc,degree,h1,p1,h2,p2,s1,s2) + use bitmasks + implicit none + BEGIN_DOC + ! Decodes the exc arrays returned by get_excitation. + ! h1,h2 : Holes + ! p1,p2 : Particles + ! s1,s2 : Spins (1:alpha, 2:beta) + ! degree : Degree of excitation + END_DOC + integer, intent(in) :: exc(0:2,2,2),degree + integer*2, intent(out) :: h1,h2,p1,p2,s1,s2 + ASSERT (degree > 0) + ASSERT (degree < 3) + + select case(degree) + case(2) + if (exc(0,1,1) == 2) then + h1 = exc(1,1,1) + h2 = exc(2,1,1) + p1 = exc(1,2,1) + p2 = exc(2,2,1) + s1 = 1 + s2 = 1 + else if (exc(0,1,2) == 2) then + h1 = exc(1,1,2) + h2 = exc(2,1,2) + p1 = exc(1,2,2) + p2 = exc(2,2,2) + s1 = 2 + s2 = 2 + else + h1 = exc(1,1,1) + h2 = exc(1,1,2) + p1 = exc(1,2,1) + p2 = exc(1,2,2) + s1 = 1 + s2 = 2 + endif + case(1) + if (exc(0,1,1) == 1) then + h1 = exc(1,1,1) + h2 = 0 + p1 = exc(1,2,1) + p2 = 0 + s1 = 1 + s2 = 0 + else + h1 = exc(1,1,2) + h2 = 0 + p1 = exc(1,2,2) + p2 = 0 + s1 = 2 + s2 = 0 + endif + case(0) + h1 = 0 + p1 = 0 + h2 = 0 + p2 = 0 + s1 = 0 + s2 = 0 + end select +end + + subroutine get_double_excitation(det1,det2,exc,phase,Nint) use bitmasks implicit none @@ -429,148 +495,6 @@ end - - -subroutine i_H_j_new(key_i,key_j,Nint,hij) - use bitmasks - implicit none - BEGIN_DOC - ! Returns where i and j are determinants - END_DOC - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) - double precision, intent(out) :: hij - - integer :: exc(0:2,2,2) - integer :: degree - double precision :: get_mo_bielec_integral - integer :: m,n,p,q - integer :: i,j,k - integer :: occ(Nint*bit_kind_size,2) - double precision :: diag_H_mat_elem, phase,phase_2 - integer :: n_occ_ab(2) - logical :: has_mipi(Nint*bit_kind_size) - double precision :: mipi(Nint*bit_kind_size), miip(Nint*bit_kind_size) - PROVIDE mo_bielec_integrals_in_map mo_integrals_map - - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - ASSERT (sum(popcnt(key_i(:,1))) == elec_alpha_num) - ASSERT (sum(popcnt(key_i(:,2))) == elec_beta_num) - ASSERT (sum(popcnt(key_j(:,1))) == elec_alpha_num) - ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num) - - hij = 0.d0 - !DIR$ FORCEINLINE - call get_excitation_degree(key_i,key_j,degree,Nint) - integer :: spin - select case (degree) - case (2) - call get_double_excitation(key_i,key_j,exc,phase,Nint) - if (exc(0,1,1) == 1) then - ! Mono alpha, mono beta - hij = phase*get_mo_bielec_integral( & - exc(1,1,1), & - exc(1,1,2), & - exc(1,2,1), & - exc(1,2,2) ,mo_integrals_map) - else if (exc(0,1,1) == 2) then - ! Double alpha - hij = phase*(get_mo_bielec_integral( & - exc(1,1,1), & - exc(2,1,1), & - exc(1,2,1), & - exc(2,2,1) ,mo_integrals_map) - & - get_mo_bielec_integral( & - exc(1,1,1), & - exc(2,1,1), & - exc(2,2,1), & - exc(1,2,1) ,mo_integrals_map) ) - else if (exc(0,1,2) == 2) then - ! Double beta - hij = phase*(get_mo_bielec_integral( & - exc(1,1,2), & - exc(2,1,2), & - exc(1,2,2), & - exc(2,2,2) ,mo_integrals_map) - & - get_mo_bielec_integral( & - exc(1,1,2), & - exc(2,1,2), & - exc(2,2,2), & - exc(1,2,2) ,mo_integrals_map) ) - endif - case (1) - call get_mono_excitation(key_i,key_j,exc,phase,Nint) - !DIR$ FORCEINLINE - call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) - has_mipi = .False. - if (exc(0,1,1) == 1) then - ! Mono alpha - m = exc(1,1,1) - p = exc(1,2,1) - spin = 1 - do k = 1, elec_alpha_num - i = occ(k,1) - if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) - miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) - has_mipi(i) = .True. - endif - enddo - do k = 1, elec_beta_num - i = occ(k,2) - if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) - has_mipi(i) = .True. - endif - enddo - - do k = 1, elec_alpha_num - hij = hij + mipi(occ(k,1)) - miip(occ(k,1)) - enddo - do k = 1, elec_beta_num - hij = hij + mipi(occ(k,2)) - enddo - - else - ! Mono beta - m = exc(1,1,2) - p = exc(1,2,2) - spin = 2 - - do k = 1, elec_beta_num - i = occ(k,2) - if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) - miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) - has_mipi(i) = .True. - endif - enddo - do k = 1, elec_alpha_num - i = occ(k,1) - if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) - has_mipi(i) = .True. - endif - enddo - - do k = 1, elec_alpha_num - hij = hij + mipi(occ(k,1)) - enddo - do k = 1, elec_beta_num - hij = hij + mipi(occ(k,2)) - miip(occ(k,2)) - enddo - - endif - hij = phase*(hij + mo_mono_elec_integral(m,p)) - - - case (0) - hij = diag_H_mat_elem(key_i,Nint) - end select -end - - subroutine i_H_j(key_i,key_j,Nint,hij) use bitmasks implicit none @@ -589,8 +513,6 @@ subroutine i_H_j(key_i,key_j,Nint,hij) integer :: occ(Nint*bit_kind_size,2) double precision :: diag_H_mat_elem, phase,phase_2 integer :: n_occ_ab(2) - logical :: has_mipi(Nint*bit_kind_size) - double precision :: mipi(Nint*bit_kind_size), miip(Nint*bit_kind_size) PROVIDE mo_bielec_integrals_in_map mo_integrals_map ASSERT (Nint > 0) @@ -649,67 +571,17 @@ subroutine i_H_j(key_i,key_j,Nint,hij) call get_mono_excitation(key_i,key_j,exc,phase,Nint) !DIR$ FORCEINLINE call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) - has_mipi = .False. if (exc(0,1,1) == 1) then ! Mono alpha m = exc(1,1,1) p = exc(1,2,1) spin = 1 -! do k = 1, elec_alpha_num -! i = occ(k,1) -! if (.not.has_mipi(i)) then -! mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) -! miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) -! has_mipi(i) = .True. -! endif -! enddo -! do k = 1, elec_beta_num -! i = occ(k,2) -! if (.not.has_mipi(i)) then -! mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) -! has_mipi(i) = .True. -! endif -! enddo -! -! do k = 1, elec_alpha_num -! hij = hij + mipi(occ(k,1)) - miip(occ(k,1)) -! enddo -! do k = 1, elec_beta_num -! hij = hij + mipi(occ(k,2)) -! enddo - else ! Mono beta m = exc(1,1,2) p = exc(1,2,2) spin = 2 - -! do k = 1, elec_beta_num -! i = occ(k,2) -! if (.not.has_mipi(i)) then -! mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) -! miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) -! has_mipi(i) = .True. -! endif -! enddo -! do k = 1, elec_alpha_num -! i = occ(k,1) -! if (.not.has_mipi(i)) then -! mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) -! has_mipi(i) = .True. -! endif -! enddo -! -! do k = 1, elec_alpha_num -! hij = hij + mipi(occ(k,1)) -! enddo -! do k = 1, elec_beta_num -! hij = hij + mipi(occ(k,2)) - miip(occ(k,2)) -! enddo - endif -! hij = phase*(hij + mo_mono_elec_integral(m,p)) - call get_mono_excitation_from_fock(key_i,key_j,p,m,spin,phase,hij) case (0) @@ -1017,8 +889,6 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble) hij = diag_H_mat_elem(key_i,Nint) end select end - - subroutine create_minilist(key_mask, fullList, miniList, idx_miniList, N_fullList, N_miniList, Nint) use bitmasks implicit none @@ -1082,17 +952,17 @@ subroutine create_minilist_find_previous(key_mask, fullList, miniList, N_fullLis 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) + integer(bit_kind), allocatable :: subList(:,:,:) logical,intent(out) :: fullMatch integer,intent(out) :: N_miniList integer(bit_kind) :: key_mask(Nint, 2) integer :: ni, i, k, l, N_subList + allocate (subList(Nint, 2, N_fullList)) fullMatch = .false. N_miniList = 0 N_subList = 0 - 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)) @@ -1125,8 +995,13 @@ subroutine create_minilist_find_previous(key_mask, fullList, miniList, N_fullLis miniList(ni,2,N_minilist) = fullList(ni,2,i) enddo else if(k == 0) then - fullMatch = .true. - return + N_minilist += 1 + do ni=1,Nint + miniList(ni,1,N_minilist) = fullList(ni,1,i) + miniList(ni,2,N_minilist) = fullList(ni,2,i) + enddo +! fullMatch = .true. +! return end if end do end if @@ -1140,6 +1015,8 @@ subroutine create_minilist_find_previous(key_mask, fullList, miniList, N_fullLis enddo N_minilist = N_minilist + N_subList end if + + deallocate(sublist) end subroutine @@ -1235,6 +1112,7 @@ subroutine i_H_psi_minilist(key,keys,idx_key,N_minilist,coef,Nint,Ndet,Ndet_max, i_in_coef = idx_key(idx(ii)) !DIR$ FORCEINLINE call i_H_j(keys(1,1,i_in_key),key,Nint,hij) + ! TODO : Cache misses i_H_psi_array(1) = i_H_psi_array(1) + coef(i_in_coef,1)*hij enddo @@ -1852,7 +1730,6 @@ subroutine get_excitation_degree_vector(key1,key2,degree,Nint,sze,idx) l=1 if (Nint==1) then - !DIR$ LOOP COUNT (1000) do i=1,sze d = popcnt(xor( key1(1,1,i), key2(1,1))) + & popcnt(xor( key1(1,2,i), key2(1,2))) @@ -1867,7 +1744,6 @@ subroutine get_excitation_degree_vector(key1,key2,degree,Nint,sze,idx) else if (Nint==2) then - !DIR$ LOOP COUNT (1000) do i=1,sze d = popcnt(xor( key1(1,1,i), key2(1,1))) + & popcnt(xor( key1(1,2,i), key2(1,2))) + & @@ -1884,7 +1760,6 @@ subroutine get_excitation_degree_vector(key1,key2,degree,Nint,sze,idx) else if (Nint==3) then - !DIR$ LOOP COUNT (1000) do i=1,sze d = popcnt(xor( key1(1,1,i), key2(1,1))) + & popcnt(xor( key1(1,2,i), key2(1,2))) + & @@ -1903,10 +1778,8 @@ subroutine get_excitation_degree_vector(key1,key2,degree,Nint,sze,idx) else - !DIR$ LOOP COUNT (1000) do i=1,sze d = 0 - !DIR$ LOOP COUNT MIN(4) do m=1,Nint d = d + popcnt(xor( key1(m,1,i), key2(m,1))) & + popcnt(xor( key1(m,2,i), key2(m,2))) @@ -2166,172 +2039,117 @@ subroutine get_occ_from_key(key,occ,Nint) end -subroutine u0_H_u_0(e_0,u_0,n,keys_tmp,Nint) + +subroutine get_double_excitation_phase(det1,det2,exc,phase,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) + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: det1(Nint,2) + integer(bit_kind), intent(in) :: det2(Nint,2) + integer, intent(in) :: exc(0:2,2,2) + double precision, intent(out) :: phase + integer :: tz + integer :: l, ispin, idx_hole, idx_particle, ishift + integer :: nperm + integer :: i,j,k,m,n + integer :: high, low + integer :: a,b,c,d + integer(bit_kind) :: hole, particle, tmp + double precision, parameter :: phase_dble(0:1) = (/ 1.d0, -1.d0 /) + + ASSERT (Nint > 0) + nperm = 0 + do ispin = 1,2 + select case (exc(0,1,ispin)) + case(0) + cycle + + case(1) + low = min(exc(1,1,ispin), exc(1,2,ispin)) + high = max(exc(1,1,ispin), exc(1,2,ispin)) + + ASSERT (low > 0) + j = ishft(low-1,-bit_kind_shift)+1 ! Find integer in array(Nint) + n = iand(low-1,bit_kind_size-1)+1 ! mod(low,bit_kind_size) + ASSERT (high > 0) + k = ishft(high-1,-bit_kind_shift)+1 + m = iand(high-1,bit_kind_size-1)+1 + + if (j==k) then + nperm = nperm + popcnt(iand(det1(j,ispin), & + iand( ibset(0_bit_kind,m-1)-1_bit_kind, & + ibclr(-1_bit_kind,n)+1_bit_kind ) )) + else + nperm = nperm + popcnt(iand(det1(k,ispin), & + ibset(0_bit_kind,m-1)-1_bit_kind)) + if (n < bit_kind_size) then + nperm = nperm + popcnt(iand(det1(j,ispin), ibclr(-1_bit_kind,n) +1_bit_kind)) + endif + do i=j+1,k-1 + nperm = nperm + popcnt(det1(i,ispin)) + end do + endif + + case (2) + + do i=1,2 + low = min(exc(i,1,ispin), exc(i,2,ispin)) + high = max(exc(i,1,ispin), exc(i,2,ispin)) + + ASSERT (low > 0) + j = ishft(low-1,-bit_kind_shift)+1 ! Find integer in array(Nint) + n = iand(low-1,bit_kind_size-1)+1 ! mod(low,bit_kind_size) + ASSERT (high > 0) + k = ishft(high-1,-bit_kind_shift)+1 + m = iand(high-1,bit_kind_size-1)+1 + + if (j==k) then + nperm = nperm + popcnt(iand(det1(j,ispin), & + iand( ibset(0_bit_kind,m-1)-1_bit_kind, & + ibclr(-1_bit_kind,n)+1_bit_kind ) )) + else + nperm = nperm + popcnt(iand(det1(k,ispin), & + ibset(0_bit_kind,m-1)-1_bit_kind)) + if (n < bit_kind_size) then + nperm = nperm + popcnt(iand(det1(j,ispin), ibclr(-1_bit_kind,n) +1_bit_kind)) + endif + do l=j+1,k-1 + nperm = nperm + popcnt(det1(l,ispin)) + end do + endif + + enddo + + a = min(exc(1,1,ispin), exc(1,2,ispin)) + b = max(exc(1,1,ispin), exc(1,2,ispin)) + c = min(exc(2,1,ispin), exc(2,2,ispin)) + d = max(exc(2,1,ispin), exc(2,2,ispin)) + if (c>a .and. cb) then + nperm = nperm + 1 + endif + exit + end select + 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) + phase = phase_dble(iand(nperm,1)) end -subroutine H_u_0(v_0,u_0,H_jj,n,keys_tmp,Nint) + +subroutine get_phase(key1,key2,phase,Nint) use bitmasks implicit none + integer(bit_kind), intent(in) :: key1(Nint,2), key2(Nint,2) + integer, intent(in) :: Nint + double precision, intent(out) :: phase BEGIN_DOC - ! Computes v_0 = H|u_0> - ! - ! n : number of determinants - ! - ! H_jj : array of +! Returns the phase between key1 and key2 END_DOC - integer, intent(in) :: n,Nint - double precision, intent(out) :: v_0(n) - double precision, intent(in) :: u_0(n) - double precision, intent(in) :: H_jj(n) - integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) - integer, allocatable :: idx(:) - double precision :: hij - double precision, allocatable :: vt(:) - integer :: i,j,k,l, jj,ii - integer :: i0, j0 - - integer, allocatable :: shortcut(:), sort_idx(:) - integer(bit_kind), allocatable :: sorted(:,:), version(:,:) - integer(bit_kind) :: sorted_i(Nint) - - integer :: sh, sh2, ni, exa, ext, org_i, org_j, endi - double precision :: local_threshold - + integer :: exc(0:2, 2, 2), degree - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - ASSERT (n>0) - PROVIDE ref_bitmask_energy davidson_criterion - - allocate (shortcut(0:n+1), sort_idx(n), sorted(Nint,n), version(Nint,n)) - v_0 = 0.d0 - - call sort_dets_ab_v(keys_tmp, sorted, sort_idx, shortcut, version, n, Nint) - - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(i,hij,j,k,jj,vt,ii,sh,sh2,ni,exa,ext,org_i,org_j,endi,local_threshold,sorted_i)& - !$OMP SHARED(n,H_jj,u_0,keys_tmp,Nint,v_0,threshold_davidson,sorted,shortcut,sort_idx,version) - allocate(vt(n)) - Vt = 0.d0 - - !$OMP DO SCHEDULE(dynamic) - do sh=1,shortcut(0) - do sh2=1,sh - exa = 0 - do ni=1,Nint - exa = exa + popcnt(xor(version(ni,sh), version(ni,sh2))) - end do - if(exa > 2) then - cycle - end if - - do i=shortcut(sh),shortcut(sh+1)-1 - org_i = sort_idx(i) - local_threshold = threshold_davidson - dabs(u_0(org_i)) - if(sh==sh2) then - endi = i-1 - else - endi = shortcut(sh2+1)-1 - end if - do ni=1,Nint - sorted_i(ni) = sorted(ni,i) - enddo - - do j=shortcut(sh2),endi - org_j = sort_idx(j) - if ( dabs(u_0(org_j)) > local_threshold ) then - ext = exa - do ni=1,Nint - ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j))) - end do - if(ext <= 4) then - call i_H_j(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),Nint,hij) - vt (org_i) = vt (org_i) + hij*u_0(org_j) - vt (org_j) = vt (org_j) + hij*u_0(org_i) - endif - endif - enddo - enddo - enddo - enddo - !$OMP END DO - - !$OMP CRITICAL - do i=1,n - v_0(i) = v_0(i) + vt(i) - enddo - !$OMP END CRITICAL - - deallocate(vt) - !$OMP END PARALLEL - - call sort_dets_ba_v(keys_tmp, sorted, sort_idx, shortcut, version, n, Nint) - - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(i,hij,j,k,jj,vt,ii,sh,sh2,ni,exa,ext,org_i,org_j,endi,local_threshold)& - !$OMP SHARED(n,H_jj,u_0,keys_tmp,Nint,v_0,threshold_davidson,sorted,shortcut,sort_idx,version) - allocate(vt(n)) - Vt = 0.d0 - - !$OMP DO SCHEDULE(dynamic) - do sh=1,shortcut(0) - do i=shortcut(sh),shortcut(sh+1)-1 - org_i = sort_idx(i) - local_threshold = threshold_davidson - dabs(u_0(org_i)) - do j=shortcut(sh),i-1 - org_j = sort_idx(j) - if ( dabs(u_0(org_j)) > local_threshold ) then - ext = 0 - do ni=1,Nint - ext = ext + popcnt(xor(sorted(ni,i), sorted(ni,j))) - end do - if(ext == 4) then - call i_H_j(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),Nint,hij) - vt (org_i) = vt (org_i) + hij*u_0(org_j) - vt (org_j) = vt (org_j) + hij*u_0(org_i) - end if - end if - end do - end do - enddo - !$OMP END DO - - !$OMP CRITICAL - do i=1,n - v_0(i) = v_0(i) + vt(i) - enddo - !$OMP END CRITICAL - deallocate(vt) - !$OMP END PARALLEL - - do i=1,n - v_0(i) += H_jj(i) * u_0(i) - enddo - deallocate (shortcut, sort_idx, sorted, version) + !DIR$ FORCEINLINE + call get_excitation(key1, key2, exc, degree, phase, Nint) end subroutine H_u_0_stored(v_0,u_0,hmatrix,sze) diff --git a/src/Determinants/spindeterminants.irp.f b/src/Determinants/spindeterminants.irp.f index 8d5726f5..2eec0dea 100644 --- a/src/Determinants/spindeterminants.irp.f +++ b/src/Determinants/spindeterminants.irp.f @@ -10,7 +10,7 @@ integer*8 function spin_det_search_key(det,Nint) use bitmasks implicit none BEGIN_DOC -! Return an integer*8 corresponding to a determinant index for searching +! Return an integer(8) corresponding to a determinant index for searching END_DOC integer, intent(in) :: Nint integer(bit_kind), intent(in) :: det(Nint) @@ -64,9 +64,9 @@ BEGIN_TEMPLATE integer :: i,j,k integer, allocatable :: iorder(:) - integer*8, allocatable :: bit_tmp(:) - integer*8 :: last_key - integer*8, external :: spin_det_search_key + integer(8), allocatable :: bit_tmp(:) + integer(8) :: last_key + integer(8), external :: spin_det_search_key logical,allocatable :: duplicate(:) allocate ( iorder(N_det), bit_tmp(N_det), duplicate(N_det) ) @@ -149,8 +149,8 @@ integer function get_index_in_psi_det_alpha_unique(key,Nint) integer(bit_kind), intent(in) :: key(Nint) integer :: i, ibegin, iend, istep, l - integer*8 :: det_ref, det_search - integer*8, external :: spin_det_search_key + integer(8) :: det_ref, det_search + integer(8), external :: spin_det_search_key logical :: in_wavefunction in_wavefunction = .False. @@ -231,8 +231,8 @@ integer function get_index_in_psi_det_beta_unique(key,Nint) integer(bit_kind), intent(in) :: key(Nint) integer :: i, ibegin, iend, istep, l - integer*8 :: det_ref, det_search - integer*8, external :: spin_det_search_key + integer(8) :: det_ref, det_search + integer(8), external :: spin_det_search_key logical :: in_wavefunction in_wavefunction = .False. @@ -305,10 +305,10 @@ end subroutine write_spindeterminants use bitmasks implicit none - integer*8, allocatable :: tmpdet(:,:) + integer(8), allocatable :: tmpdet(:,:) integer :: N_int2 integer :: i,j,k - integer*8 :: det_8(100) + integer(8) :: det_8(100) integer(bit_kind) :: det_bk((100*8)/bit_kind) equivalence (det_8, det_bk) diff --git a/src/Determinants/tree_dependency.png b/src/Determinants/tree_dependency.png index f9eb10c3..9184383e 100644 Binary files a/src/Determinants/tree_dependency.png and b/src/Determinants/tree_dependency.png differ diff --git a/src/Ezfio_files/README.rst b/src/Ezfio_files/README.rst index 90e717bc..6b494339 100644 --- a/src/Ezfio_files/README.rst +++ b/src/Ezfio_files/README.rst @@ -181,6 +181,10 @@ Documentation variable if it is set, or as the 1st argument of the command line. +`ezfio_work_dir `_ + EZFIO/work/ + + `getunitandopen `_ :f: file name @@ -195,6 +199,10 @@ Documentation .br +output_all_singles + Output file for All_singles + + output_ao_basis Output file for AO_Basis @@ -203,12 +211,8 @@ output_bitmask Output file for Bitmask -output_cisd - Output file for CISD - - -output_cisd_selected - Output file for CISD_selected +output_cas_sd + Output file for CAS_SD `output_cpu_time_0 `_ @@ -227,18 +231,22 @@ output_ezfio_files Output file for Ezfio_files -output_fcidump - Output file for FCIdump - - output_full_ci Output file for Full_CI +output_generators_cas + Output file for Generators_CAS + + output_generators_full Output file for Generators_full +output_generators_restart + Output file for Generators_restart + + output_hartree_fock Output file for Hartree_Fock @@ -259,8 +267,12 @@ output_moguess Output file for MOGuess -output_mp2 - Output file for MP2 +output_mrcc_cassd + Output file for MRCC_CASSD + + +output_mrcc_utils + Output file for MRCC_Utils output_nuclei @@ -279,12 +291,20 @@ output_pseudo Output file for Pseudo +output_psiref_cas + Output file for Psiref_CAS + + +output_psiref_utils + Output file for Psiref_Utils + + output_selectors_full Output file for Selectors_full -output_singlerefmethod - Output file for SingleRefMethod +output_selectors_no_sorted + Output file for Selectors_no_sorted output_utils diff --git a/src/Ezfio_files/ezfio.irp.f b/src/Ezfio_files/ezfio.irp.f index 9432020f..6d2beb0b 100644 --- a/src/Ezfio_files/ezfio.irp.f +++ b/src/Ezfio_files/ezfio.irp.f @@ -31,3 +31,12 @@ BEGIN_PROVIDER [ character*(128), ezfio_filename ] END_PROVIDER +BEGIN_PROVIDER [ character*(128), ezfio_work_dir ] + implicit none + BEGIN_DOC + ! EZFIO/work/ + END_DOC + call ezfio_set_work_empty(.False.) + ezfio_work_dir = trim(ezfio_filename)//'/work/' +END_PROVIDER + diff --git a/src/Integrals_Bielec/.gitignore b/src/Integrals_Bielec/.gitignore index 1d52a821..aaf8a3d5 100644 --- a/src/Integrals_Bielec/.gitignore +++ b/src/Integrals_Bielec/.gitignore @@ -17,4 +17,6 @@ ZMQ ezfio_interface.irp.f irpf90.make irpf90_entities -tags \ No newline at end of file +qp_ao_ints +tags +test_integrals \ No newline at end of file diff --git a/src/Integrals_Bielec/EZFIO.cfg b/src/Integrals_Bielec/EZFIO.cfg index 0d5c5832..4e7e494f 100644 --- a/src/Integrals_Bielec/EZFIO.cfg +++ b/src/Integrals_Bielec/EZFIO.cfg @@ -12,22 +12,6 @@ interface: ezfio,provider,ocaml default: False ezfio_name: no_vvvv_integrals - -[write_ao_map_after_transfo] -type: logical -doc: If True, you dump all the ao integrals after having transformed the mo integrals -interface: ezfio,provider,ocaml -default: False -ezfio_name: write_ao_map_after_transfo - -[clear_ao_map_after_mo_transfo] -type: logical -doc: If True, you clear all the ao integrals after having done the transformation -interface: ezfio,provider,ocaml -default: False -ezfio_name: clear_ao_map_after_mo_transfo - - [no_ivvv_integrals] type: logical doc: Can be switched on only if no_vvvv_integrals is True, then do not computes the integrals having 3 virtual index and 1 belonging to the core inactive active orbitals diff --git a/src/Integrals_Bielec/README.rst b/src/Integrals_Bielec/README.rst index a22d791d..98fbbb92 100644 --- a/src/Integrals_Bielec/README.rst +++ b/src/Integrals_Bielec/README.rst @@ -9,6 +9,12 @@ Here, all bi-electronic integrals (:math:`1/r_{12}`) are computed. As they have MO integral, use ``get_mo_bielec_integral(i,j,k,l,mo_integrals_map)`` or ``mo_bielec_integral(i,j,k,l)``. +The conventions are: + +* For AO integrals : (ik|jl) = (11|22) +* For MO integrals : = <12|12> + + Needed Modules ============== @@ -48,28 +54,36 @@ Documentation i(r1) j(r1) 1/r12 k(r2) l(r2) -`ao_bielec_integral_schwartz `_ +`ao_bielec_integral_schwartz `_ Needed to compute Schwartz inequalities -`ao_bielec_integral_schwartz_accel `_ +`ao_bielec_integral_schwartz_accel `_ integral of the AO basis or (ij|kl) i(r1) j(r1) 1/r12 k(r2) l(r2) -`ao_bielec_integrals_in_map `_ +`ao_bielec_integrals_in_map `_ Map of Atomic integrals i(r1) j(r2) 1/r12 k(r1) l(r2) -`ao_bielec_integrals_in_map_collector `_ +`ao_bielec_integrals_in_map_collector `_ Collects results from the AO integral calculation -`ao_bielec_integrals_in_map_slave `_ +`ao_bielec_integrals_in_map_slave `_ Computes a buffer of integrals +`ao_bielec_integrals_in_map_slave_inproc `_ + Computes a buffer of integrals. i is the ID of the current thread. + + +`ao_bielec_integrals_in_map_slave_tcp `_ + Computes a buffer of integrals. i is the ID of the current thread. + + `ao_integrals_map `_ AO integrals @@ -78,7 +92,7 @@ Documentation If || < ao_integrals_threshold then is zero -`ao_l4 `_ +`ao_l4 `_ Computes the product of l values of i,j,k,and l @@ -98,15 +112,15 @@ Documentation Frees the memory of the AO map -`clear_mo_map `_ +`clear_mo_map `_ Frees the memory of the MO map -`compute_ao_bielec_integrals `_ +`compute_ao_bielec_integrals `_ Compute AO 1/r12 integrals for all i and fixed j,k,l -`compute_ao_integrals_jl `_ +`compute_ao_integrals_jl `_ Parallel client for AO integrals @@ -122,15 +136,15 @@ Documentation Compute integrals on the fly -`dump_ao_integrals `_ +`dump_ao_integrals `_ Save to disk the $ao integrals -`dump_mo_integrals `_ +`dump_mo_integrals `_ Save to disk the $ao integrals -`eri `_ +`eri `_ ATOMIC PRIMTIVE bielectronic integral between the 4 primitives :: primitive_1 = x1**(a_x) y1**(a_y) z1**(a_z) exp(-alpha * r1**2) primitive_2 = x1**(b_x) y1**(b_y) z1**(b_z) exp(- beta * r1**2) @@ -152,7 +166,7 @@ Documentation t_w(i,2,k) = t(i) -`general_primitive_integral `_ +`general_primitive_integral `_ Computes the integral where p,q,r,s are Gaussian primitives @@ -174,126 +188,126 @@ Documentation Returns the number of elements in the AO map -`get_mo_bielec_integral `_ +`get_mo_bielec_integral `_ Returns one integral in the MO basis -`get_mo_bielec_integral_schwartz `_ +`get_mo_bielec_integral_schwartz `_ Returns one integral in the MO basis -`get_mo_bielec_integrals `_ +`get_mo_bielec_integrals `_ Returns multiple integrals in the MO basis, all i for j,k,l fixed. -`get_mo_bielec_integrals_ij `_ +`get_mo_bielec_integrals_ij `_ Returns multiple integrals in the MO basis, all i(1)j(2) 1/r12 k(1)l(2) i, j for k,l fixed. -`get_mo_map_size `_ +`get_mo_map_size `_ Return the number of elements in the MO map -`give_polynom_mult_center_x `_ +`give_polynom_mult_center_x `_ subroutine that returns the explicit polynom in term of the "t" variable of the following polynomw : I_x1(a_x, d_x,p,q) * I_x1(a_y, d_y,p,q) * I_x1(a_z, d_z,p,q) -`i_x1_new `_ +`i_x1_new `_ recursive function involved in the bielectronic integral -`i_x1_pol_mult `_ +`i_x1_pol_mult `_ recursive function involved in the bielectronic integral -`i_x1_pol_mult_a1 `_ +`i_x1_pol_mult_a1 `_ recursive function involved in the bielectronic integral -`i_x1_pol_mult_a2 `_ +`i_x1_pol_mult_a2 `_ recursive function involved in the bielectronic integral -`i_x1_pol_mult_recurs `_ +`i_x1_pol_mult_recurs `_ recursive function involved in the bielectronic integral -`i_x2_new `_ +`i_x2_new `_ recursive function involved in the bielectronic integral -`i_x2_pol_mult `_ +`i_x2_pol_mult `_ recursive function involved in the bielectronic integral -`insert_into_ao_integrals_map `_ +`insert_into_ao_integrals_map `_ Create new entry into AO map -`insert_into_mo_integrals_map `_ +`insert_into_mo_integrals_map `_ Create new entry into MO map, or accumulate in an existing entry -`integrale_new `_ +`integrale_new `_ calculate the integral of the polynom :: I_x1(a_x+b_x, c_x+d_x,p,q) * I_x1(a_y+b_y, c_y+d_y,p,q) * I_x1(a_z+b_z, c_z+d_z,p,q) between ( 0 ; 1) -`load_ao_integrals `_ +`load_ao_integrals `_ Read from disk the $ao integrals -`load_mo_integrals `_ +`load_mo_integrals `_ Read from disk the $ao integrals -`mo_bielec_integral `_ +`mo_bielec_integral `_ Returns one integral in the MO basis -`mo_bielec_integral_jj `_ +`mo_bielec_integral_jj `_ mo_bielec_integral_jj(i,j) = J_ij mo_bielec_integral_jj_exchange(i,j) = K_ij mo_bielec_integral_jj_anti(i,j) = J_ij - K_ij -`mo_bielec_integral_jj_anti `_ +`mo_bielec_integral_jj_anti `_ mo_bielec_integral_jj(i,j) = J_ij mo_bielec_integral_jj_exchange(i,j) = K_ij mo_bielec_integral_jj_anti(i,j) = J_ij - K_ij -`mo_bielec_integral_jj_anti_from_ao `_ +`mo_bielec_integral_jj_anti_from_ao `_ mo_bielec_integral_jj_from_ao(i,j) = J_ij mo_bielec_integral_jj_exchange_from_ao(i,j) = J_ij mo_bielec_integral_jj_anti_from_ao(i,j) = J_ij - K_ij -`mo_bielec_integral_jj_exchange `_ +`mo_bielec_integral_jj_exchange `_ mo_bielec_integral_jj(i,j) = J_ij mo_bielec_integral_jj_exchange(i,j) = K_ij mo_bielec_integral_jj_anti(i,j) = J_ij - K_ij -`mo_bielec_integral_jj_exchange_from_ao `_ +`mo_bielec_integral_jj_exchange_from_ao `_ mo_bielec_integral_jj_from_ao(i,j) = J_ij mo_bielec_integral_jj_exchange_from_ao(i,j) = J_ij mo_bielec_integral_jj_anti_from_ao(i,j) = J_ij - K_ij -`mo_bielec_integral_jj_from_ao `_ +`mo_bielec_integral_jj_from_ao `_ mo_bielec_integral_jj_from_ao(i,j) = J_ij mo_bielec_integral_jj_exchange_from_ao(i,j) = J_ij mo_bielec_integral_jj_anti_from_ao(i,j) = J_ij - K_ij -`mo_bielec_integral_schwartz `_ +`mo_bielec_integral_schwartz `_ Needed to compute Schwartz inequalities @@ -305,7 +319,7 @@ Documentation Computes an unique index for i,j,k,l integrals -`mo_integrals_map `_ +`mo_integrals_map `_ MO integrals @@ -317,12 +331,28 @@ Documentation Aligned n_pt_max_integrals -`n_pt_sup `_ +`n_pt_sup `_ Returns the upper boundary of the degree of the polynomial involved in the bielctronic integral : Ix(a_x,b_x,c_x,d_x) * Iy(a_y,b_y,c_y,d_y) * Iz(a_z,b_z,c_z,d_z) +`provide_all_mo_integrals `_ + Undocumented + + +`pull_integrals `_ + How the collector pulls the computed integrals + + +`push_integrals `_ + Push integrals in the push socket + + +`qp_ao_ints `_ + Increments a running calculation to compute AO integrals + + `read_ao_integrals `_ One level of abstraction for disk_access_ao_integrals and disk_access_mo_integrals diff --git a/src/Integrals_Bielec/ao_bi_integrals.irp.f b/src/Integrals_Bielec/ao_bi_integrals.irp.f index 54bcc1c4..d8a18437 100644 --- a/src/Integrals_Bielec/ao_bi_integrals.irp.f +++ b/src/Integrals_Bielec/ao_bi_integrals.irp.f @@ -4,6 +4,7 @@ double precision function ao_bielec_integral(i,j,k,l) ! integral of the AO basis or (ij|kl) ! i(r1) j(r1) 1/r12 k(r2) l(r2) END_DOC + integer,intent(in) :: i,j,k,l integer :: p,q,r,s double precision :: I_center(3),J_center(3),K_center(3),L_center(3) @@ -352,13 +353,11 @@ BEGIN_PROVIDER [ logical, ao_bielec_integrals_in_map ] print*, 'read_ao_integrals',read_ao_integrals print*, 'disk_access_ao_integrals',disk_access_ao_integrals if (read_ao_integrals) then - integer :: load_ao_integrals print*,'Reading the AO integrals' - if (load_ao_integrals(trim(ezfio_filename)//'/work/ao_integrals.bin') == 0) then + call map_load_from_disk(trim(ezfio_filename)//'/work/ao_ints',ao_integrals_map) print*, 'AO integrals provided' ao_bielec_integrals_in_map = .True. return - endif endif print*, 'Providing the AO integrals' @@ -371,25 +370,23 @@ BEGIN_PROVIDER [ logical, ao_bielec_integrals_in_map ] call new_parallel_job(zmq_to_qp_run_socket,'ao_integrals') - do l=1,ao_num - write(task,*) l + do l=ao_num,1,-1 + write(task,*) "triangle ", l call add_task_to_taskserver(zmq_to_qp_run_socket,task) enddo + + call zmq_set_running(zmq_to_qp_run_socket) - 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) + PROVIDE nproc + !$OMP PARALLEL DEFAULT(private) num_threads(nproc+1) i = omp_get_thread_num() - call ao_bielec_integrals_in_map_slave_inproc(i) - !$OMP END TASK - !$OMP TASKWAIT + if (i==0) then + call ao_bielec_integrals_in_map_collector(i) + else + call ao_bielec_integrals_in_map_slave_inproc(i) + endif !$OMP END PARALLEL - rc = pthread_join(collector_thread) - call end_parallel_job(zmq_to_qp_run_socket, 'ao_integrals') @@ -407,8 +404,10 @@ BEGIN_PROVIDER [ logical, ao_bielec_integrals_in_map ] print*, ' wall time :',wall_2 - wall_1, 's ( x ', (cpu_2-cpu_1)/(wall_2-wall_1+tiny(1.d0)), ' )' ao_bielec_integrals_in_map = .True. + if (write_ao_integrals) then - call dump_ao_integrals(trim(ezfio_filename)//'/work/ao_integrals.bin') + call ezfio_set_work_empty(.False.) + call map_save_to_disk(trim(ezfio_filename)//'/work/ao_ints',ao_integrals_map) call ezfio_set_integrals_bielec_disk_access_ao_integrals("Read") endif @@ -1214,7 +1213,7 @@ subroutine compute_ao_integrals_jl(j,l,n_integrals,buffer_i,buffer_value) cycle endif !DIR$ FORCEINLINE - integral = ao_bielec_integral(i,k,j,l) + integral = ao_bielec_integral(i,k,j,l) ! i,k : r1 j,l : r2 if (abs(integral) < thr) then cycle endif 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 6102d119..ce4518cf 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 @@ -34,25 +34,25 @@ subroutine push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, 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)' + 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)' + 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)' + 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)' + print *, irp_here, ': f77_zmq_send( zmq_socket_push, task_id, 4, 0)' stop 'error' endif @@ -60,13 +60,15 @@ subroutine push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, ! 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)' +! 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 @@ -91,6 +93,8 @@ subroutine ao_bielec_integrals_in_map_slave(thread,iproc) integer(ZMQ_PTR), external :: new_zmq_push_socket integer(ZMQ_PTR) :: zmq_socket_push + character*(64) :: state + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() zmq_socket_push = new_zmq_push_socket(thread) @@ -101,81 +105,21 @@ subroutine ao_bielec_integrals_in_map_slave(thread,iproc) do call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task) 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) + read(task,*) j, l + call compute_ao_integrals_jl(j,l,n_integrals,buffer_i,buffer_value) + call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) call push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, task_id) enddo - deallocate( buffer_i, buffer_value ) call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) + deallocate( buffer_i, buffer_value ) call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) call end_zmq_push_socket(zmq_socket_push,thread) 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 - -! 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 - - subroutine ao_bielec_integrals_in_map_collector use map_module use f77_zmq @@ -197,19 +141,59 @@ subroutine ao_bielec_integrals_in_map_collector integer(ZMQ_PTR) :: zmq_socket_pull integer*8 :: control, accu - integer :: task_id, more + integer :: task_id, more, sze 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) ) + sze = ao_num*ao_num + allocate ( buffer_i(sze), buffer_value(sze) ) accu = 0_8 more = 1 do while (more == 1) - call pull_integrals(zmq_socket_pull, n_integrals, buffer_i, buffer_value, task_id) + 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 + + if (n_integrals > sze) then + deallocate (buffer_value, buffer_i) + sze = n_integrals + allocate (buffer_value(sze), buffer_i(sze)) + endif + + rc = f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0) + if (rc /= key_kind*n_integrals) then + print *, rc, key_kind, n_integrals + 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) + +! 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 + + call insert_into_ao_integrals_map(n_integrals,buffer_i,buffer_value) accu += n_integrals if (task_id /= 0) then @@ -225,9 +209,11 @@ subroutine ao_bielec_integrals_in_map_collector 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 *, '' + print *, irp_here + print *, 'Control : ', control + print *, 'Accu : ', accu + print *, 'Some integrals were lost during the parallel computation.' print *, 'Try to reduce the number of threads.' stop endif diff --git a/src/Integrals_Bielec/map_integrals.irp.f b/src/Integrals_Bielec/map_integrals.irp.f index 65561a57..5f6df0bd 100644 --- a/src/Integrals_Bielec/map_integrals.irp.f +++ b/src/Integrals_Bielec/map_integrals.irp.f @@ -13,7 +13,7 @@ BEGIN_PROVIDER [ type(map_type), ao_integrals_map ] call bielec_integrals_index(ao_num,ao_num,ao_num,ao_num,key_max) sze = key_max call map_init(ao_integrals_map,sze) - print*, 'AO map initialized' + print*, 'AO map initialized : ', sze END_PROVIDER subroutine bielec_integrals_index(i,j,k,l,i1) @@ -109,8 +109,50 @@ subroutine bielec_integrals_index_reverse(i,j,k,l,i1) end + BEGIN_PROVIDER [ integer, ao_integrals_cache_min ] +&BEGIN_PROVIDER [ integer, ao_integrals_cache_max ] + implicit none + BEGIN_DOC + ! Min and max values of the AOs for which the integrals are in the cache + END_DOC + ao_integrals_cache_min = max(1,ao_num - 63) + ao_integrals_cache_max = ao_num -double precision function get_ao_bielec_integral(i,j,k,l,map) +END_PROVIDER + +BEGIN_PROVIDER [ double precision, ao_integrals_cache, (0:64*64*64*64) ] + implicit none + BEGIN_DOC + ! Cache of AO integrals for fast access + END_DOC + PROVIDE ao_bielec_integrals_in_map + integer :: i,j,k,l,ii + integer(key_kind) :: idx + real(integral_kind) :: integral + !$OMP PARALLEL DO PRIVATE (i,j,k,l,idx,ii,integral) + do l=ao_integrals_cache_min,ao_integrals_cache_max + do k=ao_integrals_cache_min,ao_integrals_cache_max + do j=ao_integrals_cache_min,ao_integrals_cache_max + do i=ao_integrals_cache_min,ao_integrals_cache_max + !DIR$ FORCEINLINE + call bielec_integrals_index(i,j,k,l,idx) + !DIR$ FORCEINLINE + call map_get(ao_integrals_map,idx,integral) + ii = l-ao_integrals_cache_min + ii = ior( ishft(ii,6), k-ao_integrals_cache_min) + ii = ior( ishft(ii,6), j-ao_integrals_cache_min) + ii = ior( ishft(ii,6), i-ao_integrals_cache_min) + ao_integrals_cache(ii) = integral + enddo + enddo + enddo + enddo + !$OMP END PARALLEL DO + +END_PROVIDER + + +double precision function get_ao_bielec_integral(i,j,k,l,map) result(result) use map_module implicit none BEGIN_DOC @@ -119,18 +161,34 @@ double precision function get_ao_bielec_integral(i,j,k,l,map) integer, intent(in) :: i,j,k,l integer(key_kind) :: idx type(map_type), intent(inout) :: map + integer :: ii real(integral_kind) :: tmp - PROVIDE ao_bielec_integrals_in_map + PROVIDE ao_bielec_integrals_in_map ao_integrals_cache ao_integrals_cache_min !DIR$ FORCEINLINE if (ao_overlap_abs(i,k)*ao_overlap_abs(j,l) < ao_integrals_threshold ) then tmp = 0.d0 else if (ao_bielec_integral_schwartz(i,k)*ao_bielec_integral_schwartz(j,l) < ao_integrals_threshold) then tmp = 0.d0 else - call bielec_integrals_index(i,j,k,l,idx) - call map_get(map,idx,tmp) + ii = l-ao_integrals_cache_min + ii = ior(ii, k-ao_integrals_cache_min) + ii = ior(ii, j-ao_integrals_cache_min) + ii = ior(ii, i-ao_integrals_cache_min) + if (iand(ii, -64) /= 0) then + !DIR$ FORCEINLINE + call bielec_integrals_index(i,j,k,l,idx) + !DIR$ FORCEINLINE + call map_get(map,idx,tmp) + tmp = tmp + else + ii = l-ao_integrals_cache_min + ii = ior( ishft(ii,6), k-ao_integrals_cache_min) + ii = ior( ishft(ii,6), j-ao_integrals_cache_min) + ii = ior( ishft(ii,6), i-ao_integrals_cache_min) + tmp = ao_integrals_cache(ii) + endif endif - get_ao_bielec_integral = tmp + result = tmp end @@ -155,16 +213,9 @@ subroutine get_ao_bielec_integrals(j,k,l,sze,out_val) return endif + double precision :: get_ao_bielec_integral do i=1,sze - if (ao_overlap_abs(i,k)*ao_overlap_abs(j,l) < thresh ) then - out_val(i) = 0.d0 - else if (ao_bielec_integral_schwartz(i,k)*ao_bielec_integral_schwartz(j,l) < thresh) then - out_val(i)=0.d0 - else - !DIR$ FORCEINLINE - call bielec_integrals_index(i,j,k,l,hash) - call map_get(ao_integrals_map, hash, out_val(i)) - endif + out_val(i) = get_ao_bielec_integral(i,j,k,l,ao_integrals_map) enddo end @@ -276,6 +327,51 @@ subroutine insert_into_mo_integrals_map(n_integrals, & call map_update(mo_integrals_map, buffer_i, buffer_values, n_integrals, thr) end + BEGIN_PROVIDER [ integer, mo_integrals_cache_min ] +&BEGIN_PROVIDER [ integer, mo_integrals_cache_max ] + implicit none + BEGIN_DOC + ! Min and max values of the MOs for which the integrals are in the cache + END_DOC + mo_integrals_cache_min = max(1,elec_alpha_num - 31) + mo_integrals_cache_max = min(mo_tot_num,mo_integrals_cache_min+63) + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, mo_integrals_cache, (0:64*64*64*64) ] + implicit none + BEGIN_DOC + ! Cache of MO integrals for fast access + END_DOC + PROVIDE mo_bielec_integrals_in_map + integer :: i,j,k,l + integer :: ii + integer(key_kind) :: idx + real(integral_kind) :: integral + FREE ao_integrals_cache + !$OMP PARALLEL DO PRIVATE (i,j,k,l,idx,ii,integral) + do l=mo_integrals_cache_min,mo_integrals_cache_max + do k=mo_integrals_cache_min,mo_integrals_cache_max + do j=mo_integrals_cache_min,mo_integrals_cache_max + do i=mo_integrals_cache_min,mo_integrals_cache_max + !DIR$ FORCEINLINE + call bielec_integrals_index(i,j,k,l,idx) + !DIR$ FORCEINLINE + call map_get(mo_integrals_map,idx,integral) + ii = l-mo_integrals_cache_min + ii = ior( ishft(ii,6), k-mo_integrals_cache_min) + ii = ior( ishft(ii,6), j-mo_integrals_cache_min) + ii = ior( ishft(ii,6), i-mo_integrals_cache_min) + mo_integrals_cache(ii) = integral + enddo + enddo + enddo + enddo + !$OMP END PARALLEL DO + +END_PROVIDER + + double precision function get_mo_bielec_integral(i,j,k,l,map) use map_module implicit none @@ -284,14 +380,27 @@ double precision function get_mo_bielec_integral(i,j,k,l,map) END_DOC integer, intent(in) :: i,j,k,l integer(key_kind) :: idx + integer :: ii type(map_type), intent(inout) :: map real(integral_kind) :: tmp - PROVIDE mo_bielec_integrals_in_map - !DIR$ FORCEINLINE - call bielec_integrals_index(i,j,k,l,idx) - !DIR$ FORCEINLINE - call map_get(map,idx,tmp) - get_mo_bielec_integral = dble(tmp) + PROVIDE mo_bielec_integrals_in_map mo_integrals_cache + ii = l-mo_integrals_cache_min + ii = ior(ii, k-mo_integrals_cache_min) + ii = ior(ii, j-mo_integrals_cache_min) + ii = ior(ii, i-mo_integrals_cache_min) + if (iand(ii, -64) /= 0) then + !DIR$ FORCEINLINE + call bielec_integrals_index(i,j,k,l,idx) + !DIR$ FORCEINLINE + call map_get(map,idx,tmp) + get_mo_bielec_integral = dble(tmp) + else + ii = l-mo_integrals_cache_min + ii = ior( ishft(ii,6), k-mo_integrals_cache_min) + ii = ior( ishft(ii,6), j-mo_integrals_cache_min) + ii = ior( ishft(ii,6), i-mo_integrals_cache_min) + get_mo_bielec_integral = mo_integrals_cache(ii) + endif end @@ -302,6 +411,8 @@ double precision function mo_bielec_integral(i,j,k,l) END_DOC integer, intent(in) :: i,j,k,l double precision :: get_mo_bielec_integral + PROVIDE mo_bielec_integrals_in_map mo_integrals_cache + !DIR$ FORCEINLINE PROVIDE mo_bielec_integrals_in_map mo_bielec_integral = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) return @@ -566,6 +677,7 @@ integer function load_$ao_integrals(filename) real(integral_kind), pointer :: val(:) integer :: iknd, kknd integer*8 :: n, j + double precision :: get_$ao_bielec_integral load_$ao_integrals = 1 open(unit=66,file=filename,FORM='unformatted',STATUS='UNKNOWN') read(66,err=98,end=98) iknd, kknd diff --git a/src/Integrals_Bielec/mo_bi_integrals.irp.f b/src/Integrals_Bielec/mo_bi_integrals.irp.f index af7f21d2..b56f3518 100644 --- a/src/Integrals_Bielec/mo_bi_integrals.irp.f +++ b/src/Integrals_Bielec/mo_bi_integrals.irp.f @@ -20,164 +20,153 @@ end BEGIN_PROVIDER [ logical, mo_bielec_integrals_in_map ] -use map_module + use map_module implicit none - integer(bit_kind) :: mask_ijkl(N_int,4) - integer(bit_kind) :: mask_ijk(N_int,3) + integer(bit_kind) :: mask_ijkl(N_int,4) + integer(bit_kind) :: mask_ijk(N_int,3) BEGIN_DOC ! If True, the map of MO bielectronic integrals is provided END_DOC - + mo_bielec_integrals_in_map = .True. if (read_mo_integrals) then - integer :: load_mo_integrals print*,'Reading the MO integrals' - if (load_mo_integrals(trim(ezfio_filename)//'/work/mo_integrals.bin') == 0) then - print*, 'MO integrals provided' - return - endif + call map_load_from_disk(trim(ezfio_filename)//'/work/mo_ints',mo_integrals_map) + print*, 'MO integrals provided' + return endif if(no_vvvv_integrals)then - integer :: i,j,k,l - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I I I !!!!!!!!!!!!!!!!!!!! - ! (core+inact+act) ^ 4 - ! - print*, '' - print*, '' - do i = 1,N_int - mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,4) = core_inact_act_bitmask_4(i,1) - enddo - call add_integrals_to_map(mask_ijkl) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I V V !!!!!!!!!!!!!!!!!!!! - ! (core+inact+act) ^ 2 (virt) ^2 - ! = J_iv - print*, '' - print*, '' - do i = 1,N_int - mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,2) = virt_bitmask(i,1) - mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,4) = virt_bitmask(i,1) - enddo - call add_integrals_to_map(mask_ijkl) - - ! (core+inact+act) ^ 2 (virt) ^2 - ! = (iv|iv) - print*, '' - print*, '' - do i = 1,N_int - mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,3) = virt_bitmask(i,1) - mask_ijkl(i,4) = virt_bitmask(i,1) - enddo - call add_integrals_to_map(mask_ijkl) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! V V V !!!!!!!!!!!!!!!!!!!!!!! - if(.not.no_vvv_integrals)then - print*, '' - print*, ' and ' - do i = 1,N_int - mask_ijk(i,1) = virt_bitmask(i,1) - mask_ijk(i,2) = virt_bitmask(i,1) - mask_ijk(i,3) = virt_bitmask(i,1) - enddo - call add_integrals_to_map_three_indices(mask_ijk) - endif - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I I V !!!!!!!!!!!!!!!!!!!! - ! (core+inact+act) ^ 3 (virt) ^1 - ! - print*, '' - print*, '' - do i = 1,N_int - mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,4) = virt_bitmask(i,1) - enddo - call add_integrals_to_map(mask_ijkl) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I V V V !!!!!!!!!!!!!!!!!!!! - ! (core+inact+act) ^ 1 (virt) ^3 - ! - if(.not.no_ivvv_integrals)then + integer :: i,j,k,l + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I I I !!!!!!!!!!!!!!!!!!!! + ! (core+inact+act) ^ 4 + ! print*, '' - print*, '' + print*, '' do i = 1,N_int - mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,2) = virt_bitmask(i,1) - mask_ijkl(i,3) = virt_bitmask(i,1) - mask_ijkl(i,4) = virt_bitmask(i,1) + mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) + mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1) + mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1) + mask_ijkl(i,4) = core_inact_act_bitmask_4(i,1) enddo - call add_integrals_to_map_no_exit_34(mask_ijkl) - endif - + call add_integrals_to_map(mask_ijkl) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I V V !!!!!!!!!!!!!!!!!!!! + ! (core+inact+act) ^ 2 (virt) ^2 + ! = J_iv + print*, '' + print*, '' + do i = 1,N_int + mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) + mask_ijkl(i,2) = virt_bitmask(i,1) + mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1) + mask_ijkl(i,4) = virt_bitmask(i,1) + enddo + call add_integrals_to_map(mask_ijkl) + + ! (core+inact+act) ^ 2 (virt) ^2 + ! = (iv|iv) + print*, '' + print*, '' + do i = 1,N_int + mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) + mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1) + mask_ijkl(i,3) = virt_bitmask(i,1) + mask_ijkl(i,4) = virt_bitmask(i,1) + enddo + call add_integrals_to_map(mask_ijkl) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! V V V !!!!!!!!!!!!!!!!!!!!!!! + if(.not.no_vvv_integrals)then + print*, '' + print*, ' and ' + do i = 1,N_int + mask_ijk(i,1) = virt_bitmask(i,1) + mask_ijk(i,2) = virt_bitmask(i,1) + mask_ijk(i,3) = virt_bitmask(i,1) + enddo + call add_integrals_to_map_three_indices(mask_ijk) + endif + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I I V !!!!!!!!!!!!!!!!!!!! + ! (core+inact+act) ^ 3 (virt) ^1 + ! + print*, '' + print*, '' + do i = 1,N_int + mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) + mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1) + mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1) + mask_ijkl(i,4) = virt_bitmask(i,1) + enddo + call add_integrals_to_map(mask_ijkl) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I V V V !!!!!!!!!!!!!!!!!!!! + ! (core+inact+act) ^ 1 (virt) ^3 + ! + if(.not.no_ivvv_integrals)then + print*, '' + print*, '' + do i = 1,N_int + mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) + mask_ijkl(i,2) = virt_bitmask(i,1) + mask_ijkl(i,3) = virt_bitmask(i,1) + mask_ijkl(i,4) = virt_bitmask(i,1) + enddo + call add_integrals_to_map_no_exit_34(mask_ijkl) + endif + else - call add_integrals_to_map(full_ijkl_bitmask_4) + call add_integrals_to_map(full_ijkl_bitmask_4) + endif + if (write_mo_integrals) then + call ezfio_set_work_empty(.False.) + call map_save_to_disk(trim(ezfio_filename)//'/work/mo_ints',mo_integrals_map) + call ezfio_set_integrals_bielec_disk_access_mo_integrals("Read") endif - if(write_ao_map_after_transfo)then - call dump_ao_integrals(trim(ezfio_filename)//'/work/ao_integrals.bin') - disk_access_ao_integrals = "Read" - touch disk_access_ao_integrals - call ezfio_set_integrals_bielec_disk_access_ao_integrals("Read") - endif - if(clear_ao_map_after_mo_transfo)then - call clear_ao_map - integer (map_size_kind) :: get_ao_map_size - print*, '^^^^^^^^^^^^^^^^^^^^^' - print *, 'get_ao_map_size',get_ao_map_size - print*, '^^^^^^^^^^^^^^^^^^^^^' - FREE ao_bielec_integrals_in_map - endif END_PROVIDER subroutine set_integrals_jj_into_map use bitmasks - implicit none - integer :: i,j,n_integrals,i0,j0 - double precision :: buffer_value(mo_tot_num * mo_tot_num) - integer(key_kind) :: buffer_i(mo_tot_num*mo_tot_num) - n_integrals = 0 - do j0 = 1, n_virt_orb - j = list_virt(j0) - do i0 = j0, n_virt_orb - i = list_virt(i0) - n_integrals += 1 -! mo_bielec_integral_jj_exchange(i,j) = mo_bielec_integral_vv_exchange_from_ao(i,j) - call mo_bielec_integrals_index(i,j,i,j,buffer_i(n_integrals)) - buffer_value(n_integrals) = mo_bielec_integral_vv_from_ao(i,j) + implicit none + integer :: i,j,n_integrals,i0,j0 + double precision :: buffer_value(mo_tot_num * mo_tot_num) + integer(key_kind) :: buffer_i(mo_tot_num*mo_tot_num) + n_integrals = 0 + do j0 = 1, n_virt_orb + j = list_virt(j0) + do i0 = j0, n_virt_orb + i = list_virt(i0) + n_integrals += 1 + ! mo_bielec_integral_jj_exchange(i,j) = mo_bielec_integral_vv_exchange_from_ao(i,j) + call mo_bielec_integrals_index(i,j,i,j,buffer_i(n_integrals)) + buffer_value(n_integrals) = mo_bielec_integral_vv_from_ao(i,j) + enddo enddo - enddo - call insert_into_mo_integrals_map(n_integrals,buffer_i,buffer_value,& - real(mo_integrals_threshold,integral_kind)) - call map_unique(mo_integrals_map) + call insert_into_mo_integrals_map(n_integrals,buffer_i,buffer_value,& + real(mo_integrals_threshold,integral_kind)) + call map_unique(mo_integrals_map) end subroutine set_integrals_exchange_jj_into_map use bitmasks - implicit none - integer :: i,j,n_integrals,i0,j0 - double precision :: buffer_value(mo_tot_num * mo_tot_num) - integer(key_kind) :: buffer_i(mo_tot_num*mo_tot_num) - n_integrals = 0 - do j0 = 1, n_virt_orb - j = list_virt(j0) - do i0 = j0+1, n_virt_orb - i = list_virt(i0) - n_integrals += 1 - call mo_bielec_integrals_index(i,j,j,i,buffer_i(n_integrals)) - buffer_value(n_integrals) = mo_bielec_integral_vv_exchange_from_ao(i,j) + implicit none + integer :: i,j,n_integrals,i0,j0 + double precision :: buffer_value(mo_tot_num * mo_tot_num) + integer(key_kind) :: buffer_i(mo_tot_num*mo_tot_num) + n_integrals = 0 + do j0 = 1, n_virt_orb + j = list_virt(j0) + do i0 = j0+1, n_virt_orb + i = list_virt(i0) + n_integrals += 1 + call mo_bielec_integrals_index(i,j,j,i,buffer_i(n_integrals)) + buffer_value(n_integrals) = mo_bielec_integral_vv_exchange_from_ao(i,j) + enddo enddo - enddo - call insert_into_mo_integrals_map(n_integrals,buffer_i,buffer_value,& - real(mo_integrals_threshold,integral_kind)) - call map_unique(mo_integrals_map) - + call insert_into_mo_integrals_map(n_integrals,buffer_i,buffer_value,& + real(mo_integrals_threshold,integral_kind)) + call map_unique(mo_integrals_map) + end subroutine add_integrals_to_map(mask_ijkl) @@ -223,49 +212,49 @@ subroutine add_integrals_to_map(mask_ijkl) call bitstring_to_list( mask_ijkl(1,2), list_ijkl(1,2), n_j, N_int ) call bitstring_to_list( mask_ijkl(1,3), list_ijkl(1,3), n_k, N_int ) call bitstring_to_list( mask_ijkl(1,4), list_ijkl(1,4), n_l, N_int ) - character*(2048) :: output(1) + character*(2048) :: output(1) print*, 'i' call bitstring_to_str( output(1), mask_ijkl(1,1), N_int ) print *, trim(output(1)) j = 0 do i = 1, N_int - j += popcnt(mask_ijkl(i,1)) + j += popcnt(mask_ijkl(i,1)) enddo if(j==0)then - return + return endif - + print*, 'j' call bitstring_to_str( output(1), mask_ijkl(1,2), N_int ) print *, trim(output(1)) j = 0 do i = 1, N_int - j += popcnt(mask_ijkl(i,2)) + j += popcnt(mask_ijkl(i,2)) enddo if(j==0)then - return + return endif - + print*, 'k' call bitstring_to_str( output(1), mask_ijkl(1,3), N_int ) print *, trim(output(1)) j = 0 do i = 1, N_int - j += popcnt(mask_ijkl(i,3)) + j += popcnt(mask_ijkl(i,3)) enddo if(j==0)then - return + return endif - + print*, 'l' call bitstring_to_str( output(1), mask_ijkl(1,4), N_int ) print *, trim(output(1)) j = 0 do i = 1, N_int - j += popcnt(mask_ijkl(i,4)) + j += popcnt(mask_ijkl(i,4)) enddo if(j==0)then - return + return endif size_buffer = min(ao_num*ao_num*ao_num,16000000) @@ -275,13 +264,13 @@ subroutine add_integrals_to_map(mask_ijkl) call wall_time(wall_1) call cpu_time(cpu_1) - double precision :: accu_bis + double precision :: accu_bis accu_bis = 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,& !$OMP buffer_i,buffer_value,n_integrals,wall_2,i0,j0,k0,l0, & - !$OMP wall_0,thread_num,accu_bis) & + !$OMP wall_0,thread_num,accu_bis) & !$OMP DEFAULT(NONE) & !$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, & @@ -299,14 +288,9 @@ subroutine add_integrals_to_map(mask_ijkl) buffer_value(size_buffer) ) thread_num = 0 -!$ thread_num = omp_get_thread_num() + !$ thread_num = omp_get_thread_num() !$OMP DO SCHEDULE(guided) do l1 = 1,ao_num -!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 @@ -429,13 +413,13 @@ subroutine add_integrals_to_map(mask_ijkl) exit endif bielec_tmp_1(i) = c*bielec_tmp_3(i,j0,k0) -! i1+=1 + ! i1+=1 enddo do i0 = 1, n_i - i = list_ijkl(i0,1) + i = list_ijkl(i0,1) if(i> min(k,j1-i1+list_ijkl(1,1)-1))then - exit + exit endif if (abs(bielec_tmp_1(i)) < mo_integrals_threshold) then cycle @@ -458,7 +442,7 @@ subroutine add_integrals_to_map(mask_ijkl) if (thread_num == 0) then if (wall_2 - wall_0 > 1.d0) then wall_0 = wall_2 - print*, 100.*float(l1)/float(ao_num), '% in ', & + print*, 100.*float(l1)/float(ao_num), '% in ', & wall_2-wall_1, 's', map_mb(mo_integrals_map) ,'MB' endif endif @@ -466,16 +450,12 @@ subroutine add_integrals_to_map(mask_ijkl) !$OMP END DO NOWAIT deallocate (bielec_tmp_1,bielec_tmp_2,bielec_tmp_3) - integer :: index_needed - + integer :: index_needed + call insert_into_mo_integrals_map(n_integrals,buffer_i,buffer_value,& real(mo_integrals_threshold,integral_kind)) deallocate(buffer_i, buffer_value) !$OMP END PARALLEL -!IRP_IF COARRAY -! print*, 'Communicating the map' -! call communicate_mo_integrals() -!IRP_ENDIF call map_unique(mo_integrals_map) call wall_time(wall_2) @@ -492,15 +472,6 @@ subroutine add_integrals_to_map(mask_ijkl) print*,' cpu time :',cpu_2 - cpu_1, 's' print*,' wall time :',wall_2 - wall_1, 's ( x ', (cpu_2-cpu_1)/(wall_2-wall_1), ')' - integer(map_size_kind) :: map_idx - map_idx = ishft(106,map_shift) -! call get_cache_map_verbose(mo_integrals_map,map_idx) - - if (write_mo_integrals) then - call dump_mo_integrals(trim(ezfio_filename)//'/work/mo_integrals.bin') - call ezfio_set_integrals_bielec_disk_access_mo_integrals("Read") - endif - end @@ -547,40 +518,40 @@ subroutine add_integrals_to_map_three_indices(mask_ijk) call bitstring_to_list( mask_ijk(1,1), list_ijkl(1,1), n_i, N_int ) call bitstring_to_list( mask_ijk(1,2), list_ijkl(1,2), n_j, N_int ) call bitstring_to_list( mask_ijk(1,3), list_ijkl(1,3), n_k, N_int ) - character*(2048) :: output(1) + character*(2048) :: output(1) print*, 'i' call bitstring_to_str( output(1), mask_ijk(1,1), N_int ) print *, trim(output(1)) j = 0 do i = 1, N_int - j += popcnt(mask_ijk(i,1)) + j += popcnt(mask_ijk(i,1)) enddo if(j==0)then - return + return endif - + print*, 'j' call bitstring_to_str( output(1), mask_ijk(1,2), N_int ) print *, trim(output(1)) j = 0 do i = 1, N_int - j += popcnt(mask_ijk(i,2)) + j += popcnt(mask_ijk(i,2)) enddo if(j==0)then - return + return endif - + print*, 'k' call bitstring_to_str( output(1), mask_ijk(1,3), N_int ) print *, trim(output(1)) j = 0 do i = 1, N_int - j += popcnt(mask_ijk(i,3)) + j += popcnt(mask_ijk(i,3)) enddo if(j==0)then - return + return endif - + size_buffer = min(ao_num*ao_num*ao_num,16000000) print*, 'Providing the molecular integrals ' print*, 'Buffers : ', 8.*(mo_tot_num_align*(n_j)*(n_k+1) + mo_tot_num_align +& @@ -588,12 +559,12 @@ subroutine add_integrals_to_map_three_indices(mask_ijk) call wall_time(wall_1) call cpu_time(cpu_1) - double precision :: accu_bis + double precision :: accu_bis accu_bis = 0.d0 - !$OMP PARALLEL PRIVATE(m,l1,k1,j1,i1,i2,i3,i4,i,j,k,l,c, ii1,kmax, & + !$OMP PARALLEL PRIVATE(m,l1,k1,j1,i1,i2,i3,i4,i,j,k,l,c, ii1,kmax, & !$OMP bielec_tmp_0_idx, bielec_tmp_0, bielec_tmp_1,bielec_tmp_2,bielec_tmp_3,& !$OMP buffer_i,buffer_value,n_integrals,wall_2,i0,j0,k0,l0, & - !$OMP wall_0,thread_num,accu_bis) & + !$OMP wall_0,thread_num,accu_bis) & !$OMP DEFAULT(NONE) & !$OMP SHARED(size_buffer,ao_num,mo_tot_num,n_i,n_j,n_k,mo_tot_num_align,& !$OMP mo_coef_transp, & @@ -611,14 +582,9 @@ subroutine add_integrals_to_map_three_indices(mask_ijk) buffer_value(size_buffer) ) thread_num = 0 -!$ thread_num = omp_get_thread_num() + !$ thread_num = omp_get_thread_num() !$OMP DO SCHEDULE(guided) do l1 = 1,ao_num -!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 @@ -718,42 +684,42 @@ subroutine add_integrals_to_map_three_indices(mask_ijk) if (abs(c) < thr_coef) then cycle endif - do k0 = 1, n_k - k = list_ijkl(k0,3) - i1 = ishft((k*k-k),-1) - bielec_tmp_1 = 0.d0 - j0 = l0 - j = list_ijkl(j0,2) - do i0 = 1, n_i - i = list_ijkl(i0,1) - if (i>k) then - exit - endif - bielec_tmp_1(i) = c*bielec_tmp_3(i,j0,k0) - enddo - - do i0 = 1, n_i - i = list_ijkl(i0,1) - if (i>k) then !min(k,j1-i1) - exit - endif - if (abs(bielec_tmp_1(i)) < mo_integrals_threshold) then - cycle - endif - n_integrals += 1 - buffer_value(n_integrals) = bielec_tmp_1(i) - if(i==k .and. j==l .and. i.ne.j)then - buffer_value(n_integrals) = buffer_value(n_integrals) *0.5d0 - endif - !DEC$ FORCEINLINE - call mo_bielec_integrals_index(i,j,k,l,buffer_i(n_integrals)) - if (n_integrals == size_buffer) then - call insert_into_mo_integrals_map(n_integrals,buffer_i,buffer_value,& - real(mo_integrals_threshold,integral_kind)) - n_integrals = 0 - endif - enddo + do k0 = 1, n_k + k = list_ijkl(k0,3) + i1 = ishft((k*k-k),-1) + bielec_tmp_1 = 0.d0 + j0 = l0 + j = list_ijkl(j0,2) + do i0 = 1, n_i + i = list_ijkl(i0,1) + if (i>k) then + exit + endif + bielec_tmp_1(i) = c*bielec_tmp_3(i,j0,k0) enddo + + do i0 = 1, n_i + i = list_ijkl(i0,1) + if (i>k) then !min(k,j1-i1) + exit + endif + if (abs(bielec_tmp_1(i)) < mo_integrals_threshold) then + cycle + endif + n_integrals += 1 + buffer_value(n_integrals) = bielec_tmp_1(i) + if(i==k .and. j==l .and. i.ne.j)then + buffer_value(n_integrals) = buffer_value(n_integrals) *0.5d0 + endif + !DEC$ FORCEINLINE + call mo_bielec_integrals_index(i,j,k,l,buffer_i(n_integrals)) + if (n_integrals == size_buffer) then + call insert_into_mo_integrals_map(n_integrals,buffer_i,buffer_value,& + real(mo_integrals_threshold,integral_kind)) + n_integrals = 0 + endif + enddo + enddo enddo do l0 = 1,n_j @@ -762,36 +728,36 @@ subroutine add_integrals_to_map_three_indices(mask_ijk) if (abs(c) < thr_coef) then cycle endif - do k0 = 1, n_k - k = list_ijkl(k0,3) - i1 = ishft((k*k-k),-1) - bielec_tmp_1 = 0.d0 - j0 = k0 - j = list_ijkl(k0,2) - i0 = l0 - i = list_ijkl(i0,2) - if (k==l) then - cycle - endif - bielec_tmp_1(i) = c*bielec_tmp_3(i,j0,k0) - - n_integrals += 1 - buffer_value(n_integrals) = bielec_tmp_1(i) - !DEC$ FORCEINLINE - call mo_bielec_integrals_index(i,j,k,l,buffer_i(n_integrals)) - if (n_integrals == size_buffer) then - call insert_into_mo_integrals_map(n_integrals,buffer_i,buffer_value,& - real(mo_integrals_threshold,integral_kind)) - n_integrals = 0 - endif - enddo + do k0 = 1, n_k + k = list_ijkl(k0,3) + i1 = ishft((k*k-k),-1) + bielec_tmp_1 = 0.d0 + j0 = k0 + j = list_ijkl(k0,2) + i0 = l0 + i = list_ijkl(i0,2) + if (k==l) then + cycle + endif + bielec_tmp_1(i) = c*bielec_tmp_3(i,j0,k0) + + n_integrals += 1 + buffer_value(n_integrals) = bielec_tmp_1(i) + !DEC$ FORCEINLINE + call mo_bielec_integrals_index(i,j,k,l,buffer_i(n_integrals)) + if (n_integrals == size_buffer) then + call insert_into_mo_integrals_map(n_integrals,buffer_i,buffer_value,& + real(mo_integrals_threshold,integral_kind)) + n_integrals = 0 + endif + enddo enddo call wall_time(wall_2) if (thread_num == 0) then if (wall_2 - wall_0 > 1.d0) then wall_0 = wall_2 - print*, 100.*float(l1)/float(ao_num), '% in ', & + print*, 100.*float(l1)/float(ao_num), '% in ', & wall_2-wall_1, 's', map_mb(mo_integrals_map) ,'MB' endif endif @@ -799,16 +765,12 @@ subroutine add_integrals_to_map_three_indices(mask_ijk) !$OMP END DO NOWAIT deallocate (bielec_tmp_1,bielec_tmp_2,bielec_tmp_3) - integer :: index_needed - + integer :: index_needed + call insert_into_mo_integrals_map(n_integrals,buffer_i,buffer_value,& real(mo_integrals_threshold,integral_kind)) deallocate(buffer_i, buffer_value) !$OMP END PARALLEL -!IRP_IF COARRAY -! print*, 'Communicating the map' -! call communicate_mo_integrals() -!IRP_ENDIF call map_unique(mo_integrals_map) call wall_time(wall_2) @@ -825,15 +787,6 @@ subroutine add_integrals_to_map_three_indices(mask_ijk) print*,' cpu time :',cpu_2 - cpu_1, 's' print*,' wall time :',wall_2 - wall_1, 's ( x ', (cpu_2-cpu_1)/(wall_2-wall_1), ')' - integer(map_size_kind) :: map_idx - map_idx = ishft(106,map_shift) -! call get_cache_map_verbose(mo_integrals_map,map_idx) - - if (write_mo_integrals) then - call dump_mo_integrals(trim(ezfio_filename)//'/work/mo_integrals.bin') - call ezfio_set_integrals_bielec_disk_access_mo_integrals("Read") - endif - end @@ -892,7 +845,7 @@ subroutine add_integrals_to_map_no_exit_34(mask_ijkl) !$OMP PARALLEL PRIVATE(l1,k1,j1,i1,i2,i3,i4,i,j,k,l,c, ii1,kmax, & !$OMP bielec_tmp_0_idx, bielec_tmp_0, bielec_tmp_1,bielec_tmp_2,bielec_tmp_3,& !$OMP buffer_i,buffer_value,n_integrals,wall_2,i0,j0,k0,l0, & - !$OMP wall_0,thread_num) & + !$OMP wall_0,thread_num) & !$OMP DEFAULT(NONE) & !$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, & @@ -910,14 +863,14 @@ subroutine add_integrals_to_map_no_exit_34(mask_ijkl) buffer_value(size_buffer) ) thread_num = 0 -!$ thread_num = omp_get_thread_num() + !$ thread_num = omp_get_thread_num() !$OMP DO SCHEDULE(guided) do l1 = 1,ao_num -!IRP_IF COARRAY -! if (mod(l1-this_image(),num_images()) /= 0 ) then -! cycle -! endif -!IRP_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 @@ -1038,11 +991,11 @@ subroutine add_integrals_to_map_no_exit_34(mask_ijkl) enddo do i0 = 1, n_i - i = list_ijkl(i0,1) + i = list_ijkl(i0,1) if(i> k)then - exit + exit endif - + if (abs(bielec_tmp_1(i)) < mo_integrals_threshold) then cycle endif @@ -1064,7 +1017,7 @@ subroutine add_integrals_to_map_no_exit_34(mask_ijkl) if (thread_num == 0) then if (wall_2 - wall_0 > 1.d0) then wall_0 = wall_2 - print*, 100.*float(l1)/float(ao_num), '% in ', & + print*, 100.*float(l1)/float(ao_num), '% in ', & wall_2-wall_1, 's', map_mb(mo_integrals_map) ,'MB' endif endif @@ -1076,10 +1029,10 @@ subroutine add_integrals_to_map_no_exit_34(mask_ijkl) real(mo_integrals_threshold,integral_kind)) deallocate(buffer_i, buffer_value) !$OMP END PARALLEL -!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) @@ -1096,10 +1049,6 @@ subroutine add_integrals_to_map_no_exit_34(mask_ijkl) print*,' cpu time :',cpu_2 - cpu_1, 's' print*,' wall time :',wall_2 - wall_1, 's ( x ', (cpu_2-cpu_1)/(wall_2-wall_1), ')' - if (write_mo_integrals) then - call dump_mo_integrals(trim(ezfio_filename)//'/work/mo_integrals.bin') - call ezfio_set_integrals_bielec_disk_access_mo_integrals("Read") - endif end @@ -1138,7 +1087,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) & + !$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), & @@ -1181,9 +1130,9 @@ end endif enddo enddo - + else - + do r=1,ao_num call get_ao_bielec_integrals_non_zero(q,r,s,ao_num,int_value,int_idx,n) do pp=1,n @@ -1270,10 +1219,10 @@ END_PROVIDER !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE (i0,j0,i,j,p,q,r,s,integral,c,n,pp,int_value,int_idx, & + !$OMP PRIVATE (i0,j0,i,j,p,q,r,s,integral,c,n,pp,int_value,int_idx,& !$OMP iqrs, iqsr,iqri,iqis) & !$OMP SHARED(n_virt_orb,mo_tot_num,list_virt,mo_coef_transp,mo_tot_num_align,ao_num,& - !$OMP ao_integrals_threshold,do_direct_integrals) & + !$OMP ao_integrals_threshold,do_direct_integrals) & !$OMP REDUCTION(+:mo_bielec_integral_vv_from_ao,mo_bielec_integral_vv_exchange_from_ao) allocate( int_value(ao_num), int_idx(ao_num), & @@ -1319,9 +1268,9 @@ END_PROVIDER endif enddo enddo - + else - + do r=1,ao_num call get_ao_bielec_integrals_non_zero(q,r,s,ao_num,int_value,int_idx,n) do pp=1,n @@ -1377,12 +1326,12 @@ END_PROVIDER !$OMP END PARALLEL mo_bielec_integral_vv_anti_from_ao = mo_bielec_integral_vv_from_ao - mo_bielec_integral_vv_exchange_from_ao -! print*, '**********' -! do i0 =1, n_virt_orb -! i = list_virt(i0) -! print*, mo_bielec_integral_vv_from_ao(i,i) -! enddo -! print*, '**********' + ! print*, '**********' + ! do i0 =1, n_virt_orb + ! i = list_virt(i0) + ! print*, mo_bielec_integral_vv_from_ao(i,i) + ! enddo + ! print*, '**********' END_PROVIDER @@ -1404,46 +1353,14 @@ END_PROVIDER PROVIDE mo_bielec_integrals_in_map mo_bielec_integral_jj = 0.d0 mo_bielec_integral_jj_exchange = 0.d0 - -! if(.not.no_vvvv_integrals)then - do j=1,mo_tot_num + + do j=1,mo_tot_num do i=1,mo_tot_num mo_bielec_integral_jj(i,j) = get_mo_bielec_integral(i,j,i,j,mo_integrals_map) mo_bielec_integral_jj_exchange(i,j) = get_mo_bielec_integral(i,j,j,i,mo_integrals_map) - mo_bielec_integral_jj_anti(i,j) = mo_bielec_integral_jj(i,j) - mo_bielec_integral_jj_exchange(i,j) + mo_bielec_integral_jj_anti(i,j) = mo_bielec_integral_jj(i,j) - mo_bielec_integral_jj_exchange(i,j) enddo enddo -!else -! integer :: j0,i0 -! do j0=1,n_core_inact_act_orb -! j = list_core_inact_act(j0) -! do i0=1,n_core_inact_act_orb -! i = list_core_inact_act(i0) -! mo_bielec_integral_jj(i,j) = get_mo_bielec_integral(i,j,i,j,mo_integrals_map) -! mo_bielec_integral_jj_exchange(i,j) = get_mo_bielec_integral(i,j,j,i,mo_integrals_map) -! mo_bielec_integral_jj_anti(i,j) = mo_bielec_integral_jj(i,j) - mo_bielec_integral_jj_exchange(i,j) -! enddo -! enddo -! do j0 = 1, n_virt_orb -! j = list_virt(j0) -! do i0 = 1, n_virt_orb -! i = list_virt(i0) -! mo_bielec_integral_jj(i,j) = mo_bielec_integral_vv_from_ao(i,j) -! mo_bielec_integral_jj_exchange(i,j) = mo_bielec_integral_vv_exchange_from_ao(i,j) -! mo_bielec_integral_jj_anti(i,j) = mo_bielec_integral_jj(i,j) - mo_bielec_integral_jj_exchange(i,j) -! enddo -! do i0=1,n_core_inact_act_orb -! i = list_core_inact_act(i0) -! mo_bielec_integral_jj(i,j) = get_mo_bielec_integral(i,j,i,j,mo_integrals_map) -! mo_bielec_integral_jj_exchange(i,j) = get_mo_bielec_integral(i,j,j,i,mo_integrals_map) -! mo_bielec_integral_jj_anti(i,j) = mo_bielec_integral_jj(i,j) - mo_bielec_integral_jj_exchange(i,j) -! mo_bielec_integral_jj(j,i) = mo_bielec_integral_jj(i,j) -! mo_bielec_integral_jj_exchange(j,i) = mo_bielec_integral_jj_exchange(i,j) -! mo_bielec_integral_jj_anti(j,i) = mo_bielec_integral_jj_anti(i,j) -! enddo -! enddo -! -!endif END_PROVIDER @@ -1456,13 +1373,13 @@ subroutine clear_mo_map call map_deinit(mo_integrals_map) FREE mo_integrals_map mo_bielec_integral_jj mo_bielec_integral_jj_anti FREE mo_bielec_integral_jj_exchange mo_bielec_integrals_in_map - - + + end subroutine provide_all_mo_integrals - implicit none - provide mo_integrals_map mo_bielec_integral_jj mo_bielec_integral_jj_anti - provide mo_bielec_integral_jj_exchange mo_bielec_integrals_in_map - + implicit none + provide mo_integrals_map mo_bielec_integral_jj mo_bielec_integral_jj_anti + provide mo_bielec_integral_jj_exchange mo_bielec_integrals_in_map + end diff --git a/src/Integrals_Bielec/qp_ao_ints.irp.f b/src/Integrals_Bielec/qp_ao_ints.irp.f index f932df0f..93f62a7d 100644 --- a/src/Integrals_Bielec/qp_ao_ints.irp.f +++ b/src/Integrals_Bielec/qp_ao_ints.irp.f @@ -8,7 +8,8 @@ program qp_ao_ints call switch_qp_run_to_master - PROVIDE zmq_context + zmq_context = f77_zmq_ctx_new () + ! Set the state of the ZMQ zmq_state = 'ao_integrals' @@ -16,10 +17,15 @@ program qp_ao_ints double precision :: integral, ao_bielec_integral integral = ao_bielec_integral(1,1,1,1) - !$OMP PARALLEL DEFAULT(PRIVATE) PRIVATE(i) - i = omp_get_thread_num() - call ao_bielec_integrals_in_map_slave_tcp(i) - !$OMP END PARALLEL + character*(64) :: state + call wait_for_state(zmq_state,state) + do while (state /= 'Stopped') + !$OMP PARALLEL DEFAULT(PRIVATE) PRIVATE(i) + i = omp_get_thread_num() + call ao_bielec_integrals_in_map_slave_tcp(i) + !$OMP END PARALLEL + call wait_for_state(zmq_state,state) + enddo print *, 'Done' end diff --git a/src/Integrals_Bielec/tree_dependency.png b/src/Integrals_Bielec/tree_dependency.png index 4161fd0a..92944e89 100644 Binary files a/src/Integrals_Bielec/tree_dependency.png and b/src/Integrals_Bielec/tree_dependency.png differ diff --git a/src/Integrals_Monoelec/.gitignore b/src/Integrals_Monoelec/.gitignore index e8bd9b05..577068de 100644 --- a/src/Integrals_Monoelec/.gitignore +++ b/src/Integrals_Monoelec/.gitignore @@ -12,7 +12,9 @@ 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/EZFIO.cfg b/src/Integrals_Monoelec/EZFIO.cfg new file mode 100644 index 00000000..04e49ec1 --- /dev/null +++ b/src/Integrals_Monoelec/EZFIO.cfg @@ -0,0 +1,12 @@ +[disk_access_mo_one_integrals] +type: Disk_access +doc: Read/Write MO one-electron integrals from/to disk [ Write | Read | None ] +interface: ezfio,provider,ocaml +default: None + +[disk_access_ao_one_integrals] +type: Disk_access +doc: Read/Write AO one-electron integrals from/to disk [ Write | Read | None ] +interface: ezfio,provider,ocaml +default: None + diff --git a/src/Integrals_Monoelec/README.rst b/src/Integrals_Monoelec/README.rst index 1d2d158b..d92cea0a 100644 --- a/src/Integrals_Monoelec/README.rst +++ b/src/Integrals_Monoelec/README.rst @@ -102,20 +102,20 @@ Documentation interaction nuclear electron -`ao_nucl_elec_integral_per_atom `_ +`ao_nucl_elec_integral_per_atom `_ ao_nucl_elec_integral_per_atom(i,j,k) = - where Rk is the geometry of the kth atom `ao_pseudo_integral `_ - Pseudo-potential + Pseudo-potential integrals -`ao_pseudo_integral_local `_ +`ao_pseudo_integral_local `_ Local pseudo-potential -`ao_pseudo_integral_non_local `_ +`ao_pseudo_integral_non_local `_ Local pseudo-potential @@ -141,44 +141,34 @@ Documentation Undocumented +`disk_access_ao_one_integrals `_ + Read/Write AO one-electron integrals from/to disk [ Write | Read | None ] + + +`disk_access_mo_one_integrals `_ + Read/Write MO one-electron integrals from/to disk [ Write | Read | None ] + + `do_print `_ Undocumented -`give_polynom_mult_center_mono_elec `_ +`give_polynom_mult_center_mono_elec `_ Undocumented -`i_x1_pol_mult_mono_elec `_ +`i_x1_pol_mult_mono_elec `_ Undocumented -`i_x2_pol_mult_mono_elec `_ +`i_x2_pol_mult_mono_elec `_ Undocumented -`int_gaus_pol `_ +`int_gaus_pol `_ Undocumented -`mo_deriv_1_x `_ - array of the integrals of MO_i * d/dx MO_j - array of the integrals of MO_i * d/dy MO_j - array of the integrals of MO_i * d/dz MO_j - - -`mo_deriv_1_y `_ - array of the integrals of MO_i * d/dx MO_j - array of the integrals of MO_i * d/dy MO_j - array of the integrals of MO_i * d/dz MO_j - - -`mo_deriv_1_z `_ - array of the integrals of MO_i * d/dx MO_j - array of the integrals of MO_i * d/dy MO_j - array of the integrals of MO_i * d/dz MO_j - - `mo_dipole_x `_ array of the integrals of MO_i * x MO_j array of the integrals of MO_i * y MO_j @@ -198,12 +188,12 @@ Documentation `mo_kinetic_integral `_ - Undocumented + Kinetic energy integrals in the MO basis `mo_mono_elec_integral `_ - array of the mono electronic hamiltonian on the MOs basis - : sum of the kinetic and nuclear electronic potential + array of the mono electronic hamiltonian on the MOs basis : + sum of the kinetic and nuclear electronic potential `mo_nucl_elec_integral `_ @@ -219,25 +209,25 @@ Documentation interaction nuclear electron on the MO basis -`mo_spread_x `_ +`mo_spread_x `_ array of the integrals of MO_i * x^2 MO_j array of the integrals of MO_i * y^2 MO_j array of the integrals of MO_i * z^2 MO_j -`mo_spread_y `_ +`mo_spread_y `_ array of the integrals of MO_i * x^2 MO_j array of the integrals of MO_i * y^2 MO_j array of the integrals of MO_i * z^2 MO_j -`mo_spread_z `_ +`mo_spread_z `_ array of the integrals of MO_i * x^2 MO_j array of the integrals of MO_i * y^2 MO_j array of the integrals of MO_i * z^2 MO_j -`nai_pol_mult `_ +`nai_pol_mult `_ Undocumented @@ -269,26 +259,74 @@ Documentation Undocumented +`pseudo_dz_k_transp `_ + Transposed arrays for pseudopotentials + + +`pseudo_dz_kl_transp `_ + Transposed arrays for pseudopotentials + + +`pseudo_n_k_transp `_ + Transposed arrays for pseudopotentials + + +`pseudo_n_kl_transp `_ + Transposed arrays for pseudopotentials + + +`pseudo_v_k_transp `_ + Transposed arrays for pseudopotentials + + +`pseudo_v_kl_transp `_ + Transposed arrays for pseudopotentials + + +`read_ao_one_integrals `_ + One level of abstraction for disk_access_ao_integrals and disk_access_mo_integrals + + +`read_mo_one_integrals `_ + One level of abstraction for disk_access_ao_integrals and disk_access_mo_integrals + + +`read_one_e_integrals `_ + Read the 1-electron integrals into in A(m,n) from file 'filename' + + `save_ortho_mos `_ Undocumented -`v_e_n `_ +`v_e_n `_ Undocumented -`v_phi `_ +`v_phi `_ Undocumented -`v_r `_ +`v_r `_ Undocumented -`v_theta `_ +`v_theta `_ Undocumented -`wallis `_ +`wallis `_ Undocumented + +`write_ao_one_integrals `_ + One level of abstraction for disk_access_ao_integrals and disk_access_mo_integrals + + +`write_mo_one_integrals `_ + One level of abstraction for disk_access_ao_integrals and disk_access_mo_integrals + + +`write_one_e_integrals `_ + Write the 1-electron integrals stored in A(m,n) into file 'filename' + diff --git a/src/Integrals_Monoelec/kin_ao_ints.irp.f b/src/Integrals_Monoelec/kin_ao_ints.irp.f index 10b065b4..6cb2aa49 100644 --- a/src/Integrals_Monoelec/kin_ao_ints.irp.f +++ b/src/Integrals_Monoelec/kin_ao_ints.irp.f @@ -123,26 +123,36 @@ END_PROVIDER BEGIN_PROVIDER [double precision, ao_kinetic_integral, (ao_num_align,ao_num)] - implicit none - BEGIN_DOC - ! array of the priminitve basis kinetic integrals - ! \langle \chi_i |\hat{T}| \chi_j \rangle - END_DOC - integer :: i,j,k,l - - !$OMP PARALLEL DO DEFAULT(NONE) & - !$OMP PRIVATE(i,j) & - !$OMP SHARED(ao_num, ao_num_align, ao_kinetic_integral,ao_deriv2_x,ao_deriv2_y,ao_deriv2_z) - do j = 1, ao_num - !DEC$ VECTOR ALWAYS - !DEC$ VECTOR ALIGNED - do i = 1, ao_num - ao_kinetic_integral(i,j) = -0.5d0 * (ao_deriv2_x(i,j) + ao_deriv2_y(i,j) + ao_deriv2_z(i,j) ) - enddo - do i = ao_num +1,ao_num_align - ao_kinetic_integral(i,j) = 0.d0 - enddo - enddo - !$OMP END PARALLEL DO + implicit none + BEGIN_DOC + ! array of the priminitve basis kinetic integrals + ! \langle \chi_i |\hat{T}| \chi_j \rangle + END_DOC + integer :: i,j,k,l + + if (read_ao_one_integrals) then + call ezfio_get_ao_basis_integral_kinetic(ao_kinetic_integral(1:ao_num, 1:ao_num)) + call ezfio_set_ao_basis_integral_kinetic(ao_kinetic_integral(1:ao_num, 1:ao_num)) + print *, 'AO kinetic integrals read from disk' + else + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP PRIVATE(i,j) & + !$OMP SHARED(ao_num, ao_num_align, ao_kinetic_integral,ao_deriv2_x,ao_deriv2_y,ao_deriv2_z) + do j = 1, ao_num + !DEC$ VECTOR ALWAYS + !DEC$ VECTOR ALIGNED + do i = 1, ao_num + ao_kinetic_integral(i,j) = -0.5d0 * (ao_deriv2_x(i,j) + ao_deriv2_y(i,j) + ao_deriv2_z(i,j) ) + enddo + do i = ao_num +1,ao_num_align + ao_kinetic_integral(i,j) = 0.d0 + enddo + enddo + !$OMP END PARALLEL DO + endif + if (write_ao_one_integrals) then + call ezfio_set_ao_basis_integral_kinetic(ao_kinetic_integral(1:ao_num, 1:ao_num)) + print *, 'AO kinetic integrals written to disk' + endif END_PROVIDER diff --git a/src/Integrals_Monoelec/kin_mo_ints.irp.f b/src/Integrals_Monoelec/kin_mo_ints.irp.f index 2bcbd5df..2301c23d 100644 --- a/src/Integrals_Monoelec/kin_mo_ints.irp.f +++ b/src/Integrals_Monoelec/kin_mo_ints.irp.f @@ -1,25 +1,26 @@ - BEGIN_PROVIDER [double precision, mo_kinetic_integral, (mo_tot_num_align,mo_tot_num)] - implicit none - integer :: i1,j1,i,j - double precision :: c_i1 +BEGIN_PROVIDER [double precision, mo_kinetic_integral, (mo_tot_num_align,mo_tot_num)] + implicit none + BEGIN_DOC + ! Kinetic energy integrals in the MO basis + END_DOC + + if (read_mo_one_integrals) then + call read_one_e_integrals('mo_kinetic_integral', mo_kinetic_integral,& + size(mo_kinetic_integral,1), size(mo_kinetic_integral,2)) + print *, 'MO kinetic integrals read from disk' + else + call ao_to_mo( & + ao_kinetic_integral, & + size(ao_kinetic_integral,1), & + mo_kinetic_integral, & + size(mo_kinetic_integral,1) & + ) + endif + if (write_mo_one_integrals) then + call write_one_e_integrals('mo_kinetic_integral', mo_kinetic_integral,& + size(mo_kinetic_integral,1), size(mo_kinetic_integral,2)) + print *, 'MO kinetic integrals written to disk' + endif - mo_kinetic_integral = 0.d0 - !$OMP PARALLEL DO DEFAULT(none) & - !$OMP PRIVATE(i,j,i1,j1,c_i1) & - !$OMP SHARED(mo_tot_num,ao_num,mo_coef,ao_Kinetic_integral, & - !$OMP mo_kinetic_integral) - do i = 1,mo_tot_num - do j = 1,mo_tot_num - do i1 = 1,ao_num - c_i1 = mo_coef(i1,i) - !DIR$ VECTOR ALIGNED - do j1 = 1,ao_num - mo_kinetic_integral(j,i) = mo_kinetic_integral(j,i) + c_i1*mo_coef(j1,j) *& - ao_Kinetic_integral(j1,i1) - enddo - enddo - enddo - enddo - !$OMP END PARALLEL DO END_PROVIDER diff --git a/src/Integrals_Monoelec/mo_mono_ints.irp.f b/src/Integrals_Monoelec/mo_mono_ints.irp.f index 5bae9868..50ab7ffa 100644 --- a/src/Integrals_Monoelec/mo_mono_ints.irp.f +++ b/src/Integrals_Monoelec/mo_mono_ints.irp.f @@ -1,14 +1,15 @@ BEGIN_PROVIDER [ double precision, mo_mono_elec_integral,(mo_tot_num_align,mo_tot_num)] implicit none - integer :: i,j,n,l + integer :: i,j,n,l BEGIN_DOC - ! array of the mono electronic hamiltonian on the MOs basis - ! : sum of the kinetic and nuclear electronic potential + ! array of the mono electronic hamiltonian on the MOs basis : + ! sum of the kinetic and nuclear electronic potential END_DOC print*,'Providing the mono electronic integrals' do j = 1, mo_tot_num - do i = 1, mo_tot_num - mo_mono_elec_integral(i,j) = mo_nucl_elec_integral(i,j) + mo_kinetic_integral(i,j) + mo_pseudo_integral(i,j) - enddo + do i = 1, mo_tot_num + mo_mono_elec_integral(i,j) = mo_nucl_elec_integral(i,j) + & + mo_kinetic_integral(i,j) + mo_pseudo_integral(i,j) + enddo enddo END_PROVIDER diff --git a/src/Integrals_Monoelec/pot_ao_ints.irp.f b/src/Integrals_Monoelec/pot_ao_ints.irp.f index 9e64d5e2..7116d2c7 100644 --- a/src/Integrals_Monoelec/pot_ao_ints.irp.f +++ b/src/Integrals_Monoelec/pot_ao_ints.irp.f @@ -1,73 +1,84 @@ - BEGIN_PROVIDER [ double precision, ao_nucl_elec_integral, (ao_num_align,ao_num)] - BEGIN_DOC -! interaction nuclear electron - END_DOC - implicit none - double precision :: alpha, beta, gama, delta - integer :: num_A,num_B - double precision :: A_center(3),B_center(3),C_center(3) - integer :: power_A(3),power_B(3) - integer :: i,j,k,l,n_pt_in,m - double precision ::overlap_x,overlap_y,overlap_z,overlap,dx,NAI_pol_mult - - ao_nucl_elec_integral = 0.d0 - - ! _ - ! /| / |_) - ! | / | \ - ! - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i,j,k,l,m,alpha,beta,A_center,B_center,C_center,power_A,power_B, & - !$OMP num_A,num_B,Z,c,n_pt_in) & - !$OMP SHARED (ao_num,ao_prim_num,ao_expo_ordered_transp,ao_power,ao_nucl,nucl_coord,ao_coef_normalized_ordered_transp, & - !$OMP n_pt_max_integrals,ao_nucl_elec_integral,nucl_num,nucl_charge) - - n_pt_in = n_pt_max_integrals - - !$OMP DO SCHEDULE (dynamic) - - do j = 1, ao_num - num_A = ao_nucl(j) - power_A(1:3)= ao_power(j,1:3) - A_center(1:3) = nucl_coord(num_A,1:3) - - do i = 1, ao_num - - num_B = ao_nucl(i) - power_B(1:3)= ao_power(i,1:3) - B_center(1:3) = nucl_coord(num_B,1:3) - - do l=1,ao_prim_num(j) - alpha = ao_expo_ordered_transp(l,j) - - do m=1,ao_prim_num(i) - beta = ao_expo_ordered_transp(m,i) - - double precision :: c - c = 0.d0 - - do k = 1, nucl_num - double precision :: Z - Z = nucl_charge(k) - - C_center(1:3) = nucl_coord(k,1:3) - - c = c - Z*NAI_pol_mult(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in) - - enddo - ao_nucl_elec_integral(i,j) = ao_nucl_elec_integral(i,j) + & - ao_coef_normalized_ordered_transp(l,j)*ao_coef_normalized_ordered_transp(m,i)*c - enddo - enddo - enddo - enddo - - !$OMP END DO - !$OMP END PARALLEL - - END_PROVIDER +BEGIN_PROVIDER [ double precision, ao_nucl_elec_integral, (ao_num_align,ao_num)] + BEGIN_DOC + ! interaction nuclear electron + END_DOC + implicit none + double precision :: alpha, beta, gama, delta + integer :: num_A,num_B + double precision :: A_center(3),B_center(3),C_center(3) + integer :: power_A(3),power_B(3) + integer :: i,j,k,l,n_pt_in,m + double precision :: overlap_x,overlap_y,overlap_z,overlap,dx,NAI_pol_mult + + if (read_ao_one_integrals) then + call ezfio_get_ao_basis_integral_nuclear(ao_nucl_elec_integral(1:ao_num, 1:ao_num)) + print *, 'AO N-e integrals read from disk' + else + + ao_nucl_elec_integral = 0.d0 + + ! _ + ! /| / |_) + ! | / | \ + ! + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,k,l,m,alpha,beta,A_center,B_center,C_center,power_A,power_B,& + !$OMP num_A,num_B,Z,c,n_pt_in) & + !$OMP SHARED (ao_num,ao_prim_num,ao_expo_ordered_transp,ao_power,ao_nucl,nucl_coord,ao_coef_normalized_ordered_transp,& + !$OMP n_pt_max_integrals,ao_nucl_elec_integral,nucl_num,nucl_charge) + + n_pt_in = n_pt_max_integrals + + !$OMP DO SCHEDULE (dynamic) + + do j = 1, ao_num + num_A = ao_nucl(j) + power_A(1:3)= ao_power(j,1:3) + A_center(1:3) = nucl_coord(num_A,1:3) + + do i = 1, ao_num + + num_B = ao_nucl(i) + power_B(1:3)= ao_power(i,1:3) + B_center(1:3) = nucl_coord(num_B,1:3) + + do l=1,ao_prim_num(j) + alpha = ao_expo_ordered_transp(l,j) + + do m=1,ao_prim_num(i) + beta = ao_expo_ordered_transp(m,i) + + double precision :: c + c = 0.d0 + + do k = 1, nucl_num + double precision :: Z + Z = nucl_charge(k) + + C_center(1:3) = nucl_coord(k,1:3) + + c = c - Z*NAI_pol_mult(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in) + + enddo + ao_nucl_elec_integral(i,j) = ao_nucl_elec_integral(i,j) +& + ao_coef_normalized_ordered_transp(l,j)*ao_coef_normalized_ordered_transp(m,i)*c + enddo + enddo + enddo + enddo + + !$OMP END DO + !$OMP END PARALLEL + endif + if (write_ao_one_integrals) then + call ezfio_set_ao_basis_integral_nuclear(ao_nucl_elec_integral(1:ao_num, 1:ao_num)) + print *, 'AO N-e integrals written to disk' + endif + + +END_PROVIDER BEGIN_PROVIDER [ double precision, ao_nucl_elec_integral_per_atom, (ao_num_align,ao_num,nucl_num)] BEGIN_DOC diff --git a/src/Integrals_Monoelec/pot_ao_pseudo_ints.irp.f b/src/Integrals_Monoelec/pot_ao_pseudo_ints.irp.f index 615ed127..b34b201e 100644 --- a/src/Integrals_Monoelec/pot_ao_pseudo_ints.irp.f +++ b/src/Integrals_Monoelec/pot_ao_pseudo_ints.irp.f @@ -1,13 +1,32 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integral, (ao_num_align,ao_num)] implicit none BEGIN_DOC -! Pseudo-potential + ! Pseudo-potential integrals END_DOC - if (do_pseudo) then - ao_pseudo_integral = ao_pseudo_integral_local + ao_pseudo_integral_non_local + + if (read_ao_one_integrals) then + call read_one_e_integrals('ao_pseudo_integral', ao_pseudo_integral,& + size(ao_pseudo_integral,1), size(ao_pseudo_integral,2)) + print *, 'AO pseudopotential integrals read from disk' else + ao_pseudo_integral = 0.d0 + if (do_pseudo) then + if (pseudo_klocmax > 0) then + ao_pseudo_integral += ao_pseudo_integral_local + endif + if (pseudo_kmax > 0) then + ao_pseudo_integral += ao_pseudo_integral_non_local + endif + endif endif + + if (write_ao_one_integrals) then + call write_one_e_integrals('ao_pseudo_integral', ao_pseudo_integral,& + size(ao_pseudo_integral,1), size(ao_pseudo_integral,2)) + print *, 'AO pseudopotential integrals written to disk' + endif + END_PROVIDER BEGIN_PROVIDER [ double precision, ao_pseudo_integral_local, (ao_num_align,ao_num)] @@ -34,6 +53,13 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integral_local, (ao_num_align,ao_nu call wall_time(wall_1) call cpu_time(cpu_1) +!write(33,*) 'xxxLOCxxx' +!write(33,*) 'pseudo_klocmax', pseudo_klocmax +!write(33,*) 'pseudo_v_k_transp ', pseudo_v_k_transp +!write(33,*) 'pseudo_n_k_transp ', pseudo_n_k_transp +!write(33,*) 'pseudo_dz_k_transp', pseudo_dz_k_transp +!write(33,*) 'xxxLOCxxx' + thread_num = 0 !$OMP PARALLEL & !$OMP DEFAULT (NONE) & @@ -83,7 +109,15 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integral_local, (ao_num_align,ao_nu pseudo_n_k_transp (1,k), & pseudo_dz_k_transp(1,k), & A_center,power_A,alpha,B_center,power_B,beta,C_center) - +! write(33,*) i,j,k +! write(33,*) A_center,power_A,alpha,B_center,power_B,beta,C_center, & +! Vloc(pseudo_klocmax, & +! pseudo_v_k_transp (1,k), & +! pseudo_n_k_transp (1,k), & +! pseudo_dz_k_transp(1,k), & +! A_center,power_A,alpha,B_center,power_B,beta,C_center) +! write(33,*) + enddo ao_pseudo_integral_local(i,j) = ao_pseudo_integral_local(i,j) +& ao_coef_normalized_ordered_transp(l,j)*ao_coef_normalized_ordered_transp(m,i)*c @@ -104,7 +138,6 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integral_local, (ao_num_align,ao_nu !$OMP END DO !$OMP END PARALLEL - END_PROVIDER @@ -132,6 +165,13 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integral_local, (ao_num_align,ao_nu call wall_time(wall_1) call cpu_time(cpu_1) thread_num = 0 +!write(34,*) 'xxxNONLOCxxx' +!write(34,*) ' pseudo_lmax,pseudo_kmax', pseudo_lmax,pseudo_kmax +!write(34,*) ' pseudo_v_kl_transp(1,0,k)', pseudo_v_kl_transp +!write(34,*) ' pseudo_n_kl_transp(1,0,k)', pseudo_n_kl_transp +!write(34,*) ' pseudo_dz_kl_transp(1,0,k)', pseudo_dz_kl_transp +!write(34,*) 'xxxNONLOCxxx' + !$OMP PARALLEL & !$OMP DEFAULT (NONE) & !$OMP PRIVATE (i,j,k,l,m,alpha,beta,A_center,B_center,C_center,power_A,power_B,& @@ -182,6 +222,15 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integral_local, (ao_num_align,ao_nu pseudo_n_kl_transp(1,0,k), & pseudo_dz_kl_transp(1,0,k), & A_center,power_A,alpha,B_center,power_B,beta,C_center) +! write(34,*) i,j,k +! write(34,*) & +! A_center,power_A,alpha,B_center,power_B,beta,C_center, & +! Vpseudo(pseudo_lmax,pseudo_kmax, & +! pseudo_v_kl_transp(1,0,k), & +! pseudo_n_kl_transp(1,0,k), & +! pseudo_dz_kl_transp(1,0,k), & +! A_center,power_A,alpha,B_center,power_B,beta,C_center) +! write(34,*) '' enddo ao_pseudo_integral_non_local(i,j) = ao_pseudo_integral_non_local(i,j) +& ao_coef_normalized_ordered_transp(l,j)*ao_coef_normalized_ordered_transp(m,i)*c @@ -204,7 +253,6 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integral_local, (ao_num_align,ao_nu !$OMP END PARALLEL - END_PROVIDER BEGIN_PROVIDER [ double precision, pseudo_v_k_transp, (pseudo_klocmax,nucl_num) ] diff --git a/src/Integrals_Monoelec/pot_mo_ints.irp.f b/src/Integrals_Monoelec/pot_mo_ints.irp.f index 50019abb..7c7e306f 100644 --- a/src/Integrals_Monoelec/pot_mo_ints.irp.f +++ b/src/Integrals_Monoelec/pot_mo_ints.irp.f @@ -1,60 +1,47 @@ BEGIN_PROVIDER [double precision, mo_nucl_elec_integral, (mo_tot_num_align,mo_tot_num)] implicit none - integer :: i1,j1,i,j - double precision :: c_i1,c_j1 BEGIN_DOC ! interaction nuclear electron on the MO basis END_DOC - mo_nucl_elec_integral = 0.d0 - !$OMP PARALLEL DO DEFAULT(none) & - !$OMP PRIVATE(i,j,i1,j1,c_j1,c_i1) & - !$OMP SHARED(mo_tot_num,ao_num,mo_coef, & - !$OMP mo_nucl_elec_integral, ao_nucl_elec_integral) - do i = 1, mo_tot_num - do j = 1, mo_tot_num - do i1 = 1,ao_num - c_i1 = mo_coef(i1,i) - do j1 = 1,ao_num - c_j1 = c_i1*mo_coef(j1,j) - mo_nucl_elec_integral(j,i) = mo_nucl_elec_integral(j,i) + & - c_j1 * ao_nucl_elec_integral(j1,i1) - enddo - enddo - enddo - enddo - !$OMP END PARALLEL DO + if (read_mo_one_integrals) then + call read_one_e_integrals('mo_ne_integral', mo_nucl_elec_integral, & + size(mo_nucl_elec_integral,1), size(mo_nucl_elec_integral,2)) + print *, 'MO N-e integrals read from disk' + else + call ao_to_mo( & + ao_nucl_elec_integral, & + size(ao_nucl_elec_integral,1), & + mo_nucl_elec_integral, & + size(mo_nucl_elec_integral,1) & + ) + endif + if (write_mo_one_integrals) then + call write_one_e_integrals('mo_ne_integral', mo_nucl_elec_integral, & + size(mo_nucl_elec_integral,1), size(mo_nucl_elec_integral,2)) + print *, 'MO N-e integrals written to disk' + endif + END_PROVIDER BEGIN_PROVIDER [double precision, mo_nucl_elec_integral_per_atom, (mo_tot_num_align,mo_tot_num,nucl_num)] implicit none - integer :: i1,j1,i,j,k - double precision :: c_i1,c_j1 BEGIN_DOC ! mo_nucl_elec_integral_per_atom(i,j,k) = - ! where Rk is the geometry of the kth atom END_DOC + integer :: k mo_nucl_elec_integral_per_atom = 0.d0 do k = 1, nucl_num - !$OMP PARALLEL DO DEFAULT(none) & - !$OMP PRIVATE(i,j,i1,j1,c_j1,c_i1) & - !$OMP SHARED(mo_tot_num,ao_num,mo_coef, & - !$OMP mo_nucl_elec_integral_per_atom, ao_nucl_elec_integral_per_atom,k) - do i = 1, mo_tot_num - do j = 1, mo_tot_num - do i1 = 1,ao_num - c_i1 = mo_coef(i1,i) - do j1 = 1,ao_num - c_j1 = c_i1*mo_coef(j1,j) - mo_nucl_elec_integral_per_atom(j,i,k) = mo_nucl_elec_integral_per_atom(j,i,k) + & - c_j1 * ao_nucl_elec_integral_per_atom(j1,i1,k) - enddo - enddo - enddo - enddo - !$OMP END PARALLEL DO + call ao_to_mo( & + ao_nucl_elec_integral_per_atom(1,1,k), & + size(ao_nucl_elec_integral_per_atom,1), & + mo_nucl_elec_integral_per_atom(1,1,k), & + size(mo_nucl_elec_integral_per_atom,1) & + ) enddo + END_PROVIDER diff --git a/src/Integrals_Monoelec/pot_mo_pseudo_ints.irp.f b/src/Integrals_Monoelec/pot_mo_pseudo_ints.irp.f index 6c412e4b..f2fee5f4 100644 --- a/src/Integrals_Monoelec/pot_mo_pseudo_ints.irp.f +++ b/src/Integrals_Monoelec/pot_mo_pseudo_ints.irp.f @@ -1,33 +1,27 @@ BEGIN_PROVIDER [double precision, mo_pseudo_integral, (mo_tot_num_align,mo_tot_num)] implicit none - integer :: i1,j1,i,j - double precision :: c_i1,c_j1 BEGIN_DOC ! interaction nuclear electron on the MO basis END_DOC - mo_pseudo_integral = 0.d0 - - if (.not.do_pseudo) then - return + if (read_mo_one_integrals) then + call read_one_e_integrals('mo_pseudo_integral', mo_pseudo_integral,& + size(mo_pseudo_integral,1), size(mo_pseudo_integral,2)) + print *, 'MO pseudopotential integrals read from disk' + else + call ao_to_mo( & + ao_pseudo_integral, & + size(ao_pseudo_integral,1), & + mo_pseudo_integral, & + size(mo_pseudo_integral,1) & + ) endif - !$OMP PARALLEL DO DEFAULT(none) & - !$OMP PRIVATE(i,j,i1,j1,c_j1,c_i1) & - !$OMP SHARED(mo_tot_num,ao_num,mo_coef, & - !$OMP mo_pseudo_integral, ao_pseudo_integral) - do i = 1, mo_tot_num - do j = 1, mo_tot_num - do i1 = 1,ao_num - c_i1 = mo_coef(i1,i) - do j1 = 1,ao_num - c_j1 = c_i1*mo_coef(j1,j) - mo_pseudo_integral(j,i) = mo_pseudo_integral(j,i) + & - c_j1 * ao_pseudo_integral(j1,i1) - enddo - enddo - enddo - enddo - !$OMP END PARALLEL DO + if (write_mo_one_integrals) then + call write_one_e_integrals('mo_pseudo_integral', mo_pseudo_integral,& + size(mo_pseudo_integral,1), size(mo_pseudo_integral,2)) + print *, 'MO pseudopotential integrals written to disk' + endif + END_PROVIDER diff --git a/src/Integrals_Monoelec/pseudopot.f90 b/src/Integrals_Monoelec/pseudopot.f90 index 32402c74..d77b3ca0 100644 --- a/src/Integrals_Monoelec/pseudopot.f90 +++ b/src/Integrals_Monoelec/pseudopot.f90 @@ -109,9 +109,10 @@ end DIMENSION PM(0:100,0:100) MM=100 pi=dacos(-1.d0) + fourpi=4.d0*pi iabs_m=iabs(m) if(iabs_m.gt.l)stop 'm must be between -l and l' - factor= dsqrt( ((2*l+1)*fact(l-iabs_m))/(4.d0*pi*fact(l+iabs_m)) ) + factor= dsqrt( ((l+l+1)*fact(l-iabs_m))/(fourpi*fact(l+iabs_m)) ) if(dabs(x).gt.1.d0)then print*,'pb. in ylm_no' print*,'x=',x @@ -124,7 +125,6 @@ end if(m.eq.0)ylm_real=coef if(m.lt.0)ylm_real=dsqrt(2.d0)*coef*dsin(iabs_m*phi) - fourpi=4.d0*dacos(-1.d0) if(l.eq.0)ylm_real=dsqrt(1.d0/fourpi) xchap=dsqrt(1.d0-x**2)*dcos(phi) @@ -134,9 +134,9 @@ end if(l.eq.1.and.m.eq.0)ylm_real=dsqrt(3.d0/fourpi)*zchap if(l.eq.1.and.m.eq.-1)ylm_real=dsqrt(3.d0/fourpi)*ychap - if(l.eq.2.and.m.eq.2)ylm_real=dsqrt(15.d0/16.d0/pi)*(xchap**2-ychap**2) + if(l.eq.2.and.m.eq.2)ylm_real=dsqrt(15.d0/16.d0/pi)*(xchap*xchap-ychap*ychap) if(l.eq.2.and.m.eq.1)ylm_real=dsqrt(15.d0/fourpi)*xchap*zchap - if(l.eq.2.and.m.eq.0)ylm_real=dsqrt(5.d0/16.d0/pi)*(-xchap**2-ychap**2+2.d0*zchap**2) + if(l.eq.2.and.m.eq.0)ylm_real=dsqrt(5.d0/16.d0/pi)*(2.d0*zchap*zchap-xchap*xchap-ychap*ychap) if(l.eq.2.and.m.eq.-1)ylm_real=dsqrt(15.d0/fourpi)*ychap*zchap if(l.eq.2.and.m.eq.-2)ylm_real=dsqrt(15.d0/fourpi)*xchap*ychap @@ -276,30 +276,16 @@ if(ac.eq.0.d0.and.bc.eq.0.d0)then do k=1,kmax do l=0,lmax ktot=ntot+n_kl(k,l) + if (v_kl(k,l) == 0.d0) cycle do m=-l,l prod=bigI(0,0,l,m,n_a(1),n_a(2),n_a(3)) + if (prod == 0.d0) cycle prodp=bigI(0,0,l,m,n_b(1),n_b(2),n_b(3)) - - accu=accu+prod*prodp*v_kl(k,l)*int_prod_bessel(ktot+2,g_a+g_b+dz_kl(k,l),0,0,areal,breal,arg) - + if (prodp == 0.d0) cycle + accu=accu+prod*prodp*v_kl(k,l)*int_prod_bessel(ktot+2,g_a+g_b+dz_kl(k,l),0,0,areal,breal,arg) enddo enddo enddo -! do k=1,kmax -! do l=0,lmax -! ktot=ntot+n_kl(k,l) -! do m=-l,l -! prod =bigI(0,0,l,m,n_a(1),n_a(2),n_a(3))*v_kl(k,l) -! prodp=bigI(0,0,l,m,n_b(1),n_b(2),n_b(3))*prod -! if (dabs (prodp) < 1.d-15) then -! cycle -! endif -! -! accu=accu+prodp*int_prod_bessel(ktot+2,g_a+g_b+dz_kl(k,l),0,0,areal,breal,arg) -! -! enddo -! enddo -! enddo !=!=!=!=! ! E n d ! @@ -313,7 +299,7 @@ else if(ac.ne.0.d0.and.bc.ne.0.d0)then ! I n i t ! !=!=!=!=!=! - f=fourpi**2 + f=fourpi*fourpi theta_AC0=dacos( (a(3)-c(3))/ac ) phi_AC0=datan2((a(2)-c(2))/ac,(a(1)-c(1))/ac) @@ -386,14 +372,17 @@ else if(ac.ne.0.d0.and.bc.ne.0.d0)then enddo do k3=0,n_a(3) + if (array_coefs_A(k3,3) == 0.d0) cycle do k2=0,n_a(2) + if (array_coefs_A(k2,2) == 0.d0) cycle do k1=0,n_a(1) - + if (array_coefs_A(k1,1) == 0.d0) cycle + do lambda=0,l+ntotA do mu=-lambda,lambda prod=ylm(lambda,mu,theta_AC0,phi_AC0)*array_coefs_A(k1,1)*array_coefs_A(k2,2)*array_coefs_A(k3,3)*array_I_A(mu,lambda,k1,k2,k3) - + if (prod == 0.d0) cycle do k3p=0,n_b(3) do k2p=0,n_b(2) @@ -405,6 +394,7 @@ else if(ac.ne.0.d0.and.bc.ne.0.d0)then array_coefs_B(k1p,1)*array_coefs_B(k2p,2)*array_coefs_B(k3p,3)* & array_I_B(mup,lambdap,k1p,k2p,k3p) + if (prodp == 0.d0) cycle do k=1,kmax ktot=k1+k2+k3+k1p+k2p+k3p+n_kl(k,l) accu=accu+prodp*v_kl(k,l)*array_R(k,ktot,l,lambda,lambdap) @@ -490,13 +480,18 @@ else if(ac.eq.0.d0.and.bc.ne.0.d0)then prod=bigI(0,0,l,m,n_a(1),n_a(2),n_a(3)) do k3p=0,n_b(3) + if (array_coefs_B(k3p,3) == 0.d0) cycle do k2p=0,n_b(2) + if (array_coefs_B(k2p,2) == 0.d0) cycle do k1p=0,n_b(1) + if (array_coefs_B(k1p,1) == 0.d0) cycle do lambdap=0,l+ntotB do mup=-lambdap,lambdap prodp=prod*array_coefs_B(k1p,1)*array_coefs_B(k2p,2)*array_coefs_B(k3p,3)*ylm(lambdap,mup,theta_BC0,phi_BC0)*array_I_B(mup,lambdap,k1p,k2p,k3p) + if (prodp == 0.d0) cycle + do k=1,kmax ktot=ntotA+k1p+k2p+k3p+n_kl(k,l) @@ -573,13 +568,19 @@ else if(ac.ne.0.d0.and.bc.eq.0.d0)then enddo do k3=0,n_a(3) + if (array_coefs_A(k3,3) == 0.d0) cycle do k2=0,n_a(2) + if (array_coefs_A(k2,2) == 0.d0) cycle do k1=0,n_a(1) + if (array_coefs_A(k1,1) == 0.d0) cycle do lambda=0,l+ntotA do mu=-lambda,lambda prod=array_coefs_A(k1,1)*array_coefs_A(k2,2)*array_coefs_A(k3,3)*ylm(lambda,mu,theta_AC0,phi_AC0)*array_I_A(mu,lambda,k1,k2,k3) + if (prod == 0.d0) cycle prodp=prod*bigI(0,0,l,m,n_b(1),n_b(2),n_b(3)) + + if (prodp == 0.d0) cycle do k=1,kmax ktot=k1+k2+k3+ntotB+n_kl(k,l) @@ -812,18 +813,22 @@ double precision int_prod_bessel_loc,binom_func,accu,prod,ylm,bigI,arg phi_DC0=datan2(d(2)/d2,d(1)/d2) do k=1,klocmax + if (v_k(k) == 0.d0) cycle do k1=0,n_a(1) do k2=0,n_a(2) do k3=0,n_a(3) do k1p=0,n_b(1) do k2p=0,n_b(2) do k3p=0,n_b(3) + if (array_coefs(k1,k2,k3,k1p,k2p,k3p) == 0.d0) cycle do l=0,ntot do m=-l,l coef=ylm(l,m,theta_DC0,phi_DC0) + if (coef == 0.d0) cycle + ktot=k1+k2+k3+k1p+k2p+k3p+n_k(k) + if (array_R_loc(ktot,k,l) == 0.d0) cycle prod=coef*array_coefs(k1,k2,k3,k1p,k2p,k3p) & *bigI(l,m,0,0,k1+k1p,k2+k2p,k3+k3p) - ktot=k1+k2+k3+k1p+k2p+k3p+n_k(k) accu=accu+prod*v_k(k)*array_R_loc(ktot,k,l) enddo enddo @@ -864,18 +869,24 @@ double precision pi,sum,factor1,factor2,cylm,cylmp,bigA,binom_func,fact,coef_pm double precision sgn, sgnp pi=dacos(-1.d0) +bigI=0.d0 if(mu.gt.0.and.m.gt.0)then sum=0.d0 factor1=dsqrt((2*lambda+1)*fact(lambda-iabs(mu))/(2.d0*pi*fact(lambda+iabs(mu)))) +if (factor1== 0.d0) return factor2=dsqrt((2*l+1)*fact(l-iabs(m))/(2.d0*pi*fact(l+iabs(m)))) +if (factor2== 0.d0) return sgn = 1.d0 do k=0,mu/2 do i=0,lambda-mu + if (coef_pm(lambda,i+mu) == 0.d0) cycle sgnp = 1.d0 do kp=0,m/2 do ip=0,l-m cylm=sgn*factor1*binom_func(mu,2*k)*fact(mu+i)/fact(i)*coef_pm(lambda,i+mu) + if (cylm == 0.d0) cycle cylmp=sgnp*factor2*binom_func(m,2*kp)*fact(m+ip)/fact(ip)*coef_pm(l,ip+m) + if (cylmp == 0.d0) cycle sum=sum+cylm*cylmp*bigA(mu-2*k+m-2*kp+k1,2*k+2*kp+k2,i+ip+k3) enddo sgnp = -sgnp @@ -889,12 +900,16 @@ endif if(mu.eq.0.and.m.eq.0)then factor1=dsqrt((2*lambda+1)/(4.d0*pi)) +if (factor1== 0.d0) return factor2=dsqrt((2*l+1)/(4.d0*pi)) +if (factor2== 0.d0) return sum=0.d0 do i=0,lambda do ip=0,l cylm=factor1*coef_pm(lambda,i) + if (cylm == 0.d0) cycle cylmp=factor2*coef_pm(l,ip) + if (cylmp == 0.d0) cycle sum=sum+cylm*cylmp*bigA(k1,k2,i+ip+k3) enddo enddo @@ -904,14 +919,18 @@ endif if(mu.eq.0.and.m.gt.0)then factor1=dsqrt((2*lambda+1)/(4.d0*pi)) +if (factor1== 0.d0) return factor2=dsqrt((2*l+1)*fact(l-iabs(m))/(2.d0*pi*fact(l+iabs(m)))) +if (factor2== 0.d0) return sum=0.d0 do i=0,lambda sgnp = 1.d0 do kp=0,m/2 do ip=0,l-m cylm=factor1*coef_pm(lambda,i) + if (cylm == 0.d0) cycle cylmp=sgnp*factor2*binom_func(m,2*kp)*fact(m+ip)/fact(ip)*coef_pm(l,ip+m) + if (cylmp == 0.d0) cycle sum=sum+cylm*cylmp*bigA(m-2*kp+k1,2*kp+k2,i+ip+k3) enddo sgnp = -sgnp @@ -924,13 +943,18 @@ endif if(mu.gt.0.and.m.eq.0)then sum=0.d0 factor1=dsqrt((2*lambda+1)*fact(lambda-iabs(mu))/(2.d0*pi*fact(lambda+iabs(mu)))) +if (factor1== 0.d0) return factor2=dsqrt((2*l+1)/(4.d0*pi)) +if (factor2== 0.d0) return sgn = 1.d0 do k=0,mu/2 do i=0,lambda-mu + if (coef_pm(lambda,i+mu) == 0.d0) cycle do ip=0,l cylm=sgn*factor1*binom_func(mu,2*k)*fact(mu+i)/fact(i)*coef_pm(lambda,i+mu) + if (cylm == 0.d0) cycle cylmp=factor2*coef_pm(l,ip) + if (cylmp == 0.d0) cycle sum=sum+cylm*cylmp*bigA(mu-2*k +k1,2*k +k2,i+ip +k3) enddo enddo @@ -944,16 +968,22 @@ if(mu.lt.0.and.m.lt.0)then mu=-mu m=-m factor1=dsqrt((2*lambda+1)*fact(lambda-iabs(mu))/(2.d0*pi*fact(lambda+iabs(mu)))) +if (factor1== 0.d0) return factor2=dsqrt((2*l+1)*fact(l-iabs(m))/(2.d0*pi*fact(l+iabs(m)))) +if (factor2== 0.d0) return sum=0.d0 sgn = 1.d0 do k=0,(mu-1)/2 do i=0,lambda-mu + if (coef_pm(lambda,i+mu) == 0.d0) cycle sgnp = 1.d0 do kp=0,(m-1)/2 do ip=0,l-m + if (coef_pm(l,ip+m) == 0.d0) cycle cylm=sgn*factor1*binom_func(mu,2*k+1)*fact(mu+i)/fact(i)*coef_pm(lambda,i+mu) + if (cylm == 0.d0) cycle cylmp=sgnp*factor2*binom_func(m,2*kp+1)*fact(m+ip)/fact(ip)*coef_pm(l,ip+m) + if (cylmp == 0.d0) cycle sum=sum+cylm*cylmp*bigA(mu-(2*k+1)+m-(2*kp+1)+k1,(2*k+1)+(2*kp+1)+k2,i+ip+k3) enddo sgnp = -sgnp @@ -970,14 +1000,18 @@ endif if(mu.eq.0.and.m.lt.0)then m=-m factor1=dsqrt((2*lambda+1)/(4.d0*pi)) +if (factor1 == 0.d0) return factor2=dsqrt((2*l+1)*fact(l-iabs(m))/(2.d0*pi*fact(l+iabs(m)))) +if (factor2 == 0.d0) return sum=0.d0 do i=0,lambda sgnp = 1.d0 do kp=0,(m-1)/2 do ip=0,l-m cylm=factor1*coef_pm(lambda,i) + if (cylm == 0.d0) cycle cylmp=sgnp*factor2*binom_func(m,2*kp+1)*fact(m+ip)/fact(ip)*coef_pm(l,ip+m) + if (cylmp == 0.d0) cycle sum=sum+cylm*cylmp*bigA(m-(2*kp+1)+k1,2*kp+1+k2,i+ip+k3) enddo sgnp = -sgnp @@ -992,13 +1026,17 @@ if(mu.lt.0.and.m.eq.0)then sum=0.d0 mu=-mu factor1=dsqrt((2*lambda+1)*fact(lambda-iabs(mu))/(2.d0*pi*fact(lambda+iabs(mu)))) +if (factor1== 0.d0) return factor2=dsqrt((2*l+1)/(4.d0*pi)) +if (factor2== 0.d0) return sgn = 1.d0 do k=0,(mu-1)/2 do i=0,lambda-mu do ip=0,l cylm=sgn*factor1*binom_func(mu,2*k+1)*fact(mu+i)/fact(i)*coef_pm(lambda,i+mu) + if (cylm == 0.d0) cycle cylmp=factor2*coef_pm(l,ip) + if (cylmp == 0.d0) cycle sum=sum+cylm*cylmp*bigA(mu-(2*k+1)+k1,2*k+1+k2,i+ip+k3) enddo enddo @@ -1012,16 +1050,22 @@ endif if(mu.gt.0.and.m.lt.0)then sum=0.d0 factor1=dsqrt((2*lambda+1)*fact(lambda-iabs(mu))/(2.d0*pi*fact(lambda+iabs(mu)))) +if (factor1== 0.d0) return factor2=dsqrt((2*l+1)*fact(l-iabs(m))/(2.d0*pi*fact(l+iabs(m)))) +if (factor2== 0.d0) return m=-m sgn=1.d0 do k=0,mu/2 do i=0,lambda-mu + if (coef_pm(lambda,i+mu) == 0.d0) cycle sgnp=1.d0 do kp=0,(m-1)/2 do ip=0,l-m + if (coef_pm(l,ip+m) == 0.d0) cycle cylm =sgn *factor1*binom_func(mu,2*k)*fact(mu+i)/fact(i)*coef_pm(lambda,i+mu) + if (cylm == 0.d0) cycle cylmp=sgnp*factor2*binom_func(m,2*kp+1)*fact(m+ip)/fact(ip)*coef_pm(l,ip+m) + if (cylmp == 0.d0) cycle sum=sum+cylm*cylmp*bigA(mu-2*k+m-(2*kp+1)+k1,2*k+2*kp+1+k2,i+ip+k3) enddo sgnp = -sgnp @@ -1037,16 +1081,22 @@ endif if(mu.lt.0.and.m.gt.0)then mu=-mu factor1=dsqrt((2*lambda+1)*fact(lambda-iabs(mu))/(2.d0*pi*fact(lambda+iabs(mu)))) +if (factor1== 0.d0) return factor2=dsqrt((2*l+1)*fact(l-iabs(m))/(2.d0*pi*fact(l+iabs(m)))) +if (factor2== 0.d0) return sum=0.d0 sgn = 1.d0 do k=0,(mu-1)/2 do i=0,lambda-mu + if (coef_pm(lambda,i+mu) == 0.d0) cycle sgnp = 1.d0 do kp=0,m/2 do ip=0,l-m + if (coef_pm(l,ip+m) == 0.d0) cycle cylm=sgn*factor1 *binom_func(mu,2*k+1)*fact(mu+i)/fact(i)*coef_pm(lambda,i+mu) + if (cylm == 0.d0) cycle cylmp=sgnp*factor2*binom_func(m,2*kp)*fact(m+ip)/fact(ip)*coef_pm(l,ip+m) + if (cylmp == 0.d0) cycle sum=sum+cylm*cylmp*bigA(mu-(2*k+1)+m-2*kp+k1,2*k+1+2*kp+k2,i+ip+k3) enddo sgnp = -sgnp @@ -1068,7 +1118,7 @@ integer n double precision g,dble_fact,expo double precision, parameter :: sq_pi_ov_2=dsqrt(dacos(-1.d0)*0.5d0) expo=0.5d0*dfloat(n+1) -crochet=dble_fact(n-1)/(2.d0*g)**expo +crochet=dble_fact(n-1)/(g+g)**expo if(mod(n,2).eq.0)crochet=crochet*sq_pi_ov_2 end @@ -1544,7 +1594,7 @@ end r=(i-1)*dr x1=delta1*r x2=delta2*r - sum=sum+dr*r**(n+2)*dexp(-cc*r**2)*bessel_mod(x1,lambda)*bessel_mod(x2,lambdap) + sum=sum+dr*r**(n+2)*dexp(-cc*r*r)*bessel_mod(x1,lambda)*bessel_mod(x2,lambdap) enddo bigR=sum*factor end @@ -1569,8 +1619,8 @@ end return endif if(n.eq.0)a=dsinh(x)/x - if(n.eq.1)a=(x*dcosh(x)-dsinh(x))/x**2 - if(n.ge.2)a=bessel_mod_recur(n-2,x)-(2*n-1)/x*bessel_mod_recur(n-1,x) + if(n.eq.1)a=(x*dcosh(x)-dsinh(x))/(x*x) + if(n.ge.2)a=bessel_mod_recur(n-2,x)-(n+n-1)/x*bessel_mod_recur(n-1,x) end double precision function bessel_mod_exp(n,x) @@ -1579,8 +1629,8 @@ end double precision x,coef,accu,fact,dble_fact accu=0.d0 do k=0,10 - coef=1.d0/fact(k)/dble_fact(2*(n+k)+1) - accu=accu+(x**2/2.d0)**k*coef + coef=1.d0/(fact(k)*dble_fact(2*(n+k)+1)) + accu=accu+(0.5d0*x*x)**k*coef enddo bessel_mod_exp=x**n*accu end @@ -1775,27 +1825,18 @@ double precision function binom_gen(alpha,n) enddo end - double precision FUNCTION ERF(X) - implicit double precision(a-h,o-z) - IF(X.LT.0.d0)THEN - ERF=-GAMMP(.5d0,X**2) - ELSE - ERF=GAMMP(.5d0,X**2) - ENDIF - RETURN - END double precision function coef_nk(n,k) implicit none - integer n,k, ISHFT + integer n,k double precision gam,dble_fact,fact - gam=dble_fact(2*(n+k)+1) - -! coef_nk=1.d0/(dble(ISHFT(1,k))*fact(k)*gam) - - coef_nk=1.d0/(2.d0**k*fact(k)*gam) + if (k<0) stop 'pseudopot.f90 : coef_nk' + if (k>63) stop 'pseudopot.f90 : coef_nk' + gam=dble_fact(n+n+k+k+1) +! coef_nk=1.d0/(2.d0**k*fact(k)*gam) + coef_nk=1.d0/(dble(ibset(0_8,k))*fact(k)*gam) return @@ -1820,11 +1861,11 @@ double precision function int_prod_bessel(l,gam,n,m,a,b,arg) double precision :: s_q_0, s_q_k, s_0_0, a_over_b_square double precision :: int_prod_bessel_loc double precision :: inverses(0:300) - double precision :: two_qkmp1, qk + double precision :: two_qkmp1, qk, mk, nk logical done - u=(a+b)/(2.d0*dsqrt(gam)) + u=(a+b)*0.5d0/dsqrt(gam) freal=dexp(-arg) if(a.eq.0.d0.and.b.eq.0.d0)then @@ -1849,8 +1890,8 @@ double precision function int_prod_bessel(l,gam,n,m,a,b,arg) int=0.d0 done=.false. - n_1 = 2*(n)+1 - m_1 = 2*m+1 + n_1 = n+n+1 + m_1 = m+m+1 nlm = n+m+l pi=dacos(-1.d0) a_over_b_square = (a/b)**2 @@ -1862,12 +1903,13 @@ double precision function int_prod_bessel(l,gam,n,m,a,b,arg) term_rap = term_a / (2.d0*gam)**expo s_0_0=term_rap*a**(n)*b**(m) - if(mod(nlm,2).eq.0)s_0_0=s_0_0*dsqrt(pi/2.d0) + if(mod(nlm,2).eq.0)s_0_0=s_0_0*dsqrt(pi*.5d0) ! Initialise the first recurence terme for the q loop s_q_0 = s_0_0 + mk = dble(m) ! Loop over q for the convergence of the sequence do while (.not.done) @@ -1879,15 +1921,15 @@ double precision function int_prod_bessel(l,gam,n,m,a,b,arg) stop 'pseudopot.f90 : q > 300' endif - two_qkmp1 = dble(2*(q+m)+1) qk = dble(q) + two_qkmp1 = 2.d0*(qk+mk)+1.d0 do k=0,q-1 - s_q_k = ( two_qkmp1*qk*inverses(k) ) * s_q_k + s_q_k = two_qkmp1*qk*inverses(k)*s_q_k sum=sum+s_q_k two_qkmp1 = two_qkmp1-2.d0 qk = qk-1.d0 enddo - inverses(q) = a_over_b_square/(dble(2*(q+n)+3) * dble(q+1)) + inverses(q) = a_over_b_square/(dble(q+n+q+n+3) * dble(q+1)) ! do k=0,q ! sum=sum+s_q_k ! s_q_k = a_over_b_square * ( dble(2*(q-k+m)+1)*dble(q-k)/(dble(2*(k+n)+3) * dble(k+1)) ) * s_q_k @@ -1900,9 +1942,10 @@ double precision function int_prod_bessel(l,gam,n,m,a,b,arg) else !Compute the s_q+1_0 - s_q_0=s_q_0*(2.d0*q+nlm+1)*b**2/((2.d0*(m+q)+3)*4.d0*(q+1)*gam) +! s_q_0=s_q_0*(2.d0*q+nlm+1)*b**2/((2.d0*(m+q)+3)*4.d0*(q+1)*gam) + s_q_0=s_q_0*(q+q+nlm+1)*b*b/(dble(8*(m+q)+12)*(q+1)*gam) - if(mod(n+m+l,2).eq.1)s_q_0=s_q_0*dsqrt(pi/2.d0) + if(mod(n+m+l,2).eq.1)s_q_0=s_q_0*dsqrt(pi*.5d0) ! Increment q q=q+1 intold=int @@ -1941,7 +1984,7 @@ double precision function int_prod_bessel_large(l,gam,n,m,a,b,arg) double precision xq(100),wq(100) u=(a+b)/(2.d0*dsqrt(gam)) - factor=dexp(u**2-arg)/dsqrt(gam) + factor=dexp(u*u-arg)/dsqrt(gam) xq(1)= 5.38748089001123 xq(2)= 4.60368244955074 @@ -2017,7 +2060,7 @@ double precision function int_prod_bessel_loc(l,gam,n,a) ! Int f_0 coef_nk=1.d0/dble_fact( n+n+1 ) expo=0.5d0*dfloat(n+l+1) - crochet=dble_fact(n+l-1)/(2.d0*gam)**expo + crochet=dble_fact(n+l-1)/(gam+gam)**expo if(mod(n+l,2).eq.0)crochet=crochet*dsqrt(0.5d0*pi) f_0 = coef_nk*a**n*crochet @@ -2029,7 +2072,8 @@ double precision function int_prod_bessel_loc(l,gam,n,a) int=int+f_k - f_k = f_k*(a**2*(2*(k+1)+n+l-1)) / (2*(k+1)*(2*(n+k+1)+1)*2*gam) +! f_k = f_k*(a**2*(2*(k+1)+n+l-1)) / (2*(k+1)*(2*(n+k+1)+1)*2*gam) + f_k = f_k*(a*a*dble(k+k+1+n+l)) / (dble((k+k+2)*(4*(n+k+1)+2))*gam) if(dabs(int-intold).lt.1d-15)then done=.true. diff --git a/src/Integrals_Monoelec/read_write.irp.f b/src/Integrals_Monoelec/read_write.irp.f new file mode 100644 index 00000000..697bf356 --- /dev/null +++ b/src/Integrals_Monoelec/read_write.irp.f @@ -0,0 +1,84 @@ + BEGIN_PROVIDER [ logical, read_ao_one_integrals ] +&BEGIN_PROVIDER [ logical, read_mo_one_integrals ] +&BEGIN_PROVIDER [ logical, write_ao_one_integrals ] +&BEGIN_PROVIDER [ logical, write_mo_one_integrals ] + + BEGIN_DOC + ! One level of abstraction for disk_access_ao_integrals and disk_access_mo_integrals + END_DOC + implicit none + + if (disk_access_ao_one_integrals.EQ.'Read') then + read_ao_one_integrals = .True. + write_ao_one_integrals = .False. + + else if (disk_access_ao_one_integrals.EQ.'Write') then + read_ao_one_integrals = .False. + write_ao_one_integrals = .True. + + else if (disk_access_ao_one_integrals.EQ.'None') then + read_ao_one_integrals = .False. + write_ao_one_integrals = .False. + + else + print *, 'bielec_integrals/disk_access_ao_integrals has a wrong type' + stop 1 + + endif + + if (disk_access_mo_one_integrals.EQ.'Read') then + read_mo_one_integrals = .True. + write_mo_one_integrals = .False. + + else if (disk_access_mo_one_integrals.EQ.'Write') then + read_mo_one_integrals = .False. + write_mo_one_integrals = .True. + + else if (disk_access_mo_one_integrals.EQ.'None') then + read_mo_one_integrals = .False. + write_mo_one_integrals = .False. + + else + print *, 'bielec_integrals/disk_access_mo_integrals has a wrong type' + stop 1 + + endif + +END_PROVIDER + +subroutine write_one_e_integrals(filename, A, m, n) + implicit none + BEGIN_DOC +! Write the 1-electron integrals stored in A(m,n) into file 'filename' + END_DOC + character(len=*), intent(in) :: filename + integer, intent(in) :: m,n + double precision, intent(in) :: A(m,n) + + integer :: iunit + integer, external :: getUnitAndOpen + character*(256) :: f + + iunit = getUnitAndOpen( trim(ezfio_work_dir)//trim(filename), 'W' ) + write(iunit) A + close(iunit) +end + +subroutine read_one_e_integrals(filename, A, m, n) + implicit none + BEGIN_DOC +! Read the 1-electron integrals into in A(m,n) from file 'filename' + END_DOC + character(len=*), intent(in) :: filename + integer, intent(in) :: m,n + double precision, intent(out) :: A(m,n) + + integer :: iunit + integer, external :: getUnitAndOpen + character*(256) :: f + + iunit = getUnitAndOpen( trim(ezfio_work_dir)//trim(filename), 'R' ) + read(iunit) A + close(iunit) +end + diff --git a/src/Integrals_Monoelec/spread_dipole_mo.irp.f b/src/Integrals_Monoelec/spread_dipole_mo.irp.f index d7306727..aa5ef8aa 100644 --- a/src/Integrals_Monoelec/spread_dipole_mo.irp.f +++ b/src/Integrals_Monoelec/spread_dipole_mo.irp.f @@ -7,30 +7,26 @@ ! array of the integrals of MO_i * z MO_j END_DOC implicit none - integer :: i1,j1,i,j - double precision :: c_i1,c_j1 - mo_dipole_x = 0.d0 - mo_dipole_y = 0.d0 - mo_dipole_z = 0.d0 - !$OMP PARALLEL DO DEFAULT(none) & - !$OMP PRIVATE(i,j,i1,j1,c_j1,c_i1) & - !$OMP SHARED(mo_tot_num,ao_num,mo_coef, & - !$OMP mo_dipole_x,mo_dipole_y,mo_dipole_z,ao_dipole_x,ao_dipole_y,ao_dipole_z) - do i = 1, mo_tot_num - do j = 1, mo_tot_num - do i1 = 1,ao_num - c_i1 = mo_coef(i1,i) - do j1 = 1,ao_num - c_j1 = c_i1*mo_coef(j1,j) - mo_dipole_x(j,i) = mo_dipole_x(j,i) + c_j1 * ao_dipole_x(j1,i1) - mo_dipole_y(j,i) = mo_dipole_y(j,i) + c_j1 * ao_dipole_y(j1,i1) - mo_dipole_z(j,i) = mo_dipole_z(j,i) + c_j1 * ao_dipole_z(j1,i1) - enddo - enddo - enddo - enddo - !$OMP END PARALLEL DO + call ao_to_mo( & + ao_dipole_x, & + size(ao_dipole_x,1), & + mo_dipole_x, & + size(mo_dipole_x,1) & + ) + call ao_to_mo( & + ao_dipole_y, & + size(ao_dipole_y,1), & + mo_dipole_y, & + size(mo_dipole_y,1) & + ) + call ao_to_mo( & + ao_dipole_z, & + size(ao_dipole_z,1), & + mo_dipole_z, & + size(mo_dipole_z,1) & + ) + END_PROVIDER BEGIN_PROVIDER [double precision, mo_spread_x , (mo_tot_num_align,mo_tot_num)] @@ -42,60 +38,23 @@ END_PROVIDER ! array of the integrals of MO_i * z^2 MO_j END_DOC implicit none - integer :: i1,j1,i,j - double precision :: c_i1,c_j1 - - mo_nucl_elec_integral = 0.d0 - !$OMP PARALLEL DO DEFAULT(none) & - !$OMP PRIVATE(i,j,i1,j1,c_j1,c_i1) & - !$OMP SHARED(mo_tot_num,ao_num,mo_coef, & - !$OMP mo_spread_x,mo_spread_y,mo_spread_z,ao_spread_x,ao_spread_y,ao_spread_z) - do i = 1, mo_tot_num - do j = 1, mo_tot_num - do i1 = 1,ao_num - c_i1 = mo_coef(i1,i) - do j1 = 1,ao_num - c_j1 = c_i1*mo_coef(j1,j) - mo_spread_x(j,i) = mo_spread_x(j,i) + c_j1 * ao_spread_x(j1,i1) - mo_spread_y(j,i) = mo_spread_y(j,i) + c_j1 * ao_spread_y(j1,i1) - mo_spread_z(j,i) = mo_spread_z(j,i) + c_j1 * ao_spread_z(j1,i1) - enddo - enddo - enddo - enddo - !$OMP END PARALLEL DO -END_PROVIDER - - BEGIN_PROVIDER [double precision, mo_deriv_1_x , (mo_tot_num_align,mo_tot_num)] -&BEGIN_PROVIDER [double precision, mo_deriv_1_y , (mo_tot_num_align,mo_tot_num)] -&BEGIN_PROVIDER [double precision, mo_deriv_1_z , (mo_tot_num_align,mo_tot_num)] - BEGIN_DOC - ! array of the integrals of MO_i * d/dx MO_j - ! array of the integrals of MO_i * d/dy MO_j - ! array of the integrals of MO_i * d/dz MO_j - END_DOC - implicit none - integer :: i1,j1,i,j - double precision :: c_i1,c_j1 - - mo_nucl_elec_integral = 0.d0 - !$OMP PARALLEL DO DEFAULT(none) & - !$OMP PRIVATE(i,j,i1,j1,c_j1,c_i1) & - !$OMP SHARED(mo_tot_num,ao_num,mo_coef, & - !$OMP mo_deriv_1_x,mo_deriv_1_y,mo_deriv_1_z,ao_spread_x,ao_spread_y,ao_spread_z) - do i = 1, mo_tot_num - do j = 1, mo_tot_num - do i1 = 1,ao_num - c_i1 = mo_coef(i1,i) - do j1 = 1,ao_num - c_j1 = c_i1*mo_coef(j1,j) - mo_deriv_1_x(j,i) = mo_deriv_1_x(j,i) + c_j1 * ao_spread_x(j1,i1) - mo_deriv_1_y(j,i) = mo_deriv_1_y(j,i) + c_j1 * ao_spread_y(j1,i1) - mo_deriv_1_z(j,i) = mo_deriv_1_z(j,i) + c_j1 * ao_spread_z(j1,i1) - enddo - enddo - enddo - enddo - !$OMP END PARALLEL DO + call ao_to_mo( & + ao_spread_x, & + size(ao_spread_x,1), & + mo_spread_x, & + size(mo_spread_x,1) & + ) + call ao_to_mo( & + ao_spread_y, & + size(ao_spread_y,1), & + mo_spread_y, & + size(mo_spread_y,1) & + ) + call ao_to_mo( & + ao_spread_z, & + size(ao_spread_z,1), & + mo_spread_z, & + size(mo_spread_z,1) & + ) END_PROVIDER diff --git a/src/MOGuess/.gitignore b/src/MOGuess/.gitignore index 797574f4..a912636d 100644 --- a/src/MOGuess/.gitignore +++ b/src/MOGuess/.gitignore @@ -4,6 +4,7 @@ AO_Basis Electrons Ezfio_files +H_CORE_guess IRPF90_man IRPF90_temp Integrals_Monoelec diff --git a/src/MOGuess/README.rst b/src/MOGuess/README.rst index 06a21370..3fca60c0 100644 --- a/src/MOGuess/README.rst +++ b/src/MOGuess/README.rst @@ -28,7 +28,11 @@ Documentation .. by the `update_README.py` script. -`ao_ortho_lowdin_coef `_ +`ao_ortho_canonical_nucl_elec_integral `_ + Undocumented + + +`ao_ortho_lowdin_coef `_ matrix of the coefficients of the mos generated by the orthonormalization by the S^{-1/2} canonical transformation of the aos ao_ortho_lowdin_coef(i,j) = coefficient of the ith ao on the jth ao_ortho_lowdin orbital @@ -38,15 +42,11 @@ Documentation Undocumented -`ao_ortho_lowdin_overlap `_ +`ao_ortho_lowdin_overlap `_ overlap matrix of the ao_ortho_lowdin supposed to be the Identity -`guess_mimi `_ - Produce `H_core` MO orbital - - `h_core_guess `_ Produce `H_core` MO orbital output: mo_basis.mo_tot_num mo_basis.mo_label mo_basis.ao_md5 mo_basis.mo_coef mo_basis.mo_occ @@ -55,7 +55,3 @@ Documentation `hcore_guess `_ Produce `H_core` MO orbital - -`prog_truncate_mo `_ - Truncate MO set - diff --git a/src/MO_Basis/.gitignore b/src/MO_Basis/.gitignore index 8eb04d30..110e93f9 100644 --- a/src/MO_Basis/.gitignore +++ b/src/MO_Basis/.gitignore @@ -1,17 +1,17 @@ -# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py -IRPF90_temp -IRPF90_man -irpf90_entities -tags -irpf90.make -Makefile -Makefile.depend -build.ninja -.ninja_log +# Automatically created by $QP_ROOT/scripts/module/module_handler.py .ninja_deps -ezfio_interface.irp.f -Utils -Nuclei +.ninja_log AO_Basis Electrons -Ezfio_files \ No newline at end of file +Ezfio_files +IRPF90_man +IRPF90_temp +Makefile +Makefile.depend +Nuclei +Utils +ezfio_interface.irp.f +irpf90.make +irpf90_entities +swap_mos +tags \ No newline at end of file diff --git a/src/MO_Basis/README.rst b/src/MO_Basis/README.rst index afc6008b..aa99670b 100644 --- a/src/MO_Basis/README.rst +++ b/src/MO_Basis/README.rst @@ -58,7 +58,44 @@ Documentation .. by the `update_README.py` script. -`ao_to_mo `_ +`ao_cart_to_sphe_coef `_ + matrix of the coefficients of the mos generated by the + orthonormalization by the S^{-1/2} canonical transformation of the aos + ao_cart_to_sphe_coef(i,j) = coefficient of the ith ao on the jth ao_ortho_canonical orbital + + +`ao_cart_to_sphe_inv `_ + AO_cart_to_sphe_coef^(-1) + + +`ao_cart_to_sphe_num `_ + matrix of the coefficients of the mos generated by the + orthonormalization by the S^{-1/2} canonical transformation of the aos + ao_cart_to_sphe_coef(i,j) = coefficient of the ith ao on the jth ao_ortho_canonical orbital + + +`ao_cart_to_sphe_overlap `_ + AO overlap matrix in the spherical basis set + + +`ao_ortho_canonical_coef `_ + matrix of the coefficients of the mos generated by the + orthonormalization by the S^{-1/2} canonical transformation of the aos + ao_ortho_canonical_coef(i,j) = coefficient of the ith ao on the jth ao_ortho_canonical orbital + + +`ao_ortho_canonical_num `_ + matrix of the coefficients of the mos generated by the + orthonormalization by the S^{-1/2} canonical transformation of the aos + ao_ortho_canonical_coef(i,j) = coefficient of the ith ao on the jth ao_ortho_canonical orbital + + +`ao_ortho_canonical_overlap `_ + overlap matrix of the ao_ortho_canonical. + Expected to be the Identity + + +`ao_to_mo `_ Transform A from the AO basis to the MO basis @@ -67,7 +104,7 @@ Documentation generate MOs -`mix_mo_jk `_ +`mix_mo_jk `_ subroutine that rotates the jth MO with the kth MO to give two new MO's that are '+' = 1/sqrt(2) (|j> + |k>) @@ -80,17 +117,21 @@ Documentation Undocumented -`mo_as_eigvectors_of_mo_matrix_sort_by_observable `_ +`mo_as_eigvectors_of_mo_matrix_sort_by_observable `_ Undocumented -`mo_coef `_ +`mo_as_svd_vectors_of_mo_matrix `_ + Undocumented + + +`mo_coef `_ Molecular orbital coefficients on AO basis set mo_coef(i,j) = coefficient of the ith ao on the jth mo mo_label : Label characterizing the MOS (local, canonical, natural, etc) -`mo_coef_transp `_ +`mo_coef_transp `_ Molecular orbital coefficients on AO basis set @@ -102,13 +143,13 @@ Documentation Density matrix in MO basis (virtual MOs) -`mo_label `_ +`mo_label `_ Molecular orbital coefficients on AO basis set mo_coef(i,j) = coefficient of the ith ao on the jth mo mo_label : Label characterizing the MOS (local, canonical, natural, etc) -`mo_occ `_ +`mo_occ `_ MO occupation numbers @@ -116,15 +157,15 @@ Documentation Undocumented -`mo_sort_by_observable `_ +`mo_sort_by_observable `_ Undocumented -`mo_to_ao `_ +`mo_to_ao `_ Transform A from the MO basis to the AO basis -`mo_to_ao_no_overlap `_ +`mo_to_ao_no_overlap `_ Transform A from the MO basis to the S^-1 AO basis @@ -132,11 +173,11 @@ Documentation Total number of molecular orbitals and the size of the keys corresponding -`mo_tot_num_align `_ +`mo_tot_num_align `_ Aligned variable for dimensioning of arrays -`s_mo_coef `_ +`s_mo_coef `_ Product S.C where S is the overlap matrix in the AO basis and C the mo_coef matrix. @@ -147,3 +188,7 @@ Documentation `save_mos_truncated `_ Undocumented + +`swap_mos `_ + Undocumented + diff --git a/src/MO_Basis/swap_mos.irp.f b/src/MO_Basis/swap_mos.irp.f new file mode 100644 index 00000000..df0dc64d --- /dev/null +++ b/src/MO_Basis/swap_mos.irp.f @@ -0,0 +1,14 @@ +program swap_mos + implicit none + integer :: i,j, i1, i2 + double precision :: x + print *, 'MOs to swap?' + read(*,*) i1, i2 + do i=1,ao_num_align + x = mo_coef(i,i1) + mo_coef(i,i1) = mo_coef(i,i2) + mo_coef(i,i2) = x + enddo + call save_mos + +end diff --git a/src/Pseudo/README.rst b/src/Pseudo/README.rst index cba187aa..2b3f87dd 100644 --- a/src/Pseudo/README.rst +++ b/src/Pseudo/README.rst @@ -28,15 +28,19 @@ Documentation .. by the `update_README.py` script. -`do_pseudo `_ +`do_pseudo `_ Using pseudo potential integral or not -`pseudo_dz_k `_ +`nucl_charge_remove `_ + Nuclear charges removed + + +`pseudo_dz_k `_ test -`pseudo_dz_kl `_ +`pseudo_dz_kl `_ test @@ -44,23 +48,23 @@ Documentation R_maxof the QMC grid -`pseudo_grid_size `_ +`pseudo_grid_size `_ Nb of points of the QMC grid -`pseudo_klocmax `_ +`pseudo_klocmax `_ test -`pseudo_kmax `_ +`pseudo_kmax `_ test -`pseudo_lmax `_ +`pseudo_lmax `_ test -`pseudo_n_k `_ +`pseudo_n_k `_ test @@ -68,10 +72,10 @@ Documentation test -`pseudo_v_k `_ +`pseudo_v_k `_ test -`pseudo_v_kl `_ +`pseudo_v_kl `_ test diff --git a/src/Utils/LinearAlgebra.irp.f b/src/Utils/LinearAlgebra.irp.f index f9645aa4..9c3b35b5 100644 --- a/src/Utils/LinearAlgebra.irp.f +++ b/src/Utils/LinearAlgebra.irp.f @@ -11,9 +11,9 @@ subroutine svd(A,LDA,U,LDU,D,Vt,LDVt,m,n) integer, intent(in) :: LDA, LDU, LDVt, m, n double precision, intent(in) :: A(LDA,n) - double precision, intent(out) :: U(LDU,n) + double precision, intent(out) :: U(LDU,m) double precision,intent(out) :: Vt(LDVt,n) - double precision,intent(out) :: D(n) + double precision,intent(out) :: D(min(m,n)) double precision,allocatable :: work(:) integer :: info, lwork, i, j, k @@ -24,13 +24,13 @@ subroutine svd(A,LDA,U,LDU,D,Vt,LDVt,m,n) ! Find optimal size for temp arrays allocate(work(1)) lwork = -1 - call dgesvd('A','A', n, n, A_tmp, LDA, & + call dgesvd('A','A', m, n, A_tmp, LDA, & D, U, LDU, Vt, LDVt, work, lwork, info) lwork = work(1) deallocate(work) allocate(work(lwork)) - call dgesvd('A','A', n, n, A_tmp, LDA, & + call dgesvd('A','A', m, n, A_tmp, LDA, & D, U, LDU, Vt, LDVt, work, lwork, info) deallocate(work,A_tmp) @@ -73,6 +73,10 @@ subroutine ortho_canonical(overlap,LDA,N,C,LDC,m) !DEC$ ATTRIBUTES ALIGN : 64 :: U, Vt, D integer :: info, i, j + if (n < 2) then + return + endif + allocate (U(ldc,n), Vt(lda,n), D(n), S_half(lda,n)) call svd(overlap,lda,U,ldc,D,Vt,lda,n,n) @@ -121,6 +125,40 @@ subroutine ortho_canonical(overlap,LDA,N,C,LDC,m) end +subroutine ortho_qr(A,LDA,m,n) + implicit none + BEGIN_DOC + ! Orthogonalization using Q.R factorization + ! + ! A : matrix to orthogonalize + ! + ! LDA : leftmost dimension of A + ! + ! n : Number of rows of A + ! + ! m : Number of columns of A + ! + END_DOC + integer, intent(in) :: m,n, LDA + double precision, intent(inout) :: A(LDA,n) + + integer :: lwork, info + integer, allocatable :: jpvt(:) + double precision, allocatable :: tau(:), work(:) + + allocate (jpvt(n), tau(n), work(1)) + LWORK=-1 +! call dgeqp3(m, n, A, LDA, jpvt, tau, WORK, LWORK, INFO) + call dgeqrf( m, n, A, LDA, TAU, WORK, LWORK, INFO ) + LWORK=WORK(1) + deallocate(WORK) + allocate(WORK(LWORK)) +! call dgeqp3(m, n, A, LDA, jpvt, tau, WORK, LWORK, INFO) + call dgeqrf( m, n, A, LDA, TAU, WORK, LWORK, INFO ) + call dorgqr(m, n, n, A, LDA, tau, WORK, LWORK, INFO) + deallocate(WORK,jpvt,tau) +end + subroutine ortho_lowdin(overlap,LDA,N,C,LDC,m) implicit none BEGIN_DOC @@ -144,14 +182,20 @@ subroutine ortho_lowdin(overlap,LDA,N,C,LDC,m) integer, intent(in) :: LDA, ldc, n, m double precision, intent(in) :: overlap(lda,n) double precision, intent(inout) :: C(ldc,n) - double precision :: U(ldc,n) - double precision :: Vt(lda,n) - double precision :: D(n) - double precision :: S_half(lda,n) + double precision, allocatable :: U(:,:) + double precision, allocatable :: Vt(:,:) + double precision, allocatable :: D(:) + double precision, allocatable :: S_half(:,:) !DEC$ ATTRIBUTES ALIGN : 64 :: U, Vt, D integer :: info, i, j, k - call svd(overlap,lda,U,ldc,D,Vt,lda,m,n) + if (n < 2) then + return + endif + + allocate(U(ldc,n),Vt(lda,n),S_half(lda,n),D(n)) + + call svd(overlap,lda,U,ldc,D,Vt,lda,n,n) !$OMP PARALLEL DEFAULT(NONE) & !$OMP SHARED(S_half,U,D,Vt,n,C,m) & @@ -195,6 +239,7 @@ subroutine ortho_lowdin(overlap,LDA,N,C,LDC,m) call dgemm('N','N',m,n,n,1.d0,U,size(U,1),S_half,size(S_half,1),0.d0,C,size(C,1)) + deallocate(U,Vt,S_half,D) end diff --git a/src/Utils/README.rst b/src/Utils/README.rst index ecd5db56..03ec80f5 100644 --- a/src/Utils/README.rst +++ b/src/Utils/README.rst @@ -14,14 +14,6 @@ Documentation Undocumented -`abort_all `_ - If True, all the calculation is aborted - - -`abort_here `_ - If True, all the calculation is aborted - - `add_poly `_ Add two polynomials D(t) =! D(t) +( B(t)+C(t)) @@ -36,11 +28,11 @@ Documentation Compute 1st dimension such that it is aligned for vectorization. -`apply_rotation `_ +`apply_rotation `_ Apply the rotation found by find_rotation -`approx_dble `_ +`approx_dble `_ Undocumented @@ -63,10 +55,6 @@ Documentation Binomial coefficients -`catch_signal `_ - What to do on Ctrl-C. If two Ctrl-C are pressed within 1 sec, the calculation if aborted. - - `dble_fact `_ Undocumented @@ -122,7 +110,7 @@ Documentation 1/n! -`find_rotation `_ +`find_rotation `_ Find A.C = B @@ -148,7 +136,7 @@ Documentation Undocumented -`get_pseudo_inverse `_ +`get_pseudo_inverse `_ Find C = A^-1 @@ -257,7 +245,7 @@ Documentation Hermite polynomial -`i2radix_sort `_ +`i2radix_sort `_ Sort integer array x(isize) using the radix sort algorithm. iorder in input should be (1,2,3,...,isize), and in output contains the new order of the elements. @@ -282,14 +270,14 @@ Documentation contains the new order of the elements. -`i8radix_sort `_ +`i8radix_sort `_ Sort integer array x(isize) using the radix sort algorithm. iorder in input should be (1,2,3,...,isize), and in output contains the new order of the elements. iradix should be -1 in input. -`i8radix_sort_big `_ +`i8radix_sort_big `_ Sort integer array x(isize) using the radix sort algorithm. iorder in input should be (1,2,3,...,isize), and in output contains the new order of the elements. @@ -388,14 +376,14 @@ Documentation 1/i -`iradix_sort `_ +`iradix_sort `_ Sort integer array x(isize) using the radix sort algorithm. iorder in input should be (1,2,3,...,isize), and in output contains the new order of the elements. iradix should be -1 in input. -`iradix_sort_big `_ +`iradix_sort_big `_ Sort integer array x(isize) using the radix sort algorithm. iorder in input should be (1,2,3,...,isize), and in output contains the new order of the elements. @@ -420,7 +408,7 @@ Documentation contains the new order of the elements. -`lapack_diag `_ +`lapack_diag `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -431,7 +419,7 @@ Documentation .br -`lapack_diag_s2 `_ +`lapack_diag_s2 `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -442,7 +430,7 @@ Documentation .br -`lapack_diagd `_ +`lapack_diagd `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -453,7 +441,7 @@ Documentation .br -`lapack_partial_diag `_ +`lapack_partial_diag `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -468,12 +456,16 @@ Documentation n! +`lowercase `_ + Transform to lower case + + `multiply_poly `_ Multiply two polynomials D(t) =! D(t) +( B(t)*C(t)) -`normalize `_ +`normalize `_ Normalizes vector u u is expected to be aligned in memory. @@ -482,8 +474,26 @@ Documentation Number of current OpenMP threads -`ortho_lowdin `_ - Compute C_new=C_old.S^-1/2 canonical orthogonalization. +`ortho_canonical `_ + Compute C_new=C_old.U.s^-1/2 canonical orthogonalization. + .br + overlap : overlap matrix + .br + LDA : leftmost dimension of overlap array + .br + N : Overlap matrix is NxN (array is (LDA,N) ) + .br + C : Coefficients of the vectors to orthogonalize. On exit, + orthogonal vectors + .br + LDC : leftmost dimension of C + .br + m : Coefficients matrix is MxN, ( array is (LDC,N) ) + .br + + +`ortho_lowdin `_ + Compute C_new=C_old.S^-1/2 orthogonalization. .br overlap : overlap matrix .br @@ -597,7 +607,7 @@ Documentation to be in integer*8 format -`set_zero_extra_diag `_ +`set_zero_extra_diag `_ Undocumented @@ -624,11 +634,7 @@ Documentation .br -`trap_signals `_ - What to do when a signal is caught. Here, trap Ctrl-C and call the control_C subroutine. - - -`u_dot_u `_ +`u_dot_u `_ Compute diff --git a/src/Utils/fortran_mmap.c b/src/Utils/fortran_mmap.c new file mode 100644 index 00000000..eee8337e --- /dev/null +++ b/src/Utils/fortran_mmap.c @@ -0,0 +1,72 @@ +#include +#include +#include +#include +#include +#include +#include + + +void* mmap_fortran(char* filename, size_t bytes, int* file_descr, int read_only) +{ + int i; + int fd; + int result; + void* map; + + if (read_only == 1) + { + fd = open(filename, O_RDONLY, (mode_t)0600); + if (fd == -1) { + printf("%s:\n", filename); + perror("Error opening mmap file for reading"); + exit(EXIT_FAILURE); + } + map = mmap(NULL, bytes, PROT_READ, MAP_SHARED, fd, 0); + } + else + { + fd = open(filename, O_RDWR | O_CREAT, (mode_t)0600); + if (fd == -1) { + printf("%s:\n", filename); + perror("Error opening mmap file for writing"); + exit(EXIT_FAILURE); + } + + result = lseek(fd, bytes, SEEK_SET); + if (result == -1) { + close(fd); + printf("%s:\n", filename); + perror("Error calling lseek() to stretch the file"); + exit(EXIT_FAILURE); + } + + result = write(fd, "", 1); + if (result != 1) { + close(fd); + printf("%s:\n", filename); + perror("Error writing last byte of the file"); + exit(EXIT_FAILURE); + } + + map = mmap(NULL, bytes, PROT_READ | PROT_WRITE, MAP_SHARED, fd, 0); + } + + if (map == MAP_FAILED) { + close(fd); + printf("%s:\n", filename); + perror("Error mmapping the file"); + exit(EXIT_FAILURE); + } + + *file_descr = fd; + return map; +} + +void munmap_fortran(size_t bytes, int fd, void* map) +{ + if (munmap(map, bytes) == -1) { + perror("Error un-mmapping the file"); + } + close(fd); +} diff --git a/src/Utils/map_functions.irp.f b/src/Utils/map_functions.irp.f new file mode 100644 index 00000000..68ba342c --- /dev/null +++ b/src/Utils/map_functions.irp.f @@ -0,0 +1,115 @@ +subroutine map_save_to_disk(filename,map) + use map_module + use mmap_module + implicit none + character*(*), intent(in) :: filename + type(map_type), intent(inout) :: map + type(c_ptr) :: c_pointer(3) + integer :: fd(3) + integer*8 :: i,k + integer :: j + + + if (map % consolidated) then + stop 'map already consolidated' + endif + + call mmap(trim(filename)//'_consolidated_idx', (/ map % map_size + 2_8 /), 8, fd(1), .False., c_pointer(1)) + call c_f_pointer(c_pointer(1),map % consolidated_idx, (/ map % map_size +2_8/)) + + call mmap(trim(filename)//'_consolidated_key', (/ map % n_elements /), cache_key_kind, fd(2), .False., c_pointer(2)) + call c_f_pointer(c_pointer(2),map % consolidated_key, (/ map % n_elements /)) + + call mmap(trim(filename)//'_consolidated_value', (/ map % n_elements /), integral_kind, fd(3), .False., c_pointer(3)) + call c_f_pointer(c_pointer(3),map % consolidated_value, (/ map % n_elements /)) + + if (.not.associated(map%consolidated_key)) then + stop 'cannot consolidate map : consolidated_key not associated' + endif + + if (.not.associated(map%consolidated_value)) then + stop 'cannot consolidate map : consolidated_value not associated' + endif + + if (.not.associated(map%consolidated_idx)) then + stop 'cannot consolidate map : consolidated_idx not associated' + endif + + call map_sort(map) + k = 1_8 + do i=0_8, map % map_size + map % consolidated_idx (i+1) = k + do j=1, map % map(i) % n_elements + map % consolidated_value(k) = map % map(i) % value(j) + map % consolidated_key (k) = map % map(i) % key(j) + k = k+1_8 + enddo + deallocate(map % map(i) % value) + deallocate(map % map(i) % key) + map % map(i) % value => map % consolidated_value ( map % consolidated_idx (i+1) :) + map % map(i) % key => map % consolidated_key ( map % consolidated_idx (i+1) :) + enddo + map % consolidated_idx (map % map_size + 2_8) = k + map % consolidated = .True. + + +! call munmap( (/ map % map_size + 2_8 /), 8, fd(1), c_pointer(1)) +! call mmap(trim(filename)//'_consolidated_idx', (/ map % map_size + 2_8 /), 8, fd(1), .True., c_pointer(1)) +! call c_f_pointer(c_pointer(1),map % consolidated_idx, (/ map % map_size +2_8/)) +! +! call munmap( (/ map % n_elements /), cache_key_kind, fd(2), c_pointer(2)) +! call mmap(trim(filename)//'_consolidated_key', (/ map % n_elements /), cache_key_kind, fd(2), .True., c_pointer(2)) +! call c_f_pointer(c_pointer(2),map % consolidated_key, (/ map % n_elements /)) +! +! call munmap( (/ map % n_elements /), integral_kind, fd(3), c_pointer(3)) +! call mmap(trim(filename)//'_consolidated_value', (/ map % n_elements /), integral_kind, fd(3), .True., c_pointer(3)) +! call c_f_pointer(c_pointer(3),map % consolidated_value, (/ map % n_elements /)) + +end + +subroutine map_load_from_disk(filename,map) + use map_module + use mmap_module + implicit none + character*(*), intent(in) :: filename + type(map_type), intent(inout) :: map + type(c_ptr) :: c_pointer(3) + integer :: fd(3) + integer*8 :: i,k + integer :: n_elements + + + + if (map % consolidated) then + stop 'map already consolidated' + endif + + call mmap(trim(filename)//'_consolidated_idx', (/ map % map_size + 2_8 /), 8, fd(1), .True., c_pointer(1)) + call c_f_pointer(c_pointer(1),map % consolidated_idx, (/ map % map_size + 2_8/)) + + map% n_elements = map % consolidated_idx (map % map_size+2_8)-1 + + call mmap(trim(filename)//'_consolidated_key', (/ map % n_elements /), cache_key_kind, fd(2), .True., c_pointer(2)) + call c_f_pointer(c_pointer(2),map % consolidated_key, (/ map % n_elements /)) + + call mmap(trim(filename)//'_consolidated_value', (/ map % n_elements /), integral_kind, fd(3), .True., c_pointer(3)) + call c_f_pointer(c_pointer(3),map % consolidated_value, (/ map % n_elements /)) + + k = 1_8 + do i=0_8, map % map_size + deallocate(map % map(i) % value) + deallocate(map % map(i) % key) + map % map(i) % value => map % consolidated_value ( map % consolidated_idx (i+1) :) + map % map(i) % key => map % consolidated_key ( map % consolidated_idx (i+1) :) + map % map(i) % sorted = .True. + n_elements = map % consolidated_idx (i+2) - k + k = map % consolidated_idx (i+2) + map % map(i) % map_size = n_elements + map % map(i) % n_elements = n_elements + enddo + map % n_elements = k-1 + map % sorted = .True. + map % consolidated = .True. + +end + diff --git a/src/Utils/map_module.f90 b/src/Utils/map_module.f90 index af2af34f..4a83582f 100644 --- a/src/Utils/map_module.f90 +++ b/src/Utils/map_module.f90 @@ -30,8 +30,8 @@ module map_module integer*8, parameter :: map_mask = ibset(0_8,15)-1_8 type cache_map_type - integer(cache_key_kind), pointer :: key(:) real(integral_kind), pointer :: value(:) + integer(cache_key_kind), pointer :: key(:) logical :: sorted integer(cache_map_size_kind) :: map_size integer(cache_map_size_kind) :: n_elements @@ -40,9 +40,13 @@ module map_module type map_type type(cache_map_type), allocatable :: map(:) + real(integral_kind), pointer :: consolidated_value(:) + integer(cache_key_kind), pointer :: consolidated_key(:) + integer*8, pointer :: consolidated_idx(:) + logical :: sorted + logical :: consolidated integer(map_size_kind) :: map_size integer(map_size_kind) :: n_elements - logical :: sorted integer(omp_lock_kind) :: lock end type map_type @@ -92,6 +96,7 @@ subroutine map_init(map,keymax) map%n_elements = 0_8 map%map_size = ishft(keymax,map_shift) + map%consolidated = .False. allocate(map%map(0_8:map%map_size),stat=err) if (err /= 0) then @@ -619,6 +624,7 @@ subroutine search_key_big_interval(key,X,sze,idx,ibegin_in,iend_in) idx = ibegin + istep do while (istep > 16) idx = ibegin + istep + ! TODO : Cache misses if (cache_key < X(idx)) then iend = idx istep = ishft(idx-ibegin,-1) @@ -656,12 +662,10 @@ subroutine search_key_big_interval(key,X,sze,idx,ibegin_in,iend_in) idx = ibegin if (min(iend_in,sze) > ibegin+16) then iend = ibegin+16 - !DIR$ VECTOR ALIGNED do while (cache_key > X(idx)) idx = idx+1 end do else - !DIR$ VECTOR ALIGNED do while (cache_key > X(idx)) idx = idx+1 if (idx /= iend) then @@ -769,13 +773,11 @@ subroutine search_key_value_big_interval(key,value,X,Y,sze,idx,ibegin_in,iend_in value = Y(idx) if (min(iend_in,sze) > ibegin+16) then iend = ibegin+16 - !DIR$ VECTOR ALIGNED do while (cache_key > X(idx)) idx = idx+1 value = Y(idx) end do else - !DIR$ VECTOR ALIGNED do while (cache_key > X(idx)) idx = idx+1 value = Y(idx) @@ -849,30 +851,9 @@ subroutine get_cache_map(map,map_idx,keys,values,n_elements) n_elements = map%map(map_idx)%n_elements do i=1,n_elements - keys(i) = map%map(map_idx)%key(i) + shift + keys(i) = map%map(map_idx)%key(i) + shift values(i) = map%map(map_idx)%value(i) enddo end -subroutine get_cache_map_verbose(map,map_idx) - use map_module - implicit none - type (map_type), intent(in) :: map - integer(map_size_kind), intent(in) :: map_idx - integer(cache_map_size_kind) :: n_elements - integer(key_kind) :: keys(2**16) - double precision :: values(2**16) - integer(cache_map_size_kind) :: i - integer(key_kind) :: shift - - shift = ishft(map_idx,-map_shift) - - n_elements = map%map(map_idx)%n_elements - do i=1,n_elements - keys(i) = map%map(map_idx)%key(i) + shift - values(i) = map%map(map_idx)%value(i) - print*, ',key,values',keys(i),values(i) - enddo - -end diff --git a/src/Utils/mmap.f90 b/src/Utils/mmap.f90 new file mode 100644 index 00000000..75b996de --- /dev/null +++ b/src/Utils/mmap.f90 @@ -0,0 +1,69 @@ +module mmap_module + + use iso_c_binding + + interface + + ! File descriptors + ! ---------------- + + type(c_ptr) function c_mmap_fortran(filename, length, fd, read_only) bind(c,name='mmap_fortran') + use iso_c_binding + character(c_char), intent(in) :: filename(*) + integer(c_size_t), intent(in), value :: length + integer(c_int), intent(out) :: fd + integer(c_int), intent(in), value :: read_only + end function + + subroutine c_munmap(length, fd, map) bind(c,name='munmap_fortran') + use iso_c_binding + integer(c_size_t), intent(in), value :: length + integer(c_int), intent(in), value :: fd + type(c_ptr), intent(in), value :: map + end subroutine + + end interface + + contains + + subroutine mmap(filename, shape, bytes, fd, read_only, map) + use iso_c_binding + implicit none + character*(*), intent(in) :: filename ! Name of the mapped file + integer*8, intent(in) :: shape(:) ! Shape of the array to map + integer, intent(in) :: bytes ! Number of bytes per element + logical, intent(in) :: read_only ! If true, mmap is read-only + integer, intent(out) :: fd ! File descriptor + type(c_ptr), intent(out) :: map ! C Pointer + + integer(c_long) :: length + integer(c_int) :: fd_ + + length = PRODUCT( shape(:) ) * bytes + if (read_only) then + map = c_mmap_fortran( trim(filename)//char(0), length, fd_, 1) + else + map = c_mmap_fortran( trim(filename)//char(0), length, fd_, 0) + endif + fd = fd_ + end subroutine + + subroutine munmap(shape, bytes, fd, map) + use iso_c_binding + implicit none + integer*8, intent(in) :: shape(:) ! Shape of the array to map + integer, intent(in) :: bytes ! Number of bytes per element + integer, intent(in) :: fd ! File descriptor + type(c_ptr), intent(in) :: map ! C pointer + + integer(c_long) :: length + integer(c_int) :: fd_ + + length = PRODUCT( shape(:) ) * bytes + fd_ = fd + call c_munmap( length, fd_, map) + end subroutine + +end module mmap_module + + diff --git a/src/Utils/transpose.irp.f b/src/Utils/transpose.irp.f new file mode 100644 index 00000000..32e502e9 --- /dev/null +++ b/src/Utils/transpose.irp.f @@ -0,0 +1,78 @@ +!DIR$ attributes forceinline :: transpose +recursive subroutine transpose(A,LDA,B,LDB,d1,d2) + implicit none + BEGIN_DOC +! Transpose input matrix A into output matrix B + END_DOC + integer, intent(in) :: d1, d2, LDA, LDB + real, intent(in) :: A(LDA,d2) + real, intent(out) :: B(LDB,d1) + + integer :: i,j,k, mod_align + if ( d2 < 32 ) then + do j=1,d1 + !DIR$ LOOP COUNT (16) + do i=1,d2 + B(i,j ) = A(j ,i) + enddo + enddo + return + else if (d1 > d2) then + !DIR$ forceinline + k=d1/2 + !DIR$ forceinline recursive + call transpose(A(1,1),LDA,B(1,1),LDB,k,d2) + !DIR$ forceinline recursive + call transpose(A(k+1,1),LDA,B(1,k+1),LDB,d1-k,d2) + return + else + !DIR$ forceinline + k=d2/2 + !DIR$ forceinline recursive + call transpose(A(1,k+1),LDA,B(k+1,1),LDB,d1,d2-k) + !DIR$ forceinline recursive + call transpose(A(1,1),LDA,B(1,1),LDB,d1,k) + return + endif + +end + +!DIR$ attributes forceinline :: dtranspose +recursive subroutine dtranspose(A,LDA,B,LDB,d1,d2) + implicit none + BEGIN_DOC +! Transpose input matrix A into output matrix B + END_DOC + integer, intent(in) :: d1, d2, LDA, LDB + double precision, intent(in) :: A(LDA,d2) + double precision, intent(out) :: B(LDB,d1) + + integer :: i,j,k, mod_align + if ( d2 < 32 ) then + do j=1,d1 + !DIR$ LOOP COUNT (16) + do i=1,d2 + B(i,j ) = A(j ,i) + enddo + enddo + return + else if (d1 > d2) then + !DIR$ forceinline + k=d1/2 + !DIR$ forceinline recursive + call dtranspose(A(1,1),LDA,B(1,1),LDB,k,d2) + !DIR$ forceinline recursive + call dtranspose(A(k+1,1),LDA,B(1,k+1),LDB,d1-k,d2) + return + else + !DIR$ forceinline + k=d2/2 + !DIR$ forceinline recursive + call dtranspose(A(1,k+1),LDA,B(k+1,1),LDB,d1,d2-k) + !DIR$ forceinline recursive + call dtranspose(A(1,1),LDA,B(1,1),LDB,d1,k) + return + endif + +end + diff --git a/src/Utils/util.irp.f b/src/Utils/util.irp.f index a5904183..4001e9df 100644 --- a/src/Utils/util.irp.f +++ b/src/Utils/util.irp.f @@ -84,10 +84,8 @@ double precision function fact(n) memo(i) = memo(i-1)*dble(i) enddo memomax = min(n,100) - fact = memo(memomax) - do i=101,n - fact = fact*dble(i) - enddo + double precision :: logfact + fact = dexp(logfact(n)) end function double precision function logfact(n) @@ -158,18 +156,41 @@ double precision function dble_fact_even(n) result(fact2) ! n!! END_DOC integer :: n,k - double precision, save :: memo(1:100) - integer, save :: memomax = 2 + double precision, save :: memo(0:100) + integer, save :: memomax = 0 double precision :: prod ASSERT (iand(n,1) /= 1) - prod=1.d0 - do k=2,n,2 - prod=prod*dfloat(k) +! prod=1.d0 +! do k=2,n,2 +! prod=prod*dfloat(k) +! enddo +! fact2=prod +! return +! + if (n <= memomax) then + if (n < 2) then + fact2 = 1.d0 + else + fact2 = memo(n) + endif + return + endif + + integer :: i + memo(0)=1.d0 + memo(1)=1.d0 + do i=memomax+2,min(n,100),2 + memo(i) = memo(i-2)* dble(i) enddo - fact2=prod - return + memomax = min(n,100) + fact2 = memo(memomax) + + if (n > 100) then + double precision :: dble_logfact + fact2 = dexp(dble_logfact(n)) + endif end function @@ -295,18 +316,6 @@ 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 @@ -315,22 +324,10 @@ double precision function u_dot_v(u,v,sze) END_DOC integer, intent(in) :: sze double precision, intent(in) :: u(sze),v(sze) + double precision, external :: ddot - integer :: i,t1, t2, t3, t4 - - ASSERT (sze > 0) - t1 = 0 - t2 = sze/4 - t3 = t2+t2 - t4 = t3+t2 - u_dot_v = 0.d0 - do i=1,t2 - u_dot_v = u_dot_v + u(t1+i)*v(t1+i) + u(t2+i)*v(t2+i) + & - u(t3+i)*v(t3+i) + u(t4+i)*v(t4+i) - enddo - do i=t4+t2+1,sze - u_dot_v = u_dot_v + u(i)*v(i) - enddo + !DIR$ FORCEINLINE + u_dot_v = ddot(sze,u,1,v,1) end @@ -341,27 +338,10 @@ double precision function u_dot_u(u,sze) END_DOC integer, intent(in) :: sze double precision, intent(in) :: u(sze) + double precision, external :: ddot - integer :: i - integer :: t1, t2, t3, t4 - - ASSERT (sze > 0) - t1 = 0 - t2 = sze/4 - t3 = t2+t2 - t4 = t3+t2 - u_dot_u = 0.d0 -! do i=1,t2 -! u_dot_u = u_dot_u + u(t1+i)*u(t1+i) + u(t2+i)*u(t2+i) + & -! u(t3+i)*u(t3+i) + u(t4+i)*u(t4+i) -! enddo -! do i=t4+t2+1,sze -! u_dot_u = u_dot_u+u(i)*u(i) -! enddo - - do i=1,sze - u_dot_u = u_dot_u + u(i)*u(i) - enddo + !DIR$ FORCEINLINE + u_dot_u = ddot(sze,u,1,u,1) end @@ -374,18 +354,17 @@ subroutine normalize(u,sze) integer, intent(in) :: sze double precision, intent(inout):: u(sze) double precision :: d - double precision, external :: u_dot_u + double precision, external :: dnrm2 integer :: i !DIR$ FORCEINLINE - d = u_dot_u(u,sze) + d = dnrm2(sze,u,1) if (d /= 0.d0) then - d = 1.d0/dsqrt( d ) + d = 1.d0/d endif if (d /= 1.d0) then - do i=1,sze - u(i) = d*u(i) - enddo + !DIR$ FORCEINLINE + call dscal(sze,d,u,1) endif end diff --git a/src/ZMQ/README.rst b/src/ZMQ/README.rst index f189ce24..187af23e 100644 --- a/src/ZMQ/README.rst +++ b/src/ZMQ/README.rst @@ -5,38 +5,134 @@ ZMQ Socket address : defined as an environment variable : QP_RUN_ADDRESS +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + + +.. image:: tree_dependency.png + +* `Utils `_ + Documentation ============= .. Do not edit this section It was auto-generated .. by the `update_README.py` script. -`qp_run_address `_ +`add_task_to_taskserver `_ + Get a task from the task server + + +`connect_to_taskserver `_ + Connect to the task server and obtain the worker ID + + +`disconnect_from_taskserver `_ + Disconnect from the task server + + +`end_parallel_job `_ + End a new parallel job with name 'name'. The slave tasks execute subroutine 'slave' + + +`end_zmq_pair_socket `_ + Terminate socket on which the results are sent. + + +`end_zmq_pull_socket `_ + Terminate socket on which the results are sent. + + +`end_zmq_push_socket `_ + Terminate socket on which the results are sent. + + +`end_zmq_to_qp_run_socket `_ + Terminate the socket from the application to qp_run + + +`get_task_from_taskserver `_ + Get a task from the task server + + +`new_parallel_job `_ + Start a new parallel job with name 'name'. The slave tasks execute subroutine 'slave' + + +`new_zmq_pair_socket `_ + Socket on which the collector and the main communicate + + +`new_zmq_pull_socket `_ + Socket on which the results are sent. If thread is 1, use inproc + + +`new_zmq_push_socket `_ + Socket on which the results are sent. If thread is 1, use inproc + + +`new_zmq_to_qp_run_socket `_ + Socket on which the qp_run process replies + + +`qp_run_address `_ Address of the qp_run socket Example : tcp://130.120.229.139:12345 -`zmq_context `_ - Context for the ZeroMQ library - - -`zmq_port `_ +`reset_zmq_addresses `_ Undocumented -`zmq_port_start `_ +`switch_qp_run_to_master `_ + Address of the master qp_run socket + Example : tcp://130.120.229.139:12345 + + +`task_done_to_taskserver `_ + Get a task from the task server + + +`zmq_context `_ + Context for the ZeroMQ library + + +`zmq_delete_task `_ + 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. + + +`zmq_port `_ + Return the value of the ZMQ port from the corresponding integer + + +`zmq_port_start `_ Address of the qp_run socket Example : tcp://130.120.229.139:12345 -`zmq_socket_pull `_ +`zmq_socket_pair_inproc_address `_ Socket which pulls the results (2) -`zmq_socket_push `_ - Socket on which to push the results (1) +`zmq_socket_pull_inproc_address `_ + Socket which pulls the results (2) -`zmq_to_qp_run_socket `_ - Socket on which the qp_run process replies +`zmq_socket_pull_tcp_address `_ + Socket which pulls the results (2) + + +`zmq_socket_push_inproc_address `_ + Socket which pulls the results (2) + + +`zmq_socket_push_tcp_address `_ + Socket which pulls the results (2) + + +`zmq_state `_ + Threads executing work through the ZeroMQ interface diff --git a/src/ZMQ/utils.irp.f b/src/ZMQ/utils.irp.f index d730f612..3177d3e3 100644 --- a/src/ZMQ/utils.irp.f +++ b/src/ZMQ/utils.irp.f @@ -46,31 +46,39 @@ END_PROVIDER &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 ] +&BEGIN_PROVIDER [ character*(128), zmq_socket_sub_tcp_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_sub_tcp_address = trim(qp_run_address)//':'//zmq_port(1)//' ' + zmq_socket_pull_tcp_address = 'tcp://*:'//zmq_port(2)//' ' + zmq_socket_push_tcp_address = trim(qp_run_address)//':'//zmq_port(2)//' ' + zmq_socket_pull_inproc_address = 'inproc://'//zmq_port(2)//' ' zmq_socket_push_inproc_address = zmq_socket_pull_inproc_address - zmq_socket_pair_inproc_address = 'inproc://'//zmq_port(2)//' ' + zmq_socket_pair_inproc_address = 'inproc://'//zmq_port(3)//' ' + + ! /!\ Don't forget to change subroutine reset_zmq_addresses END_PROVIDER subroutine reset_zmq_addresses 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_sub_tcp_address = trim(qp_run_address)//':'//zmq_port(1)//' ' + zmq_socket_pull_tcp_address = 'tcp://*:'//zmq_port(2)//' ' + zmq_socket_push_tcp_address = trim(qp_run_address)//':'//zmq_port(2)//' ' + zmq_socket_pull_inproc_address = 'inproc://'//zmq_port(2)//' ' zmq_socket_push_inproc_address = zmq_socket_pull_inproc_address - zmq_socket_pair_inproc_address = 'inproc://'//zmq_port(2)//' ' -end + zmq_socket_pair_inproc_address = 'inproc://'//zmq_port(3)//' ' +end subroutine switch_qp_run_to_master @@ -87,6 +95,7 @@ subroutine switch_qp_run_to_master stop -1 endif qp_run_address = trim(buffer) + print *, 'Switched to qp_run master : ', trim(qp_run_address) integer :: i do i=len(buffer),1,-1 @@ -96,7 +105,6 @@ subroutine switch_qp_run_to_master exit endif enddo - call reset_zmq_addresses end @@ -126,25 +134,28 @@ function new_zmq_to_qp_run_socket() integer(ZMQ_PTR) :: new_zmq_to_qp_run_socket call omp_set_lock(zmq_lock) + if (zmq_context == 0_ZMQ_PTR) then + stop 'zmq_context is uninitialized' + endif 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' + stop 'Unable to set send timeout 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' + stop 'Unable to set recv timeout in new_zmq_to_qp_run_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 end @@ -162,12 +173,36 @@ function new_zmq_pair_socket(bind) integer(ZMQ_PTR) :: new_zmq_pair_socket call omp_set_lock(zmq_lock) + if (zmq_context == 0_ZMQ_PTR) then + stop 'zmq_context is uninitialized' + endif 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 + + rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_SNDHWM, 1, 4) + if (rc /= 0) then + stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_SNDHWM, 1, 4)' + endif + + rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_RCVHWM, 1, 4) + if (rc /= 0) then + stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_RCVHWM, 1, 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 + if (bind) then rc = f77_zmq_bind(new_zmq_pair_socket,zmq_socket_pair_inproc_address) if (rc /= 0) then @@ -181,26 +216,6 @@ function new_zmq_pair_socket(bind) 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 @@ -217,6 +232,9 @@ function new_zmq_pull_socket() integer(ZMQ_PTR) :: new_zmq_pull_socket call omp_set_lock(zmq_lock) + if (zmq_context == 0_ZMQ_PTR) then + stop 'zmq_context is uninitialized' + endif 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) @@ -229,25 +247,49 @@ function new_zmq_pull_socket() stop 'Unable to set ZMQ_LINGER on pull socket' endif - rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_RCVHWM,100000,4) + rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_RCVBUF,100000000,4) + if (rc /= 0) then + stop 'Unable to set ZMQ_RCVBUF on pull socket' + endif + + rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_RCVHWM,1,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' + integer :: icount + + icount = 10 + do while (icount > 0) + rc = f77_zmq_bind(new_zmq_pull_socket, zmq_socket_pull_inproc_address) + if (rc /= 0) then + icount = icount-1 + call sleep(3) + else + exit + endif + enddo + + if (icount == 0) then + print *, 'Unable to bind new_zmq_pull_socket (inproc)', zmq_socket_pull_inproc_address + stop -1 endif - - rc = f77_zmq_bind(new_zmq_pull_socket, zmq_socket_pull_tcp_address) - if (rc /= 0) then + + + icount = 10 + do while (icount > 0) + rc = f77_zmq_bind(new_zmq_pull_socket, zmq_socket_pull_tcp_address) + if (rc /= 0) then + icount = icount-1 + call sleep(3) + else + exit + endif + enddo + + if (icount == 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)' + stop -1 endif end @@ -267,6 +309,9 @@ function new_zmq_push_socket(thread) integer(ZMQ_PTR) :: new_zmq_push_socket call omp_set_lock(zmq_lock) + if (zmq_context == 0_ZMQ_PTR) then + stop 'zmq_context is uninitialized' + endif 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) @@ -279,11 +324,16 @@ function new_zmq_push_socket(thread) stop 'Unable to set ZMQ_LINGER on push socket' endif - rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_SNDHWM,100,4) + rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_SNDHWM,1,4) if (rc /= 0) then stop 'Unable to set ZMQ_SNDHWM on push socket' endif + rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_SNDBUF,100000000,4) + if (rc /= 0) then + stop 'Unable to set ZMQ_RCVBUF 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' @@ -307,6 +357,65 @@ end +function new_zmq_sub_socket() + use f77_zmq + implicit none + BEGIN_DOC + ! Socket to read the state published by the Task server + END_DOC + integer :: rc + integer(ZMQ_PTR) :: new_zmq_sub_socket + + call omp_set_lock(zmq_lock) + if (zmq_context == 0_ZMQ_PTR) then + stop 'zmq_context is uninitialized' + endif + new_zmq_sub_socket = f77_zmq_socket(zmq_context, ZMQ_SUB) + call omp_unset_lock(zmq_lock) + if (new_zmq_sub_socket == 0_ZMQ_PTR) then + stop 'Unable to create zmq sub socket' + endif + + rc = f77_zmq_setsockopt(new_zmq_sub_socket,ZMQ_RCVTIMEO,10000,4) + if (rc /= 0) then + stop 'Unable to set timeout in new_zmq_sub_socket' + endif + + rc = f77_zmq_setsockopt(new_zmq_sub_socket,ZMQ_CONFLATE,1,4) + if (rc /= 0) then + stop 'Unable to set conflate in new_zmq_sub_socket' + endif + + rc = f77_zmq_setsockopt(new_zmq_sub_socket,ZMQ_SUBSCRIBE,"",0) + if (rc /= 0) then + stop 'Unable to subscribe new_zmq_sub_socket' + endif + + rc = f77_zmq_connect(new_zmq_sub_socket, zmq_socket_sub_tcp_address) + if (rc /= 0) then + stop 'Unable to connect new_zmq_sub_socket' + endif +end + + +subroutine end_zmq_sub_socket(zmq_socket_sub) + use f77_zmq + implicit none + BEGIN_DOC + ! Terminate socket on which the results are sent. + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_socket_sub + integer :: rc + + rc = f77_zmq_close(zmq_socket_sub) + if (rc /= 0) then + print *, 'f77_zmq_close(zmq_socket_sub)' + stop 'error' + endif + +end + + subroutine end_zmq_pair_socket(zmq_socket_pair) use f77_zmq implicit none @@ -317,18 +426,6 @@ subroutine end_zmq_pair_socket(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)' @@ -347,25 +444,6 @@ subroutine end_zmq_pull_socket(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)' @@ -386,22 +464,7 @@ subroutine end_zmq_push_socket(zmq_socket_push,thread) 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) + rc = f77_zmq_setsockopt(zmq_socket_push,ZMQ_LINGER,300000,4) if (rc /= 0) then stop 'Unable to set ZMQ_LINGER on push socket' endif @@ -464,6 +527,34 @@ subroutine new_parallel_job(zmq_to_qp_run_socket,name_in) end +subroutine zmq_set_running(zmq_to_qp_run_socket) + use f77_zmq + implicit none + BEGIN_DOC + ! Set the job to Running in QP-run + END_DOC + + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + character*(512) :: message + integer :: rc, sze + + message = 'set_running' + 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 *, 'Unable to set qp_run to Running' + stop 1 + endif + + +end + subroutine end_parallel_job(zmq_to_qp_run_socket,name_in) use f77_zmq @@ -513,7 +604,6 @@ subroutine connect_to_taskserver(zmq_to_qp_run_socket,worker_id,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 @@ -530,6 +620,10 @@ subroutine connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) rc = f77_zmq_recv(zmq_to_qp_run_socket, message, 510, 0) message = trim(message(1:rc)) + if(message(1:5) == "error") then + worker_id = -1 + return + end if read(message,*) reply, state, worker_id, address if ( (trim(reply) /= 'connect_reply') .and. & (trim(state) /= trim(zmq_state)) ) then @@ -538,7 +632,6 @@ subroutine connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) print *, 'Address: ', trim(address) stop -1 endif - end subroutine disconnect_from_taskserver(zmq_to_qp_run_socket, & @@ -568,12 +661,16 @@ subroutine disconnect_from_taskserver(zmq_to_qp_run_socket, & 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 + if ((trim(reply) == 'disconnect_reply').and.(trim(state) == trim(zmq_state))) then + return endif + if (trim(message) == 'error No job is running') then + return + endif + + print *, 'Unable to disconnect : ', trim(zmq_state) + print *, trim(message) + stop -1 end @@ -608,7 +705,7 @@ subroutine add_task_to_taskserver(zmq_to_qp_run_socket,task) end -subroutine task_done_to_taskserver(zmq_to_qp_run_socket,worker_id, task_id) +subroutine task_done_to_taskserver(zmq_to_qp_run_socket, worker_id, task_id) use f77_zmq implicit none BEGIN_DOC @@ -678,6 +775,9 @@ subroutine get_task_from_taskserver(zmq_to_qp_run_socket,worker_id,task_id,task) else if (trim(reply) == 'terminate') then task_id = 0 task = 'terminate' + else if (trim(message) == 'error No job is running') then + task_id = 0 + task = 'terminate' else print *, 'Unable to get the next task' print *, trim(message) @@ -697,13 +797,7 @@ subroutine end_zmq_to_qp_run_socket(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) + rc = f77_zmq_setsockopt(zmq_to_qp_run_socket,ZMQ_LINGER,1000,4) if (rc /= 0) then stop 'Unable to set ZMQ_LINGER on zmq_to_qp_run_socket' endif @@ -757,3 +851,90 @@ subroutine zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more) endif end + +subroutine wait_for_next_state(state) + use f77_zmq + implicit none + + character*(64), intent(out) :: state + integer(ZMQ_PTR) :: zmq_socket_sub + integer(ZMQ_PTR), external :: new_zmq_sub_socket + integer :: rc + + zmq_socket_sub = new_zmq_sub_socket() + state = 'Waiting' + do while(state == "Waiting") + rc = f77_zmq_recv( zmq_socket_sub, state, 64, 0) + if (rc > 0) then + state = trim(state(1:rc)) + else + print *, 'Timeout reached. Stopping' + state = "Stopped" + end if + end do + call end_zmq_sub_socket(zmq_socket_sub) +end subroutine + + +subroutine wait_for_state(state_wait,state) + use f77_zmq + implicit none + BEGIN_DOC +! Wait for the ZMQ state to be ready + END_DOC + character*(64), intent(in) :: state_wait + character*(64), intent(out) :: state + integer(ZMQ_PTR) :: zmq_socket_sub + integer(ZMQ_PTR), external :: new_zmq_sub_socket + integer :: rc + + zmq_socket_sub = new_zmq_sub_socket() + state = 'Waiting' + do while (trim(state) /= trim(state_wait) .and. trim(state) /= 'Stopped') + rc = f77_zmq_recv( zmq_socket_sub, state, 64, 0) + if (rc > 0) then + state = trim(state(1:rc)) + else + print *, 'Timeout reached. Stopping' + state = "Stopped" + endif + end do + call end_zmq_sub_socket(zmq_socket_sub) +end + + + +subroutine wait_for_states(state_wait,state,n) + use f77_zmq + implicit none + BEGIN_DOC +! Wait for the ZMQ state to be ready + END_DOC + integer, intent(in) :: n + character*(64), intent(in) :: state_wait(n) + character*(64), intent(out) :: state + integer(ZMQ_PTR) :: zmq_socket_sub + integer(ZMQ_PTR), external :: new_zmq_sub_socket + integer :: rc, i + logical :: condition + + zmq_socket_sub = new_zmq_sub_socket() + state = 'Waiting' + condition = .True. + do while (condition) + rc = f77_zmq_recv( zmq_socket_sub, state, 64, 0) + if (rc > 0) then + state = trim(state(1:rc)) + else + print *, 'Timeout reached. Stopping' + state = "Stopped" + endif + condition = trim(state) /= 'Stopped' + do i=1,n + condition = condition .and. (trim(state) /= trim(state_wait(i))) + enddo + end do + call end_zmq_sub_socket(zmq_socket_sub) +end + + diff --git a/tests/bats/cassd.bats b/tests/bats/cassd.bats new file mode 100644 index 00000000..07d79f1a --- /dev/null +++ b/tests/bats/cassd.bats @@ -0,0 +1,17 @@ +#!/usr/bin/env bats + +source $QP_ROOT/tests/bats/common.bats.sh + +@test "CAS_SD H2O cc-pVDZ" { + test_exe cas_sd_selected || skip + INPUT=h2o.ezfio + qp_edit -c $INPUT + 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 + energy="$(ezfio get cas_sd energy)" + eq $energy -76.2221842108163 1.E-5 +} + diff --git a/tests/bats/common.bats.sh b/tests/bats/common.bats.sh new file mode 100644 index 00000000..2aaff591 --- /dev/null +++ b/tests/bats/common.bats.sh @@ -0,0 +1,44 @@ +#!/usr/bin/env bats + +# floating point number comparison +# Compare two numbers ($1, $2) with a given precision ($3) +# If the numbers are not equal, the exit code is 1 else it is 0 +# So we strip the "-", is the abs value of the poor +function eq() { + declare -a diff + diff=($(awk -v d1=$1 -v d2=$2 -v n1=${1#-} -v n2=${2#-} -v p=$3 'BEGIN{ if ((n1-n2)^2 < p^2) print 0; print 1 " " (d1-d2) " " d1 " " d2 }')) + if [[ "${diff[0]}" == "0" ]] + then + return 0 + else + echo "Test : " ${BATS_TEST_DESCRIPTION} + echo "Error : " ${diff[1]} + echo "Reference : " ${diff[3]} + echo "Computed : " ${diff[2]} + exit 1 + fi +} + + +# ___ +# | ._ o _|_ +# _|_ | | | |_ +# +source ${QP_ROOT}/install/EZFIO/Bash/ezfio.sh +TEST_DIR=${QP_ROOT}/tests/work/ + +mkdir -p "${TEST_DIR}" + +cd "${TEST_DIR}" || exit 1 + +function test_exe() { + l_EXE=$(awk "/^$1 / { print \$2 }" < "${QP_ROOT}"/data/executables) + l_EXE=$(echo $l_EXE | sed "s|\$QP_ROOT|$QP_ROOT|") + if [[ -x "$l_EXE" ]] + then + return 0 + else + return 127 + fi +} + diff --git a/tests/bats/convert.bats b/tests/bats/convert.bats new file mode 100644 index 00000000..a1fbd7ce --- /dev/null +++ b/tests/bats/convert.bats @@ -0,0 +1,27 @@ +#!/usr/bin/env bats + +source $QP_ROOT/tests/bats/common.bats.sh + +#=== Convert +@test "gamess convert HBO.out" { + cp ${QP_ROOT}/tests/input/HBO.out . + qp_convert_output_to_ezfio.py HBO.out + qp_edit -c HBO.out.ezfio + ezfio set_file HBO.out.ezfio + qp_run SCF HBO.out.ezfio + # Check energy + energy="$(ezfio get hartree_fock energy)" + eq $energy -100.0185822590964 1.e-10 +} + +@test "g09 convert H2O.log" { + cp ${QP_ROOT}/tests/input/h2o.log . + qp_convert_output_to_ezfio.py h2o.log + qp_edit -c h2o.log.ezfio + ezfio set_file 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/fci.bats b/tests/bats/fci.bats new file mode 100644 index 00000000..174c8f61 --- /dev/null +++ b/tests/bats/fci.bats @@ -0,0 +1,52 @@ +#!/usr/bin/env bats + +source $QP_ROOT/tests/bats/common.bats.sh + +function run_FCI() { + thresh=5.e-5 + test_exe full_ci || skip + qp_edit -c $1 + ezfio set_file $1 + ezfio set perturbation do_pt2_end True + ezfio set determinants n_det_max $2 + ezfio set davidson threshold_davidson 1.e-10 + + 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_FCI_ZMQ() { + thresh=5.e-5 + test_exe full_ci || skip + qp_edit -c $1 + ezfio set_file $1 + ezfio set perturbation do_pt2_end True + ezfio set determinants n_det_max $2 + ezfio set davidson threshold_davidson 1.e-10 + + qp_run fci_zmq $1 + energy="$(ezfio get full_ci energy)" + eq $energy $3 $thresh + energy_pt2="$(ezfio get full_ci energy_pt2)" + eq $energy_pt2 $4 $thresh +} + + + +#=== H2O + +@test "qp_set_mo_class H2O cc-pVDZ" { + qp_set_mo_class h2o.ezfio -core "[1]" -act "[2-12]" -del "[13-24]" +} +@test "FCI H2O cc-pVDZ" { + run_FCI h2o.ezfio 2000 -0.761255633582109E+02 -0.761258377850042E+02 +} + +@test "FCI-ZMQ H2O cc-pVDZ" { + run_FCI_ZMQ h2o.ezfio 2000 -0.761255633582109E+02 -0.761258377850042E+02 +} + + diff --git a/tests/bats/foboci.bats b/tests/bats/foboci.bats new file mode 100644 index 00000000..98255969 --- /dev/null +++ b/tests/bats/foboci.bats @@ -0,0 +1,27 @@ +#!/usr/bin/env bats + +source $QP_ROOT/tests/bats/common.bats.sh + +function run_all_1h_1p() { + thresh=1.e-6 + test_exe all_1h_1p || skip + qp_edit -c $1 + ezfio set_file $1 + ezfio set determinants n_det_max $2 + ezfio set perturbation pt2_max $3 + ezfio set davidson 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 "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 +} + + diff --git a/tests/bats/hf.bats b/tests/bats/hf.bats new file mode 100644 index 00000000..e280c986 --- /dev/null +++ b/tests/bats/hf.bats @@ -0,0 +1,52 @@ +#!/usr/bin/env bats + +source $QP_ROOT/tests/bats/common.bats.sh + +function run_init() { + cp "${QP_ROOT}/tests/input/$1" . + qp_create_ezfio_from_xyz $1 -o $3 $2 + qp_edit -c $3 +} + + +function run_HF() { + thresh=1.e-7 + test_exe SCF || skip + qp_edit -c $1 + ezfio set_file $1 + ezfio set hartree_fock thresh_scf 1.e-11 + qp_run SCF $1 + energy="$(ezfio get hartree_fock energy)" + eq $energy $2 $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 +} + +#=== HBO +@test "init HBO STO-3G" { + run_init HBO.xyz "-b STO-3G" hbo.ezfio +} + +@test "SCF HBO STO-3G" { + run_HF hbo.ezfio -98.8251985678084 +} + + +#=== H2O +@test "init H2O cc-pVDZ" { + run_init h2o.xyz "-b cc-pvdz" h2o.ezfio +} + +@test "SCF H2O cc-pVDZ" { + run_HF h2o.ezfio -0.760270218692179E+02 +} + diff --git a/tests/bats/mrcepa0.bats b/tests/bats/mrcepa0.bats new file mode 100644 index 00000000..8b56c606 --- /dev/null +++ b/tests/bats/mrcepa0.bats @@ -0,0 +1,70 @@ +#!/usr/bin/env bats + +source $QP_ROOT/tests/bats/common.bats.sh + +#=== H2O +@test "MRCC-lambda H2O cc-pVDZ" { + INPUT=h2o.ezfio + EXE=mrcc + test_exe $EXE || skip + qp_edit -c $INPUT + ezfio set_file $INPUT + ezfio set determinants threshold_generators 1. + ezfio set determinants threshold_selectors 1. + ezfio set determinants read_wf True + ezfio set mrcepa0 lambda_type 1 + ezfio set mrcepa0 n_it_max_dressed_ci 3 + qp_run $EXE $INPUT + energy="$(ezfio get mrcepa0 energy)" + eq $energy -76.22903276183061 1.e-4 +} + +@test "MRCC H2O cc-pVDZ" { + INPUT=h2o.ezfio + EXE=mrcc + test_exe $EXE || skip + qp_edit -c $INPUT + ezfio set_file $INPUT + ezfio set determinants threshold_generators 1. + ezfio set determinants threshold_selectors 1. + ezfio set determinants read_wf True + ezfio set determinants read_wf True + ezfio set mrcepa0 lambda_type 0 + ezfio set mrcepa0 n_it_max_dressed_ci 3 + qp_run $EXE $INPUT + energy="$(ezfio get mrcepa0 energy)" + eq $energy -76.22899302846875 1.e-4 +} + +@test "MRSC2 H2O cc-pVDZ" { + INPUT=h2o.ezfio + EXE=mrsc2 + test_exe $EXE || skip + qp_edit -c $INPUT + ezfio set_file $INPUT + ezfio set determinants threshold_generators 1. + ezfio set determinants threshold_selectors 1. + ezfio set determinants read_wf True + ezfio set mrcepa0 lambda_type 0 + ezfio set mrcepa0 n_it_max_dressed_ci 3 + qp_run $EXE $INPUT + energy="$(ezfio get mrcepa0 energy)" + eq $energy -76.22647345292708 1.e-4 +} + +@test "MRCEPA0 H2O cc-pVDZ" { + INPUT=h2o.ezfio + EXE=mrcepa0 + test_exe $EXE || skip + qp_edit -c $INPUT + ezfio set_file $INPUT + ezfio set determinants threshold_generators 1. + ezfio set determinants threshold_selectors 1. + ezfio set determinants read_wf True + ezfio set mrcepa0 lambda_type 0 + ezfio set mrcepa0 n_it_max_dressed_ci 3 + qp_run $EXE $INPUT + energy="$(ezfio get mrcepa0 energy)" + eq $energy -76.23199784430074 1.e-4 +} + diff --git a/tests/bats/pseudo.bats b/tests/bats/pseudo.bats new file mode 100644 index 00000000..8cccf229 --- /dev/null +++ b/tests/bats/pseudo.bats @@ -0,0 +1,53 @@ +#!/usr/bin/env bats + +source $QP_ROOT/tests/bats/common.bats.sh + +function run_init() { + cp "${QP_ROOT}/tests/input/$1" . + qp_create_ezfio_from_xyz $1 -o $3 $2 + qp_edit -c $3 +} + + +function run_HF() { + thresh=1.e-7 + test_exe SCF || skip + qp_edit -c $1 + ezfio set_file $1 + ezfio set hartree_fock thresh_scf 1.e-11 + qp_run SCF $1 + energy="$(ezfio get hartree_fock energy)" + eq $energy $2 $thresh +} + + +function run_FCI_ZMQ() { + thresh=5.e-5 + test_exe full_ci || skip + qp_edit -c $1 + ezfio set_file $1 + ezfio set perturbation do_pt2_end True + ezfio set determinants n_det_max $2 + ezfio set davidson threshold_davidson 1.e-10 + + qp_run fci_zmq $1 + energy="$(ezfio get full_ci energy)" + eq $energy $3 $thresh + energy_pt2="$(ezfio get full_ci energy_pt2)" + eq $energy_pt2 $4 $thresh +} + +#=== H2O Pseudo +@test "init H2O VDZ pseudo" { + run_init h2o.xyz "-p bfd -b vdz-bfd" h2o_pseudo.ezfio +} + +@test "SCF H2O VDZ pseudo" { + run_HF h2o_pseudo.ezfio -16.9483703905461 +} + +@test "FCI H2O VDZ pseudo" { + qp_set_mo_class h2o_pseudo.ezfio -core "[1]" -act "[2-12]" -del "[13-23]" + run_FCI_ZMQ h2o_pseudo.ezfio 2000 -0.170399597228904E+02 -0.170400168816800E+02 +} + diff --git a/tests/bats/qp.bats b/tests/bats/qp.bats deleted file mode 100644 index de0cd1c8..00000000 --- a/tests/bats/qp.bats +++ /dev/null @@ -1,205 +0,0 @@ -#!/usr/bin/env bats - -# -# |\/| o _ _ -# | | | _> (_ -# -# floating point number comparison -# Compare two numbers ($1, $2) with a given precision ($3) -# If the numbers are not equal, the exit code is 1 else it is 0 -# So we strip the "-", is the abs value of the poor -function eq() { - declare -a diff - diff=($(awk -v d1=$1 -v d2=$2 -v n1=${1#-} -v n2=${2#-} -v p=$3 'BEGIN{ if ((n1-n2)^2 < p^2) print 0; print 1 " " (d1-d2) " " d1 " " d2 }')) - if [[ "${diff[0]}" == "0" ]] - then - return 0 - else - echo "Test : " ${BATS_TEST_DESCRIPTION} - echo "Error : " ${diff[1]} - echo "Reference : " ${diff[3]} - echo "Computed : " ${diff[2]} - exit 1 - fi -} - - -# ___ -# | ._ o _|_ -# _|_ | | | |_ -# -source ${QP_ROOT}/install/EZFIO/Bash/ezfio.sh -TEST_DIR=${QP_ROOT}/tests/work/ - -mkdir -p "${TEST_DIR}" - -cd "${TEST_DIR}" || exit 1 - -function run_init() { - cp "${QP_ROOT}/tests/input/$1" . - qp_create_ezfio_from_xyz $1 -o $3 $2 - qp_edit -c $3 -} - -function test_exe() { - EXE=$(awk "/^$1 / { print \$2 }" < "${QP_ROOT}"/data/executables) - EXE=$(echo $EXE | sed "s|\$QP_ROOT|$QP_ROOT|") - if [[ -x "$EXE" ]] - then - return 0 - else - return 127 - fi -} - -function run_HF() { - thresh=1.e-8 - test_exe SCF || skip - ezfio set_file $1 - ezfio set hartree_fock thresh_scf 1.e-10 - qp_run SCF $1 - energy="$(ezfio get hartree_fock energy)" - eq $energy $2 $thresh -} - -function run_FCI() { - 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 - 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 -} - -@test "SCF HBO STO-3G" { - run_HF hbo.ezfio -98.8251985678084 -} - - -#=== H2O -@test "init H2O cc-pVDZ" { - run_init h2o.xyz "-b cc-pvdz" h2o.ezfio -} - -@test "SCF H2O cc-pVDZ" { - run_HF h2o.ezfio -0.760270218692179E+02 -} - -@test "FCI H2O cc-pVDZ" { - qp_set_mo_class h2o.ezfio -core "[1]" -act "[2-12]" -del "[13-24]" - run_FCI h2o.ezfio 2000 -0.761255633582109E+02 -0.761258377850042E+02 -} - -@test "CAS_SD H2O cc-pVDZ" { - test_exe cas_sd_selected || skip - INPUT=h2o.ezfio - 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 - energy="$(ezfio get cas_sd energy)" - eq $energy -0.762219854008117E+02 1.E-5 -} - -@test "MRCC H2O cc-pVDZ" { - test_exe mrcc_cassd || skip - INPUT=h2o.ezfio - ezfio set_file $INPUT - ezfio set determinants threshold_generators 1. - ezfio set determinants threshold_selectors 1. - ezfio set determinants read_wf True - qp_run mrcc_cassd $INPUT - energy="$(ezfio get mrcc_cassd energy)" - eq $energy -0.762303253805911E+02 1.E-3 - -} - - -#=== H2O Pseudo -@test "init H2O VDZ pseudo" { - run_init h2o.xyz "-p bfd -b vdz-bfd" h2o_pseudo.ezfio -} - -@test "SCF H2O VDZ pseudo" { - run_HF h2o_pseudo.ezfio -0.169483703904991E+02 -} - -@test "FCI H2O VDZ pseudo" { - 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 -@test "gamess convert HBO.out" { - 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 - # Check energy - energy="$(ezfio get hartree_fock energy)" - eq $energy -100.0185822590964 1.e-10 -} - -@test "g09 convert H2O.log" { - 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 - # Check energy - energy="$(ezfio get hartree_fock energy)" - eq $energy -76.0270218704265 1E-10 -} - - -# TODO N_int = 1,2,3,4,5 -# TODO mod(64) MOs -# TODO All G2 SCF energies -# TODO Long and short tests -# TODO MP2 -# TODO CISD_selected - diff --git a/tests/bats_to_sh.py b/tests/bats_to_sh.py index 2c6b4a05..8feb9272 100755 --- a/tests/bats_to_sh.py +++ b/tests/bats_to_sh.py @@ -1,6 +1,8 @@ #!/usr/bin/env python -with open('bats/qp.bats','r') as f: +import sys + +with open(sys.argv[1],'r') as f: raw_data = f.read() output = [] diff --git a/tests/run_tests.sh b/tests/run_tests.sh index 2436c60c..4664ce82 100755 --- a/tests/run_tests.sh +++ b/tests/run_tests.sh @@ -1,18 +1,39 @@ #!/bin/bash +LIST=" + +convert.bats +hf.bats +foboci.bats +pseudo.bats +fci.bats +cassd.bats +mrcepa0.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 + +for BATS_FILE in $LIST +do + echo + echo "-~-~-~-~-~-~" + echo + echo "Running tests for ${BATS_FILE%.bats}" + echo + BATS_FILE=bats/$BATS_FILE + if [[ "$1" == "-v" ]] + then + echo "Verbose mode" + ./bats_to_sh.py $BATS_FILE | bash + else + bats $BATS_FILE + fi +done